hopenpgp-tools 0.17.1 → 0.18
raw patch · 2 files changed
+48/−8 lines, 2 files
Files
- hokey.hs +46/−6
- hopenpgp-tools.cabal +2/−2
hokey.hs view
@@ -94,6 +94,7 @@ , keyUIDsAndUAts :: FakeMap Text (Colored UIDReport) , keyBestOf :: Maybe UIDReport , keySubkeys :: [SubkeyReport]+ , keyHasEncryptionCapableSubkey :: Colored Bool } deriving Generic data UIDReport = UIDReport {@@ -109,8 +110,16 @@ , skVer :: Colored KeyVersion , skCreationTime :: ThirtyTwoBitTimeStamp , skAlgorithmAndSize :: KAS+ , skBindingSigHashAlgorithms :: [Colored HashAlgorithm]+ , skUsageFlags :: [Colored (Set.Set KeyFlag)]+ , skCrossCerts :: CrossCertReport } deriving Generic +data CrossCertReport = CrossCertReport {+ ccPresent :: Colored Bool+ , ccHashAlgorithms :: [Colored HashAlgorithm]+} deriving Generic+ data RevocationStatus = RevocationStatus { isRevoked :: Bool , revocationCode :: String@@ -123,6 +132,7 @@ instance A.ToJSON KeyReport instance A.ToJSON UIDReport instance A.ToJSON SubkeyReport+instance A.ToJSON CrossCertReport instance A.ToJSON b => A.ToJSON (FakeMap Text b) where toJSON = A.toJSON . Map.fromList . unFakeMap instance A.ToJSON RevocationStatus@@ -132,7 +142,7 @@ mappend (UIDReport a b c d e) (UIDReport a' b' c' d' e') = UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') checkKey :: Maybe POSIXTime -> TK -> KeyReport-checkKey mpt key = (\x -> x { keyBestOf = populateBestOf x }) KeyReport {+checkKey mpt key = (\x -> x { keyBestOf = populateBestOf x, keyHasEncryptionCapableSubkey = hasEncryptionCapableSubkey (concatMap skUsageFlags (keySubkeys x)) }) KeyReport { keyStatus = either id (const "good") processedTK , keyFingerprint = key^.tkKey._1 & fingerprint , keyVer = key^.tkKey._1.keyVersion & colorizeKV@@ -141,6 +151,7 @@ , keyUIDsAndUAts = FakeMap (map (\(x,y) -> (x, uidr (Just x) y)) (processedOrOrig^.tkUIDs) ++ map (uatspsToText *** uidr Nothing) (processedOrOrig^.tkUAts)) , keyBestOf = Nothing , keySubkeys = map checkSK (key^.tkSubs)+ , keyHasEncryptionCapableSubkey = Colored Nothing Nothing False } where processedOrOrig = either (const key) id processedTK@@ -200,12 +211,12 @@ uidr Nothing sps = Colored Nothing Nothing (UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0?- (kufs sps)+ (kufs False sps) (findRevocationReason sps)) uidr (Just u) sps = colorizeUID u (UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0?- (kufs sps)+ (kufs False sps) (findRevocationReason sps)) populateBestOf krep = Just (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best . uidPreferredHashAlgorithms <*> best . uidKeyExpirationTimes <*> best . uidKeyUsageFlags <*> pure [] $ mconcat (justTheUIDRs krep)) justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts@@ -222,22 +233,46 @@ grabReasons _ = [] grabReasons' (ReasonForRevocation a b) = Just (RevocationStatus True (show a) b) grabReasons' _ = Nothing- kufs = map (colorizeKUFs . (\(SigSubPacket _ (KeyFlags x)) -> x) . maybe undefined id . find isKUF . hasheds) . newestWith (any isKUF . hasheds)+ kufs s = map (colorizeKUFs s . (\(SigSubPacket _ (KeyFlags x)) -> x) . maybe undefined id . find isKUF . hasheds) . newestWith (any isKUF . hasheds) isKUF (SigSubPacket _ (KeyFlags _)) = True isKUF _ = False- colorizeKUFs x = uncurry Colored (if (Set.member EncryptStorageKey x || Set.member EncryptCommunicationsKey x) && (Set.member SignDataKey x || Set.member CertifyKeysKey x) then (Just Yellow, Just "both signing & encryption") else (Just Green, Nothing)) x+ colorizeKUFs False x = uncurry Colored (if (Set.member EncryptStorageKey x || Set.member EncryptCommunicationsKey x) && (Set.member SignDataKey x || Set.member CertifyKeysKey x) then (Just Yellow, Just "both signing & encryption") else (Just Green, Nothing)) x+ colorizeKUFs True x = uncurry Colored (if (Set.member CertifyKeysKey x) then (Just Red, Just "certification-capable subkey") else (if (Set.member EncryptStorageKey x || Set.member EncryptCommunicationsKey x) && Set.member SignDataKey x then (Just Yellow, Just "both signing & encryption") else (Just Green, Nothing))) x newestWith p = take 1 . sortBy (comparing (Down . take 1 . sigcts)) . filter p -- FIXME: this is terrible hasheds (SigV4 _ _ _ xs _ _ _) = xs hasheds _ = [] checkSK :: (Pkt, [SignaturePayload]) -> SubkeyReport checkSK (PublicSubkeyPkt pkp, sigs) = checkSK' pkp sigs checkSK (SecretSubkeyPkt pkp _, sigs) = checkSK' pkp sigs- checkSK' pkp sigs = SubkeyReport {+ checkSK' pkp sigs = (\x -> x { skCrossCerts = ccr (map decolorize (skUsageFlags x)) sigs }) SubkeyReport { skFingerprint = fingerprint pkp , skVer = colorizeKV (pkp^.keyVersion) , skCreationTime = pkp^.timestamp , skAlgorithmAndSize = kasIt pkp+ , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs)+ , skUsageFlags = kufs True (filter isSKBindingSig sigs)+ , skCrossCerts = CrossCertReport (Colored Nothing Nothing False) [] }+ hasEncryptionCapableSubkey skrs = if any ((\x -> Set.member EncryptStorageKey x || Set.member EncryptCommunicationsKey x) . decolorize) skrs then Colored (Just Green) Nothing True else Colored (Just Red) (Just "no encryption-capable subkey present") False+ isSKBindingSig (SigV4 SubkeyBindingSig _ _ _ _ _ _) = True+ isSKBindingSig _ = False+ isPKBindingSig (SigV4 PrimaryKeyBindingSig _ _ _ _ _ _) = True+ isPKBindingSig _ = False+ embeddedSigs = filter isPKBindingSig . concatMap getEmbeds . filter isSKBindingSig+ getEmbeds (SigV4 _ _ _ _ xs _ _) = concatMap getEmbed xs+ getEmbeds _ = []+ getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp]+ getEmbed _ = []+ ccr kufs sigs = CrossCertReport (colorES kufs sigs) (map (colorizeHA . hashAlgo) sigs)+ colorES kufs sigs = case (null (embeddedSigs sigs), any (Set.member SignDataKey) kufs, any (Set.member AuthKey) kufs) of+ (True, True, True) -> Colored (Just Red) (Just "signing- and auth-capable subkey without cross-cert") False+ (True, True, False) -> Colored (Just Red) (Just "signing-capable subkey without cross-cert") False+ (True, False, True) -> Colored (Just Yellow) (Just "auth-capable subkey without cross-cert") False+ (False, True, True) -> Colored (Just Green) Nothing True+ (False, True, False) -> Colored (Just Green) Nothing True+ (False, False, True) -> Colored (Just Green) Nothing True+ (False, False, False) -> Colored Nothing Nothing True+ (True, _, _) -> Colored Nothing Nothing False prettyKeyReport :: POSIXTime -> TK -> Doc Effect prettyKeyReport cpt key = do@@ -250,6 +285,7 @@ <> linebreak <> text "Checking user-ID- and user-attribute-related items" <> colon <> mconcat (map (uidtrip (keyCreationTime keyReport) . gottabeabetterway) (unFakeMap (keyUIDsAndUAts keyReport))) <> linebreak <> text "Checking subkeys" <> colon+ <> linebreak <> indent 2 (text "one of the subkeys is encryption-capable" <> colon <+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport)) <> mconcat (map (subkeyrep) (keySubkeys keyReport)) <> linebreak )@@ -273,6 +309,10 @@ <> linebreak <> indent 4 (text "version" <> colon <+> coloredToColor pretty (skVer skr)) <> linebreak <> indent 4 (text "timestamp" <> colon <+> pretty (skCreationTime skr)) <> linebreak <> indent 4 ((\kas -> text "algo/size" <> colon <+> coloredToColor pretty (pubkeyalgo kas) <+> coloredToColor (maybe (text "unknown") pretty) (pubkeysize kas)) (skAlgorithmAndSize skr))+ <> linebreak <> indent 4 (text "binding sig hash algorithms" <> colon <+> (list . map (coloredToColor pretty) . skBindingSigHashAlgorithms) skr)+ <> linebreak <> indent 4 (text "usage flags" <> colon <+> (list . map (coloredToColor (pretty . Set.toList))) (skUsageFlags skr))+ <> linebreak <> indent 4 (text "embedded cross-cert" <> colon <+> (coloredToColor pretty . ccPresent . skCrossCerts) skr)+ <> linebreak <> indent 4 (text "cross-cert hash algorithms" <> colon <+> (list . map (coloredToColor pretty) . ccHashAlgorithms . skCrossCerts) skr) jsonReport :: POSIXTime -> TK -> BL.ByteString jsonReport ps = A.encode . checkKey (Just ps)
hopenpgp-tools.cabal view
@@ -1,5 +1,5 @@ name: hopenpgp-tools-version: 0.17.1+version: 0.18 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools@@ -120,4 +120,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.17.1+ tag: hopenpgp-tools/0.18