hopenpgp-tools-0.25.7: HOpenPGP/Tools/Hokey/Lint/Policy.hs
-- 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