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
    , mkPassphrase
    , passphraseBytes
    , EncryptedPayload
    , mkEncryptedPayload
    , encryptedPayloadBytes
    , ClearPayload
    , mkClearPayload
    , clearPayloadBytes
    , WrappedSessionMaterial
    , SigningAlgorithm (..)
    , SecretKeyFor
    , VersionedPKPayload
    , asV4PKPayload
    , asV6PKPayload
    , Signer
    , SigningCapability
    , mkRSASignerV4
    , mkRSASignerV6
    , mkEd25519SignerV4
    , mkEd25519SignerV6
    , mkEd448SignerV4
    , mkEd448SignerV6
    , MessageParseFailure (..)
    , MessageDecryptFailure (..)
    , MessageError (..)
    , SessionMaterialExposure (..)
    , EncryptMessageProfile
    , EncryptMessageOptions (..)
    , RecoveredSessionMaterial (..)
    , encryptMessage
    , decryptMessage
    , signMessage
    , signMessageWith
    , ConduitMessage.VerificationPolicy (..)
    , ConduitMessage.VerificationOptions (..)
    , ConduitMessage.defaultVerificationOptions
    , verifySignedMessage
    ) where

import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import qualified Crypto.Hash as CH
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 (first)
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Kind (Type)
import Data.Word (Word8)

import Codec.Encryption.OpenPGP.BlockCipher
    ( CipherError
    , keySize
    , renderCipherError
    , withSymmetricCipher
    )
import Codec.Encryption.OpenPGP.CFB
    ( OpenPGPCFBModeW (..)
    , decryptOpenPGPCfb
    , decryptPreservingNonce
    , encryptOpenPGPCfbRaw
    , mdcTrailerForSEIPDv1
    , seipdv1NonceFromIV
    , validateSEIPD1MDC
    )
import Codec.Encryption.OpenPGP.Encrypt
    ( encryptSEIPDv2WithSKESKBlock
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
    ( decryptSKESK6SessionKey
    , deriveSKESK6KEK
    )
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher
    ( HOBlockCipher (..)
    )
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.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Signatures
    ( SignError (..)
    , VerificationError
    , 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 Passphrase = Passphrase {unPassphrase :: BL.ByteString}
    deriving (Eq, Ord, Show)

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
    = MessageEncryptError String
    | MessageDecryptError String
    | MessageSignError SignError
    | MessageParseError String
    | MessageParseFailureError MessageParseFailure
    | MessageDecryptFailureError MessageDecryptFailure
    deriving (Eq, Show)

newtype MessageFlow a
    = MessageFlow
    { runMessageFlow :: Either MessageError a
    }

instance Functor MessageFlow where
    fmap f (MessageFlow result) = MessageFlow (fmap f result)

instance Applicative MessageFlow where
    pure = MessageFlow . Right
    MessageFlow ff <*> MessageFlow fa = MessageFlow (ff <*> fa)

instance Monad MessageFlow where
    MessageFlow result >>= f =
        case result of
            Left err -> MessageFlow (Left err)
            Right x -> f x

messageStep :: Either MessageError a -> MessageFlow a
messageStep = MessageFlow

type MessageFlowT m = ExceptT MessageError m

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

liftMessageFlowT :: Monad m => MessageFlow a -> MessageFlowT m a
liftMessageFlowT (MessageFlow result) =
    case result of
        Left err -> throwE err
        Right x -> pure x

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

data MessageDecryptFailure
    = SessionMaterialDerivationFailed S2KError
    | PayloadDecryptFailed String
    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) = err

mkPassphrase :: BL.ByteString -> Passphrase
mkPassphrase = Passphrase

passphraseBytes :: Passphrase -> BL.ByteString
passphraseBytes = unPassphrase

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

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

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

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

firstLeft :: (e -> e') -> Either e a -> Either e' a
firstLeft f = either (Left . f) Right

-- | Lift a parse failure step into the unified MessageError channel
parseStep :: Either MessageParseFailure a -> MessageFlow a
parseStep = messageStep . firstLeft MessageParseFailureError

-- | Lift a decrypt failure step into the unified MessageError channel
decryptStep :: Either MessageDecryptFailure a -> MessageFlow a
decryptStep = messageStep . firstLeft MessageDecryptFailureError

-- | Lift a string encrypt error step into the unified MessageError channel
encryptStep :: Either String a -> MessageFlow a
encryptStep = messageStep . firstLeft MessageEncryptError

-- | Lift a sign error step into the unified MessageError channel
signStep :: Either SignError a -> MessageFlow a
signStep = messageStep . firstLeft MessageSignError

signStepT :: Monad m => Either SignError a -> MessageFlowT m a
signStepT = liftMessageFlowT . signStep

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

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

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

decryptCipherStep
    :: Either CipherError a -> Either MessageDecryptFailure a
decryptCipherStep = firstLeft (PayloadDecryptFailed . renderCipherError)

decryptPayloadStep
    :: Either String a -> Either MessageDecryptFailure a
decryptPayloadStep = firstLeft PayloadDecryptFailed

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 $
                    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
    :: SymmetricAlgorithm
    -> S2K
    -> IV
    -> Passphrase
    -> ClearPayload
    -> MessageFlow EncryptedPayload
encryptMessageWithRFC4880Fallback sa s2k iv passphrase payload = do
    keyLen <-
        encryptStep . first renderCipherError $ keySize sa
    sessionMaterial <-
        encryptStep . first renderS2KError $
            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 renderCipherError $
            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
    :: SymmetricAlgorithm
    -> S2K
    -> Passphrase
    -> MessageFlow B.ByteString
deriveSessionMaterial sa s2k passphrase = do
    keyLen <- encryptStep . first renderCipherError $ keySize sa
    encryptStep . first renderS2KError $
        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 $ decryptPayloadTyped 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 $
    case signer of
        RSASigner signerPK signingKey ->
            case signerPK of
                VersionedPKPayloadV4 pk ->
                    signV4Message
                        pk
                        ( \hashed unhashed clear ->
                            let builder =
                                    sigBuilderInitTyped @'PKA.RSA RFC9580W BinarySig SHA512W
                                withHashed = addHashedSubs (listToHashedSubs hashed) builder
                                withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
                             in signDataWithRSABuilder withUnhashed signingKey clear
                        )
                        payload
                VersionedPKPayloadV6 pk ->
                    signV6Message
                        pk
                        ( \salt hashed unhashed clear ->
                            let builder =
                                    sigBuilderInitV6Typed @'PKA.RSA RFC9580W BinarySig SHA512W salt
                                withHashed = addHashedSubs (listToHashedSubs hashed) builder
                                withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
                             in signDataWithRSAV6Builder withUnhashed signingKey clear
                        )
                        payload
        Ed25519Signer signerPK signingKey ->
            case signerPK of
                VersionedPKPayloadV4 pk ->
                    signV4Message
                        pk
                        ( \hashed unhashed clear ->
                            let builder =
                                    sigBuilderInitTyped @'PKA.Ed25519 RFC9580W BinarySig SHA512W
                                withHashed = addHashedSubs (listToHashedSubs hashed) builder
                                withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
                             in signDataWithEd25519Builder withUnhashed signingKey clear
                        )
                        payload
                VersionedPKPayloadV6 pk ->
                    signV6Message
                        pk
                        ( \salt hashed unhashed clear ->
                            let builder =
                                    sigBuilderInitV6Typed @'PKA.Ed25519
                                        RFC9580W
                                        BinarySig
                                        SHA512W
                                        salt
                                withHashed = addHashedSubs (listToHashedSubs hashed) builder
                                withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
                             in signDataWithEd25519V6Builder withUnhashed signingKey clear
                        )
                        payload
        Ed448Signer signerPK signingKey ->
            case signerPK of
                VersionedPKPayloadV4 pk ->
                    signV4Message
                        pk
                        ( \hashed unhashed clear ->
                            let builder =
                                    sigBuilderInitTyped @'PKA.Ed448 RFC9580W BinarySig SHA512W
                                withHashed = addHashedSubs (listToHashedSubs hashed) builder
                                withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
                             in signDataWithEd448Builder withUnhashed signingKey clear
                        )
                        payload
                VersionedPKPayloadV6 pk ->
                    signV6Message
                        pk
                        ( \salt hashed unhashed clear ->
                            let builder =
                                    sigBuilderInitV6Typed @'PKA.Ed448 RFC9580W BinarySig SHA512W salt
                                withHashed = addHashedSubs (listToHashedSubs hashed) builder
                                withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
                             in signDataWithEd448V6Builder withUnhashed signingKey clear
                        )
                        payload

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

versionedPKPayload :: VersionedPKPayload v -> PKPayload v
versionedPKPayload (VersionedPKPayloadV4 pk) = pk
versionedPKPayload (VersionedPKPayloadV6 pk) = pk

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
    return . runPut . put $ Block [literal, SignaturePkt signature]

encryptOpenPGPCfb
    :: SymmetricAlgorithm
    -> IV
    -> B.ByteString
    -> WrappedSessionMaterial
    -> Either CipherError B.ByteString
encryptOpenPGPCfb sa iv cleartext (WrappedSessionMaterial keydata) =
    encryptOpenPGPCfbRaw OpenPGPCFBResyncW sa iv cleartext keydata

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 String ClearPayload
decryptPayload passphrase =
    first renderMessageDecryptFailure
        . decryptPayloadTyped passphrase

decryptPayloadTyped
    :: Passphrase
    -> SomeParsedEncryptedPayload
    -> Either MessageDecryptFailure ClearPayload
decryptPayloadTyped 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 <-
        decryptPayloadStep $ 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
    decryptPayloadStep $
        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 <- decryptPayloadStep $ deriveSKESK6KEK sa aead ikm
    decryptPayloadStep $
        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 =
    go []
  where
    go acc [] = Right (reverse acc)
    go acc (pkt : rest) =
        case pkt of
            OtherPacketPkt t _ | t < 40 -> Left (UnknownCriticalPacketType t)
            BrokenPacketPkt err t _ | t < 40 -> Left (BrokenCriticalPacketType t err)
            _ -> go (pkt : acc) rest

validateModernMessageS2K
    :: OpenPGPPolicy -> S2K -> Either String ()
validateModernMessageS2K policy s2k =
    case s2kHashAlgorithm s2k of
        Just ha
            | ha
                `elem` deprecatedHashAlgorithms (policyGenerationDeprecations policy) ->
                Left
                    ( "deprecated hash algorithm disallowed for modern message generation: "
                        ++ show ha
                    )
        _ -> Right ()

validateRFC9580MessageSymmetric
    :: OpenPGPPolicy -> SymmetricAlgorithm -> Either String ()
validateRFC9580MessageSymmetric policy sa
    | supportsSEIPDv2Symmetric policy sa = Right ()
    | otherwise =
        Left
            ( "symmetric algorithm disallowed for RFC9580 message generation: "
                ++ show 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