hopenpgp-tools 0.25.6 → 0.25.7
raw patch · 5 files changed
+1102/−674 lines, 5 files
Files
- HOpenPGP/Tools/Hokey/Lint.hs +61/−652
- HOpenPGP/Tools/Hokey/Lint/Policy.hs +758/−0
- HOpenPGP/Tools/Hokey/Lint/Types.hs +227/−0
- hop.hs +52/−20
- hopenpgp-tools.cabal +4/−2
HOpenPGP/Tools/Hokey/Lint.hs view
@@ -15,11 +15,7 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see <http://www.gnu.org/licenses/>.-{-# 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 =- "<uat:[" ++ intercalate "," (map uaspToString 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 _ = []
+ HOpenPGP/Tools/Hokey/Lint/Policy.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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 =+ "<uat:[" ++ intercalate "," (map uaspToString 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
+ HOpenPGP/Tools/Hokey/Lint/Types.hs view
@@ -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 <http://www.gnu.org/licenses/>.+{-# 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
hop.hs view
@@ -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 $
hopenpgp-tools.cabal view
@@ -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