-- 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 (OpenPGPRFC -> OpenPGPRFC -> Bool
(OpenPGPRFC -> OpenPGPRFC -> Bool)
-> (OpenPGPRFC -> OpenPGPRFC -> Bool) -> Eq OpenPGPRFC
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: OpenPGPRFC -> OpenPGPRFC -> Bool
== :: OpenPGPRFC -> OpenPGPRFC -> Bool
$c/= :: OpenPGPRFC -> OpenPGPRFC -> Bool
/= :: OpenPGPRFC -> OpenPGPRFC -> Bool
Eq, Int -> OpenPGPRFC -> ShowS
[OpenPGPRFC] -> ShowS
OpenPGPRFC -> String
(Int -> OpenPGPRFC -> ShowS)
-> (OpenPGPRFC -> String)
-> ([OpenPGPRFC] -> ShowS)
-> Show OpenPGPRFC
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> OpenPGPRFC -> ShowS
showsPrec :: Int -> OpenPGPRFC -> ShowS
$cshow :: OpenPGPRFC -> String
show :: OpenPGPRFC -> String
$cshowList :: [OpenPGPRFC] -> ShowS
showList :: [OpenPGPRFC] -> ShowS
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 :: forall (rfc :: OpenPGPRFC). OpenPGPRFCW rfc -> OpenPGPRFC
demoteOpenPGPRFCW OpenPGPRFCW rfc
RFC2440W = OpenPGPRFC
RFC2440
demoteOpenPGPRFCW OpenPGPRFCW rfc
RFC4880W = OpenPGPRFC
RFC4880
demoteOpenPGPRFCW OpenPGPRFCW rfc
RFC9580W = OpenPGPRFC
RFC9580

promoteOpenPGPRFC :: OpenPGPRFC -> SomeOpenPGPRFCW
promoteOpenPGPRFC :: OpenPGPRFC -> SomeOpenPGPRFCW
promoteOpenPGPRFC OpenPGPRFC
RFC2440 = OpenPGPRFCW 'RFC2440 -> SomeOpenPGPRFCW
forall (h :: OpenPGPRFC). OpenPGPRFCW h -> SomeOpenPGPRFCW
SomeOpenPGPRFCW OpenPGPRFCW 'RFC2440
RFC2440W
promoteOpenPGPRFC OpenPGPRFC
RFC4880 = OpenPGPRFCW 'RFC4880 -> SomeOpenPGPRFCW
forall (h :: OpenPGPRFC). OpenPGPRFCW h -> SomeOpenPGPRFCW
SomeOpenPGPRFCW OpenPGPRFCW 'RFC4880
RFC4880W
promoteOpenPGPRFC OpenPGPRFC
RFC9580 = OpenPGPRFCW 'RFC9580 -> SomeOpenPGPRFCW
forall (h :: OpenPGPRFC). OpenPGPRFCW h -> SomeOpenPGPRFCW
SomeOpenPGPRFCW OpenPGPRFCW 'RFC9580
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 :: forall (h :: HashAlgorithm). HashAlgorithmW h -> HashAlgorithm
demoteHashAlgorithmW HashAlgorithmW h
DeprecatedMD5W = HashAlgorithm
DeprecatedMD5
demoteHashAlgorithmW HashAlgorithmW h
SHA1W = HashAlgorithm
SHA1
demoteHashAlgorithmW HashAlgorithmW h
RIPEMD160W = HashAlgorithm
RIPEMD160
demoteHashAlgorithmW HashAlgorithmW h
SHA256W = HashAlgorithm
SHA256
demoteHashAlgorithmW HashAlgorithmW h
SHA384W = HashAlgorithm
SHA384
demoteHashAlgorithmW HashAlgorithmW h
SHA512W = HashAlgorithm
SHA512
demoteHashAlgorithmW HashAlgorithmW h
SHA224W = HashAlgorithm
SHA224
demoteHashAlgorithmW HashAlgorithmW h
SHA3_256W = HashAlgorithm
SHA3_256
demoteHashAlgorithmW HashAlgorithmW h
SHA3_512W = HashAlgorithm
SHA3_512

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

signatureV6SaltSizeForHashAlgorithm
    :: HashAlgorithm -> Maybe Word8
signatureV6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
SHA224 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
16
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
SHA256 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
16
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
SHA384 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
24
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
SHA512 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
32
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
SHA3_256 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
16
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
SHA3_512 = Word8 -> Maybe Word8
forall a. a -> Maybe a
Just Word8
32
signatureV6SaltSizeForHashAlgorithm HashAlgorithm
_ = Maybe Word8
forall a. Maybe a
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 (PKESKVersionPolicy -> PKESKVersionPolicy -> Bool
(PKESKVersionPolicy -> PKESKVersionPolicy -> Bool)
-> (PKESKVersionPolicy -> PKESKVersionPolicy -> Bool)
-> Eq PKESKVersionPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKVersionPolicy -> PKESKVersionPolicy -> Bool
== :: PKESKVersionPolicy -> PKESKVersionPolicy -> Bool
$c/= :: PKESKVersionPolicy -> PKESKVersionPolicy -> Bool
/= :: PKESKVersionPolicy -> PKESKVersionPolicy -> Bool
Eq, Int -> PKESKVersionPolicy -> ShowS
[PKESKVersionPolicy] -> ShowS
PKESKVersionPolicy -> String
(Int -> PKESKVersionPolicy -> ShowS)
-> (PKESKVersionPolicy -> String)
-> ([PKESKVersionPolicy] -> ShowS)
-> Show PKESKVersionPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKVersionPolicy -> ShowS
showsPrec :: Int -> PKESKVersionPolicy -> ShowS
$cshow :: PKESKVersionPolicy -> String
show :: PKESKVersionPolicy -> String
$cshowList :: [PKESKVersionPolicy] -> ShowS
showList :: [PKESKVersionPolicy] -> ShowS
Show)

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

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

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

data VerificationDefaults = VerificationDefaults
    { VerificationDefaults -> Bool
verificationDefaultStrict :: Bool
    , VerificationDefaults -> 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 (VerificationPolicyAction -> VerificationPolicyAction -> Bool
(VerificationPolicyAction -> VerificationPolicyAction -> Bool)
-> (VerificationPolicyAction -> VerificationPolicyAction -> Bool)
-> Eq VerificationPolicyAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerificationPolicyAction -> VerificationPolicyAction -> Bool
== :: VerificationPolicyAction -> VerificationPolicyAction -> Bool
$c/= :: VerificationPolicyAction -> VerificationPolicyAction -> Bool
/= :: VerificationPolicyAction -> VerificationPolicyAction -> Bool
Eq, Int -> VerificationPolicyAction -> ShowS
[VerificationPolicyAction] -> ShowS
VerificationPolicyAction -> String
(Int -> VerificationPolicyAction -> ShowS)
-> (VerificationPolicyAction -> String)
-> ([VerificationPolicyAction] -> ShowS)
-> Show VerificationPolicyAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationPolicyAction -> ShowS
showsPrec :: Int -> VerificationPolicyAction -> ShowS
$cshow :: VerificationPolicyAction -> String
show :: VerificationPolicyAction -> String
$cshowList :: [VerificationPolicyAction] -> ShowS
showList :: [VerificationPolicyAction] -> ShowS
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
    { VerificationPolicy -> VerificationPolicyAction
vpDeprecatedHashAlgorithm :: VerificationPolicyAction
    -- ^ Action for deprecated hash algorithms (MD5, SHA1, RIPEMD160)
    , VerificationPolicy -> VerificationPolicyAction
vpUnsupportedHashAlgorithm :: VerificationPolicyAction
    -- ^ Action for unsupported/unknown hash algorithms
    , VerificationPolicy -> VerificationPolicyAction
vpPkaMismatch :: VerificationPolicyAction
    -- ^ Action for PKA mismatch between signature and key
    , VerificationPolicy -> VerificationPolicyAction
vpUnsupportedCriticalSubpacket :: VerificationPolicyAction
    -- ^ Action for unsupported critical subpackets
    , VerificationPolicy -> VerificationPolicyAction
vpLegacyIssuerKeyIdInV6 :: VerificationPolicyAction
    -- ^ Action for legacy Issuer Key ID subpacket in v6 signatures
    , VerificationPolicy -> VerificationPolicyAction
vpMissingSubkeyBackSignature :: VerificationPolicyAction
    -- ^ Action for missing subkey back-signature (v6 subkeys)
    , VerificationPolicy -> VerificationPolicyAction
vpInvalidSignatureContext :: VerificationPolicyAction
    -- ^ Action for signature context violations (wrong sig type for context)
    , VerificationPolicy -> VerificationPolicyAction
vpExpiredSignature :: VerificationPolicyAction
    -- ^ Action for expired signatures
    }
    deriving (VerificationPolicy -> VerificationPolicy -> Bool
(VerificationPolicy -> VerificationPolicy -> Bool)
-> (VerificationPolicy -> VerificationPolicy -> Bool)
-> Eq VerificationPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: VerificationPolicy -> VerificationPolicy -> Bool
== :: VerificationPolicy -> VerificationPolicy -> Bool
$c/= :: VerificationPolicy -> VerificationPolicy -> Bool
/= :: VerificationPolicy -> VerificationPolicy -> Bool
Eq, Int -> VerificationPolicy -> ShowS
[VerificationPolicy] -> ShowS
VerificationPolicy -> String
(Int -> VerificationPolicy -> ShowS)
-> (VerificationPolicy -> String)
-> ([VerificationPolicy] -> ShowS)
-> Show VerificationPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> VerificationPolicy -> ShowS
showsPrec :: Int -> VerificationPolicy -> ShowS
$cshow :: VerificationPolicy -> String
show :: VerificationPolicy -> String
$cshowList :: [VerificationPolicy] -> ShowS
showList :: [VerificationPolicy] -> ShowS
Show)

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

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

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

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

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

-- | Apply a policy action: return Left error or Right warning message.
applyVerificationPolicy
    :: VerificationPolicyAction
    -> String
    -> Either String String
applyVerificationPolicy :: VerificationPolicyAction -> String -> Either String String
applyVerificationPolicy VerificationPolicyAction
action String
msg =
    if VerificationPolicyAction -> Bool
isVerificationError VerificationPolicyAction
action
        then String -> Either String String
forall a b. a -> Either a b
Left String
msg
        else String -> Either String String
forall a b. b -> Either a b
Right String
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
    { DecryptPolicy -> Bool
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.
    -}
    , DecryptPolicy -> Bool
decryptAllowSEIPDv1 :: Bool
    {- ^ When 'False', receiving a SEIPDv1 (MDC-protected) packet is rejected.
    Defaults to 'True' for interoperability with RFC4880 senders.
    -}
    , DecryptPolicy -> Maybe [SymmetricAlgorithm]
decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm]
    {- ^ Allowed symmetric algorithms for session keys.  'Nothing' means
    unrestricted.  The RFC9580 default restricts to AES-128/192/256.
    -}
    , DecryptPolicy -> Maybe [AEADAlgorithm]
decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm]
    {- ^ Allowed AEAD algorithms for SEIPDv2 payloads.  'Nothing' means
    unrestricted.  The RFC9580 default allows EAX, OCB, and GCM.
    -}
    , DecryptPolicy -> Bool
decryptRejectDeprecatedSKESK :: Bool
    {- ^ When 'True' (RFC9580 default), reject SKESK packets that use Simple
    or Salted S2K specifiers (both deprecated since RFC9580).
    -}
    , DecryptPolicy -> Bool
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').
    -}
    , DecryptPolicy -> Bool
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 (DecryptPolicy -> DecryptPolicy -> Bool
(DecryptPolicy -> DecryptPolicy -> Bool)
-> (DecryptPolicy -> DecryptPolicy -> Bool) -> Eq DecryptPolicy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecryptPolicy -> DecryptPolicy -> Bool
== :: DecryptPolicy -> DecryptPolicy -> Bool
$c/= :: DecryptPolicy -> DecryptPolicy -> Bool
/= :: DecryptPolicy -> DecryptPolicy -> Bool
Eq, Int -> DecryptPolicy -> ShowS
[DecryptPolicy] -> ShowS
DecryptPolicy -> String
(Int -> DecryptPolicy -> ShowS)
-> (DecryptPolicy -> String)
-> ([DecryptPolicy] -> ShowS)
-> Show DecryptPolicy
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecryptPolicy -> ShowS
showsPrec :: Int -> DecryptPolicy -> ShowS
$cshow :: DecryptPolicy -> String
show :: DecryptPolicy -> String
$cshowList :: [DecryptPolicy] -> ShowS
showList :: [DecryptPolicy] -> ShowS
Show)

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

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

requireSalt8 :: String -> Salt -> Salt8
requireSalt8 :: String -> Salt -> Salt8
requireSalt8 String
context Salt
salt =
    case Salt -> Maybe Salt8
salt8FromSalt Salt
salt of
        Just Salt8
salt8 -> Salt8
salt8
        Maybe Salt8
Nothing -> String -> Salt8
forall a. HasCallStack => String -> a
error (String
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" requires an 8-octet salt")

requireSalt16 :: String -> Salt -> Salt16
requireSalt16 :: String -> Salt -> Salt16
requireSalt16 String
context Salt
salt =
    case Salt -> Maybe Salt16
salt16FromSalt Salt
salt of
        Just Salt16
salt16 -> Salt16
salt16
        Maybe Salt16
Nothing -> String -> Salt16
forall a. HasCallStack => String -> a
error (String
context String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" requires a 16-octet salt")

defaultPolicy :: OpenPGPPolicy
defaultPolicy :: OpenPGPPolicy
defaultPolicy = OpenPGPRFC -> OpenPGPPolicy
policyForRFC OpenPGPRFC
RFC9580

defaultPKESKVersionPolicy :: PKESKVersionPolicy
defaultPKESKVersionPolicy :: PKESKVersionPolicy
defaultPKESKVersionPolicy = PKESKVersionPolicy
PreferV6

defaultVerificationDefaults :: VerificationDefaults
defaultVerificationDefaults :: VerificationDefaults
defaultVerificationDefaults =
    VerificationDefaults
        { verificationDefaultStrict :: Bool
verificationDefaultStrict = Bool
True
        , verificationDefaultStreaming :: Bool
verificationDefaultStreaming = Bool
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
defaultDecryptPolicy =
    DecryptPolicy
        { decryptAllowSEDNoIntegrity :: Bool
decryptAllowSEDNoIntegrity = Bool
False
        , decryptAllowSEIPDv1 :: Bool
decryptAllowSEIPDv1 = Bool
True
        , decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm]
decryptAllowedSymmetricAlgos = [SymmetricAlgorithm] -> Maybe [SymmetricAlgorithm]
forall a. a -> Maybe a
Just [SymmetricAlgorithm
AES128, SymmetricAlgorithm
AES192, SymmetricAlgorithm
AES256]
        , decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm]
decryptAllowedAEADAlgos = [AEADAlgorithm] -> Maybe [AEADAlgorithm]
forall a. a -> Maybe a
Just [AEADAlgorithm
EAX, AEADAlgorithm
OCB, AEADAlgorithm
GCM]
        , decryptRejectDeprecatedSKESK :: Bool
decryptRejectDeprecatedSKESK = Bool
True
        , decryptRejectTrailingData :: Bool
decryptRejectTrailingData = Bool
True
        , decryptRejectESKVersionMismatch :: Bool
decryptRejectESKVersionMismatch = Bool
True
        }

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

supportsSEIPDv2Symmetric
    :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool
supportsSEIPDv2Symmetric :: OpenPGPPolicy -> SymmetricAlgorithm -> Bool
supportsSEIPDv2Symmetric OpenPGPPolicy
policy SymmetricAlgorithm
sa =
    SymmetricAlgorithm
sa
        SymmetricAlgorithm -> [SymmetricAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` MessageEncryptionPolicy -> [SymmetricAlgorithm]
messageSEIPDv2SymmetricAlgorithms
            (OpenPGPPolicy -> MessageEncryptionPolicy
policyMessageEncryption OpenPGPPolicy
policy)

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

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

validateTable30PolicyForRecipient
    :: SomePKPayload
    -> HashAlgorithm
    -> SymmetricAlgorithm
    -> Either String ()
validateTable30PolicyForRecipient :: SomePKPayload
-> HashAlgorithm -> SymmetricAlgorithm -> Either String ()
validateTable30PolicyForRecipient SomePKPayload
recipientPKP HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA =
    case SomePKPayload
-> PKey -> Maybe (String, [(HashAlgorithm, SymmetricAlgorithm)])
allowedTable30EcdhParameterSets
        SomePKPayload
recipientPKP
        (SomePKPayload -> PKey
_pubkey SomePKPayload
recipientPKP) of
        Maybe (String, [(HashAlgorithm, SymmetricAlgorithm)])
Nothing -> () -> Either String ()
forall a b. b -> Either a b
Right ()
        Just (String
curveName, [(HashAlgorithm, SymmetricAlgorithm)]
allowedParams) ->
            if (HashAlgorithm
kdfHA, SymmetricAlgorithm
kdfSA) (HashAlgorithm, SymmetricAlgorithm)
-> [(HashAlgorithm, SymmetricAlgorithm)] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [(HashAlgorithm, SymmetricAlgorithm)]
allowedParams
                then () -> Either String ()
forall a b. b -> Either a b
Right ()
                else
                    String -> Either String ()
forall a b. a -> Either a b
Left
                        ( String
"RFC9580 Table 30 policy violation for "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ KeyVersion -> String
forall a. Show a => a -> String
show (SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
recipientPKP)
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" ECDH key on "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
curveName
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": expected one of "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ [(HashAlgorithm, SymmetricAlgorithm)] -> String
forall a. Show a => a -> String
show [(HashAlgorithm, SymmetricAlgorithm)]
allowedParams
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", got ("
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ HashAlgorithm -> String
forall a. Show a => a -> String
show HashAlgorithm
kdfHA
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", "
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymmetricAlgorithm -> String
forall a. Show a => a -> String
show SymmetricAlgorithm
kdfSA
                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
                        )

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

legacySecretKeyProtectionErrorMessage :: String
legacySecretKeyProtectionErrorMessage :: String
legacySecretKeyProtectionErrorMessage =
    String
"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 :: SignaturePayload -> Bool
isAllowedPrimaryKeySig = Bool -> (SigType -> Bool) -> Maybe SigType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False SigType -> Bool
isAllowedPrimaryKeySigType (Maybe SigType -> Bool)
-> (SignaturePayload -> Maybe SigType) -> SignaturePayload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturePayload -> Maybe SigType
sigType

-- | RFC9580 §3.3: Subkey can only have SubkeyBindingSig or SubkeyRevocationSig
isAllowedSubkeySig :: SignaturePayload -> Bool
isAllowedSubkeySig :: SignaturePayload -> Bool
isAllowedSubkeySig = Bool -> (SigType -> Bool) -> Maybe SigType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False SigType -> Bool
isAllowedSubkeySigType (Maybe SigType -> Bool)
-> (SignaturePayload -> Maybe SigType) -> SignaturePayload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturePayload -> Maybe SigType
sigType

-- | RFC9580 §3.4: User ID can only have various certification types or CertRevocationSig
isAllowedUIDSig :: SignaturePayload -> Bool
isAllowedUIDSig :: SignaturePayload -> Bool
isAllowedUIDSig = Bool -> (SigType -> Bool) -> Maybe SigType -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False SigType -> Bool
isAllowedUIDSigType (Maybe SigType -> Bool)
-> (SignaturePayload -> Maybe SigType) -> SignaturePayload -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SignaturePayload -> Maybe SigType
sigType

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

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

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