-- Encrypt.hs: OpenPGP (RFC9580) packet-level encryption helpers
-- Copyright © 2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

module Codec.Encryption.OpenPGP.Encrypt
    ( PKESKEncryptError (..)
    , RecipientCapabilityNegotiationMode (..)
    , RecipientCapabilityError (..)
    , renderRecipientCapabilityError
    , RecipientCapabilities (..)
    , recipientCapabilitiesFromSubpacketPayloads
    , recipientCapabilitySupportsEncryption
    , RecipientTargetRejectionReason (..)
    , RecipientEncryptionTargetRejected (..)
    , RecipientEncryptionTargetsReport (..)
    , recipientEncryptionTargetsReportFromTKAtTimestamp
    , recipientEncryptionTargetsReportFromTK
    , recipientEncryptionTargetFromTKAtTimestamp
    , recipientEncryptionTargetFromTKAtTimestampWithPolicy
    , recipientEncryptionTargetsFromTKAtTimestamp
    , recipientEncryptionTargetFromTK
    , recipientEncryptionTargetFromTKWithPolicy
    , recipientEncryptionTargetsFromTK
    , RecipientTargetSelectionPolicy (..)
    , PassphraseSKESKVersionPolicy (..)
    , PassphraseEncryptRequest (..)
    , encryptPassphraseWithPolicy
    , PKESKVersionPolicy (..)
    , RecipientPKESKVersionStrategy (..)
    , RecipientPKESKVersionStrategyW (..)
    , SomeRecipientPKESKVersionStrategyW (..)
    , RecipientPKESKVersionSelector
    , RecipientPKESKVersionSelectorTyped
    , EncryptCompatibilityProfile (..)
    , EncryptCompatibilityProfileW (..)
    , SomeEncryptCompatibilityProfileW (..)
    , RecipientEncryptionTarget (..)
    , recipientEncryptionTarget
    , recipientEncryptionTargetWithStrategy
    , recipientEncryptionTargetWithCapabilities
    , recipientEncryptionTargetWithStrategyTyped
    , recipientVersionStrategyForProfile
    , recipientVersionStrategyForProfileTyped
    , RecipientPayloadShape (..)
    , defaultRecipientPayloadShape
    , SEIPDVersion (..)
    , RecipientEncryptResult (..)
    , RecipientEncryptRequest (..)
    , RecipientEncryptRequestOverrides (..)
    , encryptForRecipients
    , encryptForRecipientsLegacy
    , encryptForRecipientsWithCapabilityNegotiation
    , PKESKV3SessionMaterial
    , PKESKV6RawSessionMaterial
    , PKESKSessionMaterial
    , pkeskSessionAlgorithm
    , pkeskSessionKey
    , mkPKESKSessionMaterial
    , mkPKESKV3SessionMaterial
    , mkPKESKV6RawSessionMaterial
    , pkeskV3SessionMaterial
    , pkeskV6RawSessionMaterial
    , encodeOpenPGPSessionMaterial
    , generateSessionKeyMaterial
    , canonicalizePKESKRecipientId
    , canonicalizePKESKPacketRecipientIds
    , buildPKESKv3PayloadForRecipient
    , buildPKESKv3PktForRecipient
    , buildPKESKPayloadForRecipient
    , buildPKESKPktForRecipient
    , buildPKESKPktsForRecipientTargetsWithSelector
    , buildPKESKPktsForRecipientTargetsWithSelectorTyped
    , encryptSEIPDv2Payload
    , encryptSEIPDv1Payload
    , encryptSEIPDv2WithSKESK
    , encryptSEIPDv2WithSKESKBlock
    , encryptSEIPDv2LiteralDataWithSKESK
    , composeMessageWithSEIPDv2
    ) where

import Control.Applicative ((<|>))
import Control.Lens (ix, (.~))
import Control.Monad (when)
import qualified Crypto.Error as CE
import qualified Crypto.Hash.Algorithms as CHAlg
import Crypto.KDF.HKDF (expand, extract)
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.Curve25519 as C25519
import qualified Crypto.PubKey.Curve448 as C448
import qualified Crypto.PubKey.ECC.DH as ECCDH
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Generate as ECCGen
import qualified Crypto.PubKey.RSA.PKCS15 as RSA15
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Bifunctor (first)
import Data.Binary (put)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bits (shiftL, shiftR, xor, (.&.))
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Containers.ListUtils (nubOrd)
import Data.Int (Int64)
import Data.List (find, foldl', maximumBy)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
import Data.Ord (comparing)
import qualified Data.Set as Set
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Data.Word (Word16, Word64, Word8)
import qualified "crypton" Crypto.Cipher.Types as CCT

import Codec.Encryption.OpenPGP.BlockCipher
    ( CipherError
    , keySize
    , renderCipherError
    , withSymmetricCipher
    )
import Codec.Encryption.OpenPGP.CFB
    ( OpenPGPCFBModeW (..)
    , encryptOpenPGPCfbRaw
    , mdcTrailerForSEIPDv1
    )
import Codec.Encryption.OpenPGP.Expirations
    ( effectiveKeyPreferencesAtTimestamp
    , isPKTimeValidWithSelfSignatures
    , keyStateAt
    , keyStateValid
    , signatureEffectiveAt
    )
import Codec.Encryption.OpenPGP.Fingerprint
    ( eightOctetKeyID
    , fingerprint
    )
import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS)
import Codec.Encryption.OpenPGP.Internal.CryptoAES
    ( withAESCipher
    )
import Codec.Encryption.OpenPGP.Internal.CryptoECDH
    ( buildECDHKDFParam
    , deriveECDHKek
    , normalizeMontgomeryPublic
    )
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
    ( aeadModeAndNonceSizeForSEIPDv2
    , deriveSKESK6KEK
    , encryptSKESK6SessionKey
    , seipdv2SymmetricKeySize
    )
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher
    ( HOBlockCipher (..)
    )
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB
    ( encryptWithOCBRFC7253
    )
import Codec.Encryption.OpenPGP.Ontology
    ( isSubkeyBindingSig
    , isSubkeyRevocation
    )
import Codec.Encryption.OpenPGP.Policy
    ( MessageEncryptionPolicy
    , OpenPGPRFC (..)
    , PKESKVersionPolicy (..)
    , defaultPKESKVersionPolicy
    , messageDefaultAEADAlgorithm
    , messageDefaultChunkSize
    , messageDefaultSymmetricAlgorithm
    , messageSEIPDv2SaltOctets
    , messageSEIPDv2SymmetricAlgorithms
    , policyForRFC
    , policyMessageEncryption
    )
import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.SignatureQualities
    ( sigCT
    , signatureHashedSubpacketsKnown
    )
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes

-- | Typed failures from one-pass signature packet construction.
data OPSBuildError
    = OPSBuildMissingIssuerKeyId
    | OPSBuildMissingIssuerFingerprint
    | OPSBuildFingerprintWrongLength Int64
    | OPSBuildUnsupportedSigVersion PacketVersion
    deriving (Eq, Show)

renderOPSBuildError :: OPSBuildError -> String
renderOPSBuildError OPSBuildMissingIssuerKeyId =
    "cannot build OPS3 packet from v4 signature without issuer metadata"
renderOPSBuildError OPSBuildMissingIssuerFingerprint =
    "cannot build OPS6 packet from v6 signature without issuer fingerprint"
renderOPSBuildError (OPSBuildFingerprintWrongLength n) =
    "cannot build OPS6 packet: issuer fingerprint must be 32 octets, got "
        ++ show n
renderOPSBuildError (OPSBuildUnsupportedSigVersion v) =
    "cannot build one-pass signature packet for unsupported signature version "
        ++ show v

-- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers.
data PKESKEncryptError
    = UnsupportedSessionKeyAlgorithm SymmetricAlgorithm String
    | InvalidSessionKeyLength SymmetricAlgorithm Int Int
    | InvalidRecipientIdentifier String
    | UnsupportedRecipientAlgorithm PubKeyAlgorithm
    | InvalidRecipientKeyMaterial PubKeyAlgorithm String
    | RecipientKdfFailure PubKeyAlgorithm String
    | RecipientKeyWrapFailure PubKeyAlgorithm String
    | RecipientCapabilitySelectionFailure RecipientCapabilityError
    | PayloadBuildFailure String
    | NoRecipientsProvided
    deriving (Eq, Show)

renderPKESKEncryptError :: PKESKEncryptError -> String
renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm algo reason) =
    "unsupported session key algorithm "
        ++ show algo
        ++ ": "
        ++ reason
renderPKESKEncryptError (InvalidSessionKeyLength algo expected actual) =
    "invalid session key length for "
        ++ show algo
        ++ ": expected "
        ++ show expected
        ++ ", got "
        ++ show actual
renderPKESKEncryptError (InvalidRecipientIdentifier reason) =
    "invalid recipient identifier: " ++ reason
renderPKESKEncryptError (UnsupportedRecipientAlgorithm algo) =
    "unsupported recipient public-key algorithm: " ++ show algo
renderPKESKEncryptError (InvalidRecipientKeyMaterial algo reason) =
    "invalid recipient key material for "
        ++ show algo
        ++ ": "
        ++ reason
renderPKESKEncryptError (RecipientKdfFailure algo reason) =
    "KDF failure for recipient algorithm "
        ++ show algo
        ++ ": "
        ++ reason
renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) =
    "key wrap failure for recipient algorithm "
        ++ show algo
        ++ ": "
        ++ reason
renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =
    renderRecipientCapabilityError err
renderPKESKEncryptError (PayloadBuildFailure reason) =
    "payload build failure: " ++ reason
renderPKESKEncryptError NoRecipientsProvided =
    "no recipients provided"

data RecipientCapabilityNegotiationMode
    = RecipientCapabilityNegotiationOff
    | RecipientCapabilityNegotiationOn
    deriving (Eq, Show)

data RecipientCapabilityError
    = RecipientCapabilityMissingEncryptionFlags
        SomePKPayload
        (Set.Set KeyFlag)
    | RecipientCapabilityNoEncryptableKeyMaterialInTK
    | RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]
    | RecipientCapabilityMissingSEIPDv2Support [SomePKPayload]
    | RecipientCapabilityNoCommonSymmetricAlgorithms
        [SymmetricAlgorithm]
    | RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm]
    deriving (Eq, Show)

renderRecipientCapabilityError
    :: RecipientCapabilityError -> String
renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags recipient flags) =
    "recipient "
        ++ show (_keyVersion recipient, _pkalgo recipient)
        ++ " does not advertise encryption-capable key flags; observed flags: "
        ++ show (Set.toList flags)
renderRecipientCapabilityError RecipientCapabilityNoEncryptableKeyMaterialInTK =
    "no encryption-capable primary key or subkey was found in transferable key material"
renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support recipients) =
    "recipient set does not advertise SEIPDv1 (MDC) support: "
        ++ show (map (\r -> (_keyVersion r, _pkalgo r)) recipients)
renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support recipients) =
    "recipient set does not advertise SEIPDv2 support: "
        ++ show (map (\r -> (_keyVersion r, _pkalgo r)) recipients)
renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms syms) =
    "no common recipient-supported symmetric algorithms: "
        ++ show syms
renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms aeads) =
    "no common recipient-supported AEAD algorithms: " ++ show aeads

data RecipientCapabilities
    = RecipientCapabilities
    { recipientCapabilityKeyVersion :: KeyVersion
    , recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm
    , recipientCapabilityKeyFlags :: Set.Set KeyFlag
    , recipientCapabilityFeatures :: Set.Set FeatureFlag
    , recipientCapabilityPreferredSymmetricAlgorithms
        :: [SymmetricAlgorithm]
    , recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm]
    }
    deriving (Eq, Show)

data RecipientTargetRejectionReason
    = RecipientTargetUnsupportedAlgorithm PubKeyAlgorithm
    | RecipientTargetMissingEncryptionFlags
        SomePKPayload
        (Set.Set KeyFlag)
    | RecipientTargetRevoked SomePKPayload
    | RecipientTargetNotValidAtTimestamp
        SomePKPayload
        ThirtyTwoBitTimeStamp
    deriving (Eq, Show)

data RecipientEncryptionTargetRejected
    = RecipientEncryptionTargetRejected
    { recipientEncryptionTargetRejectedKey :: SomePKPayload
    , recipientEncryptionTargetRejectedCapabilities
        :: Maybe RecipientCapabilities
    , recipientEncryptionTargetRejectedReason
        :: RecipientTargetRejectionReason
    }
    deriving (Eq, Show)

data RecipientEncryptionTargetsReport
    = RecipientEncryptionTargetsReport
    { recipientEncryptionTargetsAccepted :: [RecipientEncryptionTarget]
    , recipientEncryptionTargetsRejected
        :: [RecipientEncryptionTargetRejected]
    }
    deriving (Eq, Show)

{- | Extract encrypt-relevant recipient capabilities from effective
self-signature subpackets.

RFC 9580 preferred AEAD ciphersuites are currently carried through
'OtherSigSub' type 39 and decoded into AEAD preferences here.
-}
recipientCapabilitiesFromSubpacketPayloads
    :: SomePKPayload
    -> [SigSubPacketPayload]
    -> RecipientCapabilities
recipientCapabilitiesFromSubpacketPayloads recipient payloads =
    foldl' step (emptyRecipientCapabilities recipient) payloads
  where
    preferredAEADCiphersuitesSubpacketType :: Word8
    preferredAEADCiphersuitesSubpacketType = 39

    step caps payload =
        case payload of
            KeyFlags flags ->
                caps
                    { recipientCapabilityKeyFlags =
                        recipientCapabilityKeyFlags caps `Set.union` flags
                    }
            Features features ->
                caps
                    { recipientCapabilityFeatures =
                        recipientCapabilityFeatures caps `Set.union` features
                    }
            PreferredSymmetricAlgorithms syms ->
                caps
                    { recipientCapabilityPreferredSymmetricAlgorithms =
                        recipientCapabilityPreferredSymmetricAlgorithms caps ++ syms
                    }
            PreferredAEADCiphersuites ciphersuites ->
                caps
                    { recipientCapabilityPreferredAEADAlgorithms =
                        recipientCapabilityPreferredAEADAlgorithms caps
                            ++ preferredAEADAlgorithmsFromCiphersuitePairs ciphersuites
                    }
            OtherSigSub subpacketType rawPayload
                | subpacketType == preferredAEADCiphersuitesSubpacketType ->
                    caps
                        { recipientCapabilityPreferredAEADAlgorithms =
                            recipientCapabilityPreferredAEADAlgorithms caps
                                ++ preferredAEADAlgorithmsFromCiphersuites rawPayload
                        }
            _ -> caps

    emptyRecipientCapabilities key =
        RecipientCapabilities
            { recipientCapabilityKeyVersion = _keyVersion key
            , recipientCapabilityPublicKeyAlgorithm = _pkalgo key
            , recipientCapabilityKeyFlags = Set.empty
            , recipientCapabilityFeatures = Set.empty
            , recipientCapabilityPreferredSymmetricAlgorithms = []
            , recipientCapabilityPreferredAEADAlgorithms = []
            }

    preferredAEADAlgorithmsFromCiphersuites
        :: BL.ByteString -> [AEADAlgorithm]
    preferredAEADAlgorithmsFromCiphersuites =
        nubOrd . parsePairs . BL.unpack
      where
        parsePairs (_symAlgo : aeadAlgo : rest) =
            (toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest
        parsePairs _ = []

    preferredAEADAlgorithmsFromCiphersuitePairs
        :: [(SymmetricAlgorithm, AEADAlgorithm)] -> [AEADAlgorithm]
    preferredAEADAlgorithmsFromCiphersuitePairs =
        nubOrd . map snd

recipientCapabilitySupportsEncryption
    :: RecipientCapabilities -> Bool
recipientCapabilitySupportsEncryption caps =
    let flags = recipientCapabilityKeyFlags caps
     in Set.null flags
            || Set.member EncryptStorageKey flags
            || Set.member EncryptCommunicationsKey flags

recipientCapabilityAdvertisesSEIPDv1Support
    :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv1Support caps =
    let features = recipientCapabilityFeatures caps
     in Set.null features || Set.member FeatureSEIPDv1 features

recipientCapabilityAdvertisesSEIPDv2Support
    :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv2Support caps =
    recipientCapabilityAdvertisesSEIPDv1Support caps
        && Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps)

{-# DEPRECATED
    recipientEncryptionTargetFromTKAtTimestamp
    "Use recipientEncryptionTargetFromTKAtTimestampWithPolicy instead"
    #-}
recipientEncryptionTargetFromTKAtTimestamp
    :: ThirtyTwoBitTimeStamp
    -> TK 'PublicTK
    -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestamp timestamp tk =
    recipientEncryptionTargetFromTKAtTimestampWithPolicy
        RecipientTargetSelectionFirstValid
        timestamp
        tk

data RecipientTargetSelectionPolicy
    = RecipientTargetSelectionFirstValid
    | RecipientTargetSelectionPreferPrimary
    | RecipientTargetSelectionPreferSubkey
    | RecipientTargetSelectionPreferNewestCreationTime
    deriving (Eq, Show)

recipientEncryptionTargetFromTKAtTimestampWithPolicy
    :: RecipientTargetSelectionPolicy
    -> ThirtyTwoBitTimeStamp
    -> TK 'PublicTK
    -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestampWithPolicy policy timestamp tk =
    case chooseRecipientTarget policy tk acceptedTargets of
        Just target -> Right target
        Nothing -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK
  where
    acceptedTargets =
        recipientEncryptionTargetsAccepted
            (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk)

{-# DEPRECATED
    recipientEncryptionTargetFromTK
    "Use recipientEncryptionTargetFromTKWithPolicy instead"
    #-}
recipientEncryptionTargetFromTK
    :: TK 'PublicTK
    -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTK tk =
    recipientEncryptionTargetFromTKAtTimestampWithPolicy
        RecipientTargetSelectionFirstValid
        (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
        tk

recipientEncryptionTargetFromTKWithPolicy
    :: RecipientTargetSelectionPolicy
    -> TK 'PublicTK
    -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKWithPolicy policy tk =
    recipientEncryptionTargetFromTKAtTimestampWithPolicy
        policy
        (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
        tk

recipientEncryptionTargetsFromTKAtTimestamp
    :: ThirtyTwoBitTimeStamp
    -> TK 'PublicTK
    -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTKAtTimestamp timestamp tk =
    recipientEncryptionTargetsAccepted
        (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk)

recipientEncryptionTargetsReportFromTKAtTimestamp
    :: ThirtyTwoBitTimeStamp
    -> TK 'PublicTK
    -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk =
    foldr
        classifyCandidate
        emptyReport
        (subkeyCandidates ++ [primaryCandidate])
  where
    emptyReport = RecipientEncryptionTargetsReport [] []
    primaryCandidate = keyPktPKPayload (_tkPrimaryKey tk)
    primaryPreferencePayloads =
        fromMaybe [] (effectiveKeyPreferencesAtTimestamp timestamp tk)
    subkeyCandidates =
        map (keyPktPKPayload . fst) (_tkSubs tk)
    classifyCandidate key report =
        let caps =
                recipientCapabilitiesFromSubpacketPayloads
                    key
                    ( primaryPreferencePayloads
                        ++ subkeyBindingCapabilityPayloads timestamp tk key
                    )
            keyStateRejection = recipientValidityRejectionReason timestamp tk key
         in case keyStateRejection of
                Just rejectionReason ->
                    report
                        { recipientEncryptionTargetsRejected =
                            RecipientEncryptionTargetRejected
                                { recipientEncryptionTargetRejectedKey = key
                                , recipientEncryptionTargetRejectedCapabilities = Just caps
                                , recipientEncryptionTargetRejectedReason = rejectionReason
                                }
                                : recipientEncryptionTargetsRejected report
                        }
                Nothing ->
                    if not (supportsPKESKRecipientAlgorithm key)
                        then
                            report
                                { recipientEncryptionTargetsRejected =
                                    RecipientEncryptionTargetRejected
                                        { recipientEncryptionTargetRejectedKey = key
                                        , recipientEncryptionTargetRejectedCapabilities = Just caps
                                        , recipientEncryptionTargetRejectedReason =
                                            RecipientTargetUnsupportedAlgorithm (_pkalgo key)
                                        }
                                        : recipientEncryptionTargetsRejected report
                                }
                        else
                            if recipientCapabilitySupportsEncryption caps
                                then
                                    report
                                        { recipientEncryptionTargetsAccepted =
                                            recipientEncryptionTargetWithCapabilities key caps
                                                : recipientEncryptionTargetsAccepted report
                                        }
                                else
                                    report
                                        { recipientEncryptionTargetsRejected =
                                            RecipientEncryptionTargetRejected
                                                { recipientEncryptionTargetRejectedKey = key
                                                , recipientEncryptionTargetRejectedCapabilities = Just caps
                                                , recipientEncryptionTargetRejectedReason =
                                                    RecipientTargetMissingEncryptionFlags
                                                        key
                                                        (recipientCapabilityKeyFlags caps)
                                                }
                                                : recipientEncryptionTargetsRejected report
                                        }

{-# DEPRECATED
    recipientEncryptionTargetsFromTK
    "Use recipientEncryptionTargetsFromTKAtTimestamp instead"
    #-}
recipientEncryptionTargetsFromTK
    :: TK 'PublicTK -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTK tk =
    recipientEncryptionTargetsFromTKAtTimestamp
        (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
        tk

recipientEncryptionTargetsReportFromTK
    :: TK 'PublicTK -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTK tk =
    recipientEncryptionTargetsReportFromTKAtTimestamp
        (_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
        tk

subkeyBindingCapabilityPayloads
    :: ThirtyTwoBitTimeStamp
    -> TK 'PublicTK
    -> SomePKPayload
    -> [SigSubPacketPayload]
subkeyBindingCapabilityPayloads timestamp tk recipient =
    maybe [] latestEffectiveBindingPayloads matchingSubkey
  where
    matchingSubkey =
        find
            ( \(kp, _) -> fingerprint (keyPktPKPayload kp) == fingerprint recipient
            )
            (_tkSubs tk)
    latestEffectiveBindingPayloads (_, sigs) =
        maybe
            []
            signaturePayloadsFromSignature
            (latestEffectiveSubkeyBindingSignature timestamp sigs)

latestEffectiveSubkeyBindingSignature
    :: ThirtyTwoBitTimeStamp
    -> [SignaturePayload]
    -> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignature timestamp sigs =
    case filter (isEffectiveSubkeyBindingSignature timestamp) sigs of
        [] -> Nothing
        candidates ->
            Just
                (maximumBy (comparing signatureCreationTimestamp) candidates)

isEffectiveSubkeyBindingSignature
    :: ThirtyTwoBitTimeStamp
    -> SignaturePayload
    -> Bool
isEffectiveSubkeyBindingSignature timestamp sig =
    isSubkeyBindingSig sig
        && maybe
            False
            ( \created ->
                let tsValue = toInteger (unThirtyTwoBitTimeStamp timestamp)
                    createdValue = toInteger (unThirtyTwoBitTimeStamp created)
                 in createdValue <= tsValue
                        && maybe
                            True
                            ( \duration ->
                                if unThirtyTwoBitDuration duration == 0
                                    then True
                                    else
                                        tsValue
                                            < createdValue + toInteger (unThirtyTwoBitDuration duration)
                            )
                            (signatureExpirationDuration sig)
            )
            (sigCT sig)

signatureCreationTimestamp
    :: SignaturePayload -> ThirtyTwoBitTimeStamp
signatureCreationTimestamp sig =
    fromMaybe (ThirtyTwoBitTimeStamp 0) (sigCT sig)

signatureExpirationDuration
    :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration sig =
    case signatureHashedSubpacketsKnown sig of
        Just hashed ->
            foldr
                ( \subpacket acc ->
                    case subpacket of
                        SigSubPacket _ (SigExpirationTime duration) -> Just duration
                        _ -> acc
                )
                Nothing
                hashed
        Nothing -> Nothing

signaturePayloadsFromSignature
    :: SignaturePayload -> [SigSubPacketPayload]
signaturePayloadsFromSignature sig =
    case signatureHashedSubpacketsKnown sig of
        Just hashed -> map (\(SigSubPacket _ payload) -> payload) hashed
        Nothing -> []

recipientValidityRejectionReason
    :: ThirtyTwoBitTimeStamp
    -> TK 'PublicTK
    -> SomePKPayload
    -> Maybe RecipientTargetRejectionReason
recipientValidityRejectionReason timestamp tk key
    | fingerprint key
        == fingerprint (keyPktPKPayload (_tkPrimaryKey tk)) =
        if keyStateValid (keyStateAt (timestampToUTC timestamp) tk)
            then Nothing
            else Just (RecipientTargetNotValidAtTimestamp key timestamp)
    | otherwise =
        case findMatchingSubkeySignatures tk key of
            Nothing -> Nothing
            Just sigs
                | subkeyRevokedAtTimestamp timestamp sigs ->
                    Just (RecipientTargetRevoked key)
                | isPKTimeValidWithSelfSignatures
                    (timestampToUTC timestamp)
                    key
                    sigs ->
                    Nothing
                | otherwise ->
                    Just (RecipientTargetNotValidAtTimestamp key timestamp)

findMatchingSubkeySignatures
    :: TK 'PublicTK -> SomePKPayload -> Maybe [SignaturePayload]
findMatchingSubkeySignatures tk recipient =
    snd
        <$> find
            ( \(kp, _) -> fingerprint (keyPktPKPayload kp) == fingerprint recipient
            )
            (_tkSubs tk)

subkeyRevokedAtTimestamp
    :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool
subkeyRevokedAtTimestamp timestamp =
    any
        ( \sig ->
            isSubkeyRevocation sig
                && signatureEffectiveAt (timestampToUTC timestamp) sig
        )

timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC =
    posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp

supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool
supportsPKESKRecipientAlgorithm recipient =
    case _pkalgo recipient of
        RSA -> True
        DeprecatedRSAEncryptOnly -> True
        ECDH -> True
        X25519 -> True
        X448 -> True
        _ -> False

chooseRecipientTarget
    :: RecipientTargetSelectionPolicy
    -> TK 'PublicTK
    -> [RecipientEncryptionTarget]
    -> Maybe RecipientEncryptionTarget
chooseRecipientTarget policy tk targets =
    case policy of
        RecipientTargetSelectionFirstValid -> listToMaybe targets
        RecipientTargetSelectionPreferPrimary ->
            listToMaybe (filter (isPrimaryTarget tk) targets)
                <|> listToMaybe targets
        RecipientTargetSelectionPreferSubkey ->
            listToMaybe (filter (not . isPrimaryTarget tk) targets)
                <|> listToMaybe targets
        RecipientTargetSelectionPreferNewestCreationTime ->
            case targets of
                [] -> Nothing
                (target : rest) ->
                    Just
                        ( foldl'
                            ( \best candidate ->
                                if _timestamp (recipientEncryptionTargetKey candidate)
                                    > _timestamp (recipientEncryptionTargetKey best)
                                    then candidate
                                    else best
                            )
                            target
                            rest
                        )
  where
    isPrimaryTarget currentTK target =
        fingerprint (recipientEncryptionTargetKey target)
            == fingerprint (keyPktPKPayload (_tkPrimaryKey currentTK))

-- | Session-key bundle for PKESK/SKESK packet construction.
newtype PKESKV3SessionMaterial
    = PKESKV3SessionMaterial
    { unPKESKV3SessionMaterial :: B.ByteString
    }
    deriving (Eq, Show)

newtype PKESKV6RawSessionMaterial
    = PKESKV6RawSessionMaterial
    { unPKESKV6RawSessionMaterial :: B.ByteString
    }
    deriving (Eq, Show)

data PKESKSessionMaterial
    = PKESKSessionMaterial
    { pkeskSessionAlgorithm :: SymmetricAlgorithm
    , pkeskSessionKey :: SessionKey
    , pkeskEncodedSessionMaterial :: B.ByteString
    }
    deriving (Eq, Show)

mkPKESKSessionMaterial
    :: SymmetricAlgorithm
    -> SessionKey
    -> Either PKESKEncryptError PKESKSessionMaterial
mkPKESKSessionMaterial symalgo sessionKey = do
    v3Material <- mkPKESKV3SessionMaterial symalgo sessionKey
    _v6Material <- mkPKESKV6RawSessionMaterial symalgo sessionKey
    pure
        PKESKSessionMaterial
            { pkeskSessionAlgorithm = symalgo
            , pkeskSessionKey = sessionKey
            , pkeskEncodedSessionMaterial = unPKESKV3SessionMaterial v3Material
            }

mkPKESKV3SessionMaterial
    :: SymmetricAlgorithm
    -> SessionKey
    -> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial symalgo sessionKey = do
    keyBytes <- validatedSessionKeyBytes symalgo sessionKey
    pure $
        PKESKV3SessionMaterial
            ( B.singleton (fromFVal symalgo)
                <> keyBytes
                <> checksum16Bytes keyBytes
            )

mkPKESKV6RawSessionMaterial
    :: SymmetricAlgorithm
    -> SessionKey
    -> Either PKESKEncryptError PKESKV6RawSessionMaterial
mkPKESKV6RawSessionMaterial symalgo sessionKey =
    PKESKV6RawSessionMaterial
        <$> validatedSessionKeyBytes symalgo sessionKey

pkeskV3SessionMaterial
    :: PKESKSessionMaterial -> PKESKV3SessionMaterial
pkeskV3SessionMaterial =
    PKESKV3SessionMaterial . pkeskEncodedSessionMaterial

pkeskV6RawSessionMaterial
    :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial
pkeskV6RawSessionMaterial =
    PKESKV6RawSessionMaterial . unSessionKey . pkeskSessionKey

validatedSessionKeyBytes
    :: SymmetricAlgorithm
    -> SessionKey
    -> Either PKESKEncryptError B.ByteString
validatedSessionKeyBytes symalgo (SessionKey sessionKey) = do
    keyLen <-
        first
            (UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)
            (keySize symalgo)
    let actualLen = B.length sessionKey
    if actualLen /= keyLen
        then Left (InvalidSessionKeyLength symalgo keyLen actualLen)
        else Right sessionKey

data RecipientPKESKVersionStrategy
    = RecipientPreferV6
    | RecipientForceV3Interop
    deriving (Eq, Show)

data
    RecipientPKESKVersionStrategyW
        (strategy :: RecipientPKESKVersionStrategy)
    where
    RecipientPreferV6W
        :: RecipientPKESKVersionStrategyW 'RecipientPreferV6
    RecipientForceV3InteropW
        :: RecipientPKESKVersionStrategyW 'RecipientForceV3Interop

data SomeRecipientPKESKVersionStrategyW where
    SomeRecipientPKESKVersionStrategyW
        :: RecipientPKESKVersionStrategyW strategy
        -> SomeRecipientPKESKVersionStrategyW

type RecipientPKESKVersionSelector =
    SomePKPayload
    -> Either PKESKEncryptError RecipientPKESKVersionStrategy

type RecipientPKESKVersionSelectorTyped =
    SomePKPayload
    -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW

data EncryptCompatibilityProfile
    = EncryptStrictDefault
    | EncryptInteropLegacy
    deriving (Eq, Show)

data
    EncryptCompatibilityProfileW
        (profile :: EncryptCompatibilityProfile)
    where
    EncryptStrictDefaultW
        :: EncryptCompatibilityProfileW 'EncryptStrictDefault
    EncryptInteropLegacyW
        :: EncryptCompatibilityProfileW 'EncryptInteropLegacy

data SomeEncryptCompatibilityProfileW where
    SomeEncryptCompatibilityProfileW
        :: EncryptCompatibilityProfileW profile
        -> SomeEncryptCompatibilityProfileW

data SEIPDVersion
    = SEIPDv1
    | SEIPDv2
    deriving (Eq, Show)

type family
    PayloadVersionForProfile (profile :: EncryptCompatibilityProfile)
        :: SEIPDVersion
    where
    PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2
    PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1

type family
    ProfileForPayloadVersion (version :: SEIPDVersion)
        :: EncryptCompatibilityProfile
    where
    ProfileForPayloadVersion 'SEIPDv1 = 'EncryptInteropLegacy
    ProfileForPayloadVersion 'SEIPDv2 = 'EncryptStrictDefault

data RecipientEncryptionTarget
    = RecipientEncryptionTarget
    { recipientEncryptionTargetKey :: SomePKPayload
    -- ^ Recipient key packet selected for PKESK wrapping.
    , recipientEncryptionTargetStrategy
        :: Maybe RecipientPKESKVersionStrategy
    {- ^ Optional explicit PKESK version strategy hint.
    When absent, profile defaults and auto-detection apply.
    -}
    , recipientEncryptionTargetCapabilities
        :: Maybe RecipientCapabilities
    {- ^ Optional recipient capability hints used by negotiation-enabled
    encryption to choose common symmetric/AEAD algorithms.
    -}
    }
    deriving (Eq, Show)

recipientEncryptionTarget
    :: SomePKPayload -> RecipientEncryptionTarget
recipientEncryptionTarget recipient =
    RecipientEncryptionTarget recipient Nothing Nothing

{-# DEPRECATED
    recipientEncryptionTargetWithStrategy
    "Use recipientEncryptionTargetWithStrategyTyped instead"
    #-}
recipientEncryptionTargetWithStrategy
    :: SomePKPayload
    -> RecipientPKESKVersionStrategy
    -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategy recipient strategy =
    RecipientEncryptionTarget recipient (Just strategy) Nothing

recipientEncryptionTargetWithCapabilities
    :: SomePKPayload
    -> RecipientCapabilities
    -> RecipientEncryptionTarget
recipientEncryptionTargetWithCapabilities recipient capabilities =
    RecipientEncryptionTarget recipient Nothing (Just capabilities)

recipientEncryptionTargetWithStrategyTyped
    :: SomePKPayload
    -> RecipientPKESKVersionStrategyW strategy
    -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategyTyped recipient strategyW =
    recipientEncryptionTargetWithStrategy
        recipient
        (demoteRecipientStrategy strategyW)

{-# DEPRECATED
    recipientVersionStrategyForProfile
    "Use recipientVersionStrategyForProfileTyped instead"
    #-}
recipientVersionStrategyForProfile
    :: EncryptCompatibilityProfile
    -> RecipientEncryptionTarget
    -> Either PKESKEncryptError RecipientPKESKVersionStrategy
recipientVersionStrategyForProfile profile target =
    case promoteEncryptCompatibilityProfile profile of
        SomeEncryptCompatibilityProfileW profileW ->
            demoteSomeRecipientStrategy
                <$> recipientVersionStrategyForProfileTyped profileW target

recipientVersionStrategyForProfileTyped
    :: EncryptCompatibilityProfileW profile
    -> RecipientEncryptionTarget
    -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
recipientVersionStrategyForProfileTyped profile target =
    Right $
        case recipientEncryptionTargetStrategy target of
            Just strategy ->
                promoteRecipientStrategy strategy
            Nothing ->
                case profile of
                    EncryptStrictDefaultW ->
                        autoDetectRecipientVersionStrategy
                            (recipientEncryptionTargetKey target)
                    EncryptInteropLegacyW ->
                        SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW

profileForPayloadVersionW
    :: RecipientEncryptRequestOverrides version
    -> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
profileForPayloadVersionW overrides =
    case overrides of
        RecipientEncryptRequestSEIPDv2Overrides {} -> EncryptStrictDefaultW
        RecipientEncryptRequestSEIPDv1Overrides {} -> EncryptInteropLegacyW

autoDetectRecipientVersionStrategy
    :: SomePKPayload
    -> SomeRecipientPKESKVersionStrategyW
autoDetectRecipientVersionStrategy recipient
    | _keyVersion recipient == V6 =
        SomeRecipientPKESKVersionStrategyW RecipientPreferV6W
    | _pkalgo recipient `elem` [X25519, X448] =
        SomeRecipientPKESKVersionStrategyW RecipientPreferV6W
    | otherwise =
        SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW

data RecipientPayloadShape
    = RecipientPayloadShape
    { recipientPayloadDataType :: LiteralDataType
    , recipientPayloadFileName :: FileName
    , recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp
    , recipientPayloadUseOnePassSignatures :: Bool
    , recipientPayloadSignatures :: [SignaturePayload]
    }
    deriving (Eq, Show)

data PassphraseSKESKVersionPolicy
    = PassphraseSKESKPreferV6
    | PassphraseSKESKForceV4Interop
    deriving (Eq, Show)

data PassphraseEncryptRequest
    = PassphraseEncryptRequest
    { passphraseEncryptVersionPolicy :: PassphraseSKESKVersionPolicy
    , passphraseEncryptSymmetricAlgorithm :: SymmetricAlgorithm
    , passphraseEncryptS2K :: S2K
    , passphraseEncryptPassphrase :: BL.ByteString
    , passphraseEncryptPayload :: B.ByteString
    , passphraseEncryptSEIPDv1IVOverride :: Maybe IV
    , passphraseEncryptSEIPDv2AEADOverride :: Maybe AEADAlgorithm
    , passphraseEncryptSEIPDv2ChunkSizeOverride :: Maybe Word8
    , passphraseEncryptSEIPDv2SaltOverride :: Maybe Salt
    }
    deriving (Eq, Show)

encryptPassphraseWithPolicy
    :: MonadRandom m
    => PassphraseEncryptRequest
    -> m (Either String [Pkt])
encryptPassphraseWithPolicy request =
    case passphraseEncryptVersionPolicy request of
        PassphraseSKESKForceV4Interop ->
            encryptSEIPDv1WithSKESK
                (passphraseEncryptSymmetricAlgorithm request)
                (passphraseEncryptS2K request)
                (passphraseEncryptSEIPDv1IVOverride request)
                (passphraseEncryptPassphrase request)
                (passphraseEncryptPayload request)
        PassphraseSKESKPreferV6 -> do
            let messagePolicy = policyMessageEncryption (policyForRFC RFC9580)
                aead =
                    fromMaybe
                        (messageDefaultAEADAlgorithm messagePolicy)
                        (passphraseEncryptSEIPDv2AEADOverride request)
                chunkSize =
                    fromMaybe
                        (messageDefaultChunkSize messagePolicy)
                        (passphraseEncryptSEIPDv2ChunkSizeOverride request)
            salt <-
                maybe
                    (Salt <$> getRandomBytes (messageSEIPDv2SaltOctets messagePolicy))
                    pure
                    (passphraseEncryptSEIPDv2SaltOverride request)
            pure $
                encryptSEIPDv2WithSKESK
                    (passphraseEncryptSymmetricAlgorithm request)
                    aead
                    chunkSize
                    salt
                    (passphraseEncryptS2K request)
                    (passphraseEncryptPassphrase request)
                    (passphraseEncryptPayload request)

defaultRecipientPayloadShape :: RecipientPayloadShape
defaultRecipientPayloadShape =
    RecipientPayloadShape
        { recipientPayloadDataType = BinaryData
        , recipientPayloadFileName = BL.empty
        , recipientPayloadTimestamp = 0
        , recipientPayloadUseOnePassSignatures = False
        , recipientPayloadSignatures = []
        }

data RecipientEncryptResult
    = RecipientEncryptResult
    { recipientEncryptPackets :: [Pkt]
    , recipientEncryptSessionMaterial :: PKESKSessionMaterial
    }
    deriving (Eq, Show)

data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where
    RecipientEncryptRequestSEIPDv1Overrides
        :: { recipientEncryptRequestIVOverride :: Maybe IV
           }
        -> RecipientEncryptRequestOverrides 'SEIPDv1
    {- | For SEIPDv2 requests:
    - when AEAD override is 'Nothing', encrypt-side capability negotiation
    selects a common recipient-supported AEAD algorithm (if enabled).
    - when AEAD override is 'Just', the explicit AEAD wins.
    -}
    RecipientEncryptRequestSEIPDv2Overrides
        :: { recipientEncryptRequestAEADOverride :: Maybe AEADAlgorithm
           , recipientEncryptRequestChunkSizeOverride :: Maybe Word8
           , recipientEncryptRequestSaltOverride :: Maybe Salt
           }
        -> RecipientEncryptRequestOverrides 'SEIPDv2

data RecipientEncryptRequest (v :: SEIPDVersion)
    = RecipientEncryptRequest
    { recipientEncryptRequestTargets :: [RecipientEncryptionTarget]
    -- ^ Recipient encryption targets. At least one target is required.
    , recipientEncryptRequestPayloadShape :: RecipientPayloadShape
    , recipientEncryptRequestPayload :: B.ByteString
    , recipientEncryptRequestSymmetricOverride
        :: Maybe SymmetricAlgorithm
    {- ^ Explicit symmetric algorithm override. When 'Nothing', the selected
    mode (negotiated or legacy) determines algorithm selection.
    -}
    , recipientEncryptRequestOverrides
        :: RecipientEncryptRequestOverrides v
    }

deriving instance Eq (RecipientEncryptRequestOverrides v)
deriving instance Show (RecipientEncryptRequestOverrides v)
deriving instance Eq (RecipientEncryptRequest v)
deriving instance Show (RecipientEncryptRequest v)

{- | Encode the RFC 9580 PKESK/SKESK session-key material:
  one-octet algorithm ID, raw session key, then 16-bit checksum.
-}
encodeOpenPGPSessionMaterial
    :: SymmetricAlgorithm
    -> SessionKey
    -> Either PKESKEncryptError B.ByteString
encodeOpenPGPSessionMaterial symalgo sessionKey =
    unPKESKV3SessionMaterial
        <$> mkPKESKV3SessionMaterial symalgo sessionKey

-- | Generate a fresh session key and return both raw and encoded forms.
generateSessionKeyMaterial
    :: MonadRandom m
    => SymmetricAlgorithm
    -> m (Either PKESKEncryptError PKESKSessionMaterial)
generateSessionKeyMaterial symalgo =
    case keySize symalgo of
        Left err ->
            pure
                ( Left
                    (UnsupportedSessionKeyAlgorithm symalgo (renderCipherError err))
                )
        Right keyLen -> do
            sessionKeyBytes <- getRandomBytes keyLen
            let sessionKey = SessionKey sessionKeyBytes
            pure (mkPKESKSessionMaterial symalgo sessionKey)

canonicalizePKESKRecipientId
    :: PKESKPayload -> Either PKESKEncryptError PKESKPayload
canonicalizePKESKRecipientId payload =
    case payload of
        PKESKPayloadV6Packet payloadV6 ->
            PKESKPayloadV6Packet <$> canonicalizePKESKRecipientIdV6 payloadV6
        _ -> Right payload

canonicalizePKESKRecipientIdV6
    :: PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6
canonicalizePKESKRecipientIdV6 (PKESKPayloadV6 rid pka esk) =
    (\normalizedRid -> PKESKPayloadV6 normalizedRid pka esk)
        <$> canonicalizeRecipientKeyIdentifier rid

canonicalizeRecipientKeyIdentifier
    :: BL.ByteString -> Either PKESKEncryptError BL.ByteString
canonicalizeRecipientKeyIdentifier rid
    | BL.length rid == 20 || BL.length rid == 32 = Right rid
    | BL.length rid == 21 && BL.head rid == 0x04 =
        Right (BL.tail rid)
    | BL.length rid == 33 && BL.head rid == 0x06 =
        Right (BL.tail rid)
    | otherwise =
        Left
            ( InvalidRecipientIdentifier
                ( "unsupported PKESK recipient identifier length/prefix: "
                    ++ show (BL.length rid)
                )
            )

canonicalizePKESKPacketRecipientIds
    :: [Pkt] -> Either PKESKEncryptError [Pkt]
canonicalizePKESKPacketRecipientIds =
    mapM
        ( \pkt ->
            case pkt of
                PKESKPkt payload -> fmap PKESKPkt (canonicalizePKESKRecipientId payload)
                _ -> Right pkt
        )

-- | Build a v6 PKESK payload for one recipient key according to the selected version policy.
buildPKESKPayloadForRecipient
    :: MonadRandom m
    => PKESKVersionPolicy
    -> SomePKPayload
    -> PKESKSessionMaterial
    -> m (Either PKESKEncryptError PKESKPayload)
buildPKESKPayloadForRecipient policy recipient material =
    case policy of
        ForceV3Interop ->
            buildPKESKv3PayloadForRecipient
                recipient
                (pkeskV3SessionMaterial material)
        PreferV6 ->
            case _pkalgo recipient of
                RSA ->
                    fmap
                        (fmap PKESKPayloadV6Packet)
                        (buildRsaPKESKv6 recipient material)
                ECDH ->
                    fmap
                        (fmap PKESKPayloadV6Packet)
                        (buildECDHPKESKv6 recipient material)
                X25519 ->
                    fmap
                        (fmap PKESKPayloadV6Packet)
                        (buildX25519PKESKv6 recipient (pkeskV6RawSessionMaterial material))
                X448 ->
                    fmap
                        (fmap PKESKPayloadV6Packet)
                        (buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material))
                pka -> pure (Left (UnsupportedRecipientAlgorithm pka))

-- | Build a PKESK packet for one recipient key according to the selected version policy.
buildPKESKPktForRecipient
    :: MonadRandom m
    => PKESKVersionPolicy
    -> SomePKPayload
    -> PKESKSessionMaterial
    -> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipient policy recipient material =
    fmap
        (fmap PKESKPkt)
        (buildPKESKPayloadForRecipient policy recipient material)

-- | Build a legacy PKESKv3 payload for v4/v3 RSA recipient interop.
buildPKESKv3PayloadForRecipient
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV3SessionMaterial
    -> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient recipient material =
    fmap
        (fmap PKESKPayloadV3Packet)
        (buildPKESKv3PayloadForRecipientTyped recipient material)

buildPKESKv3PayloadForRecipientTyped
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV3SessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV3)
buildPKESKv3PayloadForRecipientTyped recipient material =
    case _pkalgo recipient of
        RSA -> buildRsaPKESKv3 recipient material
        DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material
        ECDH -> buildECDHPKESKv3 recipient material
        pka -> pure (Left (UnsupportedRecipientAlgorithm pka))

-- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop.
buildPKESKv3PktForRecipient
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV3SessionMaterial
    -> m (Either PKESKEncryptError Pkt)
buildPKESKv3PktForRecipient recipient material =
    fmap
        (fmap PKESKPkt)
        (buildPKESKv3PayloadForRecipient recipient material)

-- | Build PKESK packets for all recipients with a single shared session key.
{-# DEPRECATED
    buildPKESKPktsForRecipientTargetsWithSelector
    "Use buildPKESKPktsForRecipientTargetsWithSelectorTyped instead"
    #-}
buildPKESKPktsForRecipientTargetsWithSelector
    :: MonadRandom m
    => ( RecipientEncryptionTarget
         -> Either PKESKEncryptError RecipientPKESKVersionStrategy
       )
    -> [RecipientEncryptionTarget]
    -> PKESKSessionMaterial
    -> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelector selector targets material =
    buildPKESKPktsForRecipientTargetsWithSelectorTyped
        ( \target ->
            promoteRecipientStrategy <$> selector target
        )
        targets
        material

buildPKESKPktsForRecipientTargetsWithSelectorTyped
    :: MonadRandom m
    => ( RecipientEncryptionTarget
         -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
       )
    -> [RecipientEncryptionTarget]
    -> PKESKSessionMaterial
    -> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelectorTyped selector targets material
    | null targets = pure (Left NoRecipientsProvided)
    | otherwise =
        case preparePKESKVersionedMaterial material of
            Left err -> pure (Left err)
            Right (v3Material, v6RawMaterial) -> do
                pkeskResults <-
                    mapM
                        ( \target ->
                            case selector target of
                                Left err -> pure (Left err)
                                Right (SomeRecipientPKESKVersionStrategyW RecipientPreferV6W) ->
                                    buildPKESKPktForRecipientWithPreparedPayload
                                        RecipientPreferV6W
                                        (recipientEncryptionTargetKey target)
                                        (RecipientPreferV6Payload material v6RawMaterial)
                                Right
                                    (SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW) ->
                                        buildPKESKPktForRecipientWithPreparedPayload
                                            RecipientForceV3InteropW
                                            (recipientEncryptionTargetKey target)
                                            (RecipientForceV3Payload v3Material)
                        )
                        targets
                pure
                    (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds)

preparePKESKVersionedMaterial
    :: PKESKSessionMaterial
    -> Either
        PKESKEncryptError
        (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial)
preparePKESKVersionedMaterial material = do
    v3Material <-
        mkPKESKV3SessionMaterial
            (pkeskSessionAlgorithm material)
            (pkeskSessionKey material)
    v6RawMaterial <-
        mkPKESKV6RawSessionMaterial
            (pkeskSessionAlgorithm material)
            (pkeskSessionKey material)
    pure (v3Material, v6RawMaterial)

data
    RecipientPKESKRequestPayload
        (strategy :: RecipientPKESKVersionStrategy)
    where
    RecipientForceV3Payload
        :: PKESKV3SessionMaterial
        -> RecipientPKESKRequestPayload 'RecipientForceV3Interop
    RecipientPreferV6Payload
        :: PKESKSessionMaterial
        -> PKESKV6RawSessionMaterial
        -> RecipientPKESKRequestPayload 'RecipientPreferV6

buildPKESKPktForRecipientWithPreparedPayload
    :: MonadRandom m
    => RecipientPKESKVersionStrategyW strategy
    -> SomePKPayload
    -> RecipientPKESKRequestPayload strategy
    -> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipientWithPreparedPayload strategy recipient payload =
    fmap fmapPKESKPkt payloadResult
  where
    fmapPKESKPkt = fmap PKESKPkt
    payloadResult =
        case (strategy, payload) of
            (RecipientForceV3InteropW, RecipientForceV3Payload v3Material) ->
                buildPKESKv3PayloadForRecipient recipient v3Material
            ( RecipientPreferV6W
                , RecipientPreferV6Payload material v6RawMaterial
                ) ->
                    case _pkalgo recipient of
                        RSA ->
                            fmap
                                (fmap PKESKPayloadV6Packet)
                                (buildRsaPKESKv6 recipient material)
                        ECDH ->
                            fmap
                                (fmap PKESKPayloadV6Packet)
                                (buildECDHPKESKv6 recipient material)
                        X25519 ->
                            fmap
                                (fmap PKESKPayloadV6Packet)
                                (buildX25519PKESKv6 recipient v6RawMaterial)
                        X448 ->
                            fmap
                                (fmap PKESKPayloadV6Packet)
                                (buildX448PKESKv6 recipient v6RawMaterial)
                        pka ->
                            pure (Left (UnsupportedRecipientAlgorithm pka))

{- | Encrypt for recipient targets with capability negotiation enabled.

By default this negotiates a common symmetric and (for SEIPDv2) AEAD
algorithm from recipient capabilities when available. Explicit request
overrides still take precedence.
-}
encryptForRecipients
    :: MonadRandom m
    => RecipientEncryptRequest v
    -> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipients =
    encryptForRecipientsWithCapabilityNegotiation
        RecipientCapabilityNegotiationOn

{- | Encrypt for recipient targets without recipient capability negotiation.

This preserves legacy behavior by using policy defaults unless request
overrides are provided.
-}
encryptForRecipientsLegacy
    :: MonadRandom m
    => RecipientEncryptRequest v
    -> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsLegacy =
    encryptForRecipientsWithCapabilityNegotiation
        RecipientCapabilityNegotiationOff

{- | Encrypt for recipient targets with an explicit capability-negotiation mode.

When negotiation is on, symmetric and AEAD selection use the common
intersection of recipient preferences constrained by the active policy.
When off, policy defaults are used.
-}
encryptForRecipientsWithCapabilityNegotiation
    :: MonadRandom m
    => RecipientCapabilityNegotiationMode
    -> RecipientEncryptRequest v
    -> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsWithCapabilityNegotiation negotiationMode request
    | null targets = pure (Left NoRecipientsProvided)
    | otherwise =
        case selectSymmetricAlgorithm
            negotiationMode
            request
            messagePolicy
            targets of
            Left err -> pure (Left err)
            Right symalgo -> do
                sessionMaterialResult <- generateSessionKeyMaterial symalgo
                case sessionMaterialResult of
                    Left err -> pure (Left err)
                    Right sessionMaterial -> do
                        pkeskResult <-
                            buildPKESKPktsForRecipientTargetsWithSelectorTyped
                                (recipientVersionStrategyForProfileTyped profileW)
                                targets
                                sessionMaterial
                        case pkeskResult of
                            Left err -> pure (Left err)
                            Right pkeskPkts -> do
                                payloadResult <- case recipientEncryptRequestOverrides request of
                                    RecipientEncryptRequestSEIPDv2Overrides
                                        { recipientEncryptRequestAEADOverride = aeadOverride
                                        , recipientEncryptRequestChunkSizeOverride = chunkSizeOverride
                                        , recipientEncryptRequestSaltOverride = saltOverride
                                        } ->
                                            case recipientsMissingSEIPDv2Support targets of
                                                [] -> do
                                                    case selectAEADAlgorithm
                                                        negotiationMode
                                                        messagePolicy
                                                        targets
                                                        aeadOverride of
                                                        Left err -> pure (Left err)
                                                        Right aead -> do
                                                            salt <- maybe (Salt <$> getRandomBytes 32) pure saltOverride
                                                            let chunkSize =
                                                                    maybe
                                                                        (messageDefaultChunkSize messagePolicy)
                                                                        id
                                                                        chunkSizeOverride
                                                            pure $
                                                                buildEncryptedPacketSequenceWithShape
                                                                    symalgo
                                                                    aead
                                                                    chunkSize
                                                                    (recipientEncryptRequestPayloadShape request)
                                                                    salt
                                                                    (pkeskSessionKey sessionMaterial)
                                                                    pkeskPkts
                                                                    (recipientEncryptRequestPayload request)
                                                _missingSEIPDv2 ->
                                                    case recipientsMissingSEIPDv1Support targets of
                                                        [] ->
                                                            buildSEIPDv1PayloadWithIV
                                                                symalgo
                                                                sessionMaterial
                                                                pkeskPkts
                                                                Nothing
                                                        missingSEIPDv1 ->
                                                            pure
                                                                ( Left
                                                                    ( RecipientCapabilitySelectionFailure
                                                                        (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)
                                                                    )
                                                                )
                                    RecipientEncryptRequestSEIPDv1Overrides
                                        { recipientEncryptRequestIVOverride = ivOverride
                                        } ->
                                            case recipientsMissingSEIPDv1Support targets of
                                                [] ->
                                                    buildSEIPDv1PayloadWithIV
                                                        symalgo
                                                        sessionMaterial
                                                        pkeskPkts
                                                        ivOverride
                                                missingSEIPDv1 ->
                                                    pure
                                                        ( Left
                                                            ( RecipientCapabilitySelectionFailure
                                                                (RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)
                                                            )
                                                        )
                                pure $
                                    fmap
                                        ( \pkts ->
                                            RecipientEncryptResult
                                                { recipientEncryptPackets = pkts
                                                , recipientEncryptSessionMaterial = sessionMaterial
                                                }
                                        )
                                        payloadResult
  where
    targets = recipientEncryptRequestTargets request
    profileW =
        profileForPayloadVersionW
            (recipientEncryptRequestOverrides request)
    messagePolicy =
        case profileW of
            EncryptStrictDefaultW ->
                policyMessageEncryption (policyForRFC RFC9580)
            EncryptInteropLegacyW ->
                policyMessageEncryption (policyForRFC RFC4880)

    buildSEIPDv1PayloadWithIV
        :: MonadRandom m
        => SymmetricAlgorithm
        -> PKESKSessionMaterial
        -> [Pkt]
        -> Maybe IV
        -> m (Either PKESKEncryptError [Pkt])
    buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride = do
        ivResult <-
            case ivOverride of
                Just iv -> pure (Right iv)
                Nothing ->
                    let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial)
                     in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of
                            Left err -> pure (Left (PayloadBuildFailure (renderCipherError err)))
                            Right n -> fmap (Right . IV) (getRandomBytes n)
        case ivResult of
            Left err -> pure (Left err)
            Right iv ->
                pure $
                    buildEncryptedPacketSequenceWithShapeSEIPDv1
                        symalgo
                        iv
                        (recipientEncryptRequestPayloadShape request)
                        (pkeskSessionKey sessionMaterial)
                        pkeskPkts
                        (recipientEncryptRequestPayload request)

    recipientsMissingSEIPDv1Support
        :: [RecipientEncryptionTarget] -> [SomePKPayload]
    recipientsMissingSEIPDv1Support =
        map recipientEncryptionTargetKey
            . filter (not . targetAdvertisesSEIPDv1Support)

    recipientsMissingSEIPDv2Support
        :: [RecipientEncryptionTarget] -> [SomePKPayload]
    recipientsMissingSEIPDv2Support =
        map recipientEncryptionTargetKey
            . filter (not . targetAdvertisesSEIPDv2Support)

    targetAdvertisesSEIPDv1Support
        :: RecipientEncryptionTarget -> Bool
    targetAdvertisesSEIPDv1Support target =
        case recipientEncryptionTargetCapabilities target of
            Nothing -> True
            Just caps -> recipientCapabilityAdvertisesSEIPDv1Support caps

    targetAdvertisesSEIPDv2Support
        :: RecipientEncryptionTarget -> Bool
    targetAdvertisesSEIPDv2Support target =
        case recipientEncryptionTargetCapabilities target of
            Nothing -> True
            Just caps -> recipientCapabilityAdvertisesSEIPDv2Support caps

selectSymmetricAlgorithm
    :: RecipientCapabilityNegotiationMode
    -> RecipientEncryptRequest v
    -> MessageEncryptionPolicy
    -> [RecipientEncryptionTarget]
    -> Either PKESKEncryptError SymmetricAlgorithm
selectSymmetricAlgorithm negotiationMode request messagePolicy targets =
    case recipientEncryptRequestSymmetricOverride request of
        Just override -> Right override
        Nothing ->
            case negotiationMode of
                RecipientCapabilityNegotiationOff ->
                    Right (messageDefaultSymmetricAlgorithm messagePolicy)
                RecipientCapabilityNegotiationOn ->
                    negotiateSymmetricAlgorithm messagePolicy targets

selectAEADAlgorithm
    :: RecipientCapabilityNegotiationMode
    -> MessageEncryptionPolicy
    -> [RecipientEncryptionTarget]
    -> Maybe AEADAlgorithm
    -> Either PKESKEncryptError AEADAlgorithm
selectAEADAlgorithm negotiationMode messagePolicy targets override =
    case override of
        Just explicit -> Right explicit
        Nothing ->
            case negotiationMode of
                RecipientCapabilityNegotiationOff ->
                    Right (messageDefaultAEADAlgorithm messagePolicy)
                RecipientCapabilityNegotiationOn ->
                    negotiateAEADAlgorithm messagePolicy targets

negotiateSymmetricAlgorithm
    :: MessageEncryptionPolicy
    -> [RecipientEncryptionTarget]
    -> Either PKESKEncryptError SymmetricAlgorithm
negotiateSymmetricAlgorithm messagePolicy targets =
    chooseCommonAlgorithm
        policyOrder
        recipientChoices
        ( RecipientCapabilityNoCommonSymmetricAlgorithms
            (concat recipientChoices)
        )
  where
    policyOrder =
        case messageSEIPDv2SymmetricAlgorithms messagePolicy of
            [] -> [messageDefaultSymmetricAlgorithm messagePolicy]
            syms -> syms
    recipientChoices = map choicesForTarget targets
    choicesForTarget target =
        case recipientEncryptionTargetCapabilities target of
            Just caps ->
                let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps
                    allowed = [alg | alg <- policyOrder, alg `elem` preferred]
                 in if null allowed
                        then policyOrder
                        else allowed
            Nothing -> policyOrder

negotiateAEADAlgorithm
    :: MessageEncryptionPolicy
    -> [RecipientEncryptionTarget]
    -> Either PKESKEncryptError AEADAlgorithm
negotiateAEADAlgorithm messagePolicy targets =
    chooseCommonAlgorithm
        policyOrder
        recipientChoices
        ( RecipientCapabilityNoCommonAEADAlgorithms
            (concat recipientChoices)
        )
  where
    policyOrder =
        nubOrd
            (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM])
    recipientChoices = map choicesForTarget targets
    choicesForTarget target =
        case recipientEncryptionTargetCapabilities target of
            Just caps ->
                let preferred = recipientCapabilityPreferredAEADAlgorithms caps
                    allowed = [alg | alg <- policyOrder, alg `elem` preferred]
                 in if null allowed
                        then policyOrder
                        else allowed
            Nothing -> policyOrder

chooseCommonAlgorithm
    :: Eq a
    => [a]
    -> [[a]]
    -> RecipientCapabilityError
    -> Either PKESKEncryptError a
chooseCommonAlgorithm policyOrder recipientChoices err =
    case recipientChoices of
        [] -> Left (RecipientCapabilitySelectionFailure err)
        (firstChoices : restChoices) ->
            let common = foldl' intersectOrdered firstChoices restChoices
                orderedCommon = [alg | alg <- policyOrder, alg `elem` common]
             in case orderedCommon of
                    (selected : _) -> Right selected
                    [] -> Left (RecipientCapabilitySelectionFailure err)
  where
    intersectOrdered as bs = [a | a <- as, a `elem` bs]

promoteRecipientStrategy
    :: RecipientPKESKVersionStrategy
    -> SomeRecipientPKESKVersionStrategyW
promoteRecipientStrategy RecipientPreferV6 =
    SomeRecipientPKESKVersionStrategyW RecipientPreferV6W
promoteRecipientStrategy RecipientForceV3Interop =
    SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW

demoteRecipientStrategy
    :: RecipientPKESKVersionStrategyW strategy
    -> RecipientPKESKVersionStrategy
demoteRecipientStrategy RecipientPreferV6W = RecipientPreferV6
demoteRecipientStrategy RecipientForceV3InteropW = RecipientForceV3Interop

demoteSomeRecipientStrategy
    :: SomeRecipientPKESKVersionStrategyW
    -> RecipientPKESKVersionStrategy
demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW strategyW) =
    demoteRecipientStrategy strategyW

promoteEncryptCompatibilityProfile
    :: EncryptCompatibilityProfile
    -> SomeEncryptCompatibilityProfileW
promoteEncryptCompatibilityProfile EncryptStrictDefault =
    SomeEncryptCompatibilityProfileW EncryptStrictDefaultW
promoteEncryptCompatibilityProfile EncryptInteropLegacy =
    SomeEncryptCompatibilityProfileW EncryptInteropLegacyW

{- | High-level encrypt-side helper for public-key recipient encryption.

Returns a complete packet sequence:
@[PKESK ..., SEIPD2 ...]@.
-}
buildEncryptedPacketSequence
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> RecipientPayloadShape
    -> Salt
    -> SessionKey
    -> [Pkt]
    -> B.ByteString
    -> Either String [Pkt]
buildEncryptedPacketSequence symalgo aead chunkSize payloadShape salt sessionKey pkesks payload =
    first
        renderPKESKEncryptError
        ( buildEncryptedPacketSequenceWithShape
            symalgo
            aead
            chunkSize
            payloadShape
            salt
            sessionKey
            pkesks
            payload
        )

buildEncryptedPacketSequenceWithShape
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> RecipientPayloadShape
    -> Salt
    -> SessionKey
    -> [Pkt]
    -> B.ByteString
    -> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = do
    onePassSignatures <-
        first
            (PayloadBuildFailure . renderOPSBuildError)
            (buildOnePassSignaturePackets payloadShape)
    let signatures = recipientPayloadSignatures payloadShape
        literalBlock =
            Block
                ( onePassSignatures
                    ++ [ LiteralDataPkt
                            (recipientPayloadDataType payloadShape)
                            (recipientPayloadFileName payloadShape)
                            (recipientPayloadTimestamp payloadShape)
                            (BL.fromStrict payload)
                       ]
                    ++ map SignaturePkt signatures
                )
    ciphertext <-
        first PayloadBuildFailure $
            encryptSEIPDv2Payload
                symalgo
                aead
                chunkSize
                salt
                sessionKey
                (BL.toStrict (runPut (put literalBlock)))
    Right
        ( pkesks
            ++ [ SymEncIntegrityProtectedDataPkt
                    (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict ciphertext))
               ]
        )

-- | Encrypt a plaintext block with OpenPGP CFB + MDC to produce a SEIPDv1 ciphertext.
encryptSEIPDv1Payload
    :: SymmetricAlgorithm
    -> IV
    -> SessionKey
    -> B.ByteString
    -- ^ inner packet block plaintext
    -> Either String B.ByteString
encryptSEIPDv1Payload symalgo iv (SessionKey keyBytes) plaintext =
    let cleartextWithMDC = plaintext <> mdcTrailerForSEIPDv1 iv plaintext
     in first
            renderCipherError
            ( encryptOpenPGPCfbRaw
                OpenPGPCFBNoResyncW
                symalgo
                iv
                cleartextWithMDC
                keyBytes
            )

-- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC).
buildEncryptedPacketSequenceWithShapeSEIPDv1
    :: SymmetricAlgorithm
    -> IV
    -> RecipientPayloadShape
    -> SessionKey
    -> [Pkt]
    -> B.ByteString
    -> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo iv payloadShape sessionKey pkesks payload = do
    onePassSignatures <-
        first
            (PayloadBuildFailure . renderOPSBuildError)
            (buildOnePassSignaturePackets payloadShape)
    let signatures = recipientPayloadSignatures payloadShape
        literalBlock =
            Block
                ( onePassSignatures
                    ++ [ LiteralDataPkt
                            (recipientPayloadDataType payloadShape)
                            (recipientPayloadFileName payloadShape)
                            (recipientPayloadTimestamp payloadShape)
                            (BL.fromStrict payload)
                       ]
                    ++ map SignaturePkt signatures
                )
    ciphertext <-
        first PayloadBuildFailure $
            encryptSEIPDv1Payload
                symalgo
                iv
                sessionKey
                (BL.toStrict (runPut (put literalBlock)))
    Right
        ( pkesks
            ++ [ SymEncIntegrityProtectedDataPkt
                    (SEIPD1 1 (BL.fromStrict ciphertext))
               ]
        )

buildOnePassSignaturePackets
    :: RecipientPayloadShape -> Either OPSBuildError [Pkt]
buildOnePassSignaturePackets payloadShape
    | not (recipientPayloadUseOnePassSignatures payloadShape) =
        Right []
    | null signatures = Right []
    | otherwise =
        fmap (map OnePassSignaturePkt) $
            sequence
                (zipWith buildOnePassSignature nestedFlags (reverse signatures))
  where
    signatures = recipientPayloadSignatures payloadShape
    nestedFlags = replicate (length signatures - 1) True ++ [False]

data OnePassSignatureBuildCase where
    OnePassSignatureBuildCaseV3
        :: SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase
    OnePassSignatureBuildCaseV4
        :: SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase
    OnePassSignatureBuildCaseV6
        :: SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase
    OnePassSignatureBuildCaseOther
        :: PacketVersion -> OnePassSignatureBuildCase

onePassSignatureBuildCase
    :: SignaturePayload -> OnePassSignatureBuildCase
onePassSignatureBuildCase sig =
    case toSomeSignaturePayload sig of
        SomeSignaturePayload (payload@SigPayloadV3Data {}) ->
            OnePassSignatureBuildCaseV3 payload
        SomeSignaturePayload (payload@SigPayloadV4Data {}) ->
            OnePassSignatureBuildCaseV4 payload
        SomeSignaturePayload (payload@SigPayloadV6Data {}) ->
            OnePassSignatureBuildCaseV6 payload
        SomeSignaturePayload (SigPayloadOtherData version _) ->
            OnePassSignatureBuildCaseOther version

buildOnePassSignature
    :: NestedFlag
    -> SignaturePayload
    -> Either OPSBuildError OnePassSignaturePayload
buildOnePassSignature nestedFlag sig =
    case onePassSignatureBuildCase sig of
        OnePassSignatureBuildCaseV3
            (SigPayloadV3Data sigType _ issuerKeyId pubkeyAlgo hashAlgo _ _) ->
                Right
                    ( OPSPayloadV3Packet
                        (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag)
                    )
        OnePassSignatureBuildCaseV4
            ( SigPayloadV4Data
                    sigType
                    pubkeyAlgo
                    hashAlgo
                    hashedSubpackets
                    unhashedSubpackets
                    _
                    _
                ) ->
                case signatureIssuerKeyId hashedSubpackets unhashedSubpackets of
                    Just issuerKeyId ->
                        Right
                            ( OPSPayloadV3Packet
                                (OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag)
                            )
                    Nothing ->
                        Left OPSBuildMissingIssuerKeyId
        OnePassSignatureBuildCaseV6
            ( SigPayloadV6Data
                    sigType
                    pubkeyAlgo
                    hashAlgo
                    salt
                    hashedSubpackets
                    unhashedSubpackets
                    _
                    _
                ) ->
                case signatureIssuerFingerprint
                    ( BTypes.issuerFingerprintVersionToPacketVersion
                        BTypes.IssuerFingerprintV6
                    )
                    hashedSubpackets
                    unhashedSubpackets of
                    Just signerFingerprint
                        | BL.length signerFingerprint == 32 ->
                            Right
                                ( OPSPayloadV6Packet
                                    ( OPSPayloadV6
                                        sigType
                                        hashAlgo
                                        pubkeyAlgo
                                        salt
                                        signerFingerprint
                                        nestedFlag
                                    )
                                )
                        | otherwise ->
                            Left
                                (OPSBuildFingerprintWrongLength (BL.length signerFingerprint))
                    Nothing ->
                        Left OPSBuildMissingIssuerFingerprint
        OnePassSignatureBuildCaseOther version ->
            Left (OPSBuildUnsupportedSigVersion version)

signatureIssuerKeyId
    :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId
signatureIssuerKeyId hashedSubpackets unhashedSubpackets =
    case findIssuerKeyId hashedSubpackets of
        Just issuerKeyId -> Just issuerKeyId
        Nothing ->
            case findIssuerKeyId unhashedSubpackets of
                Just issuerKeyId -> Just issuerKeyId
                Nothing ->
                    case signatureIssuerFingerprint
                        ( BTypes.issuerFingerprintVersionToPacketVersion
                            BTypes.IssuerFingerprintV4
                        )
                        hashedSubpackets
                        unhashedSubpackets of
                        Just issuerFingerprintBytes ->
                            if BL.length issuerFingerprintBytes >= 8
                                then
                                    Just
                                        ( EightOctetKeyId
                                            ( BL.drop
                                                (BL.length issuerFingerprintBytes - 8)
                                                issuerFingerprintBytes
                                            )
                                        )
                                else Nothing
                        Nothing -> Nothing

signatureIssuerFingerprint
    :: PacketVersion
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> Maybe BL.ByteString
signatureIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets =
    unFingerprint
        <$> findIssuerFingerprint
            expectedVersion
            hashedSubpackets
            unhashedSubpackets

findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId
findIssuerKeyId subpackets =
    case find isIssuerKeyIdSubpacket subpackets of
        Just (SigSubPacket _ (Issuer issuerKeyId)) -> Just issuerKeyId
        _ -> Nothing

findIssuerFingerprint
    :: PacketVersion
    -> [SigSubPacket]
    -> [SigSubPacket]
    -> Maybe Fingerprint
findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets =
    case findIssuerFingerprintIn expectedVersion hashedSubpackets of
        Just issuerFingerprint -> Just issuerFingerprint
        Nothing -> findIssuerFingerprintIn expectedVersion unhashedSubpackets

findIssuerFingerprintIn
    :: PacketVersion -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprintIn expectedVersion subpackets =
    case find (isIssuerFingerprintSubpacket expectedVersion) subpackets of
        Just (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) -> Just issuerFingerprint
        _ -> Nothing

isIssuerKeyIdSubpacket :: SigSubPacket -> Bool
isIssuerKeyIdSubpacket (SigSubPacket _ (Issuer _)) = True
isIssuerKeyIdSubpacket _ = False

isIssuerFingerprintSubpacket
    :: PacketVersion -> SigSubPacket -> Bool
isIssuerFingerprintSubpacket expectedVersion (SigSubPacket _ (IssuerFingerprint version _)) =
    BTypes.issuerFingerprintVersionToPacketVersion version
        == expectedVersion
isIssuerFingerprintSubpacket _ _ = False

buildRsaPKESKv6
    :: MonadRandom m
    => SomePKPayload
    -> PKESKSessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV6)
buildRsaPKESKv6 recipient material =
    case _pubkey recipient of
        RSAPubKey (RSA_PublicKey publicKey) -> do
            encrypted <-
                RSA15.encrypt publicKey (pkeskEncodedSessionMaterial material)
            pure $
                fmap
                    ( \esk ->
                        let mpiEsk = runPut (put (MPI (os2ip esk)))
                         in PKESKPayloadV6 (recipientKeyIdentifier recipient) RSA mpiEsk
                    )
                    (first (RecipientKeyWrapFailure RSA . show) encrypted)
        _ ->
            pure
                ( Left
                    ( InvalidRecipientKeyMaterial
                        RSA
                        "recipient PKPayload does not contain an RSA public key"
                    )
                )

buildRsaPKESKv3
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV3SessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV3)
buildRsaPKESKv3 recipient material =
    case _pubkey recipient of
        RSAPubKey (RSA_PublicKey publicKey) ->
            case eightOctetKeyID recipient of
                Left err ->
                    pure
                        ( Left
                            ( InvalidRecipientKeyMaterial
                                (_pkalgo recipient)
                                ("failed to derive PKESKv3 recipient key ID: " ++ err)
                            )
                        )
                Right eoki -> do
                    encrypted <-
                        RSA15.encrypt publicKey (unPKESKV3SessionMaterial material)
                    pure $
                        fmap
                            ( \esk ->
                                PKESKPayloadV3
                                    3
                                    eoki
                                    (_pkalgo recipient)
                                    (MPI (os2ip esk) :| [])
                            )
                            ( first
                                (RecipientKeyWrapFailure (_pkalgo recipient) . show)
                                encrypted
                            )
        _ ->
            pure
                ( Left
                    ( InvalidRecipientKeyMaterial
                        (_pkalgo recipient)
                        "recipient PKPayload does not contain an RSA public key"
                    )
                )

buildECDHPKESKv3
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV3SessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV3)
buildECDHPKESKv3 recipient material =
    case _pubkey recipient of
        ECDHPubKey ecdhPub kdfHA kdfSA ->
            case eightOctetKeyID recipient of
                Left err ->
                    pure
                        ( Left
                            ( InvalidRecipientKeyMaterial
                                ECDH
                                ("failed to derive PKESKv3 recipient key ID: " ++ err)
                            )
                        )
                Right eoki ->
                    case ecdhPub of
                        ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do
                            (ephemeralPub, ephemeralPriv) <-
                                ECCGen.generate (ECDSA.public_curve recipientPub)
                            case point2MBS (ECDSA.public_q ephemeralPub) of
                                Nothing ->
                                    pure
                                        ( Left
                                            ( InvalidRecipientKeyMaterial
                                                ECDH
                                                "failed to serialize ECDH ephemeral point"
                                            )
                                        )
                                Just ephemeralBytes ->
                                    pure $
                                        buildEcdhV3Payload
                                            recipient
                                            eoki
                                            ECDH
                                            ecdhPub
                                            kdfHA
                                            kdfSA
                                            ephemeralBytes
                                            ( BA.convert
                                                ( ECCDH.getShared
                                                    (ECDSA.public_curve recipientPub)
                                                    (ECDSA.private_d ephemeralPriv)
                                                    (ECDSA.public_q recipientPub)
                                                )
                                                :: B.ByteString
                                            )
                                            material
                        EdDSAPubKey EdSigningCurve25519 recipientPoint -> do
                            ephSecretRaw <- getRandomBytes 32
                            pure $
                                do
                                    recipientPublicBytes <-
                                        normalizeX25519Public (edPointBytes recipientPoint)
                                    ephSecret <-
                                        first (RecipientKeyWrapFailure ECDH . show)
                                            . CE.eitherCryptoError
                                            $ C25519.secretKey (leftPadTo 32 ephSecretRaw)
                                    recipientPub <-
                                        first (RecipientKeyWrapFailure ECDH . show)
                                            . CE.eitherCryptoError
                                            $ C25519.publicKey recipientPublicBytes
                                    let ephPublicBytes =
                                            B.cons
                                                0x40
                                                (BA.convert (C25519.toPublic ephSecret) :: B.ByteString)
                                        sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
                                    buildEcdhV3Payload
                                        recipient
                                        eoki
                                        ECDH
                                        ecdhPub
                                        kdfHA
                                        kdfSA
                                        ephPublicBytes
                                        sharedSecret
                                        material
                        _ ->
                            pure
                                ( Left
                                    ( InvalidRecipientKeyMaterial
                                        ECDH
                                        "recipient ECDH public key is not RFC6637-compatible"
                                    )
                                )
        _ ->
            pure
                ( Left
                    ( InvalidRecipientKeyMaterial
                        ECDH
                        "recipient PKPayload does not contain ECDH public key material"
                    )
                )

buildECDHPKESKv6
    :: MonadRandom m
    => SomePKPayload
    -> PKESKSessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV6)
buildECDHPKESKv6 recipient material =
    case _pubkey recipient of
        ECDHPubKey ecdhPub kdfHA kdfSA ->
            case ecdhPub of
                ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do
                    (ephemeralPub, ephemeralPriv) <-
                        ECCGen.generate (ECDSA.public_curve recipientPub)
                    case point2MBS (ECDSA.public_q ephemeralPub) of
                        Nothing ->
                            pure
                                ( Left
                                    ( InvalidRecipientKeyMaterial
                                        ECDH
                                        "failed to serialize ECDH ephemeral point"
                                    )
                                )
                        Just ephemeralBytes ->
                            pure $
                                buildEcdhV6Esk
                                    recipient
                                    ECDH
                                    ecdhPub
                                    kdfHA
                                    kdfSA
                                    ephemeralBytes
                                    ( BA.convert
                                        ( ECCDH.getShared
                                            (ECDSA.public_curve recipientPub)
                                            (ECDSA.private_d ephemeralPriv)
                                            (ECDSA.public_q recipientPub)
                                        )
                                        :: B.ByteString
                                    )
                                    material
                EdDSAPubKey EdSigningCurve25519 recipientPoint -> do
                    ephSecretRaw <- getRandomBytes 32
                    pure $
                        do
                            recipientPublicBytes <-
                                normalizeX25519Public (edPointBytes recipientPoint)
                            ephSecret <-
                                first (RecipientKeyWrapFailure ECDH . show)
                                    . CE.eitherCryptoError
                                    $ C25519.secretKey (leftPadTo 32 ephSecretRaw)
                            recipientPub <-
                                first (RecipientKeyWrapFailure ECDH . show)
                                    . CE.eitherCryptoError
                                    $ C25519.publicKey recipientPublicBytes
                            let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
                                sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
                            buildEcdhV6Esk
                                recipient
                                ECDH
                                ecdhPub
                                kdfHA
                                kdfSA
                                ephPublicBytes
                                sharedSecret
                                material
                EdDSAPubKey EdSigningCurve448 recipientPoint -> do
                    ephSecretRaw <- getRandomBytes 56
                    pure $
                        do
                            recipientPublicBytes <-
                                normalizeX448Public (edPointBytes recipientPoint)
                            ephSecret <-
                                first (RecipientKeyWrapFailure ECDH . show)
                                    . CE.eitherCryptoError
                                    $ C448.secretKey (leftPadTo 56 ephSecretRaw)
                            recipientPub <-
                                first (RecipientKeyWrapFailure ECDH . show)
                                    . CE.eitherCryptoError
                                    $ C448.publicKey recipientPublicBytes
                            let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString
                                sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString
                            buildEcdhV6Esk
                                recipient
                                ECDH
                                ecdhPub
                                kdfHA
                                kdfSA
                                ephPublicBytes
                                sharedSecret
                                material
                _ ->
                    pure
                        ( Left
                            ( InvalidRecipientKeyMaterial
                                ECDH
                                "recipient ECDH public key is not ECDSA/X25519/X448-compatible"
                            )
                        )
        _ ->
            pure
                ( Left
                    ( InvalidRecipientKeyMaterial
                        ECDH
                        "recipient PKPayload does not contain ECDH public key material"
                    )
                )

buildX25519PKESKv6
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV6RawSessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV6)
buildX25519PKESKv6 recipient material = do
    ephSecretRaw <- getRandomBytes 32
    pure $
        do
            recipientPublic <- extractX25519RecipientPublic recipient
            ephSecret <-
                first (RecipientKeyWrapFailure X25519 . show)
                    . CE.eitherCryptoError
                    $ C25519.secretKey (leftPadTo 32 ephSecretRaw)
            recipientPub <-
                first (RecipientKeyWrapFailure X25519 . show)
                    . CE.eitherCryptoError
                    $ C25519.publicKey recipientPublic
            let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
                sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
                kek = deriveX25519Kek ephPublicBytes recipientPublic sharedSecret
            wrapped <-
                first (RecipientKeyWrapFailure X25519)
                    . aesKeyWrapRFC3394 AES128 kek
                    $ unPKESKV6RawSessionMaterial material
            esk <- encodeV6X25519Esk ephPublicBytes wrapped
            Right
                ( PKESKPayloadV6
                    (recipientKeyIdentifier recipient)
                    X25519
                    (BL.fromStrict esk)
                )

buildX448PKESKv6
    :: MonadRandom m
    => SomePKPayload
    -> PKESKV6RawSessionMaterial
    -> m (Either PKESKEncryptError PKESKPayloadV6)
buildX448PKESKv6 recipient material = do
    ephSecretRaw <- getRandomBytes 56
    pure $
        do
            recipientPublic <- extractX448RecipientPublic recipient
            ephSecret <-
                first (RecipientKeyWrapFailure X448 . show)
                    . CE.eitherCryptoError
                    $ C448.secretKey (leftPadTo 56 ephSecretRaw)
            recipientPub <-
                first (RecipientKeyWrapFailure X448 . show)
                    . CE.eitherCryptoError
                    $ C448.publicKey recipientPublic
            let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString
                sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString
                kek = deriveX448Kek ephPublicBytes recipientPublic sharedSecret
            wrapped <-
                first (RecipientKeyWrapFailure X448)
                    . aesKeyWrapRFC3394 AES256 kek
                    $ unPKESKV6RawSessionMaterial material
            esk <- encodeV6X448Esk ephPublicBytes wrapped
            Right
                ( PKESKPayloadV6
                    (recipientKeyIdentifier recipient)
                    X448
                    (BL.fromStrict esk)
                )

buildEcdhV6Esk
    :: SomePKPayload
    -> PubKeyAlgorithm
    -> PKey
    -> HashAlgorithm
    -> SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> PKESKSessionMaterial
    -> Either PKESKEncryptError PKESKPayloadV6
buildEcdhV6Esk recipient pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do
    kdfParam <-
        first (RecipientKdfFailure pka) $
            buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA
    kek <-
        first (RecipientKdfFailure pka) $
            deriveECDHKek kdfHA kdfSA sharedSecret kdfParam
    wrapped <-
        first (RecipientKeyWrapFailure pka)
            . aesKeyWrapRFC3394 kdfSA kek
            $ padToMultipleOf8 (pkeskEncodedSessionMaterial material)
    esk <- encodeV6EcdhEsk ephemeralBytes wrapped
    Right
        ( PKESKPayloadV6
            (recipientKeyIdentifier recipient)
            pka
            (BL.fromStrict esk)
        )

buildEcdhV3Payload
    :: SomePKPayload
    -> EightOctetKeyId
    -> PubKeyAlgorithm
    -> PKey
    -> HashAlgorithm
    -> SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> PKESKV3SessionMaterial
    -> Either PKESKEncryptError PKESKPayloadV3
buildEcdhV3Payload recipient eoki pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do
    kdfParam <-
        first (RecipientKdfFailure pka) $
            buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA
    kek <-
        first (RecipientKdfFailure pka) $
            deriveECDHKek kdfHA kdfSA sharedSecret kdfParam
    wrapped <-
        first (RecipientKeyWrapFailure pka)
            . aesKeyWrapRFC3394 kdfSA kek
            $ padToMultipleOf8 (unPKESKV3SessionMaterial material)
    Right
        ( PKESKPayloadV3
            3
            eoki
            pka
            (MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)])
        )

recipientKeyIdentifier :: SomePKPayload -> BL.ByteString
recipientKeyIdentifier = unFingerprint . fingerprint

encodeV6EcdhEsk
    :: B.ByteString
    -> B.ByteString
    -> Either PKESKEncryptError B.ByteString
encodeV6EcdhEsk ephemeral wrapped = do
    let ephLen = B.length ephemeral
    if ephLen > 255
        then
            Left
                ( RecipientKeyWrapFailure
                    ECDH
                    "ephemeral key encoding is too large"
                )
        else
            Right (B.singleton (fromIntegral ephLen) <> ephemeral <> wrapped)

encodeV6X25519Esk
    :: B.ByteString
    -> B.ByteString
    -> Either PKESKEncryptError B.ByteString
encodeV6X25519Esk ephemeral wrapped
    | B.length ephemeral /= 32 =
        Left
            ( RecipientKeyWrapFailure
                X25519
                "X25519 ephemeral key must be exactly 32 octets"
            )
    | B.length wrapped > 255 =
        Left
            ( RecipientKeyWrapFailure
                X25519
                "wrapped session key encoding is too large"
            )
    | otherwise =
        Right
            ( ephemeral
                <> B.singleton (fromIntegral (B.length wrapped))
                <> wrapped
            )

encodeV6X448Esk
    :: B.ByteString
    -> B.ByteString
    -> Either PKESKEncryptError B.ByteString
encodeV6X448Esk ephemeral wrapped
    | B.length ephemeral /= 56 =
        Left
            ( RecipientKeyWrapFailure
                X448
                "X448 ephemeral key must be exactly 56 octets"
            )
    | B.length wrapped > 255 =
        Left
            ( RecipientKeyWrapFailure
                X448
                "wrapped session key encoding is too large"
            )
    | otherwise =
        Right
            ( ephemeral
                <> B.singleton (fromIntegral (B.length wrapped))
                <> wrapped
            )

extractX25519RecipientPublic
    :: SomePKPayload -> Either PKESKEncryptError B.ByteString
extractX25519RecipientPublic recipient =
    case _pubkey recipient of
        EdDSAPubKey EdSigningCurve25519 point ->
            normalizeX25519Public (edPointBytes point)
        ECDHPubKey (EdDSAPubKey EdSigningCurve25519 point) _ _ ->
            normalizeX25519Public (edPointBytes point)
        other ->
            Left
                ( InvalidRecipientKeyMaterial
                    X25519
                    ("expected X25519-compatible recipient key, got " ++ show other)
                )

extractX448RecipientPublic
    :: SomePKPayload -> Either PKESKEncryptError B.ByteString
extractX448RecipientPublic recipient =
    case _pubkey recipient of
        EdDSAPubKey EdSigningCurve448 point ->
            normalizeX448Public (edPointBytes point)
        ECDHPubKey (EdDSAPubKey EdSigningCurve448 point) _ _ ->
            normalizeX448Public (edPointBytes point)
        other ->
            Left
                ( InvalidRecipientKeyMaterial
                    X448
                    ("expected X448-compatible recipient key, got " ++ show other)
                )

normalizeX25519Public
    :: B.ByteString -> Either PKESKEncryptError B.ByteString
normalizeX25519Public =
    first (InvalidRecipientKeyMaterial X25519)
        . normalizeMontgomeryPublic
            32
            "invalid X25519 public key length/prefix: "

normalizeX448Public
    :: B.ByteString -> Either PKESKEncryptError B.ByteString
normalizeX448Public =
    first (InvalidRecipientKeyMaterial X448)
        . normalizeMontgomeryPublic
            56
            "invalid X448 public key length/prefix: "

edPointBytes :: EdPoint -> B.ByteString
edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x
edPointBytes (NativeEPoint (EPoint x)) = i2osp x

deriveX25519Kek
    :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX25519Kek ephemeralPublic recipientPublic sharedSecret =
    let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
        prk = extract @CHAlg.SHA256 B.empty ikm
        info = "OpenPGP X25519" :: B.ByteString
     in expand @CHAlg.SHA256 prk info 16

deriveX448Kek
    :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX448Kek ephemeralPublic recipientPublic sharedSecret =
    let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
        prk = extract @CHAlg.SHA512 B.empty ikm
        info = "OpenPGP X448" :: B.ByteString
     in expand @CHAlg.SHA512 prk info 32

padToMultipleOf8 :: B.ByteString -> B.ByteString
padToMultipleOf8 bs
    | padLen == 0 = bs
    | otherwise = bs <> B.replicate padLen (fromIntegral padLen)
  where
    rem8 = B.length bs `mod` 8
    padLen = if rem8 == 0 then 0 else 8 - rem8

checksum16 :: B.ByteString -> Word16
checksum16 =
    fromIntegral
        . B.foldl'
            (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))
            0

checksum16Bytes :: B.ByteString -> B.ByteString
checksum16Bytes bs =
    B.pack
        [ fromIntegral ((chk `shiftR` 8) .&. 0xff)
        , fromIntegral (chk .&. 0xff)
        ]
  where
    chk = checksum16 bs

aesKeyWrapRFC3394
    :: SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> Either String B.ByteString
aesKeyWrapRFC3394 sa kek plain =
    withAESCipher
        "ECDH PKESK currently supports AES KEK algorithms only"
        sa
        kek
        wrapWithCipher
  where
    wrapWithCipher
        :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString
    wrapWithCipher cipher = do
        if B.length plain < 16 || B.length plain `mod` 8 /= 0
            then
                Left
                    "ECDH key wrap input must be at least 16 octets and a multiple of 8"
            else Right ()
        let rs = chunksOf8 plain
        if length rs < 2
            then
                Left
                    "ECDH key wrap input must contain at least two 64-bit blocks"
            else Right ()
        (aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs
        Right (aFinal <> B.concat rFinal)
    wrapRounds
        :: CCT.BlockCipher cipher
        => cipher
        -> B.ByteString
        -> [B.ByteString]
        -> Either String (B.ByteString, [B.ByteString])
    wrapRounds cipher aInit rsInit = goJ 0 aInit rsInit
      where
        n = length rsInit
        goJ j a rs
            | j > 5 = Right (a, rs)
            | otherwise = do
                (a', rs') <- goI 1 a rs
                goJ (j + 1) a' rs'
          where
            goI i curA curRs
                | i > n = Right (curA, curRs)
                | otherwise = do
                    let t = fromIntegral (n * j + i) :: Word64
                        rI = curRs !! (i - 1)
                        block = CCT.ecbEncrypt cipher (curA <> rI)
                        (msb, lsb) = B.splitAt 8 block
                        aNext = xorBS msb (encodeWord64be t)
                        rsNext = (ix (i - 1) .~ lsb) curRs
                    goI (i + 1) aNext rsNext

chunksOf8 :: B.ByteString -> [B.ByteString]
chunksOf8 bs
    | B.null bs = []
    | otherwise =
        let (h, t) = B.splitAt 8 bs
         in h : chunksOf8 t

xorBS :: B.ByteString -> B.ByteString -> B.ByteString
xorBS a b = B.pack (B.zipWith xor a b)

encryptSEIPDv1WithSKESK
    :: MonadRandom m
    => SymmetricAlgorithm
    -> S2K
    -> Maybe IV
    -> BL.ByteString
    -> B.ByteString
    -> m (Either String [Pkt])
encryptSEIPDv1WithSKESK symalgo s2k ivOverride passphrase literalPayload = do
    let eSessionKey = do
            keyLen <- symKeySize symalgo
            first renderS2KError (string2Key s2k keyLen passphrase)
    case eSessionKey of
        Left err -> pure (Left err)
        Right sessionKeyMaterial ->
            case first
                renderCipherError
                (withSymmetricCipher symalgo sessionKeyMaterial (pure . blockSize)) of
                Left err -> pure (Left err)
                Right ivLength -> do
                    ivBytes <-
                        maybe
                            (getRandomBytes ivLength)
                            (pure . unIV)
                            ivOverride
                    let iv = IV ivBytes
                    let sessionKey = SessionKey sessionKeyMaterial
                    case encryptSEIPDv1Payload symalgo iv sessionKey literalPayload of
                        Left err -> pure (Left err)
                        Right encrypted ->
                            pure
                                ( Right
                                    [ SKESKPkt
                                        ( SKESKPayloadV4Packet
                                            (SKESKPayloadV4 symalgo s2k Nothing)
                                        )
                                    , SymEncIntegrityProtectedDataPkt
                                        (SEIPD1 1 (BL.fromStrict encrypted))
                                    ]
                                )

encryptSEIPDv2WithSKESK
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> S2K
    -> BL.ByteString
    -> B.ByteString
    -> Either String [Pkt]
encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do
    keyLen <- symKeySize symalgo
    sessionKeyMaterial <-
        first renderS2KError (string2Key s2k keyLen passphrase)
    (_, nonceSize) <-
        aeadModeAndNonceSizeForSEIPDv2
            "unsupported AEAD algorithm for SKESK v6 encrypt"
            aead
    when (B.length (unSalt salt) < nonceSize) $
        Left "SEIPD v2 salt is too short to derive the SKESK v6 IV"
    let skeskIV = B.take nonceSize (unSalt salt)
    kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial
    (wrappedSessionKey, skeskTag) <-
        encryptSKESK6SessionKey
            symalgo
            aead
            kek
            skeskIV
            sessionKeyMaterial
    let sessionKey = SessionKey sessionKeyMaterial
    encrypted <-
        encryptSEIPDv2Payload
            symalgo
            aead
            chunkSize
            salt
            sessionKey
            literalPayload
    return
        [ SKESKPkt
            ( SKESKPayloadV6Packet
                ( SKESKPayloadV6
                    symalgo
                    aead
                    s2k
                    (BL.fromStrict skeskIV)
                    (BL.fromStrict wrappedSessionKey)
                    (BL.fromStrict skeskTag)
                )
            )
        , SymEncIntegrityProtectedDataPkt
            (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict encrypted))
        ]

encryptSEIPDv2WithSKESKBlock
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> S2K
    -> BL.ByteString
    -> Block Pkt
    -> Either String [Pkt]
encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock =
    encryptSEIPDv2WithSKESK
        symalgo
        aead
        chunkSize
        salt
        s2k
        passphrase
        (BL.toStrict (runPut (put packetBlock)))

encryptSEIPDv2LiteralDataWithSKESK
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> S2K
    -> BL.ByteString
    -> B.ByteString
    -> Either String [Pkt]
encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload =
    encryptSEIPDv2WithSKESKBlock
        symalgo
        aead
        chunkSize
        salt
        s2k
        passphrase
        ( Block
            [ LiteralDataPkt
                BinaryData
                BL.empty
                (ThirtyTwoBitTimeStamp 0)
                (BL.fromStrict payload)
            ]
        )

encryptSEIPDv2Payload
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> SessionKey
    -> B.ByteString
    -> Either String B.ByteString
encryptSEIPDv2Payload symalgo aead chunkSize salt (SessionKey sessionKey) plaintext = do
    (mode, nonceSize) <- aeadModeAndNonceSize aead
    keyLen <- symKeySize symalgo
    let outputLen = keyLen + nonceSize - 8
        info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aead, chunkSize]
        prk = extract @CHAlg.SHA256 (unSalt salt) sessionKey
        okm = expand @CHAlg.SHA256 prk info outputLen :: B.ByteString
        messageKey = B.take keyLen okm
        noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm)
    withAESCipher
        "SEIPD v2 encrypt currently supports AES-128/192/256 only"
        symalgo
        messageKey
        (encryptChunks mode info chunkSize noncePrefix plaintext)

encryptChunks
    :: CCT.BlockCipher cipher
    => CCT.AEADMode
    -> B.ByteString
    -> Word8
    -> B.ByteString
    -> B.ByteString
    -> cipher
    -> Either String B.ByteString
encryptChunks mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0
  where
    chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6)
    go idx remaining acc totalPlain
        | B.null remaining = do
            (finalTag, finalCipher) <-
                if mode == CCT.AEAD_OCB
                    then
                        encryptWithOCBRFC7253
                            cipher
                            (noncePrefix <> encodeWord64be idx)
                            (info <> encodeWord64be (fromIntegral totalPlain))
                            B.empty
                    else do
                        aead <- initAEAD idx
                        let (tag, out) =
                                CCT.aeadSimpleEncrypt
                                    aead
                                    (info <> encodeWord64be (fromIntegral totalPlain))
                                    B.empty
                                    16
                        Right (tag, out)
            if B.null finalCipher
                then return (B.concat (reverse acc) <> authTagToBS finalTag)
                else Left "expected empty ciphertext for final SEIPD v2 tag"
        | otherwise = do
            let (chunkPlain, rest) = B.splitAt chunkLen remaining
            (tag, chunkCipher) <-
                if mode == CCT.AEAD_OCB
                    then
                        encryptWithOCBRFC7253
                            cipher
                            (noncePrefix <> encodeWord64be idx)
                            info
                            chunkPlain
                    else do
                        aead <- initAEAD idx
                        pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16)
            let chunkOut = chunkCipher <> authTagToBS tag
            go
                (idx + 1)
                rest
                (chunkOut : acc)
                (totalPlain + B.length chunkPlain)

    initAEAD idx =
        first show . CE.eitherCryptoError $
            CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx)

aeadModeAndNonceSize
    :: AEADAlgorithm -> Either String (CCT.AEADMode, Int)
aeadModeAndNonceSize =
    aeadModeAndNonceSizeForSEIPDv2
        "unsupported AEAD algorithm for SEIPD v2 encrypt"

symKeySize :: SymmetricAlgorithm -> Either String Int
symKeySize =
    seipdv2SymmetricKeySize
        "unsupported symmetric algorithm for SEIPD v2 encrypt"

authTagToBS :: CCT.AuthTag -> B.ByteString
authTagToBS = BA.convert . CCT.unAuthTag

encodeWord64be :: Word64 -> B.ByteString
encodeWord64be = BL.toStrict . runPut . putWord64be

{- | Compose a complete AEAD-encrypted message with optional literal data and signature.
Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization.

Example: @composeMessageWithSEIPDv2 AES256 OCB 6 (Salt 32 bytes)
           (SimpleS2K SHA256) passphrase payload Nothing@
returns @[SKESK v6, SEIPD v2, <ciphertext>]@

If the signature is provided, it will be included in the encrypted payload.
-}
composeMessageWithSEIPDv2
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> S2K
    -> BL.ByteString
    -> B.ByteString
    -> Maybe [Pkt]
    -> Either String [Pkt]
composeMessageWithSEIPDv2 symalgo aead chunkSize salt s2k passphrase payload mSigs = do
    let packets = case mSigs of
            Nothing ->
                [ LiteralDataPkt
                    BinaryData
                    BL.empty
                    (ThirtyTwoBitTimeStamp 0)
                    (BL.fromStrict payload)
                ]
            Just sigs ->
                LiteralDataPkt
                    BinaryData
                    BL.empty
                    (ThirtyTwoBitTimeStamp 0)
                    (BL.fromStrict payload)
                    : sigs
        blockPayload = Block packets
    encryptSEIPDv2WithSKESKBlock
        symalgo
        aead
        chunkSize
        salt
        s2k
        passphrase
        blockPayload
