hOpenPGP-3.0.0: Codec/Encryption/OpenPGP/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 context validation (RFC9580/RFC4880)
, isAllowedPrimaryKeySig
, isAllowedSubkeySig
, isAllowedUIDSig
-- * Signature type validation helpers (for parser use)
, isAllowedPrimaryKeySigType
, isAllowedSubkeySigType
, isAllowedUIDSigType
) where
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.SignatureQualities (sigType)
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.List (elem)
import Data.Kind (Constraint)
import Data.Word (Word8)
import GHC.TypeLits (ErrorMessage(..), TypeError)
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
}
-- | 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
{ -- | 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.
decryptAllowSEDNoIntegrity :: Bool
-- | When 'False', receiving a SEIPDv1 (MDC-protected) packet is rejected.
-- Defaults to 'True' for interoperability with RFC4880 senders.
, decryptAllowSEIPDv1 :: Bool
-- | Allowed symmetric algorithms for session keys. 'Nothing' means
-- unrestricted. The RFC9580 default restricts to AES-128/192/256.
, decryptAllowedSymmetricAlgos :: Maybe [SymmetricAlgorithm]
-- | Allowed AEAD algorithms for SEIPDv2 payloads. 'Nothing' means
-- unrestricted. The RFC9580 default allows EAX, OCB, and GCM.
, decryptAllowedAEADAlgos :: Maybe [AEADAlgorithm]
-- | When 'True' (RFC9580 default), reject SKESK packets that use Simple
-- or Salted S2K specifiers (both deprecated since RFC9580).
, decryptRejectDeprecatedSKESK :: 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').
, decryptRejectTrailingData :: 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.
, decryptRejectESKVersionMismatch :: Bool
} 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 Ed25519 _ ->
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 Ed25519 _ -> 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