hopenpgp-tools 0.6 → 0.7
raw patch · 3 files changed
+104/−34 lines, 3 filesdep +fgl
Dependencies added: fgl
Files
- hkt.hs +2/−2
- hokey.hs +98/−30
- hopenpgp-tools.cabal +4/−2
hkt.hs view
@@ -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
hokey.hs view
@@ -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"
hopenpgp-tools.cabal view
@@ -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