diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -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) 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.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