diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -57,9 +57,9 @@ 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" ++ (show . eightOctetKeyID $ key^.tkKey._1 ) ] + 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 ) ] tell $ map (\(x,_) -> "uid " ++ x) (key^.tkUIDs) - tell $ map (\(PublicSubkeyPkt x,_) -> "sub " ++ either (const "unknown") show (pubkeySize (x^.pubkey)) ++ pkalgoAbbrev (x^.pkalgo) ++ "/0x" ++ (show . eightOctetKeyID $ x)) (key^.tkSubs) + tell $ map (\(PublicSubkeyPkt x,_) -> "sub " ++ either (const "unknown") show (pubkeySize (x^.pubkey)) ++ pkalgoAbbrev (x^.pkalgo) ++ "/0x" ++ (either (const "unknown") show . eightOctetKeyID $ x)) (key^.tkSubs) data Options = Options { keyring :: String diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -22,12 +22,13 @@ 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) +import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys, verifyAgainstKeyring) 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) +import Control.Lens ((^.), (&), _1, _2, (^..)) +import qualified Control.Monad.Trans.State.Lazy as S import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash.SHA3 as SHA3 import qualified Data.Aeson as A @@ -39,15 +40,23 @@ 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) -import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate) +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.Graphviz (graphviz, Orient(..)) +import Data.Graph.Inductive.PatriciaTree (Gr) +import qualified Data.IxSet as IxSet +import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate, nub, sort) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) +import Data.Maybe (fromMaybe, mapMaybe, listToMaybe, catMaybes) import Data.Monoid ((<>), mconcat, Monoid(..)) import Data.Ord (comparing, Down(..)) import Data.Serialize (get) 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 @@ -118,12 +127,12 @@ checkKey mpt key = (\x -> x { keyBestOf = populateBestOf x }) KeyReport { keyStatus = either id (const "good") processedTK , keyFingerprint = key^.tkKey._1 & fingerprint - , keyVer = key^.tkKey._1^.keyVersion & colorizeKV - , keyCreationTime = key^.tkKey._1^.timestamp + , keyVer = key^.tkKey._1.keyVersion & colorizeKV + , keyCreationTime = key^.tkKey._1.timestamp , keyAlgorithmAndSize = KAS { - pubkeyalgo = key^.tkKey._1^.pkalgo & colorizePKA - , pubkeysize = key^.tkKey._1^.pubkey & colorizePKS . pubkeySize - , stringrep = (key^.tkKey._1^.pubkey & either (const "unknown") show . pubkeySize) ++ (key^.tkKey._1^.pkalgo & pkalgoAbbrev) + pubkeyalgo = key^.tkKey._1.pkalgo & colorizePKA + , pubkeysize = key^.tkKey._1.pubkey & colorizePKS . pubkeySize + , stringrep = (key^.tkKey._1.pubkey & either (const "unknown") show . pubkeySize) ++ (key^.tkKey._1.pkalgo & pkalgoAbbrev) } , keyUIDsAndUAts = FakeMap (map (second uidr) (processedOrOrig^.tkUIDs) ++ map (uatspsToString *** uidr) (processedOrOrig^.tkUAts)) , keyBestOf = Nothing @@ -148,17 +157,10 @@ | any (\ke -> realToFrac ts + realToFrac ke < ct) kes = Colored (Just Red) (Just "expiration passed") kes | any (\ke -> realToFrac ts + realToFrac ke > ct + (5*31557600)) kes = Colored (Just Yellow) (Just "expiration too far in future") kes | otherwise = Colored (Just Green) Nothing kes - 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 i@(Issuer _) = Just i - getIssuer _ = Nothing eoki pkp | pkp^.keyVersion == V4 = hush . eightOctetKeyID $ pkp | pkp^.keyVersion == DeprecatedV3 && elem (pkp^.pkalgo) [RSA,DeprecatedRSASignOnly] = hush . eightOctetKeyID $ pkp | otherwise = Nothing - hashAlgo (SigV4 _ _ x _ _ _ _) = x phas (SigV4 _ _ _ xs _ _ _) = colorizePHAs . concatMap (\(SigSubPacket _ (PreferredHashAlgorithms x)) -> x) $ filter isPHA xs phas _ = Colored Nothing Nothing [] isPHA (SigSubPacket _ (PreferredHashAlgorithms _)) = True @@ -168,7 +170,7 @@ isCT (SigSubPacket _ (SigCreationTime _)) = True isCT _ = False sigcts (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs - alleged = filter (\x -> ((==) <$> sigissuer x <*> fmap Issuer (eoki (key^.tkKey._1))) == Just True) + alleged = filter (\x -> ((==) <$> sigissuer x <*> eoki (key^.tkKey._1)) == Just True) newest = take 1 . sortBy (comparing (Down . take 1 . sigcts)) -- FIXME: this is terrible stripOtherSigs tk = tk { _tkUIDs = map (second alleged) (_tkUIDs tk) @@ -183,7 +185,7 @@ uaspToString (OtherUASub t d) = "other-" ++ show t ++ ':':show (B.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hash 48 d)) hdrToString (ImageHV1 JPEG) = "jpeg" hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt) - uidr sps = UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1^.timestamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0? + uidr sps = UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0? populateBestOf krep = Just (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best . uidPreferredHashAlgorithms <*> best . uidKeyExpirationTimes $ mconcat (justTheUIDRs krep)) justTheUIDRs = map snd . unFakeMap . keyUIDsAndUAts best = take 1 . sortBy (comparing color) @@ -228,17 +230,24 @@ | x > 0 = Just ((++"s") . show $ x, 0) | otherwise = Nothing -data OutputFormat = Pretty | JSON | YAML +data LintOutputFormat = Pretty | JSON | YAML deriving (Eq, Read, Show) -data Options = Options { - outputFormat :: OutputFormat +data GraphOutputFormat = GraphViz + deriving (Eq, Read, Show) + +data LintOptions = LintOptions { + lintOutputFormat :: LintOutputFormat } -data Command = Lint Options +data GraphOptions = GraphOptions { + graphOutputFormat :: GraphOutputFormat +} -lintO :: Parser Options -lintO = Options +data Command = CmdLint LintOptions | CmdGraph GraphOptions + +lintO :: Parser LintOptions +lintO = LintOptions <$> option ( long "output-format" <> metavar "FORMAT" @@ -246,8 +255,19 @@ <> 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 (Lint o) = banner' stderr >> hFlush stderr >> doLint o +dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o +dispatch (CmdGraph o) = banner' stderr >> hFlush stderr >> doGraph o main :: IO () main = do @@ -256,17 +276,65 @@ cmd :: Parser Command cmd = subparser - ( command "lint" (info ( Lint <$> lintO) ( progDesc "check key(s) for 'best practices'" ))) + ( command "lint" (info ( CmdLint <$> lintO) ( progDesc "check key(s) for 'best practices'" )) + <> command "graph" (info ( CmdGraph <$> graphO) ( progDesc "graph" ))) -doLint :: Options -> IO () +doLint :: LintOptions -> IO () doLint o = do cpt <- getPOSIXTime keys <- runResourceT $ CB.sourceHandle stdin $= conduitGet get $= conduitToTKsDropping $$ CL.consume - output (outputFormat o) cpt keys + output (lintOutputFormat o) cpt keys where output Pretty cpt = mapM_ (putDoc . prettyKeyReport cpt) 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 + putStrLn $ graphviz (buildKeyGraph ((buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))))) "Keys" (8.5,11.0) (1,1) Landscape + 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 +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/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,5 +1,5 @@ name: hopenpgp-tools -version: 0.6 +version: 0.7 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools @@ -48,7 +48,9 @@ , cryptohash >= 0.7.7 , directory , errors + , fgl , hOpenPGP >= 1.2 + , ixset , lens , old-locale , optparse-applicative >= 0.5.0 @@ -86,4 +88,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.6 + tag: hopenpgp-tools/0.7