diff --git a/HOpenPGP/Tools/Hokey/Lint.hs b/HOpenPGP/Tools/Hokey/Lint.hs --- a/HOpenPGP/Tools/Hokey/Lint.hs +++ b/HOpenPGP/Tools/Hokey/Lint.hs @@ -15,11 +15,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} @@ -27,40 +23,15 @@ ( doLint ) where -import Codec.Encryption.OpenPGP.Expirations - ( getKeyExpirationTimesFromSignature - ) -import Codec.Encryption.OpenPGP.Fingerprint - ( eightOctetKeyID - , fingerprint - ) -import Codec.Encryption.OpenPGP.KeyInfo - ( pkalgoAbbrev - , pubkeySize - ) -import Codec.Encryption.OpenPGP.Ontology - ( isCT - , isCertRevocationSig - , isKUF - , isPHA - , isPKBindingSig - , isSKBindingSig - ) -import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Types -import Control.Arrow ((***)) -import Control.Error.Util (hush) -import Control.Lens ((&)) + ( SomeTK + , SpacedFingerprint (..) + ) import Control.Monad (void) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) -import qualified Crypto.Hash as CH -import qualified Crypto.Hash.Algorithms as CHA import qualified Data.Aeson as A import Data.Binary (get) -import qualified Data.ByteArray as BA import qualified Data.ByteString as B -import qualified Data.ByteString.Base16 as Base16 -import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL import Data.Conduit (runConduitRes, (.|)) import qualified Data.Conduit.Binary as CB @@ -70,13 +41,9 @@ , conduitToSomeTKsDroppingEither ) import Data.Conduit.Serialization.Binary (conduitGet) -import Data.Foldable (find, maximumBy, sequenceA_, traverse_) -import Data.List (elemIndex, findIndex, intercalate, nub, sortOn) +import Data.Foldable (sequenceA_, traverse_) import qualified Data.Map as Map -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Ord (comparing) import qualified Data.Set as Set -import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock.POSIX ( POSIXTime @@ -86,7 +53,6 @@ import Data.Time.Format (formatTime) import Data.Time.Locale.Compat (defaultTimeLocale) import qualified Data.Yaml as Y -import GHC.Generics import Prettyprinter ( Doc , annotate @@ -104,11 +70,32 @@ ( stdin ) -import HOpenPGP.Tools.Common.Common - ( renderFingerprint - , renderKeyID +import HOpenPGP.Tools.Hokey.Lint.Policy + ( LintPolicy (..) + , checkKeyAlgorithmAndSize + , checkKeyBestOf + , checkKeyCreationTime + , checkKeyFingerprint + , checkKeyHasEncryptionCapableSubkey + , checkKeyStatus + , checkKeySubkeys + , checkKeyUIDsAndUAts + , checkKeyVersion + , mkLintContext ) -import HOpenPGP.Tools.Common.TKUtils (processTK) +import HOpenPGP.Tools.Hokey.Lint.Types + ( Color (..) + , CrossCertReport (..) + , KAS (..) + , KeyReport (..) + , LintContext (..) + , Result (..) + , RevocationStatus (..) + , SubkeyReport (..) + , SubkeyRevocationDigestWarning (..) + , UIDReport (..) + , getResult + ) import HOpenPGP.Tools.Hokey.Options ( LintOptions (..) , LintOutputFormat (..) @@ -122,569 +109,35 @@ yellow = annotate (PPA.color PPA.Yellow) red = annotate (PPA.color PPA.Red) -data KAS - = KAS - { pubkeyalgo :: Result PubKeyAlgorithm - , pubkeysize :: Result (Maybe Int) - , stringrep :: String - } - deriving (Generic) - -data Color - = Green - | Yellow - | Red - deriving (Eq, Generic, Ord) - -data Result a = Result - { resultColor :: Maybe Color - , resultFindings :: Maybe [String] - , resultValue :: a - } - deriving (Functor, Generic) - -instance Applicative Result where - pure x = Result Nothing Nothing x - (Result c1 e1 f) <*> (Result c2 e2 x) = - Result (max c1 c2) (e1 <> e2) (f x) - -instance Monad Result where - (Result c1 e1 x) >>= f = - let Result c2 e2 y = f x - in Result (max c1 c2) (e1 <> e2) y - -colored :: Maybe Color -> Maybe [String] -> a -> Result a -colored c e x = Result c e x - -withColor :: Maybe Color -> a -> Result a -withColor c x = Result c Nothing x - -getResult :: Result a -> a -getResult (Result _ _ x) = x - -newtype LintPolicy src a - = LintPolicy - { unPolicy :: src -> Maybe POSIXTime -> Result a - } - deriving (Functor, Generic) - -instance Applicative (LintPolicy src) where - pure x = LintPolicy (\_ _ -> pure x) - (LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src mpt -> f src mpt <*> x src mpt) - -data KeyReport - = KeyReport - { keyStatus :: Result String - , keyFingerprint :: Result Fingerprint - , keyVer :: Result KeyVersion - , keyCreationTime :: Result ThirtyTwoBitTimeStamp - , keyAlgorithmAndSize :: Result KAS - , keyUIDsAndUAts :: Map.Map Text (Result UIDReport) - , keyBestOf :: Maybe UIDReport - , keySubkeys :: [Result SubkeyReport] - , keyHasEncryptionCapableSubkey :: Result Bool - } - deriving (Generic) - -data UIDReport - = UIDReport - { uidSelfSigHashAlgorithms :: [Result HashAlgorithm] - , uidPreferredHashAlgorithms :: [Result [HashAlgorithm]] - , uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]] - , uidKeyUsageFlags :: [Result (Set.Set KeyFlag)] - , uidRevocationStatus :: [RevocationStatus] - } - deriving (Generic) - -data SubkeyReport - = SubkeyReport - { skFingerprint :: Result Fingerprint - , skVer :: Result KeyVersion - , skCreationTime :: ThirtyTwoBitTimeStamp - , skAlgorithmAndSize :: Result KAS - , skBindingSigHashAlgorithms :: [Result HashAlgorithm] - , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning] - , skUsageFlags :: [Result (Set.Set KeyFlag)] - , skCrossCerts :: CrossCertReport - } - deriving (Generic) - -data SubkeyRevocationDigestWarning - = SubkeyRevocationDigestWarning - { srwHashAlgorithm :: HashAlgorithm - , srwSubkeyFingerprint :: String - , srwSubkeyKeyID :: Maybe String - , srwMessage :: String - } - deriving (Generic) - -data CrossCertReport - = CrossCertReport - { ccPresent :: Result Bool - , ccHashAlgorithms :: [Result HashAlgorithm] - } - deriving (Generic) - -data RevocationStatus - = RevocationStatus - { isRevoked :: Bool - , revocationCode :: String - , revocationReason :: Text - } - deriving (Generic) - -instance A.ToJSON KAS - -instance A.ToJSON Color - -instance (A.ToJSON a) => A.ToJSON (Result a) - -instance A.ToJSON KeyReport - -instance A.ToJSON UIDReport - -instance A.ToJSON SubkeyReport - -instance A.ToJSON SubkeyRevocationDigestWarning - -instance A.ToJSON CrossCertReport - -instance A.ToJSON RevocationStatus - -instance Semigroup UIDReport where - (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') = - UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') - -instance Monoid UIDReport where - mempty = UIDReport [] [] [] [] [] - mappend = (<>) - -checkKey :: LintPolicy SomeTK KeyReport -checkKey = LintPolicy $ \tk mpt -> checkKey' mpt tk - -checkKey' :: Maybe POSIXTime -> SomeTK -> Result KeyReport -checkKey' mpt stk = - kr - <$ sequenceA_ - [ void (keyStatus kr) - , void (keyFingerprint kr) - , void (keyVer kr) - , void (keyAlgorithmAndSize kr) - , void (keyHasEncryptionCapableSubkey kr) - , traverse_ void (keySubkeys kr) - , traverse_ void (keyUIDsAndUAts kr) - ] - where - procResult = processTK mpt stk - processedTK = either (const stk) id procResult - publicView = someTKToPublicViewTK processedTK - primaryKey = keyPktPKPayload (_tkPrimaryKey publicView) - kr = - KeyReport - { keyStatus = pure (either id (const "good") procResult) - , keyFingerprint = pure (fingerprint primaryKey) - , keyVer = colorizeKV (_keyVersion primaryKey) - , keyCreationTime = pure (_timestamp primaryKey) - , keyAlgorithmAndSize = kasIt primaryKey - , keyUIDsAndUAts = uidMap - , keyBestOf = populateBestOf uidMap - , keySubkeys = subkeys - , keyHasEncryptionCapableSubkey = - hasEncryptionCapableSubkey - (concatMap (skUsageFlags . getResult) subkeys) - } - uidMap = - Map.fromListWith (liftA2 (<>)) $ - map - (\(x, y) -> (x, uidr (Just x) y)) - (_tkUIDs publicView) - ++ map - (uatspsToText *** uidr Nothing) - (_tkUAts publicView) - subkeys = map (checkSK (fingerprint primaryKey)) (_tkSubs publicView) - uidr :: Maybe Text -> [SignaturePayload] -> Result UIDReport - uidr Nothing sps = - UIDReport - <$> pure (has sps) - <*> pure (map phas sps) - <*> pure - ( map - ( colorizeKETs - (fromMaybe 0 mpt) - (unThirtyTwoBitTimeStamp (_timestamp primaryKey)) - . getKeyExpirationTimesFromSignature - ) - sps -- should that be 0? - ) - <*> pure (kufs False sps) - <*> pure (findRevocationReason sps) - uidr (Just u) sps = - colorizeUID - u - ( UIDReport - (has sps) - (map phas sps) - ( map - ( colorizeKETs - (fromMaybe 0 mpt) - (unThirtyTwoBitTimeStamp (_timestamp primaryKey)) - . getKeyExpirationTimesFromSignature - ) - sps -- should that be 0? - ) - (kufs False sps) - (findRevocationReason sps) - ) - kasIt :: SomePKPayload -> Result KAS - kasIt pkp = kasIt' (_pkalgo pkp) (_pubkey pkp & pubkeySize) - kasIt' :: PubKeyAlgorithm -> Either String Int -> Result KAS - kasIt' pka epks = - let pr = colorizePKA pka - prs = colorizePKS pka epks - strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka) - in colored - (max (resultColor pr) (resultColor prs)) - (resultFindings pr <> resultFindings prs) - (KAS pr prs strRep) - colorizeKV :: KeyVersion -> Result KeyVersion - colorizeKV kv - | kv `elem` [V4, V6] = withColor (Just Green) kv - | otherwise = - colored (Just Red) (Just ["not a V4 or V6 key"]) kv - colorizePKA :: PubKeyAlgorithm -> Result PubKeyAlgorithm - colorizePKA pka - | pka `elem` [RSA, EdDSALegacy, ECDH, Ed25519, Ed448, X25519, X448] = - colored (Just Green) Nothing pka - | otherwise = - colored - (Just Yellow) - (Just ["public key algorithm neither RSA nor elliptic-curve"]) - pka - colorizePKS - :: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int) - colorizePKS pka (Right pks) - -- Group 256-bit ECC curves - | pka `elem` [Ed25519, X25519, ECDH, EdDSALegacy] && pks >= 256 = - withColor (Just Green) (Just pks) - -- Group 448-bit ECC curves - | pka `elem` [Ed448, X448] && pks >= 448 = - withColor (Just Green) (Just pks) - -- Catch-all for undersized ECC curves - | pka `elem` [Ed25519, Ed448, X25519, X448, ECDH, EdDSALegacy] = - colored - (Just Yellow) - (Just ["Public key size insufficient for ECC algorithm"]) - (Just pks) - -- RSA size checks - | pka == RSA && pks >= 3072 = - withColor (Just Green) (Just pks) - | pka == RSA && pks >= 2048 = - colored - (Just Yellow) - (Just ["Public key size between 2048 and 3072 bits"]) - (Just pks) - | pka == RSA = - colored - (Just Red) - (Just ["Public key size under 2048 bits"]) - (Just pks) - -- Fallback for unknown algorithms but known sizes - | otherwise = - pure (Just pks) - colorizePKS _ (Left _) = - colored - (Just Red) - (Just ["public key algorithm not understood"]) - Nothing - colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm] - colorizePHAs x - | preferredWeakHash x = - colored (Just Red) (Just ["weak hash with higher preference"]) x - | otherwise = withColor (Just Green) x - fSHA2or3Family = - fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256]) - firstStrongSHA2or3 xs = fSHA2or3Family xs - preferredWeakHash xs = - any - ( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs - ) - knownWeakHashAlgorithms - fi x y = fromMaybe maxBound (findIndex x y) - colorizeKETs ct ts kes - | null kes = colored (Just Red) (Just ["no expiration set"]) kes - | 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 - eoki pkp - | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp - | _keyVersion pkp == DeprecatedV3 - && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] = - hush . eightOctetKeyID $ pkp - | otherwise = Nothing - phas sig = - colorizePHAs - ( concatMap - ( \case - SigSubPacket _ (PreferredHashAlgorithms x) -> x - _ -> [] - ) - (filter isPHA (hasheds sig)) - ) - has = map (colorizeHA . hashAlgo) . alleged - colorizeHA :: HashAlgorithm -> Result HashAlgorithm - colorizeHA ha - | isKnownWeakHashAlgorithm ha = - colored (Just Red) (Just ["weak hash algorithm"]) ha - | otherwise = pure ha - sigcts sig = - map - ( \case - SigSubPacket _ (SigCreationTime x) -> x - _ -> error "unexpected subpacket type" - ) - (filter isCT (hasheds sig)) - alleged = - filter - ( \sig -> - primaryFingerprint `elem` sigissuerFPs sig - || ((==) <$> sigissuer sig <*> eoki primaryKey) - == Just True - ) - where - primaryFingerprint = fingerprint primaryKey - uatspsToText = T.pack . uatspsToString - uatspsToString us = - "" - uaspToString (ImageAttribute hdr d) = - hdrToString hdr - ++ ':' - : show (BL.length d) - ++ ':' - : BC8.unpack - (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d))) - uaspToString (OtherUASub t d) = - "other-" - ++ show t - ++ ':' - : show (BL.length d) - ++ ':' - : BC8.unpack - (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d))) - hdrToString (ImageHV1 JPEG) = "jpeg" - hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt) - populateBestOf - :: Map.Map Text (Result UIDReport) -> Maybe UIDReport - populateBestOf um - | Map.null um = Nothing - | otherwise = - Just - ( UIDReport - <$> best . uidSelfSigHashAlgorithms - <*> best - . uidPreferredHashAlgorithms - <*> best - . uidKeyExpirationTimes - <*> best - . uidKeyUsageFlags - <*> pure [] - $ mconcat (justTheUIDRs um) - ) - justTheUIDRs = map getResult . Map.elems - -- Pick the single most favorable Result from a list, for display as - -- a representative "best of" example. - -- - -- This doesn't use Ord because there could be a Nothing in the list - -- and that would be "best". - -- - -- That also implies that this should get an overhaul. - best :: [Result a] -> [Result a] - best = take 1 . sortOn (bestOfRank . resultColor) - bestOfRank :: Maybe Color -> Int - bestOfRank (Just Green) = 0 - bestOfRank (Just Yellow) = 1 - bestOfRank (Just Red) = 2 - bestOfRank Nothing = 3 - colorizeUID :: Text -> UIDReport -> Result UIDReport - colorizeUID u ur = - let strU = T.unpack u - check cond msg = - if cond - then colored (Just Yellow) (Just [msg]) () - else pure () - in check ('(' `elem` strU) "parenthesis in uid" - *> check ('<' `notElem` strU) "no left angle bracket in uid" - *> pure ur - findRevocationReason = concatMap grabReasons . filter isCertRevocationSig - grabReasons (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) = - mapMaybe (grabReasons' . _sspPayload) hashedSubs - grabReasons (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) = - mapMaybe (grabReasons' . _sspPayload) hashedSubs - grabReasons _ = [] - grabReasons' (ReasonForRevocation a b) = - Just (RevocationStatus True (show a) b) - grabReasons' _ = Nothing - kufs s = - mapMaybe - ( \sig -> - case find isKUF (hasheds sig) of - Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs s x) - _ -> Nothing - ) - . newestWith (any isKUF . hasheds) - colorizeKUFs - :: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag) - colorizeKUFs False x - | encrypts && signsOrCertifies = - colored (Just Yellow) (Just ["both signing & encryption"]) x - | otherwise = withColor (Just Green) x - where - encrypts = - Set.member EncryptStorageKey x - || Set.member EncryptCommunicationsKey x - signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x - colorizeKUFs True x - | certifies = - colored (Just Red) (Just ["certification-capable subkey"]) x - | encryptsAndSigns = - colored (Just Yellow) (Just ["both signing & encryption"]) x - | otherwise = withColor (Just Green) x - where - certifies = Set.member CertifyKeysKey x - encryptsAndSigns = - ( Set.member EncryptStorageKey x - || Set.member EncryptCommunicationsKey x - ) - && Set.member SignDataKey x - sigTime :: SignaturePayload -> ThirtyTwoBitTimeStamp - sigTime sig = case sigcts sig of - (t : _) -> t - [] -> 0 - newestWith p sigs = - let filtered = filter p sigs - in if null filtered - then [] - else [maximumBy (comparing sigTime) filtered] - checkSK - :: Fingerprint - -> (KeyPkt k, [SignaturePayload]) - -> Result SubkeyReport - checkSK pf (KeyPktPublicSubkey pkp, sigs) = checkSK' pf pkp sigs - checkSK pf (KeyPktSecretSubkey pkp _, sigs) = checkSK' pf pkp sigs - checkSK _ _ = error "checkSK: unexpected packet type" - checkSK' pf pkp sigs = - skr +checkKey :: LintPolicy LintContext KeyReport +checkKey = LintPolicy $ \ctx -> + let kr = + KeyReport + { keyStatus = unPolicy checkKeyStatus ctx + , keyFingerprint = unPolicy checkKeyFingerprint ctx + , keyVer = unPolicy checkKeyVersion ctx + , keyCreationTime = unPolicy checkKeyCreationTime ctx + , keyAlgorithmAndSize = unPolicy checkKeyAlgorithmAndSize ctx + , keyUIDsAndUAts = unPolicy checkKeyUIDsAndUAts ctx + , keyBestOf = unPolicy checkKeyBestOf ctx + , keySubkeys = unPolicy checkKeySubkeys ctx + , keyHasEncryptionCapableSubkey = + unPolicy checkKeyHasEncryptionCapableSubkey ctx + } + in kr <$ sequenceA_ - [ void (skFingerprint skr) - , void (skVer skr) - , void (skAlgorithmAndSize skr) - , traverse_ void (skBindingSigHashAlgorithms skr) - , traverse_ void (skUsageFlags skr) - , void (ccPresent (skCrossCerts skr)) - , traverse_ void (ccHashAlgorithms (skCrossCerts skr)) + [ void (keyStatus kr) + , void (keyFingerprint kr) + , void (keyVer kr) + , void (keyAlgorithmAndSize kr) + , void (keyHasEncryptionCapableSubkey kr) + , traverse_ void (getResult (keySubkeys kr)) + , traverse_ void (getResult (keyUIDsAndUAts kr)) ] - where - skr = - ( \x -> x {skCrossCerts = ccr (map getResult (skUsageFlags x)) sigs} - ) - SubkeyReport - { skFingerprint = colorizeF pf (fingerprint pkp) - , skVer = colorizeKV (_keyVersion pkp) - , skCreationTime = _timestamp pkp - , skAlgorithmAndSize = kasIt pkp - , skBindingSigHashAlgorithms = has (filter isSKBindingSig sigs) - , skRevocationSigWeakDigests = - subkeyRevocationSigWeakDigests pkp sigs - , skUsageFlags = kufs True (filter isSKBindingSig sigs) - , skCrossCerts = CrossCertReport (pure False) [] - } - hasEncryptionCapableSubkey - :: [Result (Set.Set KeyFlag)] -> Result Bool - hasEncryptionCapableSubkey skrs = - let hasEncryption = - any - ( ( \x -> - Set.member EncryptStorageKey x - || Set.member EncryptCommunicationsKey x - ) - . getResult - ) - skrs - in if hasEncryption - then withColor (Just Green) True - else - colored - (Just Red) - (Just ["no encryption-capable subkey present"]) - False - embeddedSigs = - filter isPKBindingSig - . concatMap getEmbeds - . filter isSKBindingSig - getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys) - getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys) - getEmbeds _ = [] - getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp] - getEmbed _ = [] - ccr kufs' sigs = - CrossCertReport - (colorES kufs' sigs) - (map (colorizeHA . hashAlgo) sigs) - colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool - colorES kufs' sigs = - let noEmbedded = null (embeddedSigs sigs) - signCapable = any (Set.member SignDataKey) kufs' - authCapable = any (Set.member AuthKey) kufs' - in case (noEmbedded, signCapable, authCapable) 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 - _ -> - withColor (Just Green) True - colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint - colorizeF pf fp - | pf == fp = - colored - (Just Red) - (Just ["subkey has same fingerprint as primary key"]) - fp - | otherwise = withColor (Just Green) fp - subkeyRevocationSigWeakDigests pkp = - mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp) - . filter isSubkeyRevocationSignature - mkSubkeyRevocationSigWeakDigestWarning pkp sig = - let ha = hashAlgo sig - in if isKnownWeakHashAlgorithm ha - then - Just - SubkeyRevocationDigestWarning - { srwHashAlgorithm = ha - , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp) - , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp)) - , srwMessage = - "subkey revocation signature uses known-weak digest algorithm" - } - else Nothing prettyKeyReport :: POSIXTime -> SomeTK -> Doc PPA.AnsiStyle prettyKeyReport cpt stk = do - let keyReportResult = unPolicy checkKey stk (Just cpt) - keyReport = getResult keyReportResult + let keyReport = getResult (unPolicy checkKey (mkLintContext (Just cpt) stk)) execWriter $ tell $ vsep @@ -696,7 +149,7 @@ <+> pretty (SpacedFingerprint (getResult (keyFingerprint keyReport))) , pretty "Checking to see if key is OpenPGPv4 or v6" <> colon - <+> coloredToColor (pretty . show) (keyVer keyReport) + <+> coloredToColor pretty (keyVer keyReport) , ( \kas -> pretty "Checking the strength of your primary asymmetric key" <> colon @@ -709,7 +162,7 @@ <> mconcat ( map (uidtrip (getResult (keyCreationTime keyReport))) - (Map.toList (keyUIDsAndUAts keyReport)) + (Map.toList (getResult (keyUIDsAndUAts keyReport))) ) , pretty "Checking subkeys" <> colon , indent @@ -718,7 +171,7 @@ <> colon <+> coloredToColor pretty (keyHasEncryptionCapableSubkey keyReport) ) - <> mconcat (map subkeyrep (keySubkeys keyReport)) + <> mconcat (map subkeyrep (getResult (keySubkeys keyReport))) ] <> linebreak where @@ -887,11 +340,14 @@ ) jsonReport :: POSIXTime -> SomeTK -> BL.ByteString -jsonReport ps stk = A.encode (getResult (unPolicy checkKey stk (Just ps))) +jsonReport ps stk = + A.encode + (getResult (unPolicy checkKey (mkLintContext (Just ps) stk))) yamlReport :: POSIXTime -> SomeTK -> B.ByteString yamlReport ps stk = - Y.encode . (: []) $ getResult (unPolicy checkKey stk (Just ps)) + Y.encode . (: []) $ + getResult (unPolicy checkKey (mkLintContext (Just ps) stk)) doLint :: LintOptions -> IO () doLint o = do @@ -910,50 +366,3 @@ mapM_ (BL.putStr . flip BL.append (BL.singleton 0x0a) . jsonReport cpt) output YAML cpt = mapM_ (B.putStr . yamlReport cpt) - -sigissuer :: SignaturePayload -> Maybe EightOctetKeyId -getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId -hashAlgo :: SignaturePayload -> HashAlgorithm -sigissuer (SigVOther 2 _) = Nothing -sigissuer SigV3 {} = Nothing -sigissuer (SigV4 _ _ _ ys xs _ _) = - let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs) - in case nub issuers of - [issuer] -> Just issuer - _ -> Nothing -sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs -sigissuer (SigVOther _ _) = Nothing - -getIssuer (Issuer i) = Just i -getIssuer _ = Nothing - -sigissuerFPs :: SignaturePayload -> [Fingerprint] -sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs) -sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs) -sigissuerFPs _ = [] - -getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint -getIssuerFP (IssuerFingerprint _ fp) = Just fp -getIssuerFP _ = Nothing - -hashAlgo (SigV3 _ _ _ _ x _ _) = x -hashAlgo (SigV4 _ _ x _ _ _ _) = x -hashAlgo (SigV6 _ _ x _ _ _ _ _) = x -hashAlgo (SigVOther _ _) = OtherHA 0 - -knownWeakHashAlgorithms :: [HashAlgorithm] -knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160] - -isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool -isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms - -isSubkeyRevocationSignature :: SignaturePayload -> Bool -isSubkeyRevocationSignature (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig -isSubkeyRevocationSignature (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig -isSubkeyRevocationSignature (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig -isSubkeyRevocationSignature _ = False - -hasheds :: SignaturePayload -> [SigSubPacket] -hasheds (SigV4 _ _ _ xs _ _ _) = xs -hasheds (SigV6 _ _ _ _ xs _ _ _) = xs -hasheds _ = [] diff --git a/HOpenPGP/Tools/Hokey/Lint/Policy.hs b/HOpenPGP/Tools/Hokey/Lint/Policy.hs new file mode 100644 --- /dev/null +++ b/HOpenPGP/Tools/Hokey/Lint/Policy.hs @@ -0,0 +1,758 @@ +-- Policy.hs: hOpenPGP key tool lint subcommand linting policy +-- Copyright © 2013-2026 Clint Adams +-- +-- vim: softtabstop=4:shiftwidth=4:expandtab +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeApplications #-} + +module HOpenPGP.Tools.Hokey.Lint.Policy + ( LintPolicy (..) + , checkKeyStatus + , checkKeyFingerprint + , checkKeyVersion + , checkKeyCreationTime + , checkKeyAlgorithmAndSize + , checkKeyUIDsAndUAts + , checkKeyBestOf + , checkKeySubkeys + , checkKeyHasEncryptionCapableSubkey + , colorizeKV + , colorizePKA + , colorizePKS + , colorizePHAs + , colorizeKETs + , colorizeKUFs + , colorizeUID + , colorizeHA + , colorizeF + , colorES + , knownWeakHashAlgorithms + , isKnownWeakHashAlgorithm + , kasIt + , kasIt' + , uidr + , checkSK + , checkSK' + , hasEncryptionCapableSubkey + , kufs + , has + , phas + , findRevocationReason + , grabReasons + , grabReasons' + , subkeyRevocationSigWeakDigests + , mkSubkeyRevocationSigWeakDigestWarning + , isSubkeyRevocationSignature + , alleged + , eoki + , sigcts + , sigTime + , newestWith + , sigissuer + , getIssuer + , sigissuerFPs + , getIssuerFP + , hashAlgo + , hasheds + , ccr + , uatspsToText + , uatspsToString + , uaspToString + , hdrToString + , embeddedSigs + , getEmbeds + , getEmbed + , mkLintContext + ) where + +import Codec.Encryption.OpenPGP.Expirations + ( getKeyExpirationTimesFromSignature + ) +import Codec.Encryption.OpenPGP.Fingerprint + ( eightOctetKeyID + , fingerprint + ) +import Codec.Encryption.OpenPGP.KeyInfo + ( pkalgoAbbrev + , pubkeySize + ) +import Codec.Encryption.OpenPGP.Ontology + ( isCT + , isCertRevocationSig + , isKUF + , isPHA + , isPKBindingSig + , isSKBindingSig + ) +import Codec.Encryption.OpenPGP.Serialize () +import Codec.Encryption.OpenPGP.Types +import Control.Arrow ((***)) +import Control.Error.Util (hush) +import Control.Lens ((&)) +import Control.Monad (void) +import qualified Crypto.Hash as CH +import qualified Crypto.Hash.Algorithms as CHA +import qualified Data.ByteArray as BA +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BC8 +import qualified Data.ByteString.Lazy as BL +import Data.Foldable (find, maximumBy, sequenceA_, traverse_) +import Data.List (elemIndex, findIndex, intercalate, nub) +import qualified Data.Map as Map +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Ord (comparing) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as T +import Data.Time.Clock.POSIX (POSIXTime) + +import HOpenPGP.Tools.Common.Common + ( renderFingerprint + , renderKeyID + ) +import HOpenPGP.Tools.Common.TKUtils (processTK) +import HOpenPGP.Tools.Hokey.Lint.Types + +newtype LintPolicy src a + = LintPolicy + { unPolicy :: src -> Result a + } + deriving (Functor) + +instance Applicative (LintPolicy src) where + pure x = LintPolicy (\_ -> pure x) + (LintPolicy f) <*> (LintPolicy x) = LintPolicy (\src -> f src <*> x src) + +mkLintContext :: Maybe POSIXTime -> SomeTK -> LintContext +mkLintContext mpt stk = + let procResult = processTK mpt stk + processedTK = either (const stk) id procResult + publicView = someTKToPublicViewTK processedTK + primaryKey = keyPktPKPayload (_tkPrimaryKey publicView) + in LintContext + mpt + publicView + procResult + primaryKey + (fingerprint primaryKey) + +checkKeyStatus :: LintPolicy LintContext String +checkKeyStatus = LintPolicy $ \ctx -> + pure (either id (const "good") (lcProcResult ctx)) + +checkKeyFingerprint :: LintPolicy LintContext Fingerprint +checkKeyFingerprint = LintPolicy $ \ctx -> + pure (lcFingerprint ctx) + +checkKeyVersion :: LintPolicy LintContext KeyVersion +checkKeyVersion = LintPolicy $ \ctx -> + pure (getResult (colorizeKV (_keyVersion (lcPrimaryKey ctx)))) + +checkKeyCreationTime + :: LintPolicy LintContext ThirtyTwoBitTimeStamp +checkKeyCreationTime = LintPolicy $ \ctx -> + pure (_timestamp (lcPrimaryKey ctx)) + +checkKeyAlgorithmAndSize :: LintPolicy LintContext KAS +checkKeyAlgorithmAndSize = LintPolicy $ \ctx -> + pure (getResult (kasIt (lcPrimaryKey ctx))) + +checkKeyUIDsAndUAts + :: LintPolicy LintContext (Map.Map Text (Result UIDReport)) +checkKeyUIDsAndUAts = LintPolicy $ \ctx -> + let pkp = lcPrimaryKey ctx + publicView = (lcProcessedTK ctx) + mpt = lcMpt ctx + uidMap = + Map.fromListWith (liftA2 (<>)) $ + map + (\(x, y) -> (x, uidr (Just x) pkp mpt y)) + (_tkUIDs publicView) + ++ map + (uatspsToText *** uidr Nothing pkp mpt) + (_tkUAts publicView) + in pure uidMap + +checkKeyBestOf :: LintPolicy LintContext (Maybe UIDReport) +checkKeyBestOf = LintPolicy $ \ctx -> + let pkp = lcPrimaryKey ctx + publicView = (lcProcessedTK ctx) + mpt = lcMpt ctx + uidMap = + Map.fromListWith (liftA2 (<>)) $ + map + (\(x, y) -> (x, uidr (Just x) pkp mpt y)) + (_tkUIDs publicView) + ++ map + (uatspsToText *** uidr Nothing pkp mpt) + (_tkUAts publicView) + in pure (populateBestOf uidMap) + +checkKeySubkeys :: LintPolicy LintContext [Result SubkeyReport] +checkKeySubkeys = LintPolicy $ \ctx -> + let publicView = (lcProcessedTK ctx) + in pure (map (checkSK (lcFingerprint ctx)) (_tkSubs publicView)) + +checkKeyHasEncryptionCapableSubkey :: LintPolicy LintContext Bool +checkKeyHasEncryptionCapableSubkey = LintPolicy $ \ctx -> + let subkeys = unPolicy checkKeySubkeys ctx + in pure + ( getResult + ( hasEncryptionCapableSubkey + (concatMap skUsageFlags (map getResult (getResult subkeys))) + ) + ) + +colorizeKV :: KeyVersion -> Result KeyVersion +colorizeKV kv + | kv `elem` [V4, V6] = withColor (Just Green) kv + | otherwise = + colored (Just Red) (Just ["not a V4 or V6 key"]) kv + +colorizePKA + :: PubKeyAlgorithm -> KeyVersion -> Result PubKeyAlgorithm +colorizePKA pka kv = case (pka, kv) of + (RSA, _) -> colored (Just Green) Nothing pka + (EdDSALegacy, V4) -> colored (Just Green) Nothing pka + (EdDSALegacy, DeprecatedV3) -> colored (Just Green) Nothing pka + (EdDSALegacy, V6) -> + colored + (Just Red) + (Just ["algorithm EdDSALegacy is not legal for V6 keys"]) + pka + (ECDH, V4) -> colored (Just Green) Nothing pka + (ECDH, DeprecatedV3) -> colored (Just Green) Nothing pka + (ECDH, V6) -> + colored + (Just Red) + (Just ["algorithm ECDH is not legal for V6 keys"]) + pka + (Ed25519, V4) -> + colored + (Just Red) + (Just ["algorithm Ed25519 is not legal for V4 keys"]) + pka + (Ed25519, DeprecatedV3) -> + colored + (Just Red) + (Just ["algorithm Ed25519 is not legal for DeprecatedV3 keys"]) + pka + (Ed25519, V6) -> colored (Just Green) Nothing pka + (X25519, V4) -> + colored + (Just Red) + (Just ["algorithm X25519 is not legal for V4 keys"]) + pka + (X25519, DeprecatedV3) -> + colored + (Just Red) + (Just ["algorithm X25519 is not legal for DeprecatedV3 keys"]) + pka + (X25519, V6) -> colored (Just Green) Nothing pka + (Ed448, V4) -> + colored + (Just Red) + (Just ["algorithm Ed448 is not legal for V4 keys"]) + pka + (Ed448, DeprecatedV3) -> + colored + (Just Red) + (Just ["algorithm Ed448 is not legal for DeprecatedV3 keys"]) + pka + (Ed448, V6) -> colored (Just Green) Nothing pka + (X448, V4) -> + colored + (Just Red) + (Just ["algorithm X448 is not legal for V4 keys"]) + pka + (X448, DeprecatedV3) -> + colored + (Just Red) + (Just ["algorithm X448 is not legal for DeprecatedV3 keys"]) + pka + (X448, V6) -> colored (Just Green) Nothing pka + (_, _) -> + colored + (Just Yellow) + (Just ["public key algorithm neither RSA nor elliptic-curve"]) + pka + +colorizePKS + :: PubKeyAlgorithm -> Either String Int -> Result (Maybe Int) +colorizePKS pka (Right pks) + -- Group 256-bit ECC curves + | pka `elem` [Ed25519, X25519, ECDH, EdDSALegacy] && pks >= 256 = + withColor (Just Green) (Just pks) + -- Group 448-bit ECC curves + | pka `elem` [Ed448, X448] && pks >= 448 = + withColor (Just Green) (Just pks) + -- Catch-all for undersized ECC curves + | pka `elem` [Ed25519, Ed448, X25519, X448, ECDH, EdDSALegacy] = + colored + (Just Yellow) + (Just ["Public key size insufficient for ECC algorithm"]) + (Just pks) + -- RSA size checks + | pka == RSA && pks >= 3072 = + withColor (Just Green) (Just pks) + | pka == RSA && pks >= 2048 = + colored + (Just Yellow) + (Just ["Public key size between 2048 and 3072 bits"]) + (Just pks) + | pka == RSA = + colored + (Just Red) + (Just ["Public key size under 2048 bits"]) + (Just pks) + -- Fallback for unknown algorithms but known sizes + | otherwise = + pure (Just pks) +colorizePKS _ (Left _) = + colored + (Just Red) + (Just ["public key algorithm not understood"]) + Nothing + +colorizePHAs :: [HashAlgorithm] -> Result [HashAlgorithm] +colorizePHAs x + | preferredWeakHash x = + colored (Just Red) (Just ["weak hash with higher preference"]) x + | otherwise = withColor (Just Green) x + +fSHA2or3Family :: [HashAlgorithm] -> Int +fSHA2or3Family = + fi (`elem` [SHA512, SHA384, SHA256, SHA224, SHA3_512, SHA3_256]) + +firstStrongSHA2or3 :: [HashAlgorithm] -> Int +firstStrongSHA2or3 xs = fSHA2or3Family xs + +preferredWeakHash :: [HashAlgorithm] -> Bool +preferredWeakHash xs = + any + ( \ha -> fromMaybe maxBound (elemIndex ha xs) < firstStrongSHA2or3 xs + ) + knownWeakHashAlgorithms + +fi :: (a -> Bool) -> [a] -> Int +fi x y = fromMaybe maxBound (findIndex x y) + +colorizeKETs + :: POSIXTime + -> ThirtyTwoBitTimeStamp + -> [ThirtyTwoBitDuration] + -> Result [ThirtyTwoBitDuration] +colorizeKETs ct ts kes + | null kes = colored (Just Red) (Just ["no expiration set"]) kes + | 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 + +colorizeUID :: Text -> UIDReport -> Result UIDReport +colorizeUID u ur = + let strU = T.unpack u + check cond msg = + if cond + then colored (Just Yellow) (Just [msg]) () + else pure () + in check ('(' `elem` strU) "parenthesis in uid" + *> check ('<' `notElem` strU) "no left angle bracket in uid" + *> pure ur + +colorizeHA :: HashAlgorithm -> Result HashAlgorithm +colorizeHA ha + | isKnownWeakHashAlgorithm ha = + colored (Just Red) (Just ["weak hash algorithm"]) ha + | otherwise = pure ha + +colorizeF :: Fingerprint -> Fingerprint -> Result Fingerprint +colorizeF pf fp + | pf == fp = + colored + (Just Red) + (Just ["subkey has same fingerprint as primary key"]) + fp + | otherwise = withColor (Just Green) fp + +colorES :: [Set.Set KeyFlag] -> [SignaturePayload] -> Result Bool +colorES kufs' sigs = + let noEmbedded = null (embeddedSigs sigs) + signCapable = any (Set.member SignDataKey) kufs' + authCapable = any (Set.member AuthKey) kufs' + in case (noEmbedded, signCapable, authCapable) 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 + _ -> + withColor (Just Green) True + +colorizeKUFs + :: Bool -> Set.Set KeyFlag -> Result (Set.Set KeyFlag) +colorizeKUFs False x + | encrypts && signsOrCertifies = + colored (Just Yellow) (Just ["both signing & encryption"]) x + | otherwise = withColor (Just Green) x + where + encrypts = + Set.member EncryptStorageKey x + || Set.member EncryptCommunicationsKey x + signsOrCertifies = Set.member SignDataKey x || Set.member CertifyKeysKey x +colorizeKUFs True x + | certifies = + colored (Just Red) (Just ["certification-capable subkey"]) x + | encryptsAndSigns = + colored (Just Yellow) (Just ["both signing & encryption"]) x + | otherwise = withColor (Just Green) x + where + certifies = Set.member CertifyKeysKey x + encryptsAndSigns = + ( Set.member EncryptStorageKey x + || Set.member EncryptCommunicationsKey x + ) + && Set.member SignDataKey x + +knownWeakHashAlgorithms :: [HashAlgorithm] +knownWeakHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160] + +isKnownWeakHashAlgorithm :: HashAlgorithm -> Bool +isKnownWeakHashAlgorithm ha = ha `elem` knownWeakHashAlgorithms + +embeddedSigs :: [SignaturePayload] -> [SignaturePayload] +embeddedSigs = + filter isPKBindingSig + . concatMap getEmbeds + . filter isSKBindingSig + +getEmbeds :: SignaturePayload -> [SignaturePayload] +getEmbeds (SigV4 _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys) +getEmbeds (SigV6 _ _ _ _ xs ys _ _) = concatMap getEmbed (xs ++ ys) +getEmbeds _ = [] + +getEmbed :: SigSubPacket -> [SignaturePayload] +getEmbed (SigSubPacket _ (EmbeddedSignature sp)) = [sp] +getEmbed _ = [] + +kasIt :: SomePKPayload -> Result KAS +kasIt pkp = + kasIt' (_pkalgo pkp) (_keyVersion pkp) (_pubkey pkp & pubkeySize) + +kasIt' + :: PubKeyAlgorithm -> KeyVersion -> Either String Int -> Result KAS +kasIt' pka kv epks = + let pr = colorizePKA pka kv + prs = colorizePKS pka epks + strRep = (either (const "unknown") show epks) ++ (pkalgoAbbrev pka) + in colored + (max (resultColor pr) (resultColor prs)) + (resultFindings pr <> resultFindings prs) + (KAS pr prs strRep) + +uidr + :: Maybe Text + -> SomePKPayload + -> Maybe POSIXTime + -> [SignaturePayload] + -> Result UIDReport +uidr (Just u) pkp mpt sps = + colorizeUID u (getResult (uidr Nothing pkp mpt sps)) +uidr Nothing pkp mpt sps = + UIDReport + <$> pure (has pkp sps) + <*> pure (map (phas pkp) sps) + <*> pure + ( map + ( colorizeKETs + (fromMaybe 0 mpt) + (_timestamp pkp) + . getKeyExpirationTimesFromSignature + ) + sps + ) + <*> pure (kufs pkp sps) + <*> pure (findRevocationReason pkp sps) + +phas + :: SomePKPayload -> SignaturePayload -> Result [HashAlgorithm] +phas pkp sig = + colorizePHAs + ( concatMap + ( \case + SigSubPacket _ (PreferredHashAlgorithms x) -> x + _ -> [] + ) + (filter isPHA (hasheds pkp sig)) + ) + +has + :: SomePKPayload -> [SignaturePayload] -> [Result HashAlgorithm] +has pkp = map (colorizeHA . hashAlgo pkp) . alleged pkp + +eoki :: SomePKPayload -> Maybe EightOctetKeyId +eoki pkp + | _keyVersion pkp == V4 = hush . eightOctetKeyID $ pkp + | _keyVersion pkp == DeprecatedV3 + && elem (_pkalgo pkp) [RSA, DeprecatedRSASignOnly] = + hush . eightOctetKeyID $ pkp + | otherwise = Nothing + +sigcts + :: SomePKPayload -> SignaturePayload -> [ThirtyTwoBitTimeStamp] +sigcts pkp sig = + map + ( \case + SigSubPacket _ (SigCreationTime x) -> x + _ -> error "unexpected subpacket type" + ) + (filter isCT (hasheds pkp sig)) + +alleged + :: SomePKPayload -> [SignaturePayload] -> [SignaturePayload] +alleged pkp = + filter + ( \sig -> + fingerprint pkp `elem` sigissuerFPs sig + || ((==) <$> sigissuer sig <*> eoki pkp) + == Just True + ) + +uatspsToText :: [UserAttrSubPacket] -> Text +uatspsToText = T.pack . uatspsToString + +uatspsToString :: [UserAttrSubPacket] -> String +uatspsToString us = + "" + +uaspToString :: UserAttrSubPacket -> String +uaspToString (ImageAttribute hdr d) = + hdrToString hdr + ++ ':' + : show (BL.length d) + ++ ':' + : BC8.unpack + (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d))) +uaspToString (OtherUASub t d) = + "other-" + ++ show t + ++ ':' + : show (BL.length d) + ++ ':' + : BC8.unpack + (Base16.encode (BA.convert (CH.hashlazy @CHA.SHA3_512 d))) + +hdrToString :: ImageHeader -> String +hdrToString (ImageHV1 JPEG) = "jpeg" +hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt) + +sigTime + :: SomePKPayload -> SignaturePayload -> ThirtyTwoBitTimeStamp +sigTime pkp sig = case sigcts pkp sig of + (t : _) -> t + [] -> 0 + +newestWith + :: (SignaturePayload -> Bool) + -> SomePKPayload + -> [SignaturePayload] + -> [SignaturePayload] +newestWith p pkp sigs = + let filtered = filter p sigs + in if null filtered + then [] + else [maximumBy (comparing (sigTime pkp)) filtered] + +checkSK + :: Fingerprint + -> (KeyPkt k, [SignaturePayload]) + -> Result SubkeyReport +checkSK pf (KeyPktPublicSubkey pkp, sigs) = checkSK' pf pkp sigs +checkSK pf (KeyPktSecretSubkey pkp _, sigs) = checkSK' pf pkp sigs +checkSK _ _ = error "checkSK: unexpected packet type" + +checkSK' + :: Fingerprint + -> SomePKPayload + -> [SignaturePayload] + -> Result SubkeyReport +checkSK' pf pkp sigs = + skr + <$ sequenceA_ + [ void (skFingerprint skr) + , void (skVer skr) + , void (skAlgorithmAndSize skr) + , traverse_ void (skBindingSigHashAlgorithms skr) + , traverse_ void (skUsageFlags skr) + , void (ccPresent (skCrossCerts skr)) + , traverse_ void (ccHashAlgorithms (skCrossCerts skr)) + ] + where + skr = + ( \x -> + x {skCrossCerts = ccr pkp (map getResult (skUsageFlags x)) sigs} + ) + SubkeyReport + { skFingerprint = colorizeF pf (fingerprint pkp) + , skVer = colorizeKV (_keyVersion pkp) + , skCreationTime = _timestamp pkp + , skAlgorithmAndSize = kasIt pkp + , skBindingSigHashAlgorithms = has pkp (filter isSKBindingSig sigs) + , skRevocationSigWeakDigests = + subkeyRevocationSigWeakDigests pkp sigs + , skUsageFlags = kufs pkp (filter isSKBindingSig sigs) + , skCrossCerts = CrossCertReport (pure False) [] + } + +hasEncryptionCapableSubkey + :: [Result (Set.Set KeyFlag)] -> Result Bool +hasEncryptionCapableSubkey skrs = + let hasEncryption = + any + ( ( \x -> + Set.member EncryptStorageKey x + || Set.member EncryptCommunicationsKey x + ) + . getResult + ) + skrs + in if hasEncryption + then withColor (Just Green) True + else + colored + (Just Red) + (Just ["no encryption-capable subkey present"]) + False + +ccr + :: SomePKPayload + -> [Set.Set KeyFlag] + -> [SignaturePayload] + -> CrossCertReport +ccr pkp kufs' sigs = + CrossCertReport + (colorES kufs' sigs) + (map (colorizeHA . hashAlgo pkp) sigs) + +subkeyRevocationSigWeakDigests + :: SomePKPayload + -> [SignaturePayload] + -> [SubkeyRevocationDigestWarning] +subkeyRevocationSigWeakDigests pkp = + mapMaybe (mkSubkeyRevocationSigWeakDigestWarning pkp) + . filter (isSubkeyRevocationSignature pkp) + +mkSubkeyRevocationSigWeakDigestWarning + :: SomePKPayload + -> SignaturePayload + -> Maybe SubkeyRevocationDigestWarning +mkSubkeyRevocationSigWeakDigestWarning pkp sig = + let ha = hashAlgo pkp sig + in if isKnownWeakHashAlgorithm ha + then + Just + SubkeyRevocationDigestWarning + { srwHashAlgorithm = ha + , srwSubkeyFingerprint = renderFingerprint (fingerprint pkp) + , srwSubkeyKeyID = fmap renderKeyID (hush (eightOctetKeyID pkp)) + , srwMessage = + "subkey revocation signature uses known-weak digest algorithm" + } + else Nothing + +isSubkeyRevocationSignature + :: SomePKPayload -> SignaturePayload -> Bool +isSubkeyRevocationSignature _ (SigV3 st _ _ _ _ _ _) = st == SubkeyRevocationSig +isSubkeyRevocationSignature _ (SigV4 st _ _ _ _ _ _) = st == SubkeyRevocationSig +isSubkeyRevocationSignature _ (SigV6 st _ _ _ _ _ _ _) = st == SubkeyRevocationSig +isSubkeyRevocationSignature _ _ = False + +findRevocationReason + :: SomePKPayload -> [SignaturePayload] -> [RevocationStatus] +findRevocationReason pkp = concatMap (grabReasons pkp) . filter isCertRevocationSig + +grabReasons + :: SomePKPayload -> SignaturePayload -> [RevocationStatus] +grabReasons _ (SigV4 CertRevocationSig _ _ hashedSubs _ _ _) = + mapMaybe (grabReasons' . _sspPayload) hashedSubs +grabReasons _ (SigV6 CertRevocationSig _ _ _ hashedSubs _ _ _) = + mapMaybe (grabReasons' . _sspPayload) hashedSubs +grabReasons _ _ = [] + +grabReasons' :: SigSubPacketPayload -> Maybe RevocationStatus +grabReasons' (ReasonForRevocation a b) = + Just (RevocationStatus True (show a) b) +grabReasons' _ = Nothing + +sigissuer :: SignaturePayload -> Maybe EightOctetKeyId +getIssuer :: SigSubPacketPayload -> Maybe EightOctetKeyId +sigissuerFPs :: SignaturePayload -> [Fingerprint] +getIssuerFP :: SigSubPacketPayload -> Maybe Fingerprint +hashAlgo :: SomePKPayload -> SignaturePayload -> HashAlgorithm +hasheds :: SomePKPayload -> SignaturePayload -> [SigSubPacket] +sigissuer (SigVOther 2 _) = Nothing +sigissuer SigV3 {} = Nothing +sigissuer (SigV4 _ _ _ ys xs _ _) = + let issuers = mapMaybe (getIssuer . _sspPayload) (ys ++ xs) + in case nub issuers of + [issuer] -> Just issuer + _ -> Nothing +sigissuer (SigV6 {}) = Nothing -- v6 signatures are forbidden from carrying Issuer subpackets; see sigissuerFPs +sigissuer (SigVOther _ _) = Nothing + +getIssuer (Issuer i) = Just i +getIssuer _ = Nothing + +sigissuerFPs (SigV4 _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs) +sigissuerFPs (SigV6 _ _ _ _ ys xs _ _) = mapMaybe (getIssuerFP . _sspPayload) (ys ++ xs) +sigissuerFPs _ = [] + +getIssuerFP (IssuerFingerprint _ fp) = Just fp +getIssuerFP _ = Nothing + +hashAlgo _ (SigV3 _ _ _ _ x _ _) = x +hashAlgo _ (SigV4 _ _ x _ _ _ _) = x +hashAlgo _ (SigV6 _ _ x _ _ _ _ _) = x +hashAlgo _ (SigVOther _ _) = OtherHA 0 + +hasheds _ (SigV4 _ _ _ xs _ _ _) = xs +hasheds _ (SigV6 _ _ _ _ xs _ _ _) = xs +hasheds _ _ = [] + +kufs + :: SomePKPayload -> [SignaturePayload] -> [Result (Set.Set KeyFlag)] +kufs pkp = + mapMaybe + ( \sig -> + case find isKUF (hasheds pkp sig) of + Just (SigSubPacket _ (KeyFlags x)) -> Just (colorizeKUFs False x) + _ -> Nothing + ) + . newestWith (any isKUF . hasheds pkp) pkp diff --git a/HOpenPGP/Tools/Hokey/Lint/Types.hs b/HOpenPGP/Tools/Hokey/Lint/Types.hs new file mode 100644 --- /dev/null +++ b/HOpenPGP/Tools/Hokey/Lint/Types.hs @@ -0,0 +1,227 @@ +-- Types.hs: hOpenPGP key tool lint subcommand types +-- Copyright © 2013-2026 Clint Adams +-- +-- vim: softtabstop=4:shiftwidth=4:expandtab +-- +-- This program is free software: you can redistribute it and/or modify +-- it under the terms of the GNU Affero General Public License as +-- published by the Free Software Foundation, either version 3 of the +-- License, or (at your option) any later version. +-- +-- This program is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU Affero General Public License for more details. +-- +-- You should have received a copy of the GNU Affero General Public License +-- along with this program. If not, see . +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} + +module HOpenPGP.Tools.Hokey.Lint.Types + ( Color (..) + , Result (..) + , KAS (..) + , LintContext (..) + , KeyReport (..) + , UIDReport (..) + , SubkeyReport (..) + , SubkeyRevocationDigestWarning (..) + , CrossCertReport (..) + , RevocationStatus (..) + , colored + , withColor + , getResult + , populateBestOf + , best + , bestOfRank + , justTheUIDRs + ) where + +import Codec.Encryption.OpenPGP.Types + ( Fingerprint + , HashAlgorithm + , KeyFlag + , KeyVersion + , PubKeyAlgorithm + , SomePKPayload + , SomeTK (..) + , TK (..) + , TKKind (..) + , ThirtyTwoBitDuration + , ThirtyTwoBitTimeStamp + ) +import Data.Aeson (ToJSON) +import Data.List (sortOn) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Data.Text (Text) +import Data.Time.Clock.POSIX (POSIXTime) +import GHC.Generics + +data Color + = Green + | Yellow + | Red + deriving (Eq, Generic, Ord) + +data Result a = Result + { resultColor :: Maybe Color + , resultFindings :: Maybe [String] + , resultValue :: a + } + deriving (Functor, Generic) + +instance Applicative Result where + pure x = Result Nothing Nothing x + (Result c1 e1 f) <*> (Result c2 e2 x) = + Result (max c1 c2) (e1 <> e2) (f x) + +instance Monad Result where + (Result c1 e1 x) >>= f = + let Result c2 e2 y = f x + in Result (max c1 c2) (e1 <> e2) y + +colored :: Maybe Color -> Maybe [String] -> a -> Result a +colored c e x = Result c e x + +withColor :: Maybe Color -> a -> Result a +withColor c x = Result c Nothing x + +getResult :: Result a -> a +getResult (Result _ _ x) = x + +data KAS + = KAS + { pubkeyalgo :: Result PubKeyAlgorithm + , pubkeysize :: Result (Maybe Int) + , stringrep :: String + } + deriving (Generic) + +instance ToJSON KAS + +instance ToJSON Color + +instance (ToJSON a) => ToJSON (Result a) + +data KeyReport + = KeyReport + { keyStatus :: Result String + , keyFingerprint :: Result Fingerprint + , keyVer :: Result KeyVersion + , keyCreationTime :: Result ThirtyTwoBitTimeStamp + , keyAlgorithmAndSize :: Result KAS + , keyUIDsAndUAts :: Result (Map.Map Text (Result UIDReport)) + , keyBestOf :: Result (Maybe UIDReport) + , keySubkeys :: Result [Result SubkeyReport] + , keyHasEncryptionCapableSubkey :: Result Bool + } + deriving (Generic) + +data UIDReport + = UIDReport + { uidSelfSigHashAlgorithms :: [Result HashAlgorithm] + , uidPreferredHashAlgorithms :: [Result [HashAlgorithm]] + , uidKeyExpirationTimes :: [Result [ThirtyTwoBitDuration]] + , uidKeyUsageFlags :: [Result (Set.Set KeyFlag)] + , uidRevocationStatus :: [RevocationStatus] + } + deriving (Generic) + +data SubkeyReport + = SubkeyReport + { skFingerprint :: Result Fingerprint + , skVer :: Result KeyVersion + , skCreationTime :: ThirtyTwoBitTimeStamp + , skAlgorithmAndSize :: Result KAS + , skBindingSigHashAlgorithms :: [Result HashAlgorithm] + , skRevocationSigWeakDigests :: [SubkeyRevocationDigestWarning] + , skUsageFlags :: [Result (Set.Set KeyFlag)] + , skCrossCerts :: CrossCertReport + } + deriving (Generic) + +data SubkeyRevocationDigestWarning + = SubkeyRevocationDigestWarning + { srwHashAlgorithm :: HashAlgorithm + , srwSubkeyFingerprint :: String + , srwSubkeyKeyID :: Maybe String + , srwMessage :: String + } + deriving (Generic) + +data CrossCertReport + = CrossCertReport + { ccPresent :: Result Bool + , ccHashAlgorithms :: [Result HashAlgorithm] + } + deriving (Generic) + +data RevocationStatus + = RevocationStatus + { isRevoked :: Bool + , revocationCode :: String + , revocationReason :: Text + } + deriving (Generic) + +instance ToJSON KeyReport + +instance ToJSON UIDReport + +instance ToJSON SubkeyReport + +instance ToJSON SubkeyRevocationDigestWarning + +instance ToJSON CrossCertReport + +instance ToJSON RevocationStatus + +instance Semigroup UIDReport where + (<>) (UIDReport a b c d e) (UIDReport a' b' c' d' e') = + UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') + +instance Monoid UIDReport where + mempty = UIDReport [] [] [] [] [] + mappend = (<>) + +data LintContext = LintContext + { lcMpt :: Maybe POSIXTime + , lcProcessedTK :: TK 'PublicTK + , lcProcResult :: Either String SomeTK + , lcPrimaryKey :: SomePKPayload + , lcFingerprint :: Fingerprint + } + +populateBestOf + :: Map.Map Text (Result UIDReport) -> Maybe UIDReport +populateBestOf um + | Map.null um = Nothing + | otherwise = + Just + ( UIDReport + <$> best . uidSelfSigHashAlgorithms + <*> best + . uidPreferredHashAlgorithms + <*> best + . uidKeyExpirationTimes + <*> best + . uidKeyUsageFlags + <*> pure [] + $ mconcat (justTheUIDRs um) + ) + +justTheUIDRs :: Map.Map Text (Result UIDReport) -> [UIDReport] +justTheUIDRs = map getResult . Map.elems + +best :: [Result a] -> [Result a] +best = take 1 . sortOn (bestOfRank . resultColor) + +bestOfRank :: Maybe Color -> Int +bestOfRank (Just Green) = 0 +bestOfRank (Just Yellow) = 1 +bestOfRank (Just Red) = 2 +bestOfRank Nothing = 3 diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -248,7 +248,6 @@ import System.IO ( BufferMode (..) , Handle - , hFlush , hPutStrLn , hSetBuffering , stderr @@ -824,7 +823,7 @@ ) dispatch :: POSIXTime -> Command -> IO () -dispatch cpt cmd' = banner' stderr >> hFlush stderr >> dispatch' cpt cmd' +dispatch cpt cmd' = dispatch' cpt cmd' where dispatch' _ (VersionC o') = doVersion o' dispatch' _ (ListProfilesC o') = doListProfiles o' @@ -1134,9 +1133,6 @@ profile <- parseKeyGenProfile keyProfile password <- parseGenerateKeyPassword keyPassword let ts = ThirtyTwoBitTimeStamp (floor pt) - -- UPSTREAM: hOpenPGP should expose a supported legacy secret-key - -- re-encryption path so password-protected v4 key generation does not - -- need to switch to the v6 protection format here. keyVersion = if isJust password && keyVersionForProfile profile == V4 then V6 @@ -1153,10 +1149,43 @@ addSubkeysForProfile ts keyVersion profile keySigningOnly newkey <- get return newkey + baseKeyWithDirectSig <- + if keyVersion == V6 + then do + let pkp = keyPktPKPayload (_tkPrimaryKey baseKey) + ska = case _tkPrimaryKey baseKey of + KeyPktSecretPrimary _ ska' -> ska' + _ -> error "doGenerateKey: expected secret primary key" + issuer <- issuerSubpacketsFor "generate-key" pkp + let hashed = + [ SigSubPacket False (SigCreationTime ts) + , SigSubPacket + False + ( IssuerFingerprint + (issuerFingerprintVersionFor pkp) + (fingerprint pkp) + ) + , SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey)) + ] + payload = runPut $ putKeyForSigning pkp + sig <- + signWithKey + "generate-key" + pkp + SignatureDirectlyOnAKey + SHA512 + hashed + issuer + payload + (Just ska) + pure baseKey {_tkRevs = _tkRevs baseKey ++ [sig]} + else pure baseKey s <- maybe - (pure (SomeSecretTK baseKey)) - (`encryptTransferableSecretKey` (SomeSecretTK baseKey)) + (pure (SomeSecretTK baseKeyWithDirectSig)) + ( `encryptTransferableSecretKey` + (SomeSecretTK baseKeyWithDirectSig) + ) password let lbs = runPut $ Bin.put (someTKToUnknown s) BL.putStr $ @@ -1190,7 +1219,7 @@ -> GeneratedKeySpec -> IO SecretKey generateSecretKey ts keyVersion (GeneratedRSAKey bits) = do - (pub, priv) <- liftIO $ RSA.generate bits 0x10001 + (pub, priv) <- liftIO $ RSA.generate (bits `div` 8) 0x10001 return $ SecretKey (pkp pub) (ska priv) where pkp pub = PKPayload keyVersion ts 0 RSA (RSAPubKey (RSA_PublicKey pub)) @@ -1408,6 +1437,12 @@ ++ fdSpec ) +loadOpenPGPPackets + :: String -> FilePath -> IO [Pkt] +loadOpenPGPPackets context path = do + lbs <- loadInputFromFile context "file" path + decodeOpenPGPInput path lbs + normalizeHumanReadablePassword :: String -> String -> BL.ByteString -> IO BL.ByteString normalizeHumanReadablePassword context optionName passwordBytes = @@ -2475,11 +2510,10 @@ unhashed pkp = issuerSubpacketsFor "sign" pkp loadSigningKeys :: String -> [String] -> [BL.ByteString] -> IO [SomeTK] -loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadFromFile keyFiles +loadSigningKeys context keyFiles keyPasswords = concat <$> mapM loadSigningKeyFile keyFiles where - loadFromFile path = do - lbs <- loadInputFromFile context "file" path - packets <- decodeOpenPGPInput path lbs + loadSigningKeyFile path = do + packets <- loadOpenPGPPackets context path tks <- runConduitRes $ CL.sourceList packets @@ -4973,11 +5007,10 @@ -> [BL.ByteString] -> IO [PKESKRecipientKey] loadDecryptRecipientKeys _ _ [] _ = pure [] -loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadFromFile keyFiles +loadDecryptRecipientKeys cpt context keyFiles passwords = concat <$> mapM loadRecipientKeyFile keyFiles where - loadFromFile path = do - lbs <- loadInputFromFile context "file" path - packets <- decodeOpenPGPInput path lbs + loadRecipientKeyFile path = do + packets <- loadOpenPGPPackets context path -- Build the set of fingerprints that are explicitly non-encryption-capable. -- Keys not resolvable via TK (processTK failure, bare material) are allowed. nonEncFps <- buildNonEncryptionFingerprintSet packets @@ -5248,11 +5281,10 @@ loadRecipientPreferredHashes :: POSIXTime -> [String] -> IO [HashAlgorithm] loadRecipientPreferredHashes cpt certFiles = - concat <$> mapM loadFromFile certFiles + concat <$> mapM loadRecipientCertFile certFiles where - loadFromFile path = do - lbs <- loadInputFromFile "encrypt" "file" path - pkts <- decodeOpenPGPInput path lbs + loadRecipientCertFile path = do + pkts <- loadOpenPGPPackets "encrypt" path rejectSecretKeyPackets "encrypt" path pkts tks <- runConduitRes $ diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: hopenpgp-tools -version: 0.25.6 +version: 0.25.7 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP-tools @@ -61,6 +61,8 @@ , HOpenPGP.Tools.Hokey.Fetch , HOpenPGP.Tools.Hokey.InjectSSHAgent , HOpenPGP.Tools.Hokey.Lint + , HOpenPGP.Tools.Hokey.Lint.Types + , HOpenPGP.Tools.Hokey.Lint.Policy build-depends: base16-bytestring , conduit-extra >= 1.1 , containers @@ -130,4 +132,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hopenpgp-tools.git - tag: hopenpgp-tools/0.25.6 + tag: hopenpgp-tools/0.25.7