Policy.hs

-- Policy.hs: OpenPGP standards policy profiles
-- Copyright © 2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeFamilies #-}

module Codec.Encryption.OpenPGP.Policy
    ( OpenPGPRFC (..)
    , OpenPGPRFCW (..)
    , SomeOpenPGPRFCW (..)
    , promoteOpenPGPRFC
    , demoteOpenPGPRFCW
    , HashAlgorithmW (..)
    , SomeHashAlgorithmW (..)
    , promoteHashAlgorithm
    , demoteHashAlgorithmW
    , HashAlgoStatus (..)
    , HashAlgoStatusFor
    , HashAlgoAllowedFor
    , HashAlgoVerifiableFor
    , PKESKVersionPolicy (..)
    , MessageEncryptionPolicy (..)
    , SecretKeyProtectionPolicy (..)
    , GenerationDeprecationPolicy (..)
    , VerificationDefaults (..)
    , DecryptPolicy (..)
    , OpenPGPPolicy (..)
    , policyForRFC
    , defaultPolicy
    , defaultPKESKVersionPolicy
    , defaultVerificationDefaults
    , defaultDecryptPolicy
    , lenientDecryptPolicy
    , supportsSEIPDv2Symmetric
    , secretKeyProtectionPolicyForKeyVersion
    , signatureV6SaltSizeForHashAlgorithm
    , ecdhKdfHashDigest
    , validateTable30PolicyForRecipient
    , legacySecretKeyProtectionErrorMessage

      -- * Signature verification policy
    , VerificationPolicy (..)
    , VerificationPolicyAction (..)
    , defaultVerificationPolicy
    , strictVerificationPolicy
    , lenientVerificationPolicy
    , isVerificationError
    , isVerificationWarning
    , applyVerificationPolicy

      -- * Signature context validation (RFC9580/RFC4880)
    , isAllowedPrimaryKeySig
    , isAllowedSubkeySig
    , isAllowedUIDSig

      -- * Signature type validation helpers (for parser use)
    , isAllowedPrimaryKeySigType
    , isAllowedSubkeySigType
    , isAllowedUIDSigType
    ) where

import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHAlg
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import Data.Kind (Constraint)
import Data.List (elem)
import Data.Word (Word8)
import GHC.TypeLits (ErrorMessage (..), TypeError)

import Codec.Encryption.OpenPGP.SignatureQualities (sigType)
import Codec.Encryption.OpenPGP.Types

data OpenPGPRFC
    = RFC2440
    | RFC4880
    | RFC9580
    deriving (Eq, Show)

data OpenPGPRFCW (rfc :: OpenPGPRFC) where
    RFC2440W :: OpenPGPRFCW 'RFC2440
    RFC4880W :: OpenPGPRFCW 'RFC4880
    RFC9580W :: OpenPGPRFCW 'RFC9580

data SomeOpenPGPRFCW where
    SomeOpenPGPRFCW :: OpenPGPRFCW rfc -> SomeOpenPGPRFCW

demoteOpenPGPRFCW :: OpenPGPRFCW rfc -> OpenPGPRFC
demoteOpenPGPRFCW RFC2440W = RFC2440
demoteOpenPGPRFCW RFC4880W = RFC4880
demoteOpenPGPRFCW RFC9580W = RFC9580

promoteOpenPGPRFC :: OpenPGPRFC -> SomeOpenPGPRFCW
promoteOpenPGPRFC RFC2440 = SomeOpenPGPRFCW RFC2440W
promoteOpenPGPRFC RFC4880 = SomeOpenPGPRFCW RFC4880W
promoteOpenPGPRFC RFC9580 = SomeOpenPGPRFCW RFC9580W

data HashAlgorithmW (h :: HashAlgorithm) where
    DeprecatedMD5W :: HashAlgorithmW 'DeprecatedMD5
    SHA1W :: HashAlgorithmW 'SHA1
    RIPEMD160W :: HashAlgorithmW 'RIPEMD160
    SHA256W :: HashAlgorithmW 'SHA256
    SHA384W :: HashAlgorithmW 'SHA384
    SHA512W :: HashAlgorithmW 'SHA512
    SHA224W :: HashAlgorithmW 'SHA224
    SHA3_256W :: HashAlgorithmW 'SHA3_256
    SHA3_512W :: HashAlgorithmW 'SHA3_512

data SomeHashAlgorithmW where
    SomeHashAlgorithmW :: HashAlgorithmW h -> SomeHashAlgorithmW

demoteHashAlgorithmW :: HashAlgorithmW h -> HashAlgorithm
demoteHashAlgorithmW DeprecatedMD5W = DeprecatedMD5
demoteHashAlgorithmW SHA1W = SHA1
demoteHashAlgorithmW RIPEMD160W = RIPEMD160
demoteHashAlgorithmW SHA256W = SHA256
demoteHashAlgorithmW SHA384W = SHA384
demoteHashAlgorithmW SHA512W = SHA512
demoteHashAlgorithmW SHA224W = SHA224
demoteHashAlgorithmW SHA3_256W = SHA3_256
demoteHashAlgorithmW SHA3_512W = SHA3_512

promoteHashAlgorithm :: HashAlgorithm -> Maybe SomeHashAlgorithmW
promoteHashAlgorithm DeprecatedMD5 = Just (SomeHashAlgorithmW DeprecatedMD5W)
promoteHashAlgorithm SHA1 = Just (SomeHashAlgorithmW SHA1W)
promoteHashAlgorithm RIPEMD160 = Just (SomeHashAlgorithmW RIPEMD160W)
promoteHashAlgorithm SHA256 = Just (SomeHashAlgorithmW SHA256W)
promoteHashAlgorithm SHA384 = Just (SomeHashAlgorithmW SHA384W)
promoteHashAlgorithm SHA512 = Just (SomeHashAlgorithmW SHA512W)
promoteHashAlgorithm SHA224 = Just (SomeHashAlgorithmW SHA224W)
promoteHashAlgorithm SHA3_256 = Just (SomeHashAlgorithmW SHA3_256W)
promoteHashAlgorithm SHA3_512 = Just (SomeHashAlgorithmW SHA3_512W)
promoteHashAlgorithm (OtherHA _) = Nothing

signatureV6SaltSizeForHashAlgorithm
    :: HashAlgorithm -> Maybe Word8
signatureV6SaltSizeForHashAlgorithm SHA224 = Just 16
signatureV6SaltSizeForHashAlgorithm SHA256 = Just 16
signatureV6SaltSizeForHashAlgorithm SHA384 = Just 24
signatureV6SaltSizeForHashAlgorithm SHA512 = Just 32
signatureV6SaltSizeForHashAlgorithm SHA3_256 = Just 16
signatureV6SaltSizeForHashAlgorithm SHA3_512 = Just 32
signatureV6SaltSizeForHashAlgorithm _ = Nothing

data HashAlgoStatus
    = HashAllowed
    | HashShouldNot
    | HashMustNot

type family
    HashAlgoStatusFor (rfc :: OpenPGPRFC) (h :: HashAlgorithm)
        :: HashAlgoStatus
    where
    HashAlgoStatusFor 'RFC4880 'DeprecatedMD5 = 'HashShouldNot
    HashAlgoStatusFor 'RFC9580 'DeprecatedMD5 = 'HashMustNot
    HashAlgoStatusFor 'RFC9580 'SHA1 = 'HashMustNot
    HashAlgoStatusFor 'RFC9580 'RIPEMD160 = 'HashShouldNot
    HashAlgoStatusFor rfc h = 'HashAllowed

type family AssertHashAllowed (status :: HashAlgoStatus) :: Constraint where
    AssertHashAllowed 'HashAllowed = ()
    AssertHashAllowed 'HashShouldNot =
        TypeError
            ( 'Text
                "Hash algorithm is deprecated (SHOULD NOT) for new signatures under this RFC"
            )
    AssertHashAllowed 'HashMustNot =
        TypeError
            ( 'Text
                "Hash algorithm is disallowed (MUST NOT) for new signatures under this RFC"
            )

type HashAlgoAllowedFor rfc h =
    AssertHashAllowed (HashAlgoStatusFor rfc h)

type family AssertHashVerifiable (status :: HashAlgoStatus) :: Constraint where
    AssertHashVerifiable 'HashAllowed = ()
    AssertHashVerifiable 'HashShouldNot = ()
    AssertHashVerifiable 'HashMustNot =
        TypeError
            ( 'Text
                "Hash algorithm is disallowed for verification in this RFC context"
            )

type HashAlgoVerifiableFor rfc h =
    AssertHashVerifiable (HashAlgoStatusFor rfc h)

data PKESKVersionPolicy
    = PreferV6
    | ForceV3Interop
    deriving (Eq, Show)

data MessageEncryptionPolicy = MessageEncryptionPolicy
    { messageDefaultSymmetricAlgorithm :: SymmetricAlgorithm
    , messageDefaultAEADAlgorithm :: AEADAlgorithm
    , messageDefaultChunkSize :: Word8
    , messageS2KSaltOctets :: Int
    , messageSEIPDv2SaltOctets :: Int
    , messageDefaultS2KForSalt :: Salt -> S2K
    , messageSEIPDv2SymmetricAlgorithms :: [SymmetricAlgorithm]
    }

data SecretKeyProtectionPolicy = SecretKeyProtectionPolicy
    { secretKeyDefaultSymmetricAlgorithm :: SymmetricAlgorithm
    , secretKeyDefaultAEADAlgorithm :: AEADAlgorithm
    , secretKeyDefaultS2KForSalt :: Salt -> S2K
    , secretKeyS2KSaltOctets :: Int
    , secretKeyAEADNonceOctets :: Int
    }

data GenerationDeprecationPolicy = GenerationDeprecationPolicy
    { deprecatedHashAlgorithms :: [HashAlgorithm]
    , deprecatedSymmetricAlgorithms :: [SymmetricAlgorithm]
    }

data VerificationDefaults = VerificationDefaults
    { verificationDefaultStrict :: Bool
    , verificationDefaultStreaming :: Bool
    }

-- | Action to take when a signature feature violates policy.
data VerificationPolicyAction
    = -- | Treat as a hard verification error (reject signature)
      VerificationError
    | -- | Accept signature but record a warning
      VerificationWarning
    deriving (Eq, Show)

{- | Policy controlling how signature verification handles deprecated or
discouraged features.  This allows callers to choose between strict
rejection (errors) and lenient acceptance with warnings.
-}
data VerificationPolicy = VerificationPolicy
    { vpDeprecatedHashAlgorithm :: VerificationPolicyAction
    -- ^ Action for deprecated hash algorithms (MD5, SHA1, RIPEMD160)
    , vpUnsupportedHashAlgorithm :: VerificationPolicyAction
    -- ^ Action for unsupported/unknown hash algorithms
    , vpPkaMismatch :: VerificationPolicyAction
    -- ^ Action for PKA mismatch between signature and key
    , vpUnsupportedCriticalSubpacket :: VerificationPolicyAction
    -- ^ Action for unsupported critical subpackets
    , vpLegacyIssuerKeyIdInV6 :: VerificationPolicyAction
    -- ^ Action for legacy Issuer Key ID subpacket in v6 signatures
    , vpMissingSubkeyBackSignature :: VerificationPolicyAction
    -- ^ Action for missing subkey back-signature (v6 subkeys)
    , vpInvalidSignatureContext :: VerificationPolicyAction
    -- ^ Action for signature context violations (wrong sig type for context)
    , vpExpiredSignature :: VerificationPolicyAction
    -- ^ Action for expired signatures
    }
    deriving (Eq, Show)

{- | Default verification policy: strict on security-critical issues,
lenient on deprecated but still verifiable features.
-}
defaultVerificationPolicy :: VerificationPolicy
defaultVerificationPolicy =
    VerificationPolicy
        { vpDeprecatedHashAlgorithm = VerificationWarning
        , vpUnsupportedHashAlgorithm = VerificationError
        , vpPkaMismatch = VerificationError
        , vpUnsupportedCriticalSubpacket = VerificationError
        , vpLegacyIssuerKeyIdInV6 = VerificationError
        , vpMissingSubkeyBackSignature = VerificationWarning
        , vpInvalidSignatureContext = VerificationError
        , vpExpiredSignature = VerificationError
        }

-- | Strict verification policy: all policy violations are hard errors.
strictVerificationPolicy :: VerificationPolicy
strictVerificationPolicy =
    VerificationPolicy
        { vpDeprecatedHashAlgorithm = VerificationError
        , vpUnsupportedHashAlgorithm = VerificationError
        , vpPkaMismatch = VerificationError
        , vpUnsupportedCriticalSubpacket = VerificationError
        , vpLegacyIssuerKeyIdInV6 = VerificationError
        , vpMissingSubkeyBackSignature = VerificationError
        , vpInvalidSignatureContext = VerificationError
        , vpExpiredSignature = VerificationError
        }

{- | Lenient verification policy: all policy violations are warnings.
Use only for interoperability with legacy data.
-}
lenientVerificationPolicy :: VerificationPolicy
lenientVerificationPolicy =
    VerificationPolicy
        { vpDeprecatedHashAlgorithm = VerificationWarning
        , vpUnsupportedHashAlgorithm = VerificationWarning
        , vpPkaMismatch = VerificationWarning
        , vpUnsupportedCriticalSubpacket = VerificationWarning
        , vpLegacyIssuerKeyIdInV6 = VerificationWarning
        , vpMissingSubkeyBackSignature = VerificationWarning
        , vpInvalidSignatureContext = VerificationWarning
        , vpExpiredSignature = VerificationWarning
        }

-- | Check if a policy action is an error.
isVerificationError :: VerificationPolicyAction -> Bool
isVerificationError VerificationError = True
isVerificationError VerificationWarning = False

-- | Check if a policy action is a warning.
isVerificationWarning :: VerificationPolicyAction -> Bool
isVerificationWarning VerificationWarning = True
isVerificationWarning VerificationError = False

-- | Apply a policy action: return Left error or Right warning message.
applyVerificationPolicy
    :: VerificationPolicyAction
    -> String
    -> Either String String
applyVerificationPolicy action msg =
    if isVerificationError action
        then Left msg
        else Right msg

{- | Per-message decrypt-side enforcement policy.

'defaultDecryptPolicy' applies RFC9580-strict rules: no unauthenticated
(SED) ciphertext, modern symmetric algorithms only, and rejection of
deprecated S2K specifiers in SKESK.  Use 'lenientDecryptPolicy' when
interoperating with older RFC4880 or RFC2440 messages.
-}
data DecryptPolicy = DecryptPolicy
    { decryptAllowSEDNoIntegrity :: Bool
    {- ^ When 'False' (RFC9580 default), receiving a Symmetrically Encrypted
    Data packet (SED, tag 9) is a hard error.  RFC9580 §5.9 says
    implementations SHOULD reject unauthenticated ciphertext.
    -}
    , decryptAllowSEIPDv1 :: Bool
    {- ^ When 'False', receiving a SEIPDv1 (MDC-protected) packet is rejected.
    Defaults to 'True' for interoperability with RFC4880 senders.
    -}
    , decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm]
    {- ^ Allowed symmetric algorithms for session keys.  'Nothing' means
    unrestricted.  The RFC9580 default restricts to AES-128/192/256.
    -}
    , decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm]
    {- ^ Allowed AEAD algorithms for SEIPDv2 payloads.  'Nothing' means
    unrestricted.  The RFC9580 default allows EAX, OCB, and GCM.
    -}
    , decryptRejectDeprecatedSKESK :: Bool
    {- ^ When 'True' (RFC9580 default), reject SKESK packets that use Simple
    or Salted S2K specifiers (both deprecated since RFC9580).
    -}
    , decryptRejectTrailingData :: Bool
    {- ^ When 'True' (RFC9580 default), any packet received after the
    message-integrity boundary (MDC for SEIPDv1, final AEAD tag for
    SEIPDv2, or the outer encrypted-data packet for SED) is a hard error.
    RFC9580 §5.13.2 requires that implementations detect and reject
    data appended after the authenticated payload.  Set to 'False' only
    when interoperating with legacy implementations that emit trailing
    garbage (implies 'lenientDecryptPolicy').
    -}
    , decryptRejectESKVersionMismatch :: Bool
    {- ^ When 'True' (RFC9580 default), a payload with no version-aligned
    ESK is a hard error even when misaligned ESKs are present.  This is a
    distinct concern from trailing-data rejection: a message could have
    correct framing yet still carry only v6 PKESKs before a SEIPDv1
    payload (or only v4 SKESKs before a SEIPDv2 payload), which indicates
    a mis-assembled message rather than an integrity violation.
    Set to 'False' only when salvaging malformed legacy messages.
    -}
    }
    deriving (Eq, Show)

data OpenPGPPolicy = OpenPGPPolicy
    { policyRFC :: OpenPGPRFC
    , policyMessageEncryption :: MessageEncryptionPolicy
    , policySecretKeyProtection :: Maybe SecretKeyProtectionPolicy
    , policyGenerationDeprecations :: GenerationDeprecationPolicy
    , policyDecrypt :: DecryptPolicy
    }

policyForRFC :: OpenPGPRFC -> OpenPGPPolicy
policyForRFC RFC2440 =
    OpenPGPPolicy
        { policyRFC = RFC2440
        , policyMessageEncryption =
            MessageEncryptionPolicy
                { messageDefaultSymmetricAlgorithm = TripleDES
                , messageDefaultAEADAlgorithm = OCB
                , messageDefaultChunkSize = 6
                , messageS2KSaltOctets = 8
                , messageSEIPDv2SaltOctets = 32
                , messageDefaultS2KForSalt = \salt ->
                    IteratedSalted
                        SHA1
                        (requireSalt8 "RFC2440 message S2K" salt)
                        65536
                , messageSEIPDv2SymmetricAlgorithms = []
                }
        , policySecretKeyProtection = Nothing
        , policyGenerationDeprecations =
            GenerationDeprecationPolicy
                { deprecatedHashAlgorithms = []
                , deprecatedSymmetricAlgorithms = []
                }
        , policyDecrypt = lenientDecryptPolicy
        }
policyForRFC RFC4880 =
    OpenPGPPolicy
        { policyRFC = RFC4880
        , policyMessageEncryption =
            MessageEncryptionPolicy
                { messageDefaultSymmetricAlgorithm = AES128
                , messageDefaultAEADAlgorithm = OCB
                , messageDefaultChunkSize = 6
                , messageS2KSaltOctets = 8
                , messageSEIPDv2SaltOctets = 32
                , messageDefaultS2KForSalt = \salt ->
                    IteratedSalted
                        SHA256
                        (requireSalt8 "RFC4880 message S2K" salt)
                        65536
                , messageSEIPDv2SymmetricAlgorithms = []
                }
        , policySecretKeyProtection = Nothing
        , policyGenerationDeprecations =
            GenerationDeprecationPolicy
                { deprecatedHashAlgorithms = [DeprecatedMD5]
                , deprecatedSymmetricAlgorithms = []
                }
        , policyDecrypt = lenientDecryptPolicy
        }
policyForRFC RFC9580 =
    OpenPGPPolicy
        { policyRFC = RFC9580
        , policyMessageEncryption =
            MessageEncryptionPolicy
                { messageDefaultSymmetricAlgorithm = AES256
                , messageDefaultAEADAlgorithm = OCB
                , messageDefaultChunkSize = 6
                , messageS2KSaltOctets = 16
                , messageSEIPDv2SaltOctets = 32
                , messageDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 message S2K" salt) 1 4 15
                , messageSEIPDv2SymmetricAlgorithms = [AES128, AES192, AES256]
                }
        , policySecretKeyProtection =
            Just
                SecretKeyProtectionPolicy
                    { secretKeyDefaultSymmetricAlgorithm = AES256
                    , secretKeyDefaultAEADAlgorithm = OCB
                    , secretKeyDefaultS2KForSalt = \salt -> Argon2 (requireSalt16 "RFC9580 secret key S2K" salt) 1 4 15
                    , secretKeyS2KSaltOctets = 16
                    , secretKeyAEADNonceOctets = 15
                    }
        , policyGenerationDeprecations =
            GenerationDeprecationPolicy
                { deprecatedHashAlgorithms = [DeprecatedMD5, SHA1, RIPEMD160]
                , deprecatedSymmetricAlgorithms =
                    [IDEA, TripleDES, CAST5, Blowfish]
                }
        , policyDecrypt = defaultDecryptPolicy
        }

requireSalt8 :: String -> Salt -> Salt8
requireSalt8 context salt =
    case salt8FromSalt salt of
        Just salt8 -> salt8
        Nothing -> error (context ++ " requires an 8-octet salt")

requireSalt16 :: String -> Salt -> Salt16
requireSalt16 context salt =
    case salt16FromSalt salt of
        Just salt16 -> salt16
        Nothing -> error (context ++ " requires a 16-octet salt")

defaultPolicy :: OpenPGPPolicy
defaultPolicy = policyForRFC RFC9580

defaultPKESKVersionPolicy :: PKESKVersionPolicy
defaultPKESKVersionPolicy = PreferV6

defaultVerificationDefaults :: VerificationDefaults
defaultVerificationDefaults =
    VerificationDefaults
        { verificationDefaultStrict = True
        , verificationDefaultStreaming = True
        }

{- | RFC9580-strict decrypt policy.  Rejects unauthenticated SED ciphertext,
restricts session-key symmetric algorithms to AES-128/192/256 and AEAD to
EAX/OCB/GCM, and rejects SKESK packets carrying deprecated Simple or
Salted S2K specifiers.  SEIPDv1 (MDC-protected) is still accepted for
interoperability with RFC4880 senders.
-}
defaultDecryptPolicy :: DecryptPolicy
defaultDecryptPolicy =
    DecryptPolicy
        { decryptAllowSEDNoIntegrity = False
        , decryptAllowSEIPDv1 = True
        , decryptAllowedSymmetricAlgos = Just [AES128, AES192, AES256]
        , decryptAllowedAEADAlgos = Just [EAX, OCB, GCM]
        , decryptRejectDeprecatedSKESK = True
        , decryptRejectTrailingData = True
        , decryptRejectESKVersionMismatch = True
        }

{- | Permissive decrypt policy for interoperability with RFC4880 and RFC2440
messages.  No algorithm or integrity restrictions are applied.
-}
lenientDecryptPolicy :: DecryptPolicy
lenientDecryptPolicy =
    DecryptPolicy
        { decryptAllowSEDNoIntegrity = True
        , decryptAllowSEIPDv1 = True
        , decryptAllowedSymmetricAlgos = Nothing
        , decryptAllowedAEADAlgos = Nothing
        , decryptRejectDeprecatedSKESK = False
        , decryptRejectTrailingData = False
        , decryptRejectESKVersionMismatch = False
        }

supportsSEIPDv2Symmetric
    :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool
supportsSEIPDv2Symmetric policy sa =
    sa
        `elem` messageSEIPDv2SymmetricAlgorithms
            (policyMessageEncryption policy)

secretKeyProtectionPolicyForKeyVersion
    :: OpenPGPPolicy -> KeyVersion -> Maybe SecretKeyProtectionPolicy
secretKeyProtectionPolicyForKeyVersion policy V6 = policySecretKeyProtection policy
secretKeyProtectionPolicyForKeyVersion _ _ = Nothing

ecdhKdfHashDigest
    :: HashAlgorithm -> B.ByteString -> Either String B.ByteString
ecdhKdfHashDigest SHA1 _ = Left "ECDH KDF hash algorithm SHA1 is disallowed by policy"
ecdhKdfHashDigest SHA224 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA224))
ecdhKdfHashDigest SHA256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA256))
ecdhKdfHashDigest SHA384 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA384))
ecdhKdfHashDigest SHA512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA512))
ecdhKdfHashDigest SHA3_256 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_256))
ecdhKdfHashDigest SHA3_512 bs = Right (BA.convert (CH.hash bs :: CH.Digest CHAlg.SHA3_512))
ecdhKdfHashDigest _ _ = Left "ECDH KDF hash algorithm is unsupported"

validateTable30PolicyForRecipient
    :: SomePKPayload
    -> HashAlgorithm
    -> SymmetricAlgorithm
    -> Either String ()
validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA =
    case allowedTable30EcdhParameterSets
        recipientPKP
        (_pubkey recipientPKP) of
        Nothing -> Right ()
        Just (curveName, allowedParams) ->
            if (kdfHA, kdfSA) `elem` allowedParams
                then Right ()
                else
                    Left
                        ( "RFC9580 Table 30 policy violation for "
                            ++ show (_keyVersion recipientPKP)
                            ++ " ECDH key on "
                            ++ curveName
                            ++ ": expected one of "
                            ++ show allowedParams
                            ++ ", got ("
                            ++ show kdfHA
                            ++ ", "
                            ++ show kdfSA
                            ++ ")"
                        )

allowedTable30EcdhParameterSets
    :: SomePKPayload
    -> PKey
    -> Maybe (String, [(HashAlgorithm, SymmetricAlgorithm)])
allowedTable30EcdhParameterSets recipientPKP (ECDHPubKey ecdhPub _ _)
    | _keyVersion recipientPKP == V4 =
        case ecdhPub of
            EdDSAPubKey EdSigningCurve25519 _ ->
                Just
                    ( "Curve25519Legacy"
                    , [ (ha, sa)
                      | ha <- [SHA256, SHA384, SHA512]
                      , sa <- [AES128, AES192, AES256]
                      ]
                    )
            ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))
                | curve == ECCT.getCurveByName ECCT.SEC_p256r1 ->
                    Just ("NIST P-256", [(SHA256, AES128)])
                | curve == ECCT.getCurveByName ECCT.SEC_p384r1 ->
                    Just ("NIST P-384", [(SHA384, AES192)])
                | curve == ECCT.getCurveByName ECCT.SEC_p521r1 ->
                    Just ("NIST P-521", [(SHA512, AES256)])
            _ -> Nothing
    | _keyVersion recipientPKP == V6 =
        case ecdhPub of
            EdDSAPubKey EdSigningCurve25519 _ -> Just ("Curve25519Legacy", [(SHA256, AES128)])
            ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))
                | curve == ECCT.getCurveByName ECCT.SEC_p256r1 ->
                    Just ("NIST P-256", [(SHA256, AES128)])
                | curve == ECCT.getCurveByName ECCT.SEC_p384r1 ->
                    Just ("NIST P-384", [(SHA384, AES192)])
                | curve == ECCT.getCurveByName ECCT.SEC_p521r1 ->
                    Just ("NIST P-521", [(SHA512, AES256)])
            _ -> Nothing
    | otherwise = Nothing
allowedTable30EcdhParameterSets _ _ = Nothing

legacySecretKeyProtectionErrorMessage :: String
legacySecretKeyProtectionErrorMessage =
    "re-encrypting legacy secret keys without SHA-1 protection is unsupported; explicit legacy override required"

-- RFC9580/RFC4880 signature context validation predicates
-- These enforce which signature types are allowed in which structural contexts

-- | RFC9580 §3.2: Primary key can only have KeyRevocationSig or SignatureDirectlyOnAKey
isAllowedPrimaryKeySig :: SignaturePayload -> Bool
isAllowedPrimaryKeySig = maybe False isAllowedPrimaryKeySigType . sigType

-- | RFC9580 §3.3: Subkey can only have SubkeyBindingSig or SubkeyRevocationSig
isAllowedSubkeySig :: SignaturePayload -> Bool
isAllowedSubkeySig = maybe False isAllowedSubkeySigType . sigType

-- | RFC9580 §3.4: User ID can only have various certification types or CertRevocationSig
isAllowedUIDSig :: SignaturePayload -> Bool
isAllowedUIDSig = maybe False isAllowedUIDSigType . sigType

-- | Test if a SigType is allowed on a primary key
isAllowedPrimaryKeySigType :: SigType -> Bool
isAllowedPrimaryKeySigType KeyRevocationSig = True
isAllowedPrimaryKeySigType SignatureDirectlyOnAKey = True
isAllowedPrimaryKeySigType _ = False

-- | Test if a SigType is allowed on a subkey
isAllowedSubkeySigType :: SigType -> Bool
isAllowedSubkeySigType SubkeyBindingSig = True
isAllowedSubkeySigType SubkeyRevocationSig = True
isAllowedSubkeySigType _ = False

-- | Test if a SigType is allowed on a User ID
isAllowedUIDSigType :: SigType -> Bool
isAllowedUIDSigType GenericCert = True
isAllowedUIDSigType PersonaCert = True
isAllowedUIDSigType CasualCert = True
isAllowedUIDSigType PositiveCert = True
isAllowedUIDSigType CertRevocationSig = True
isAllowedUIDSigType _ = False