File: hkt.hs

package info (click to toggle)
haskell-hopenpgp-tools 0.21.3-1
  • links: PTS, VCS
  • area: main
  • in suites: buster, sid
  • size: 652 kB
  • sloc: haskell: 3,454; yacc: 192; makefile: 8
file content (377 lines) | stat: -rw-r--r-- 17,276 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
-- hkt.hs: hOpenPGP key tool
-- Copyright © 2013-2019  Clint Adams
--
-- vim: softtabstop=4:shiftwidth=4:expandtab
--
-- This program is free software: you can redistribute it and/or modify
-- it under the terms of the GNU Affero General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU Affero General Public License for more details.
--
-- You should have received a copy of the GNU Affero General Public License
-- along with this program.  If not, see <http://www.gnu.org/licenses/>.

{-# LANGUAGE DeriveGeneric #-}

import HOpenPGP.Tools.Common (banner, versioner, warranty, keyMatchesFingerprint, keyMatchesEightOctetKeyId, keyMatchesUIDSubString)
import HOpenPGP.Tools.Parser (parseTKExp)
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize, pkalgoAbbrev)
import Codec.Encryption.OpenPGP.KeySelection (parseEightOctetKeyId, parseFingerprint)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeyring)
import Codec.Encryption.OpenPGP.Types
import Control.Applicative (optional, (<|>))
import Control.Arrow ((&&&))
import Control.Lens ((^.), _1, _2, (^..))
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import qualified Control.Monad.Trans.State.Lazy as S
import qualified Data.Aeson as A
import Data.Binary (get, put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit ((.|), ConduitM, runConduitRes)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Filter (conduitTKFilter, FilterPredicates(RTKFilterPredicate))
import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
import qualified Data.IxSet.Typed as IxSet
import Data.Graph.Inductive.Graph (Graph(mkGraph), emap, Path, prettyPrint)
import Data.Graph.Inductive.PatriciaTree (Gr)
import Data.Graph.Inductive.Query.SP (sp)
import Data.GraphViz (graphToDot, nonClusteredParams, GraphvizParams(..))
import Data.GraphViz.Attributes (toLabel)
import Data.GraphViz.Types (printDotGraph)
import Data.HashMap.Lazy (HashMap)
import qualified Data.HashMap.Lazy as HashMap
import Data.List (nub, sort)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)
import Data.Monoid ((<>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLIO
import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)
import Data.Tuple (swap)
import qualified Data.Yaml as Y
import GHC.Generics
import System.Directory (getHomeDirectory)

import Options.Applicative.Builder (argument, auto, command, footerDoc, headerDoc, help, helpDoc, info, long, metavar, option, prefs, progDesc, showDefault, showHelpOnError, str, strOption, switch, value)
import Options.Applicative.Extra (customExecParser, helper, hsubparser)
import Options.Applicative.Types (Parser)

import System.IO (Handle, hFlush, stderr, hSetBuffering, BufferMode(..))
import Data.Text.Prettyprint.Doc ((<+>), fillSep, hardline, list, pretty)
import Data.Text.Prettyprint.Doc.Render.Text (putDoc, hPutDoc)
import Data.Text.Prettyprint.Convert.AnsiWlPprint (toAnsiWlPprint)

grabMatchingKeysConduit :: (MonadResource m, MonadThrow m) => FilePath -> Bool -> Text -> ConduitM () TK m ()
grabMatchingKeysConduit fp filt srch = CB.sourceFile fp .| conduitGet get .| conduitToTKsDropping .| (if filt then conduitTKFilter ufp else CL.filter matchAny)
    where
        matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|> return (keyMatchesUIDSubString srch tk)
        efp = parseFingerprint srch
        eeok = parseEightOctetKeyId srch
        ufp = RTKFilterPredicate (parseE srch)
        parseE = either (error . ("filter parse error: " ++)) id . parseTKExp . T.unpack -- this should be more specialized

grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TK]
grabMatchingKeys fp filt srch = runConduitRes $ grabMatchingKeysConduit fp filt srch .| CL.consume

grabMatchingKeysKeyring :: FilePath -> Bool -> Text -> IO Keyring
grabMatchingKeysKeyring fp filt srch = runConduitRes $ grabMatchingKeysConduit fp filt srch .| sinkKeyringMap

data Key = Key {
    keysize :: Maybe Int
  , keyalgo :: String
  , keyalgoabbreviation :: String
  , fpr :: String
} deriving Generic

data TKey = TKey {
    publickey :: Key
  , uids :: [Text]
  , subkeys :: [Key]
} deriving Generic

instance A.ToJSON Key
instance A.ToJSON TKey

tkToTKey :: TK -> TKey
tkToTKey tk = TKey {
    publickey = mkey (tk^.tkKey._1)
  , uids = tk^.tkUIDs^..traverse._1
  , subkeys = map (mkey . \(PublicSubkeyPkt x,_) -> x) (tk^.tkSubs)
}
    where
        mkey = Key <$> either (const Nothing) Just . pubkeySize . _pubkey
                   <*> show . _pkalgo
                   <*> pkalgoAbbrev . _pkalgo
                   <*> show . pretty . fingerprint

showTKey :: TKey -> IO ()
showTKey key = putDoc $
    pretty "pub  " <+> sizeabbrevkeyid (publickey key) <> hardline <>
    mconcat (map (\x -> pretty "uid                           " <+> pretty (T.unpack x) <> hardline) (uids key)) <>
    mconcat (map (\x -> pretty "sub  " <+> sizeabbrevkeyid x <> hardline) (subkeys key)) <>
    hardline
    where
        sizeabbrevkeyid k = pretty (maybe "unknown" show (keysize k)) <> pretty (keyalgoabbreviation k) <> pretty "/" <> pretty (fpr k)

data Options = Options {
    keyring :: String
  , graphOutputFormat :: GraphOutputFormat
  , pathsOutputFormat :: PathsOutputFormat
  , targetIsFilter :: Bool
  , target1 :: String
  , target2 :: String
  , target3 :: String
}

data Command = CmdList Options | CmdExportPubkeys Options | CmdGraph Options | CmdFindPaths Options

data GraphOutputFormat = GraphViz | LossyPretty
    deriving (Bounded, Enum, Eq, Read, Show)

data PathsOutputFormat = Unstructured | JSON | YAML
    deriving (Eq, Read, Show)

listO :: String -> Parser Options
listO homedir = Options
    <$> strOption
        ( long "keyring"
       <> metavar "FILE"
       <> help "file containing keyring" )
    <*> pure GraphViz -- unused
    <*> option auto
        ( long "output-format"
       <> metavar "FORMAT"
       <> value Unstructured
       <> showDefault
       <> help "output format" )
    <*> switch ( long "filter" <> help "treat target as filter" )
    <*> (fromMaybe "" <$> optional (argument str ( metavar "TARGET" <> targetHelp )))
    <*> pure ""
    <*> pure ""
    where
        targetHelp = helpDoc . Just . toAnsiWlPprint $ pretty "target (which keys to output)*"

graphO :: String -> Parser Options
graphO homedir = Options
    <$> strOption
        ( long "keyring"
       <> metavar "FILE"
       <> help "file containing keyring" )
    <*> option auto
        ( long "output-format"
       <> metavar "FORMAT"
       <> value GraphViz
       <> showDefault
       <> ofhelp )
    <*> pure Unstructured -- unused
    <*> switch ( long "filter" <> help "treat target as filter" )
    <*> (fromMaybe "" <$> optional (argument str ( metavar "TARGET" <> targetHelp )))
    <*> pure ""
    <*> pure ""
    where
        ofhelp = helpDoc . Just . toAnsiWlPprint $ pretty "output format" <> hardline <> list (map (pretty . show) ofchoices)
        ofchoices = [minBound..maxBound] :: [GraphOutputFormat]
        targetHelp = helpDoc . Just . toAnsiWlPprint $ pretty "target (which keys to graph)*"

findPathsO :: String -> Parser Options
findPathsO homedir = Options
    <$> strOption
        ( long "keyring"
       <> metavar "FILE"
       <> help "file containing keyring" )
    <*> pure GraphViz -- unused
    <*> option auto
        ( long "output-format"
       <> metavar "FORMAT"
       <> value Unstructured
       <> showDefault
       <> help "output format" )
    <*> switch ( long "filter" <> help "treat targets as filter" )
    <*> argument str ( metavar "TARGET-SET" <> targetHelp )
    <*> argument str ( metavar "FROM-KEYS" <> fromHelp )
    <*> argument str ( metavar "TO-KEYS" <> toHelp )
    where
        targetHelp = helpDoc . Just . toAnsiWlPprint $ pretty "target (which keys to use in pathfinding)*"
        fromHelp = helpDoc . Just . toAnsiWlPprint $ pretty "from (which keys to use for the source of paths)*"
        toHelp = helpDoc . Just . toAnsiWlPprint $ pretty "to (which keys to use for the destinations of paths)*"

dispatch :: Command -> IO ()
dispatch (CmdList o) = banner' stderr >> hFlush stderr >> doList o
dispatch (CmdExportPubkeys o) = banner' stderr >> hFlush stderr >> doExportPubkeys o
dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o
dispatch (CmdFindPaths o) = banner' stderr >> hFlush stderr >> doFindPaths o

main :: IO ()
main = do
    hSetBuffering stderr LineBuffering
    homedir <- getHomeDirectory
    customExecParser (prefs showHelpOnError)
                     (info (helper <*> versioner "hkt" <*> cmd homedir)
                           (headerDoc (Just (toAnsiWlPprint (banner "hkt")))
                           <> progDesc "hOpenPGP Keyring Tool"
                           <> footerDoc (Just (toAnsiWlPprint (warranty "hkt"))))) >>= dispatch

cmd :: String -> Parser Command
cmd homedir = hsubparser
    ( command "export-pubkeys" (info ( CmdExportPubkeys <$> listO homedir) ( progDesc "export matching keys to stdout" <> footerDoc (Just foot) ))
   <> command "findpaths" (info ( CmdFindPaths <$> findPathsO homedir) ( progDesc "find short paths between keys" <> footerDoc (Just foot) ))
   <> command "graph" (info ( CmdGraph <$> graphO homedir) ( progDesc "graph certifications" <> footerDoc (Just foot) ))
   <> command "list" (info ( CmdList <$> listO homedir) ( progDesc "list matching keys" <> footerDoc (Just foot) ))
    )
    where
        foot = toAnsiWlPprint $ hardline <> fillSep [
                   pretty "*if --filter is not specified, this must be"
                 , pretty "a fingerprint,"
                 , pretty "an eight-octet key ID,"
                 , pretty "or a substring of a UID (including an empty string)"]
               <> hardline
               <> fillSep [pretty "if --filter is specified, it must be"
                          , pretty "something in filter syntax (see source)."
                          ]

banner' :: Handle -> IO ()
banner' h = hPutDoc h (banner "hkt" <> hardline <> warranty "hkt" <> hardline)

doList :: Options -> IO ()
doList o = do
    let ttarget1 = T.pack . target1
    keys' <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
    let keys = map tkToTKey keys'
    case pathsOutputFormat o of
        Unstructured -> mapM_ showTKey keys
        JSON -> BL.putStr . A.encode $ keys
        YAML -> B.putStr . Y.encode $ keys
    putStrLn ""

doExportPubkeys :: Options -> IO ()
doExportPubkeys o = do
    let ttarget1 = T.pack . target1
    keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o)
    case pathsOutputFormat o of
        Unstructured -> mapM_ (BL.putStr . putTK') keys
        JSON -> BL.putStr . A.encode $ keys
        YAML -> B.putStr . Y.encode $ keys
    where
        putTK' key = runPut $ do
            put (PublicKey (key^.tkKey._1))
            mapM_ (put . Signature) (_tkRevs key)
            mapM_ putUid' (_tkUIDs key)
            mapM_ putUat' (_tkUAts key)
            mapM_ putSub' (_tkSubs key)
        putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps
        putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps
        putSub' (p, sps) = put p >> mapM_ (put . Signature) sps

doGraph :: Options -> IO ()
doGraph o = do
    let ttarget1 = T.pack . target1
    cpt <- getPOSIXTime
    kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (ttarget1 o)
    let g = buildKeyGraph ((buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))))
    case graphOutputFormat o of
        LossyPretty -> prettyPrint g
        GraphViz -> TLIO.putStrLn . printDotGraph . graphToDot nonClusteredLabeledNodesParams $ g
    where
        nonClusteredLabeledNodesParams = nonClusteredParams { fmtNode = \(_,l) -> [toLabel $ show (pretty l)] }

buildMaps :: [TK] -> (KeyMaps, Int)
buildMaps ks = S.execState (mapM_ mapsInsertions ks) (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0)

-- FIXME: this presumes no keyID collisions in the input
data KeyMaps = KeyMaps {
    _k2f :: HashMap EightOctetKeyId TwentyOctetFingerprint
  , _f2i :: HashMap TwentyOctetFingerprint Int
  , _i2f :: HashMap Int TwentyOctetFingerprint
}

mapsInsertions :: TK -> S.State (KeyMaps, Int) ()
mapsInsertions tk = do
    (KeyMaps k2f f2i i2f, i) <- S.get
    let fp = fingerprint (tk^.tkKey._1)
        keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [PKPayload])
        i' = i + 1
        k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids
        f2i' = HashMap.insert fp i' f2i
        i2f' = HashMap.insert i' fp i2f
    S.put (KeyMaps k2f' f2i' i2f', i')

buildKeyGraph :: ((KeyMaps, Int), [TK]) -> Gr TwentyOctetFingerprint HashAlgorithm
buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = mkGraph nodes edges
    where
        nodes = map swap . HashMap.toList $ f2i
        edges = filter (not . samesies) . nub . sort . concatMap tkToEdges $ ks
        tkToEdges tk = map (\(ha, i) -> (source i, target tk, ha)) (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))
        target tk = fromMaybe (error "Epic fail") (HashMap.lookup (fingerprint (tk^.tkKey._1)) f2i)
        source i = fromMaybe (-1) (HashMap.lookup i k2f >>= flip HashMap.lookup f2i)
        fakejoin (x, y) = fmap ((,) x) y
        sigs tk = concat ((tk^..tkUIDs.traverse._2) ++ (tk^..tkUAts.traverse._2))
        samesies (x,y,_) = x == y

data PaF = PaF {
    certPaths :: [Path]
  , keyFingerprints :: Map String TwentyOctetFingerprint
} deriving Generic

instance A.ToJSON PaF

doFindPaths :: Options -> IO ()
doFindPaths o = do
    let ttarget1 = T.pack . target1
        ttarget2 = T.pack . target2
        ttarget3 = T.pack . target3
    cpt <- getPOSIXTime
    kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (ttarget1 o)
    -- FIXME: seriously clean this up
    keys1 <- runConduitRes $ CL.sourceList (IxSet.toList kr) .| (if filt then conduitTKFilter (ufpt (ttarget2 o)) else CL.filter (matchAny (ttarget2 o))) .| CL.consume
    keys2 <- runConduitRes $ CL.sourceList (IxSet.toList kr) .| (if filt then conduitTKFilter (ufpt (ttarget3 o)) else CL.filter (matchAny (ttarget3 o))) .| CL.consume
    let ((KeyMaps k2f f2i i2f, i), ks) = (buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr)))
        keygraph = buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks)
        keysToIs = mapMaybe (\x -> HashMap.lookup (fingerprint (x^.tkKey._1)) f2i)
        froms = keysToIs keys1
        tos = keysToIs keys2
        combos = froms >>= \f -> tos >>= \t -> return (f,t)
        paths = map (\(x,y) -> fromMaybe [] (sp x y (emap (const (1.0 :: Double)) keygraph))) combos
        paf = PaF paths (Map.fromList (mapMaybe (\x -> HashMap.lookup x i2f >>= \y -> return (show x,y)) (nub (sort (concat paths)))))
    case pathsOutputFormat o of
        Unstructured -> do -- FIXME: do something about this
                           putStrLn . unlines $ map (show . ((,) =<< length)) paths
                           putStrLn . unlines $ map (\x -> maybe (show x) show $ HashMap.lookup x i2f >>= \y -> return (x, pretty y)) (nub (sort (concat paths)))
        JSON -> BL.putStr . A.encode $ paf
        YAML -> B.putStr . Y.encode $ paf
    putStrLn ""
    where
        filt = targetIsFilter o
        matchAny srch tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) (parseFingerprint srch) <|> fmap (keyMatchesEightOctetKeyId True tk . Right) (parseEightOctetKeyId srch) <|> return (keyMatchesUIDSubString srch tk)
        ufpt srch = RTKFilterPredicate (parseE srch)
        parseE e = either (error . ("filter parse error: "++)) id (parseTKExp (T.unpack e)) -- this should be more specialized

-- FIXME: deduplicate the following code
sigissuer :: SignaturePayload -> Maybe EightOctetKeyId
getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId
hashAlgo :: SignaturePayload -> HashAlgorithm

sigissuer (SigVOther 2 _) = Nothing
sigissuer SigV3 {} = Nothing
sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys++xs) -- FIXME: what should this be if there are multiple matches?
sigissuer (SigVOther _ _) = error "We're in the future." -- FIXME

getIssuer (Issuer i) = Just i
getIssuer _ = Nothing

hashAlgo (SigV4 _ _ x _ _ _ _) = x
hashAlgo _ = error "V3 sig not supported here"