diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -18,44 +18,66 @@ import HOpenPGP.Tools.Common (banner, versioner, warranty, keyMatchesFingerprint, keyMatchesEightOctetKeyId, keyMatchesUIDSubString) import HOpenPGP.Tools.ExpressionParsing (pPE) -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) +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.Lens ((^.), _1) -import Control.Monad.Trans.Resource (runResourceT) +import Control.Applicative ((<$>),(<*>), optional, (<|>), pure) +import Control.Arrow ((&&&)) +import Control.Lens ((^.), _1, _2, (^..)) +import Control.Monad.Trans.Resource (runResourceT, MonadResource) +import qualified Control.Monad.Trans.State.Lazy as S import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Data.Attoparsec.Text as A import qualified Data.ByteString as B -import Data.Conduit (($=),($$)) +import Data.Conduit (($=),($$), Source) import qualified Data.Conduit.Binary as CB import Data.Conduit.Cereal (conduitGet) import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter (Expr(..), PKPPredicate(..), PKPOp(..), PKPVar(..), PKPValue(..)) -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) -import Data.Maybe (fromMaybe) +import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap) +import Data.Data.Lens (biplate) +import Data.Either (rights) +import qualified Data.IxSet as IxSet +import Data.Graph.Inductive.Graph (Graph(mkGraph), emap) +import Data.Graph.Inductive.PatriciaTree (Gr) +import Data.Graph.Inductive.Query.SP (sp) +import Data.GraphViz (graphToDot, nonClusteredParams) +import Data.GraphViz.Types (printDotGraph) +import Data.List (nub, sort) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) import Data.Monoid ((<>)) import Data.Serialize (get, put, runPut) import qualified Data.Text as T +import qualified Data.Text.Lazy.IO as TLIO +import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) +import Data.Traversable (traverse) +import Data.Tuple (swap) import System.Directory (getHomeDirectory) -import Options.Applicative.Builder (argument, command, footer, header, help, info, long, metavar, prefs, progDesc, showHelpOnError, str, strOption, subparser, switch) +import Options.Applicative.Builder (argument, command, footer, header, help, info, long, metavar, option, prefs, progDesc, showDefault, showHelpOnError, str, strOption, subparser, switch, value) import Options.Applicative.Extra (customExecParser, helper) import Options.Applicative.Types (Parser) import System.IO (Handle, hFlush, hPutStrLn, stderr, hSetBuffering, BufferMode(..)) -grabMatchingKeys :: FilePath -> Bool -> String -> IO [TK] -grabMatchingKeys fp filt srch = runResourceT $ - CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= CL.filter (if filt then filterMatch else matchAny) $$ CL.consume +grabMatchingKeysConduit :: MonadResource m => FilePath -> Bool -> String -> Source m TK +grabMatchingKeysConduit fp filt srch = CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= CL.filter (if filt then filterMatch else matchAny) where matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|> return (keyMatchesUIDSubString srch tk) filterMatch tk = eval pkpEval (either error id (A.parseOnly pPE (T.pack srch))) (tk^.tkKey._1) efp = parseFingerprint . T.pack $ srch eeok = parseEightOctetKeyId . T.pack $ srch +grabMatchingKeys :: FilePath -> Bool -> String -> IO [TK] +grabMatchingKeys fp filt srch = runResourceT $ grabMatchingKeysConduit fp filt srch $$ CL.consume + +grabMatchingKeysKeyring :: FilePath -> Bool -> String -> IO Keyring +grabMatchingKeysKeyring fp filt srch = runResourceT $ grabMatchingKeysConduit fp filt srch $$ sinkKeyringMap + showKey :: TK -> IO () showKey key = putStrLn . unlines . execWriter $ do tell [ "pub " ++ either (const "unknown") show (pubkeySize (key^.tkKey._1.pubkey)) ++ pkalgoAbbrev (key^.tkKey._1.pkalgo) ++ "/0x" ++ (either (const "unknown") show . eightOctetKeyID $ key^.tkKey._1 ) ] @@ -64,24 +86,69 @@ data Options = Options { keyring :: String + , graphOutputFormat :: GraphOutputFormat , targetIsFilter :: Bool - , target :: String + , target1 :: String + , target2 :: String + , target3 :: String } -data Command = List Options | ExportPubkeys Options +data Command = CmdList Options | CmdExportPubkeys Options | CmdGraph Options | CmdFindPaths Options +data GraphOutputFormat = GraphViz + deriving (Eq, Read, Show) + listO :: String -> Parser Options listO homedir = Options <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> optional (strOption ( long "keyring" <> metavar "FILE" <> help "file containing keyring" ))) + <*> pure GraphViz -- unused <*> switch ( long "filter" <> help "treat target as filter" ) <*> argument str ( metavar "TARGET" ) + <*> pure "" + <*> pure "" +graphO :: String -> Parser Options +graphO homedir = Options + <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> optional (strOption + ( long "keyring" + <> metavar "FILE" + <> help "file containing keyring" ))) + <*> option + ( long "output-format" + <> metavar "FORMAT" + <> value GraphViz + <> showDefault + <> help "output format" ) + <*> switch ( long "filter" <> help "treat target as filter" ) + <*> argument str ( metavar "TARGET" ) + <*> pure "" + <*> pure "" + +findPathsO :: String -> Parser Options +findPathsO homedir = Options + <$> (fromMaybe (homedir ++ "/.gnupg/pubring.gpg") <$> optional (strOption + ( long "keyring" + <> metavar "FILE" + <> help "file containing keyring" ))) + <*> option + ( long "output-format" + <> metavar "FORMAT" + <> value GraphViz + <> showDefault + <> help "output format" ) + <*> switch ( long "filter" <> help "treat targets as filter" ) + <*> argument str ( metavar "TARGET-SET" ) + <*> argument str ( metavar "FROM-KEYS" ) + <*> argument str ( metavar "TO-KEYS" ) + dispatch :: Command -> IO () -dispatch (List o) = banner' stderr >> hFlush stderr >> doList o -dispatch (ExportPubkeys o) = banner' stderr >> hFlush stderr >> doExportPubkeys o +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 @@ -91,20 +158,22 @@ cmd :: String -> Parser Command cmd homedir = subparser - ( command "list" (info ( List <$> listO homedir) ( progDesc "list matching keys" )) - <> command "export-pubkeys" (info ( ExportPubkeys <$> listO homedir) ( progDesc "export matching keys to stdout" ))) + ( command "list" (info ( CmdList <$> listO homedir) ( progDesc "list matching keys" )) + <> command "export-pubkeys" (info ( CmdExportPubkeys <$> listO homedir) ( progDesc "export matching keys to stdout" )) + <> command "graph" (info ( CmdGraph <$> graphO homedir) ( progDesc "graph certifications" )) + <> command "findpaths" (info ( CmdFindPaths <$> findPathsO homedir) ( progDesc "find short paths between keys" ))) banner' :: Handle -> IO () banner' h = hPutStrLn h (banner "hkt" ++ "\n" ++ warranty "hkt") doList :: Options -> IO () doList o = do - keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (target o) + keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (target1 o) mapM_ showKey keys doExportPubkeys :: Options -> IO () doExportPubkeys o = do - keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (target o) + keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (target1 o) mapM_ (B.putStr . putTK') keys where putTK' key = runPut $ do @@ -117,6 +186,60 @@ 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 + cpt <- getPOSIXTime + kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (target1 o) + TLIO.putStrLn . printDotGraph $ graphToDot nonClusteredParams (buildKeyGraph ((buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))))) + +buildMaps :: [TK] -> (Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int) +buildMaps ks = S.execState (mapM_ mapsInsertions ks) (Map.empty, Map.empty, 0) + +-- FIXME: this presumes no keyID collisions in the input +mapsInsertions :: TK -> S.State (Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int) () +mapsInsertions tk = do + (k2f, f2i, i) <- S.get + let fp = fingerprint (tk^.tkKey._1) + keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [PKPayload]) + i' = i + 1 + k2f' = foldr (\k m -> Map.insert k fp m) k2f keyids + f2i' = Map.insert fp i' f2i + S.put (k2f', f2i', i') + +buildKeyGraph :: ((Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int), [TK]) -> Gr TwentyOctetFingerprint HashAlgorithm +buildKeyGraph ((k2f, f2i, _), ks) = mkGraph nodes edges + where + nodes = map swap . Map.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") (Map.lookup (fingerprint (tk^.tkKey._1)) f2i) + source i = fromMaybe (error "Lesser fail") (Map.lookup i k2f >>= flip Map.lookup f2i) + fakejoin (x, y) = fmap ((,) x) y + sigs tk = concat ((tk^..tkUIDs.traverse._2) ++ (tk^..tkUAts.traverse._2)) + samesies (x,y,_) = x == y + +doFindPaths :: Options -> IO () +doFindPaths o = do + cpt <- getPOSIXTime + kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (target1 o) + let keys1 = filter (if targetIsFilter o then filterMatch (target2 o) else matchAny (target2 o)) (IxSet.toList kr) + keys2 = filter (if targetIsFilter o then filterMatch (target3 o) else matchAny (target3 o)) (IxSet.toList kr) + ((k2f, f2i, i), ks) = (buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))) + keygraph = buildKeyGraph ((k2f, f2i, i), ks) + keysToIs = mapMaybe (\x -> Map.lookup (fingerprint (x^.tkKey._1)) f2i) + froms = keysToIs keys1 + tos = keysToIs keys2 + combos = froms >>= \f -> tos >>= \t -> return (f,t) + paths = map (\(x,y) -> sp x y (emap (const (1.0 :: Double)) keygraph)) combos + print paths + where -- FIXME: deduplicate this + matchAny srch tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) (efp srch) <|> fmap (keyMatchesEightOctetKeyId True tk . Right) (eeok srch) <|> return (keyMatchesUIDSubString srch tk) + filterMatch srch tk = eval pkpEval (either error id (A.parseOnly pPE (T.pack srch))) (tk^.tkKey._1) + efp srch = parseFingerprint . T.pack $ srch + eeok srch = parseEightOctetKeyId . T.pack $ srch + + + -- FIXME: deduplicate the following code eval :: (a -> v -> Bool) -> Expr a -> v -> Bool eval t e v = ev e @@ -139,3 +262,19 @@ vreduce (PKPVTimestamp, p) = PKPInt (fromIntegral (_timestamp p)) kv DeprecatedV3 = 3 kv V4 = 4 + +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" + diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -22,13 +22,12 @@ import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize, pkalgoAbbrev) -import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys, verifyAgainstKeyring) +import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<$>),(<*>)) -import Control.Arrow ((***), second, (&&&)) +import Control.Arrow ((***), second) import Control.Error.Util (hush) -import Control.Lens ((^.), (&), _1, _2, (^..)) -import qualified Control.Monad.Trans.State.Lazy as S +import Control.Lens ((^.), (&), _1) import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash.SHA3 as SHA3 @@ -41,25 +40,15 @@ import qualified Data.Conduit.Binary as CB import Data.Conduit.Cereal (conduitGet) import qualified Data.Conduit.List as CL -import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap) -import Data.Data.Lens (biplate) -import Data.Either (rights) -import Data.Graph.Inductive.Graph (Graph(mkGraph)) -import Data.Graph.Inductive.PatriciaTree (Gr) -import Data.GraphViz (graphToDot, nonClusteredParams) -import Data.GraphViz.Types (printDotGraph) -import qualified Data.IxSet as IxSet -import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate, nub, sort) +import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) +import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, catMaybes) +import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) import Data.Monoid ((<>), mconcat, Monoid(..)) import Data.Ord (comparing, Down(..)) import Data.Serialize (get) -import qualified Data.Text.Lazy.IO as TLIO import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Data.Time.Format (formatTime) -import Data.Traversable (traverse) -import Data.Tuple (swap) import qualified Data.Yaml as Y import GHC.Generics @@ -236,18 +225,11 @@ data LintOutputFormat = Pretty | JSON | YAML deriving (Eq, Read, Show) -data GraphOutputFormat = GraphViz - deriving (Eq, Read, Show) - data LintOptions = LintOptions { lintOutputFormat :: LintOutputFormat } -data GraphOptions = GraphOptions { - graphOutputFormat :: GraphOutputFormat -} - -data Command = CmdLint LintOptions | CmdGraph GraphOptions +data Command = CmdLint LintOptions lintO :: Parser LintOptions lintO = LintOptions @@ -258,19 +240,8 @@ <> showDefault <> help "output format" ) -graphO :: Parser GraphOptions -graphO = GraphOptions - <$> option - ( long "output-format" - <> metavar "FORMAT" - <> value GraphViz - <> showDefault - <> help "output format" ) - - dispatch :: Command -> IO () dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o -dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o main :: IO () main = do @@ -280,7 +251,7 @@ cmd :: Parser Command cmd = subparser ( command "lint" (info ( CmdLint <$> lintO) ( progDesc "check key(s) for 'best practices'" )) - <> command "graph" (info ( CmdGraph <$> graphO) ( progDesc "graph" ))) + ) doLint :: LintOptions -> IO () doLint o = do @@ -292,40 +263,8 @@ output JSON cpt = mapM_ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt) output YAML cpt = mapM_ (B.putStr . yamlReport cpt) -doGraph :: GraphOptions -> IO () -doGraph o = do - cpt <- getPOSIXTime - kr <- runResourceT $ CB.sourceHandle stdin $= conduitGet get $= conduitToTKsDropping $$ sinkKeyringMap - TLIO.putStrLn . printDotGraph $ graphToDot nonClusteredParams (buildKeyGraph ((buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))))) - banner' :: Handle -> IO () banner' h = hPutStrLn h (banner "hokey" ++ "\n" ++ warranty "hokey") - -buildMaps :: [TK] -> (Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int) -buildMaps ks = S.execState (mapM_ mapsInsertions ks) (Map.empty, Map.empty, 0) - --- FIXME: this presumes no keyID collisions in the input -mapsInsertions :: TK -> S.State (Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int) () -mapsInsertions tk = do - (k2f, f2i, i) <- S.get - let fp = fingerprint (tk^.tkKey._1) - keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [PKPayload]) - i' = i + 1 - k2f' = foldr (\k m -> Map.insert k fp m) k2f keyids - f2i' = Map.insert fp i' f2i - S.put (k2f', f2i', i') - -buildKeyGraph :: ((Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int), [TK]) -> Gr TwentyOctetFingerprint HashAlgorithm -buildKeyGraph ((k2f, f2i, _), ks) = mkGraph nodes edges - where - nodes = map swap . Map.toList $ f2i - edges = filter (not . samesies) . nub . sort . concatMap tkToEdges $ ks - tkToEdges tk = map (\(ha, i) -> (source i, target tk, ha)) (catMaybes (map (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))) - target tk = maybe (error "Epic fail") id (Map.lookup (fingerprint (tk^.tkKey._1)) f2i) - source i = maybe (error "Lesser fail") id (Map.lookup i k2f >>= flip Map.lookup f2i) - fakejoin (x, y) = fmap ((,) x) y - sigs tk = concat ((tk^..tkUIDs.traverse._2) ++ (tk^..tkUAts.traverse._2)) - samesies (x,y,_) = x == y sigissuer :: SignaturePayload -> Maybe EightOctetKeyId getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,5 +1,5 @@ name: hopenpgp-tools -version: 0.7.2 +version: 0.8 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools @@ -51,8 +51,6 @@ , cryptohash >= 0.7.7 , directory , errors - , fgl - , graphviz , hOpenPGP >= 1.2 , ixset , lens @@ -77,14 +75,18 @@ , cereal-conduit , conduit >= 1.1 , conduit-extra >= 1.1 + , containers , crypto-pubkey , directory + , fgl + , graphviz , hOpenPGP >= 1.2 , ixset , lens , optparse-applicative >= 0.5.0 , resourcet , text + , time , transformers default-language: Haskell2010 @@ -95,4 +97,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.7.2 + tag: hopenpgp-tools/0.8