-- 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
