Message.hs

-- Message.hs: OpenPGP (RFC9580) message helpers
-- Copyright © 2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Codec.Encryption.OpenPGP.Message
    ( Passphrase
    , EncryptedPayload
    , mkEncryptedPayload
    , encryptedPayloadBytes
    , ClearPayload
    , mkClearPayload
    , clearPayloadBytes
    , WrappedSessionMaterial
    , SigningAlgorithm (..)
    , SecretKeyFor
    , VersionedPKPayload
    , asV4PKPayload
    , asV6PKPayload
    , Signer
    , SigningCapability
    , mkRSASignerV4
    , mkRSASignerV6
    , mkEd25519SignerV4
    , mkEd25519SignerV6
    , mkEd448SignerV4
    , mkEd448SignerV6
    , MessageParseFailure (..)
    , renderMessageParseFailure
    , MDCFailure (..)
    , AEADFailure (..)
    , renderAEADFailure
    , PayloadDecryptFailure (..)
    , renderPayloadDecryptFailure
    , MessageDecryptFailure (..)
    , renderMessageDecryptFailure
    , MessageEncryptFailure (..)
    , renderMessageEncryptFailure
    , MessageError (..)
    , renderMessageError
    , SessionMaterialExposure (..)
    , EncryptMessageProfile
    , EncryptMessageOptions (..)
    , RecoveredSessionMaterial (..)
    , encryptMessage
    , decryptMessage
    , signMessage
    , signMessageWith
    , ConduitMessage.VerificationPolicy (..)
    , ConduitMessage.VerificationOptions (..)
    , ConduitMessage.defaultVerificationOptions
    , verifySignedMessage
    ) where

import Control.Monad (foldM)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT (..), runExceptT)
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.Ed448 as Ed448
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Bifunctor (bimap, first)
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Functor.Identity (Identity (..), runIdentity)
import Data.Kind (Type)
import Data.Word (Word8)

import Codec.Encryption.OpenPGP.BlockCipher
    ( CipherError
    , keySize
    , renderCipherError
    )
import Codec.Encryption.OpenPGP.CFB
    ( OpenPGPCFBModeW (..)
    , decryptOpenPGPCfb
    , decryptPreservingNonce
    , encryptOpenPGPCfbRaw
    )
import Codec.Encryption.OpenPGP.Encrypt
    ( buildOnePassSignature
    , encryptSEIPDv2WithSKESKBlock
    , renderOPSBuildError
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Policy
    ( HashAlgorithmW (..)
    , OpenPGPPolicy
    , OpenPGPRFCW (..)
    , defaultPolicy
    , deprecatedHashAlgorithms
    , messageDefaultAEADAlgorithm
    , messageDefaultChunkSize
    , messageSEIPDv2SaltOctets
    , policyGenerationDeprecations
    , policyMessageEncryption
    , supportsSEIPDv2Symmetric
    )
import Codec.Encryption.OpenPGP.S2K
    ( S2KError (..)
    , renderS2KError
    , skesk2SessionKey
    , string2Key
    )
import Codec.Encryption.OpenPGP.SEIPDv1
    ( MDCFailure (..)
    , mdcTrailerForSEIPDv1
    , renderMDCFailure
    , validateSEIPD1MDC
    )
import Codec.Encryption.OpenPGP.SEIPDv2
    ( SEIPDv2Failure (..)
    , decryptSKESK6SessionKey
    , deriveSKESK6KEK
    , renderSEIPDv2Failure
    )
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Signatures
    ( SignError (..)
    , VerificationError
    , renderSignError
    , signDataWithEd25519Builder
    , signDataWithEd25519V6Builder
    , signDataWithEd448Builder
    , signDataWithEd448V6Builder
    , signDataWithRSABuilder
    , signDataWithRSAV6Builder
    )
import Codec.Encryption.OpenPGP.Subpackets
    ( addHashedSubs
    , addUnhashedSubs
    , listToHashedSubs
    , listToUnhashedSubs
    , sigBuilderInitTyped
    , sigBuilderInitV6Typed
    )
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Data.Conduit.OpenPGP.Decrypt (decryptSEIPDv2Payload)
import qualified Data.Conduit.OpenPGP.Message as ConduitMessage

newtype EncryptedPayload = EncryptedPayload {unEncryptedPayload :: BL.ByteString}
    deriving (Eq, Ord, Show)

newtype ClearPayload = ClearPayload {unClearPayload :: BL.ByteString}
    deriving (Eq, Ord, Show)

newtype WrappedSessionMaterial = WrappedSessionMaterial
    {unWrappedSessionMaterial :: B.ByteString}
    deriving (Eq, Ord, Show)

data SigningAlgorithm = AlgoRSA | AlgoEd25519 | AlgoEd448

type family SecretKeyFor (alg :: SigningAlgorithm) where
    SecretKeyFor 'AlgoRSA = RSATypes.PrivateKey
    SecretKeyFor 'AlgoEd25519 = Ed25519.SecretKey
    SecretKeyFor 'AlgoEd448 = Ed448.SecretKey

type family KeyVersionForSig (v :: Type) :: KeyVersion where
    KeyVersionForSig V4Sig = 'V4
    KeyVersionForSig V6Sig = 'V6

data VersionedPKPayload (v :: KeyVersion) where
    VersionedPKPayloadV4 :: PKPayload 'V4 -> VersionedPKPayload 'V4
    VersionedPKPayloadV6 :: PKPayload 'V6 -> VersionedPKPayload 'V6

asV4PKPayload
    :: SomePKPayload -> Either String (VersionedPKPayload 'V4)
asV4PKPayload (SomePKPayload pk@(PKPayloadV4 _ _ _)) =
    Right (VersionedPKPayloadV4 pk)
asV4PKPayload _ = Left "Expected a v4 PKPayload"

asV6PKPayload
    :: SomePKPayload -> Either String (VersionedPKPayload 'V6)
asV6PKPayload (SomePKPayload pk@(PKPayloadV6 _ _ _)) =
    Right (VersionedPKPayloadV6 pk)
asV6PKPayload _ = Left "Expected a v6 PKPayload"

data Signer (alg :: SigningAlgorithm) (v :: Type) where
    RSASigner
        :: VersionedPKPayload (KeyVersionForSig v)
        -> SecretKeyFor 'AlgoRSA
        -> Signer 'AlgoRSA v
    Ed25519Signer
        :: VersionedPKPayload (KeyVersionForSig v)
        -> SecretKeyFor 'AlgoEd25519
        -> Signer 'AlgoEd25519 v
    Ed448Signer
        :: VersionedPKPayload (KeyVersionForSig v)
        -> SecretKeyFor 'AlgoEd448
        -> Signer 'AlgoEd448 v

class SigningCapability (alg :: SigningAlgorithm) v
instance SigningCapability 'AlgoRSA V4Sig
instance SigningCapability 'AlgoRSA V6Sig
instance SigningCapability 'AlgoEd25519 V4Sig
instance SigningCapability 'AlgoEd25519 V6Sig
instance SigningCapability 'AlgoEd448 V4Sig
instance SigningCapability 'AlgoEd448 V6Sig

mkRSASignerV4
    :: VersionedPKPayload 'V4
    -> SecretKeyFor 'AlgoRSA
    -> Signer 'AlgoRSA V4Sig
mkRSASignerV4 = RSASigner

mkRSASignerV6
    :: VersionedPKPayload 'V6
    -> SecretKeyFor 'AlgoRSA
    -> Signer 'AlgoRSA V6Sig
mkRSASignerV6 = RSASigner

mkEd25519SignerV4
    :: VersionedPKPayload 'V4
    -> SecretKeyFor 'AlgoEd25519
    -> Signer 'AlgoEd25519 V4Sig
mkEd25519SignerV4 = Ed25519Signer

mkEd25519SignerV6
    :: VersionedPKPayload 'V6
    -> SecretKeyFor 'AlgoEd25519
    -> Signer 'AlgoEd25519 V6Sig
mkEd25519SignerV6 = Ed25519Signer

mkEd448SignerV4
    :: VersionedPKPayload 'V4
    -> SecretKeyFor 'AlgoEd448
    -> Signer 'AlgoEd448 V4Sig
mkEd448SignerV4 = Ed448Signer

mkEd448SignerV6
    :: VersionedPKPayload 'V6
    -> SecretKeyFor 'AlgoEd448
    -> Signer 'AlgoEd448 V6Sig
mkEd448SignerV6 = Ed448Signer

data MessageError
    = MessageEncryptFailureError MessageEncryptFailure
    | MessageDecryptError String
    | MessageSignError SignError
    | MessageParseError String
    | MessageParseFailureError MessageParseFailure
    | MessageDecryptFailureError MessageDecryptFailure
    deriving (Eq, Show)

messageStep
    :: Monad m => Either MessageError a -> ExceptT MessageError m a
messageStep = ExceptT . pure

runMessageFlow
    :: ExceptT MessageError Identity a -> Either MessageError a
runMessageFlow = runIdentity . runExceptT

type MessageFlowT m = ExceptT MessageError m

runMessageFlowT :: MessageFlowT m a -> m (Either MessageError a)
runMessageFlowT = runExceptT

signStepT :: Monad m => Either SignError a -> MessageFlowT m a
signStepT = ExceptT . pure . first MessageSignError

parseStep
    :: Monad m
    => Either MessageParseFailure a -> ExceptT MessageError m a
parseStep = messageStep . first MessageParseFailureError

decryptStep
    :: Monad m
    => Either MessageDecryptFailure a -> ExceptT MessageError m a
decryptStep = messageStep . first MessageDecryptFailureError

encryptStep
    :: Monad m
    => Either MessageEncryptFailure a -> ExceptT MessageError m a
encryptStep = messageStep . first MessageEncryptFailureError

data MessageParseFailure
    = MissingEncryptedMessage
    | ExpectedSKESKThenEncryptedData
    | SKESKSEIPDAlgorithmMismatch
    | UnsupportedEncryptedSKESK
    | MissingLiteralDataPacket
    | UnknownCriticalPacketType Word8
    | BrokenCriticalPacketType Word8 String
    deriving (Eq, Show)

data AEADFailure
    = AEADChunkAuthFailed AEADAlgorithm Int
    | AEADFinalTagFailed AEADAlgorithm
    | AEADInitFailed CipherError
    deriving (Eq, Show)

data PayloadDecryptFailure
    = PayloadDecryptCipherFailed CipherError
    | PayloadDecryptMDCFailed MDCFailure
    | PayloadDecryptAEADFailed AEADFailure
    | PayloadDecryptSEIPDv2Failed SEIPDv2Failure
    | PayloadDecryptGeneric String
    deriving (Eq, Show)

data MessageDecryptFailure
    = SessionMaterialDerivationFailed S2KError
    | PayloadDecryptFailed PayloadDecryptFailure
    deriving (Eq, Show)

data MessageEncryptFailure
    = MessageEncryptSEIPDv2Failed SEIPDv2Failure
    | MessageEncryptCipherFailed CipherError
    | MessageEncryptS2KFailed S2KError
    | MessageEncryptDeprecatedS2KHash HashAlgorithm
    | MessageEncryptUnsupportedSymmetricAlgorithm SymmetricAlgorithm
    deriving (Eq, Show)

data ParsedEncryptedPayloadKind
    = LegacySEDPayloadKind
    | LegacySEIPDv1PayloadKind
    | SEIPDv2PayloadKind

data EncryptedPreludeKind
    = LegacyEncryptedPreludeKind
    | SEIPDv2EncryptedPreludeKind

data SessionMaterialExposure
    = DoNotExposeSessionMaterial
    | ExposeSessionMaterial
    deriving (Eq, Show)

data EncryptMessageProfile
    = RFC4880Message
    | RFC9580Message

data EncryptMessageOptions (p :: EncryptMessageProfile) where
    RFC4880EncryptMessageOptions
        :: { rfc4880EncryptMessageExposure :: SessionMaterialExposure
           , rfc4880EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm
           , rfc4880EncryptMessageS2K :: S2K
           , rfc4880EncryptMessageIV :: IV
           }
        -> EncryptMessageOptions 'RFC4880Message
    RFC9580EncryptMessageOptions
        :: { rfc9580EncryptMessageExposure :: SessionMaterialExposure
           , rfc9580EncryptMessageSymmetricAlgorithm :: SymmetricAlgorithm
           , rfc9580EncryptMessageS2K :: S2K
           , rfc9580EncryptMessageIV :: IV
           }
        -> EncryptMessageOptions 'RFC9580Message

deriving instance Eq (EncryptMessageOptions p)
deriving instance Show (EncryptMessageOptions p)

data RecoveredSessionMaterial
    = RecoveredSessionMaterial
    { recoveredSessionAlgorithm :: SymmetricAlgorithm
    , recoveredSessionKey :: SessionKey
    }
    deriving (Eq, Show)

renderMessageParseFailure :: MessageParseFailure -> String
renderMessageParseFailure MissingEncryptedMessage =
    "Could not parse encrypted OpenPGP message"
renderMessageParseFailure ExpectedSKESKThenEncryptedData =
    "Expected an SKESK packet followed by symmetrically encrypted data or SEIPD v2 data"
renderMessageParseFailure SKESKSEIPDAlgorithmMismatch =
    "SKESK and SEIPD v2 algorithms do not match"
renderMessageParseFailure UnsupportedEncryptedSKESK =
    "Cannot decrypt SKESK packets with encrypted session keys"
renderMessageParseFailure MissingLiteralDataPacket =
    "Decrypted message does not contain a literal data packet"
renderMessageParseFailure (UnknownCriticalPacketType t) =
    "Unknown critical packet type: " ++ show t
renderMessageParseFailure (BrokenCriticalPacketType t err) =
    "Broken critical packet type " ++ show t ++ ": " ++ err

renderMessageDecryptFailure :: MessageDecryptFailure -> String
renderMessageDecryptFailure (SessionMaterialDerivationFailed err) = renderS2KError err
renderMessageDecryptFailure (PayloadDecryptFailed err) = renderPayloadDecryptFailure err

renderMessageEncryptFailure :: MessageEncryptFailure -> String
renderMessageEncryptFailure (MessageEncryptSEIPDv2Failed err) = renderSEIPDv2Failure err
renderMessageEncryptFailure (MessageEncryptCipherFailed err) = renderCipherError err
renderMessageEncryptFailure (MessageEncryptS2KFailed err) = renderS2KError err
renderMessageEncryptFailure (MessageEncryptDeprecatedS2KHash ha) =
    "deprecated hash algorithm disallowed for modern message generation: "
        ++ show ha
renderMessageEncryptFailure (MessageEncryptUnsupportedSymmetricAlgorithm sa) =
    "symmetric algorithm disallowed for RFC9580 message generation: "
        ++ show sa

renderAEADFailure :: AEADFailure -> String
renderAEADFailure (AEADChunkAuthFailed algo chunk) =
    "AEAD chunk authentication failed for "
        ++ show algo
        ++ " at chunk "
        ++ show chunk
renderAEADFailure (AEADFinalTagFailed algo) =
    "AEAD final tag verification failed for " ++ show algo
renderAEADFailure (AEADInitFailed err) =
    "AEAD initialization failed: " ++ renderCipherError err

renderPayloadDecryptFailure :: PayloadDecryptFailure -> String
renderPayloadDecryptFailure (PayloadDecryptCipherFailed err) = renderCipherError err
renderPayloadDecryptFailure (PayloadDecryptMDCFailed err) = renderMDCFailure err
renderPayloadDecryptFailure (PayloadDecryptAEADFailed err) = renderAEADFailure err
renderPayloadDecryptFailure (PayloadDecryptSEIPDv2Failed err) = renderSEIPDv2Failure err
renderPayloadDecryptFailure (PayloadDecryptGeneric err) = err

renderMessageError :: MessageError -> String
renderMessageError (MessageEncryptFailureError err) = renderMessageEncryptFailure err
renderMessageError (MessageDecryptError err) = err
renderMessageError (MessageSignError err) = renderSignError err
renderMessageError (MessageParseError err) = err
renderMessageError (MessageParseFailureError err) = renderMessageParseFailure err
renderMessageError (MessageDecryptFailureError err) = renderMessageDecryptFailure err

mkEncryptedPayload :: BL.ByteString -> EncryptedPayload
mkEncryptedPayload = EncryptedPayload

mkClearPayload :: BL.ByteString -> ClearPayload
mkClearPayload = ClearPayload

clearPayloadBytes :: ClearPayload -> BL.ByteString
clearPayloadBytes = unClearPayload

encryptedPayloadBytes :: EncryptedPayload -> BL.ByteString
encryptedPayloadBytes = unEncryptedPayload

signBackendStep :: Either String a -> Either SignError a
signBackendStep = first SignBackendError

decryptSessionStep
    :: Either S2KError a -> Either MessageDecryptFailure a
decryptSessionStep = first SessionMaterialDerivationFailed

decryptSessionKeySizeStep
    :: Either CipherError a -> Either MessageDecryptFailure a
decryptSessionKeySizeStep =
    first
        (SessionMaterialDerivationFailed . S2KUnsupportedAlgorithm)

decryptCipherStep
    :: Either CipherError a -> Either MessageDecryptFailure a
decryptCipherStep = first (PayloadDecryptFailed . PayloadDecryptCipherFailed)

decryptMDCStep
    :: Either MDCFailure a -> Either MessageDecryptFailure a
decryptMDCStep = first (PayloadDecryptFailed . PayloadDecryptMDCFailed)

decryptSEIPDv2Step
    :: Either SEIPDv2Failure a -> Either MessageDecryptFailure a
decryptSEIPDv2Step = first (PayloadDecryptFailed . PayloadDecryptSEIPDv2Failed)

encryptMessage
    :: EncryptMessageOptions p
    -> Passphrase
    -> ClearPayload
    -> Either
        MessageError
        (EncryptedPayload, Maybe RecoveredSessionMaterial)
encryptMessage options passphrase payload = runMessageFlow $
    case options of
        RFC4880EncryptMessageOptions exposure sa s2k iv -> do
            encryptedPayload <-
                encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload
            sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase
            pure
                ( encryptedPayload
                , exposedSessionMaterial exposure sa sessionKeyMaterial
                )
        RFC9580EncryptMessageOptions exposure sa s2k iv -> do
            encryptStep $ validateRFC9580MessageSymmetric defaultPolicy sa
            encryptStep $ validateModernMessageS2K defaultPolicy s2k
            encrypted <-
                encryptStep . first MessageEncryptSEIPDv2Failed $
                    encryptSEIPDv2WithSKESKBlock
                        sa
                        (messageDefaultAEADAlgorithm messagePolicy)
                        (messageDefaultChunkSize messagePolicy)
                        ( defaultSEIPDv2SaltFromIV
                            (messageSEIPDv2SaltOctets messagePolicy)
                            iv
                        )
                        s2k
                        (unPassphrase passphrase)
                        ( Block
                            [LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)]
                        )
            sessionKeyMaterial <- deriveSessionMaterial sa s2k passphrase
            pure
                ( EncryptedPayload (runPut (put (Block encrypted)))
                , exposedSessionMaterial exposure sa sessionKeyMaterial
                )
  where
    messagePolicy = policyMessageEncryption defaultPolicy

defaultSEIPDv2SaltFromIV :: Int -> IV -> Salt
defaultSEIPDv2SaltFromIV outputLen (IV ivBytes) =
    Salt (B.take outputLen (B.concat (replicate outputLen seed)))
  where
    seed
        | B.null ivBytes = B.singleton 0
        | otherwise = ivBytes

encryptMessageWithRFC4880Fallback
    :: Monad m
    => SymmetricAlgorithm
    -> S2K
    -> IV
    -> Passphrase
    -> ClearPayload
    -> ExceptT MessageError m EncryptedPayload
encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload = do
    keyLen <-
        encryptStep . first MessageEncryptCipherFailed $ keySize sa
    sessionMaterial <-
        encryptStep . first MessageEncryptS2KFailed $
            WrappedSessionMaterial
                <$> string2Key s2k keyLen (unPassphrase passphrase)
    let literal =
            LiteralDataPkt BinaryData BL.empty 0 (unClearPayload payload)
        cleartext = BL.toStrict (runPut (put (Block [literal])))
        cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext
    encrypted <-
        encryptStep . first MessageEncryptCipherFailed $
            encryptOpenPGPCfbRaw
                OpenPGPCFBNoResyncW
                sa
                iv
                cleartextWithMDC
                (unWrappedSessionMaterial sessionMaterial)
    return . EncryptedPayload . runPut . put $
        Block
            [ SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing))
            , SymEncIntegrityProtectedDataPkt
                (SEIPD1 1 (BL.fromStrict encrypted))
            ]

deriveSessionMaterial
    :: Monad m
    => SymmetricAlgorithm
    -> S2K
    -> Passphrase
    -> ExceptT MessageError m B.ByteString
deriveSessionMaterial sa s2k passphrase = do
    keyLen <-
        encryptStep . first MessageEncryptCipherFailed $ keySize sa
    encryptStep . first MessageEncryptS2KFailed $
        string2Key s2k keyLen (unPassphrase passphrase)

exposedSessionMaterial
    :: SessionMaterialExposure
    -> SymmetricAlgorithm
    -> B.ByteString
    -> Maybe RecoveredSessionMaterial
exposedSessionMaterial DoNotExposeSessionMaterial _ _ = Nothing
exposedSessionMaterial ExposeSessionMaterial sa sessionKeyMaterial =
    Just
        ( RecoveredSessionMaterial
            { recoveredSessionAlgorithm = sa
            , recoveredSessionKey = SessionKey sessionKeyMaterial
            }
        )

decryptMessage
    :: Passphrase
    -> EncryptedPayload
    -> Either MessageError ClearPayload
decryptMessage passphrase encrypted = runMessageFlow $ do
    encryptedPackets <-
        parseStep $
            rejectUnknownCriticalPacketsTyped
                (parsePkts (unEncryptedPayload encrypted))
    payload <-
        parseStep $ extractEncryptedPayload encryptedPackets
    cleartext <-
        decryptStep $ decryptPayload passphrase payload
    clearPackets <-
        parseStep $
            rejectUnknownCriticalPacketsTyped
                (parsePkts (unClearPayload cleartext))
    parseStep $ extractLiteralPayload clearPackets

signMessageWith
    :: (MonadRandom m, SigningCapability alg v)
    => Signer alg v
    -> ClearPayload
    -> m (Either MessageError BL.ByteString)
signMessageWith signer payload =
    runMessageFlowT $
        let applySubs builder hashed unhashed =
                addUnhashedSubs
                    (listToUnhashedSubs unhashed)
                    (addHashedSubs (listToHashedSubs hashed) builder)
         in case signer of
                RSASigner signerPK signingKey ->
                    case signerPK of
                        VersionedPKPayloadV4 pk ->
                            signV4Message
                                pk
                                ( \hashed unhashed clear ->
                                    signDataWithRSABuilder
                                        ( applySubs
                                            (sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W)
                                            hashed
                                            unhashed
                                        )
                                        signingKey
                                        clear
                                )
                                payload
                        VersionedPKPayloadV6 pk ->
                            signV6Message
                                pk
                                ( \salt hashed unhashed clear ->
                                    signDataWithRSAV6Builder
                                        ( applySubs
                                            (sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt)
                                            hashed
                                            unhashed
                                        )
                                        signingKey
                                        clear
                                )
                                payload
                Ed25519Signer signerPK signingKey ->
                    case signerPK of
                        VersionedPKPayloadV4 pk ->
                            signV4Message
                                pk
                                ( \hashed unhashed clear ->
                                    signDataWithEd25519Builder
                                        ( applySubs
                                            (sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W)
                                            hashed
                                            unhashed
                                        )
                                        signingKey
                                        clear
                                )
                                payload
                        VersionedPKPayloadV6 pk ->
                            signV6Message
                                pk
                                ( \salt hashed unhashed clear ->
                                    signDataWithEd25519V6Builder
                                        ( applySubs
                                            ( sigBuilderInitV6Typed @'PKA.Ed25519
                                                RFC9580W
                                                BinarySig
                                                SHA512W
                                                salt
                                            )
                                            hashed
                                            unhashed
                                        )
                                        signingKey
                                        clear
                                )
                                payload
                Ed448Signer signerPK signingKey ->
                    case signerPK of
                        VersionedPKPayloadV4 pk ->
                            signV4Message
                                pk
                                ( \hashed unhashed clear ->
                                    signDataWithEd448Builder
                                        ( applySubs
                                            (sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W)
                                            hashed
                                            unhashed
                                        )
                                        signingKey
                                        clear
                                )
                                payload
                        VersionedPKPayloadV6 pk ->
                            signV6Message
                                pk
                                ( \salt hashed unhashed clear ->
                                    signDataWithEd448V6Builder
                                        ( applySubs
                                            (sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt)
                                            hashed
                                            unhashed
                                        )
                                        signingKey
                                        clear
                                )
                                payload

signMessage
    :: (MonadRandom m, SigningCapability alg v)
    => Signer alg v
    -> BL.ByteString
    -> m (Either MessageError BL.ByteString)
signMessage signer = signMessageWith signer . mkClearPayload

verifySignedMessage
    :: ConduitMessage.VerificationOptions
    -> PublicKeyring
    -> BL.ByteString
    -> [Either VerificationError Verification]
verifySignedMessage = ConduitMessage.verifyMessage

signV4Message
    :: Monad m
    => PKPayload 'V4
    -> ( [SigSubPacket]
         -> [SigSubPacket]
         -> BL.ByteString
         -> Either SignError SignaturePayload
       )
    -> ClearPayload
    -> MessageFlowT m BL.ByteString
signV4Message signer signingFn payload =
    signStepT (signV4WithIssuers signer signingFn payload)

signV6Message
    :: MonadRandom m
    => PKPayload 'V6
    -> ( SignatureSalt
         -> [SigSubPacket]
         -> [SigSubPacket]
         -> BL.ByteString
         -> Either SignError SignaturePayload
       )
    -> ClearPayload
    -> MessageFlowT m BL.ByteString
signV6Message signer signingFn payload = do
    salt <- lift randomSHA512SignatureSalt
    signStepT
        (signV6WithFingerprintOnly signer (signingFn salt) payload)

randomSHA512SignatureSalt :: MonadRandom m => m SignatureSalt
randomSHA512SignatureSalt =
    SignatureSalt . BL.fromStrict <$> getRandomBytes 32

signV4WithIssuers
    :: PKPayload 'V4
    -> ( [SigSubPacket]
         -> [SigSubPacket]
         -> BL.ByteString
         -> Either SignError SignaturePayload
       )
    -> ClearPayload
    -> Either SignError BL.ByteString
signV4WithIssuers signer signingFn payload = do
    issuerKeyId <-
        signBackendStep (eightOctetKeyID (SomePKPayload signer))
    let hashed =
            [ SigSubPacket
                False
                ( IssuerFingerprint
                    IssuerFingerprintV4
                    (fingerprint (SomePKPayload signer))
                )
            ]
        unhashed = [SigSubPacket False (Issuer issuerKeyId)]
    signWithSubpackets hashed unhashed signingFn payload

signV6WithFingerprintOnly
    :: PKPayload 'V6
    -> ( [SigSubPacket]
         -> [SigSubPacket]
         -> BL.ByteString
         -> Either SignError SignaturePayload
       )
    -> ClearPayload
    -> Either SignError BL.ByteString
signV6WithFingerprintOnly signer signingFn payload = do
    let hashed =
            [ SigSubPacket
                False
                ( IssuerFingerprint
                    IssuerFingerprintV6
                    (fingerprint (SomePKPayload signer))
                )
            ]
        unhashed = []
    signWithSubpackets hashed unhashed signingFn payload

signWithSubpackets
    :: [SigSubPacket]
    -> [SigSubPacket]
    -> ( [SigSubPacket]
         -> [SigSubPacket]
         -> BL.ByteString
         -> Either SignError SignaturePayload
       )
    -> ClearPayload
    -> Either SignError BL.ByteString
signWithSubpackets hashed unhashed signingFn payload = do
    let clear = unClearPayload payload
        literal = LiteralDataPkt BinaryData BL.empty 0 clear
    signature <- signingFn hashed unhashed clear
    let sigPkt = SignaturePkt signature
    bimap
        (SignBackendError . renderOPSBuildError)
        ( \ops ->
            runPut . put $ Block [OnePassSignaturePkt ops, literal, sigPkt]
        )
        (buildOnePassSignature False signature)

extractEncryptedPayload
    :: [Pkt] -> Either MessageParseFailure SomeParsedEncryptedPayload
extractEncryptedPayload =
    fmap parsedEncryptedPayloadFromPrelude
        . extractEncryptedPreludeTyped

data EncryptedPrelude (k :: EncryptedPreludeKind) where
    LegacySEDPrelude
        :: SKESK 'SKESKV4
        -> B.ByteString
        -> EncryptedPrelude 'LegacyEncryptedPreludeKind
    LegacySEIPDv1Prelude
        :: SKESK 'SKESKV4
        -> B.ByteString
        -> EncryptedPrelude 'LegacyEncryptedPreludeKind
    SEIPDv2SKESK4Prelude
        :: SymmetricAlgorithm
        -> S2K
        -> AEADAlgorithm
        -> Word8
        -> Salt
        -> B.ByteString
        -> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind
    SEIPDv2SKESK6Prelude
        :: SymmetricAlgorithm
        -> AEADAlgorithm
        -> S2K
        -> BL.ByteString
        -> BL.ByteString
        -> BL.ByteString
        -> Word8
        -> Salt
        -> B.ByteString
        -> EncryptedPrelude 'SEIPDv2EncryptedPreludeKind

data SomeEncryptedPrelude where
    SomeEncryptedPrelude
        :: EncryptedPrelude k -> SomeEncryptedPrelude

extractEncryptedPreludeTyped
    :: [Pkt] -> Either MessageParseFailure SomeEncryptedPrelude
extractEncryptedPreludeTyped
    ( SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk))
            : SymEncDataPkt payload
            : _
        ) =
        Right
            ( SomeEncryptedPrelude
                ( LegacySEDPrelude
                    (SKESK4Packet sa s2k esk)
                    (BL.toStrict payload)
                )
            )
extractEncryptedPreludeTyped
    ( SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k esk))
            : SymEncIntegrityProtectedDataPkt (SEIPD1 _ payload)
            : _
        ) =
        Right
            ( SomeEncryptedPrelude
                ( LegacySEIPDv1Prelude
                    (SKESK4Packet sa s2k esk)
                    (BL.toStrict payload)
                )
            )
extractEncryptedPreludeTyped
    ( SKESKPkt skesk
            : SymEncIntegrityProtectedDataPkt
                (SEIPD2 payloadSA aead chunkSize salt payload)
            : _
        ) =
        toSEIPDv2Prelude skesk payloadSA aead chunkSize salt payload
extractEncryptedPreludeTyped [] = Left MissingEncryptedMessage
extractEncryptedPreludeTyped _ = Left ExpectedSKESKThenEncryptedData

toSEIPDv2Prelude
    :: SKESKPayload
    -> SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> BL.ByteString
    -> Either MessageParseFailure SomeEncryptedPrelude
toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing)) payloadSA aead chunkSize salt payload
    | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch
    | otherwise =
        Right
            ( SomeEncryptedPrelude
                ( SEIPDv2SKESK4Prelude
                    sa
                    s2k
                    aead
                    chunkSize
                    salt
                    (BL.toStrict payload)
                )
            )
toSEIPDv2Prelude (SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag)) payloadSA _aead chunkSize salt payload
    | sa /= payloadSA = Left SKESKSEIPDAlgorithmMismatch
    | otherwise =
        Right
            ( SomeEncryptedPrelude
                ( SEIPDv2SKESK6Prelude
                    sa
                    aa
                    s2k
                    iv
                    esk
                    tag
                    chunkSize
                    salt
                    (BL.toStrict payload)
                )
            )
toSEIPDv2Prelude (SKESKPayloadV4Packet (SKESKPayloadV4 _ _ (Just _))) _ _ _ _ _ = Left UnsupportedEncryptedSKESK

parsedEncryptedPayloadFromPrelude
    :: SomeEncryptedPrelude -> SomeParsedEncryptedPayload
parsedEncryptedPayloadFromPrelude (SomeEncryptedPrelude prelude) =
    case prelude of
        LegacySEDPrelude skesk payload ->
            SomeParsedEncryptedPayload (LegacySEDPayload skesk payload)
        LegacySEIPDv1Prelude skesk payload ->
            SomeParsedEncryptedPayload (LegacySEIPDv1Payload skesk payload)
        SEIPDv2SKESK4Prelude sa s2k aead chunkSize salt payload ->
            SomeParsedEncryptedPayload
                ( SEIPDv2Payload
                    sa
                    aead
                    chunkSize
                    salt
                    (SEIPDv2SKESK4 sa s2k)
                    payload
                )
        SEIPDv2SKESK6Prelude sa aa s2k iv esk tag chunkSize salt payload ->
            SomeParsedEncryptedPayload
                ( SEIPDv2Payload
                    sa
                    aa
                    chunkSize
                    salt
                    (SEIPDv2SKESK6 sa aa s2k iv esk tag)
                    payload
                )

data SEIPDv2SKESKInfo (v :: KeyVersion) where
    SEIPDv2SKESK4
        :: SymmetricAlgorithm -> S2K -> SEIPDv2SKESKInfo 'V4
    SEIPDv2SKESK6
        :: SymmetricAlgorithm
        -> AEADAlgorithm
        -> S2K
        -> BL.ByteString
        -> BL.ByteString
        -> BL.ByteString
        -> SEIPDv2SKESKInfo 'V6

data ParsedEncryptedPayload (k :: ParsedEncryptedPayloadKind) where
    LegacySEDPayload
        :: SKESK 'SKESKV4
        -> B.ByteString
        -> ParsedEncryptedPayload 'LegacySEDPayloadKind
    LegacySEIPDv1Payload
        :: SKESK 'SKESKV4
        -> B.ByteString
        -> ParsedEncryptedPayload 'LegacySEIPDv1PayloadKind
    SEIPDv2Payload
        :: SymmetricAlgorithm
        -> AEADAlgorithm
        -> Word8
        -> Salt
        -> SEIPDv2SKESKInfo v
        -> B.ByteString
        -> ParsedEncryptedPayload 'SEIPDv2PayloadKind

data SomeParsedEncryptedPayload where
    SomeParsedEncryptedPayload
        :: ParsedEncryptedPayload k
        -> SomeParsedEncryptedPayload

decryptPayload
    :: Passphrase
    -> SomeParsedEncryptedPayload
    -> Either MessageDecryptFailure ClearPayload
decryptPayload passphrase (SomeParsedEncryptedPayload payload) =
    case payload of
        LegacySEDPayload skesk encryptedPayload ->
            decryptLegacySEDPayloadTyped passphrase skesk encryptedPayload
        LegacySEIPDv1Payload skesk encryptedPayload ->
            decryptLegacySEIPDv1PayloadTyped
                passphrase
                skesk
                encryptedPayload
        SEIPDv2Payload sa aead chunkSize salt skeskInfo encryptedPayload ->
            decryptSEIPDv2PayloadTyped
                passphrase
                sa
                aead
                chunkSize
                salt
                skeskInfo
                encryptedPayload

decryptLegacySEDPayloadTyped
    :: Passphrase
    -> SKESK 'SKESKV4
    -> B.ByteString
    -> Either MessageDecryptFailure ClearPayload
decryptLegacySEDPayloadTyped passphrase skesk payload = do
    (sessionAlgorithm, sessionKeyBytes) <-
        decryptSessionStep $
            skesk2SessionKey skesk (unPassphrase passphrase)
    decryptCipherStep $
        ClearPayload . BL.fromStrict
            <$> decryptOpenPGPCfb
                sessionAlgorithm
                payload
                sessionKeyBytes

decryptLegacySEIPDv1PayloadTyped
    :: Passphrase
    -> SKESK 'SKESKV4
    -> B.ByteString
    -> Either MessageDecryptFailure ClearPayload
decryptLegacySEIPDv1PayloadTyped passphrase skesk payload = do
    (sessionAlgorithm, sessionKeyBytes) <-
        decryptSessionStep $
            skesk2SessionKey skesk (unPassphrase passphrase)
    (nonce, decrypted) <-
        decryptCipherStep $
            decryptPreservingNonce sessionAlgorithm payload sessionKeyBytes
    cleartext <-
        decryptMDCStep $ validateSEIPD1MDC nonce decrypted
    Right (ClearPayload (BL.fromStrict cleartext))

decryptSEIPDv2PayloadTyped
    :: Passphrase
    -> SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> SEIPDv2SKESKInfo v
    -> B.ByteString
    -> Either MessageDecryptFailure ClearPayload
decryptSEIPDv2PayloadTyped passphrase sa aead chunkSize salt skeskInfo payload = do
    sessionKey <-
        SessionKey <$> deriveSEIPDv2SessionKeyBytes passphrase skeskInfo
    decryptSEIPDv2Step $
        ClearPayload . BL.fromStrict
            <$> decryptSEIPDv2Payload sa aead chunkSize salt payload sessionKey

deriveSEIPDv2SessionKeyBytes
    :: Passphrase
    -> SEIPDv2SKESKInfo v
    -> Either MessageDecryptFailure B.ByteString
deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK4 sa s2k) =
    deriveSessionKeyBytes passphrase sa s2k
deriveSEIPDv2SessionKeyBytes passphrase (SEIPDv2SKESK6 sa aead s2k iv esk tag) = do
    ikm <- deriveSessionKeyBytes passphrase sa s2k
    kek <- decryptSEIPDv2Step $ deriveSKESK6KEK sa aead ikm
    decryptSEIPDv2Step $
        decryptSKESK6SessionKey
            sa
            aead
            kek
            (BL.toStrict iv)
            (BL.toStrict esk)
            (BL.toStrict tag)

deriveSessionKeyBytes
    :: Passphrase
    -> SymmetricAlgorithm
    -> S2K
    -> Either MessageDecryptFailure B.ByteString
deriveSessionKeyBytes passphrase sa s2k = do
    keyLen <- decryptSessionKeySizeStep $ keySize sa
    decryptSessionStep $
        string2Key s2k keyLen (unPassphrase passphrase)

extractLiteralPayload
    :: [Pkt] -> Either MessageParseFailure ClearPayload
extractLiteralPayload pkts =
    case [p | LiteralDataPkt _ _ _ p <- pkts] of
        payload : _ -> Right (ClearPayload payload)
        [] -> Left MissingLiteralDataPacket

rejectUnknownCriticalPacketsTyped
    :: [Pkt] -> Either MessageParseFailure [Pkt]
rejectUnknownCriticalPacketsTyped =
    fmap reverse . foldM go []
  where
    go acc pkt =
        case pkt of
            OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t)
            BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err)
            _ -> Right (pkt : acc)

validateModernMessageS2K
    :: OpenPGPPolicy -> S2K -> Either MessageEncryptFailure ()
validateModernMessageS2K policy s2k =
    case s2kHashAlgorithm s2k of
        Just ha
            | ha
                `elem` deprecatedHashAlgorithms (policyGenerationDeprecations policy) ->
                Left (MessageEncryptDeprecatedS2KHash ha)
        _ -> Right ()

validateRFC9580MessageSymmetric
    :: OpenPGPPolicy
    -> SymmetricAlgorithm
    -> Either MessageEncryptFailure ()
validateRFC9580MessageSymmetric policy sa
    | supportsSEIPDv2Symmetric policy sa = Right ()
    | otherwise =
        Left
            (MessageEncryptUnsupportedSymmetricAlgorithm sa)

s2kHashAlgorithm :: S2K -> Maybe HashAlgorithm
s2kHashAlgorithm (Simple ha) = Just ha
s2kHashAlgorithm (Salted ha _) = Just ha
s2kHashAlgorithm (IteratedSalted ha _ _) = Just ha
s2kHashAlgorithm Argon2 {} = Nothing
s2kHashAlgorithm (OtherS2K _ _) = Nothing