-- Decrypt.hs: OpenPGP (RFC9580) recursive packet decryption
-- Copyright © 2013-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}

module Data.Conduit.OpenPGP.Decrypt
    ( conduitDecrypt
    , conduitDecryptWithReport
    , DecryptOptions (..)
    , DecryptKeyResolution (..)
    , PKESKRecipientKey (..)
    , PKESKAttemptFailureKind (..)
    , PKESKAttemptFailure (..)
    , DecryptOutcome (..)
    , DecryptReport (..)
    , DecryptSessionKeyResolutionReport (..)
    , DecryptSessionKeyResolutionPath (..)
    , PKESKResolverAttempt (..)
    , PKESKResolverAttemptAction (..)
    , decryptSEIPDv2Payload
    ) where

import Control.Applicative ((<|>))
import Control.Exception (SomeException, displayException, try)
import Control.Lens (ix, (.~))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import qualified Crypto.Error as CE
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
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.Types as ECCT
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Data.Bifunctor (first)
import Data.Binary (get)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bits (countLeadingZeros, shiftL, shiftR, xor)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.IORef
    ( IORef
    , modifyIORef'
    , newIORef
    , readIORef
    , writeIORef
    )
import qualified Data.IxSet.Typed as IxSet
import Data.List (intercalate, nub)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import Data.Word (Word16, Word64, Word8)
import qualified "crypton" Crypto.Cipher.Types as CCT

import Codec.Encryption.OpenPGP.BlockCipher
    ( keySize
    , renderCipherError
    )
import Codec.Encryption.OpenPGP.CFB
    ( calculateMDC
    , decryptOpenPGPCfb
    , decryptPreservingNonce
    , validateSEIPD1MDC
    )
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Internal (leftPadTo)
import Codec.Encryption.OpenPGP.Internal.CryptoAES
    ( withAESCipher
    )
import Codec.Encryption.OpenPGP.Internal.CryptoECDH
    ( buildECDHKDFParam
    , deriveECDHKek
    , normalizeMontgomeryPublic
    )
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
    ( aeadModeAndNonceSizeForSEIPDv2
    , decryptSKESK6SessionKey
    , deriveSKESK6KEK
    , seipdv2SymmetricKeySize
    )
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB
    ( decryptWithOCBRFC7253With
    )
import Codec.Encryption.OpenPGP.Policy
    ( DecryptPolicy (..)
    , defaultDecryptPolicy
    , validateTable30PolicyForRecipient
    )
import Codec.Encryption.OpenPGP.S2K
    ( S2KError (..)
    , decodeOpenPGPEncodedSessionKey
    , renderEncodedSessionKeyError
    , renderS2KError
    , skesk2Key
    , skesk2SessionKey
    , string2Key
    )
import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Compression (conduitDecompress)
import Data.Conduit.OpenPGP.Keyring.Instances ()

data RecursorState
    = RecursorState
    { _depth :: Int
    , _pendingESKs :: [PendingESK]
    , _lastNonce :: Maybe B.ByteString
    , _lastClearText :: Maybe B.ByteString
    , _decryptPolicy :: DecryptPolicy
    }
    deriving (Eq, Show)

def :: RecursorState
def = RecursorState 0 [] Nothing Nothing defaultDecryptPolicy

data DecryptStreamPhase
    = ActiveDecryptPhase
    | FinishedDecryptPhase
    | MalformedDecryptPhase

data DecryptStreamState (phase :: DecryptStreamPhase) where
    ActiveDecryptState
        :: RecursorState
        -> DecryptStreamState 'ActiveDecryptPhase
    FinishedDecryptState
        :: RecursorState
        -> Bool
        -> DecryptStreamState 'FinishedDecryptPhase
    MalformedDecryptState
        :: RecursorState
        -> String
        -> DecryptStreamState 'MalformedDecryptPhase

data SomeDecryptStreamState where
    SomeDecryptStreamState
        :: DecryptStreamState phase
        -> SomeDecryptStreamState

data PendingESK
    = PendingPKESK PKESKPayload
    | PendingSKESK SKESKPayload
    deriving (Eq, Show)

data EncryptedPayloadVersion
    = LegacyEncryptedPayloadVersion
    | SEIPDv2EncryptedPayloadVersion

data EncryptedPayloadFlavor (v :: EncryptedPayloadVersion) where
    LegacyEncryptedPayload
        :: EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
    SEIPDv2EncryptedPayload
        :: SymmetricAlgorithm
        -> AEADAlgorithm
        -> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion

type InputCallback m = String -> m BL.ByteString

data PKESKRecipientKey
    = PKESKRecipientKey
    { pkeskRecipientPKPayload :: Maybe SomePKPayload
    {- ^ Public key payload for the recipient.  Required for X25519, X448,
    and ECDH unwrap paths; may be 'Nothing' for RSA.
    -}
    , pkeskRecipientSKey :: SKey
    -- ^ Corresponding secret key.
    }

data PKESKAttemptFailure
    = PKESKAttemptFailure
    { pkeskAttemptFailureKeyContext
        :: Maybe (KeyVersion, PubKeyAlgorithm)
    , pkeskAttemptFailureKind :: PKESKAttemptFailureKind
    , pkeskAttemptFailureReason :: String
    }
    deriving (Eq, Show)

data PKESKAttemptFailureKind
    = PKESKAttemptUnwrapFailed
    | PKESKAttemptSessionMaterialDecodeFailed
    deriving (Eq, Show)

data PKESKResolverError
    = ResolverPolicyDenied String
    | ResolverBackendUnavailable String
    | ResolverInvalidResponse String
    deriving (Eq, Show)

data PKESKResolveRequest
    = PKESKResolveRequest
    { reqPKESK :: PKESKPayload
    , reqProbePacket :: Pkt
    , reqIsWildcardRecipient :: Bool
    , reqAttemptIndex :: Int
    , reqPreviousFailures :: [PKESKAttemptFailure]
    }
    deriving (Eq, Show)

data PKESKResolveAction
    = ResolveWith PKESKRecipientKey
    | ResolveSkip
    | ResolveExhausted
    | ResolveFail PKESKResolverError

type PKESKResolver m =
    PKESKResolveRequest -> m PKESKResolveAction

{- | Build a stateful 'PKESKResolver' that iterates over a pre-populated
candidate list. The returned resolver yields candidates in order and
returns 'ResolveExhausted' once the list is depleted.
| How to resolve secret keys for PKESK-encrypted messages.
-}
data DecryptKeyResolution
    = {- | Do not attempt PKESK decryption; fall through to manual session-key
      input via the passphrase callback instead.
      -}
      DecryptWithoutPKESK
    | {- | Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret
      keys (not passphrase-protected) are used. For passphrase-protected keys,
      use 'DecryptWithKeyringAndPassphrase'.
      -}
      DecryptWithKeyring SecretKeyring
    | {- | Resolve secret keys from a 'SecretKeyring', unlocking passphrase-
      protected keys using the provided callback. The callback receives the
      public key payload and returns the passphrase, or 'Nothing' to skip.
      -}
      DecryptWithKeyringAndPassphrase
        SecretKeyring
        (SomePKPayload -> IO (Maybe BL.ByteString))
    | {- | Preferred callback form for non-keyring key material. The callback
      receives a typed key identifier (8-octet key ID, fingerprint, or
      wildcard) plus the packet public-key algorithm, then returns all
      matching candidates in priority order. hOpenPGP iterates candidates
      deterministically without re-calling the callback for each retry.
      -}
      DecryptWithUnwrapCandidatesCallback
        (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])

{- | Canonical decrypt configuration.

Most callers should prefer 'conduitDecrypt' and set:

* 'decryptOptionsKeyResolution' to 'DecryptWithKeyring' or 'DecryptWithKeyringAndPassphrase'
* 'decryptOptionsPolicy' to strict ('defaultDecryptPolicy') or lenient
* 'decryptOptionsPassphraseCallback' for SKESK passphrase lookup
-}
data DecryptOptions
    = DecryptOptions
    { decryptOptionsKeyResolution :: DecryptKeyResolution
    , decryptOptionsPolicy :: DecryptPolicy
    , decryptOptionsPassphraseCallback :: InputCallback IO
    }

{- | Outcome of a checked decrypt conduit run.

Use 'conduitDecrypt' to obtain this value. Because
'Data.Conduit..|' preserves the
/rightmost/ conduit's return value, callers who also need the decrypted
packet stream should use 'Data.Conduit.fuseBoth':

@
(outcome, pkts) \<- runConduit $ source .| fuseBoth (conduitDecrypt opts) CL.consume
@
-}
data DecryptOutcome
    = {- | The integrity-terminating marker (MDC or SEIPD v2 final AEAD tag)
      was seen and no further packets arrived.  The message was
      well-formed end-to-end.
      -}
      DecryptClean
    | {- | The input stream ended before any integrity-terminating marker was
      seen.  The ciphertext was incomplete.
      -}
      DecryptTruncated
    | {- | An integrity-terminating marker was seen, but additional packets
      followed it.  Only possible with 'lenientDecryptPolicy' (strict
      policy reports 'DecryptMalformedStructure' instead).  The trailing
      packets were forwarded downstream unchanged.
      -}
      DecryptTrailingData
    | {- | A structural packet-sequencing violation was detected.  The
      'String' describes the specific violation:

      * PKESK version does not match the SEIPD version (e.g. a v6 PKESK
      preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2
      payload).

      * ESK packets arrived in the wrong order relative to the encrypted
      data packet (e.g. a literal-data packet appeared between a PKESK
      and the SEIPD it was intended to protect).

      * A packet arrived after the message integrity boundary (trailing
      data).  Under 'defaultDecryptPolicy' this is reported here; under
      'lenientDecryptPolicy' it is reported as 'DecryptTrailingData'
      instead.
      -}
      DecryptMalformedStructure String
    deriving (Eq, Show)

data DecryptSessionKeyResolutionPath
    = DecryptResolvedViaSKESK
    | DecryptResolvedViaPKESK
    | DecryptResolvedViaManualPKESKInput
    deriving (Eq, Show)

data PKESKResolverAttemptAction
    = ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm))
    | ResolverAttemptSkip
    | ResolverAttemptExhausted
    | ResolverAttemptFail PKESKResolverError
    deriving (Eq, Show)

data PKESKResolverAttempt
    = PKESKResolverAttempt
    { pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure]
    -- ^ Failures from earlier attempts on the same PKESK packet.
    , pkeskResolverAttemptAction :: PKESKResolverAttemptAction
    }
    deriving (Eq, Show)

data DecryptSessionKeyResolutionReport
    = DecryptSessionKeyResolutionReport
    { decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath
    , decryptSessionResolutionSKESKErrors :: [String]
    , decryptSessionResolutionPKESKErrors :: [String]
    , decryptSessionResolutionResolverAttempts
        :: [PKESKResolverAttempt]
    }
    deriving (Eq, Show)

data DecryptReport
    = DecryptReport
    { decryptReportOutcome :: DecryptOutcome
    , decryptReportSessionKeyResolutions
        :: [DecryptSessionKeyResolutionReport]
    }
    deriving (Eq, Show)

-- | AEAD decryption context (Reader monad eliminates parameter threading)
data AEADDecryptContext cipher
    = AEADDecryptContext
    { aeadMode :: CCT.AEADMode
    , aeadInfo :: B.ByteString
    , aeadChunkSize :: Word8
    , aeadNoncePrefix :: B.ByteString
    , aeadCipher :: cipher
    }

-- | ReaderT wrapper for AEAD decryption computations
type AEADDecrypt cipher =
    ReaderT (AEADDecryptContext cipher) (Either String)

conduitDecrypt
    :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
    => DecryptOptions
    -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecrypt opts =
    decryptReportOutcome <$> conduitDecryptWithReport opts

conduitDecryptWithReport
    :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
    => DecryptOptions
    -> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport opts = do
    reportRef <- liftIO (newIORef [])
    resolver <-
        liftIO (buildDecryptResolver (decryptOptionsKeyResolution opts))
    let allowManualPKESKPrompt =
            case decryptOptionsKeyResolution opts of
                DecryptWithoutPKESK -> True
                _ -> False
    outcome <-
        conduitDecryptChecked'
            (def {_decryptPolicy = decryptOptionsPolicy opts})
            allowManualPKESKPrompt
            resolver
            (decryptOptionsPassphraseCallback opts)
            (Just reportRef)
    resolutions <- reverse <$> liftIO (readIORef reportRef)
    pure
        DecryptReport
            { decryptReportOutcome = outcome
            , decryptReportSessionKeyResolutions = resolutions
            }

-- | Build an internal 'PKESKResolver' from the public 'DecryptKeyResolution'.
buildDecryptResolver
    :: DecryptKeyResolution -> IO (PKESKResolver IO)
buildDecryptResolver DecryptWithoutPKESK =
    pure (\_ -> pure ResolveExhausted)
buildDecryptResolver (DecryptWithKeyring kr) =
    buildKeyringResolver kr Nothing
buildDecryptResolver (DecryptWithKeyringAndPassphrase kr cb) =
    buildKeyringResolver kr (Just cb)
buildDecryptResolver (DecryptWithUnwrapCandidatesCallback cb) =
    buildUnwrapCandidatesResolver cb

-- | Build a stateful resolver that looks up keys from a 'SecretKeyring'.
buildKeyringResolver
    :: SecretKeyring
    -> Maybe (SomePKPayload -> IO (Maybe BL.ByteString))
    -> IO (PKESKResolver IO)
buildKeyringResolver kr maybePassphraseCb = do
    -- Tracks (last PKESK, remaining wildcard candidates once initialized).
    stateRef <-
        newIORef
            ( Nothing :: Maybe PKESKPayload
            , Nothing :: Maybe [PKESKRecipientKey]
            , [] :: [(Pkt, [PKESKRecipientKey])]
            )
    pure $ \req -> do
        let pkesk = reqPKESK req
            probe = reqProbePacket req
        (lastPKESK, wildcardState, exactCache) <- readIORef stateRef
        let freshPKESK = Just pkesk /= lastPKESK
        when freshPKESK $ writeIORef stateRef (Just pkesk, Nothing, [])
        let wc = if freshPKESK then Nothing else wildcardState
            ec = if freshPKESK then [] else exactCache
        case extractProbeKeyIdentifier probe of
            KeyIdentifierWildcard -> do
                -- Wildcard probe: iterate all keys
                candidates <- case wc of
                    Nothing -> keyringCandidates (IxSet.toList kr)
                    Just cs -> pure cs
                case candidates of
                    [] -> do
                        writeIORef stateRef (Just pkesk, Just [], ec)
                        pure ResolveExhausted
                    (rk : rest) -> do
                        writeIORef stateRef (Just pkesk, Just rest, ec)
                        pure (ResolveWith rk)
            keyIdentifier -> do
                -- Exact probe: direct lookup by key ID or fingerprint.
                candidates <- case lookup probe ec of
                    Just cs -> pure cs
                    Nothing -> do
                        let matchingTKs = matchingTKsForRecipient keyIdentifier
                        cs <- keyringCandidates matchingTKs
                        writeIORef
                            stateRef
                            ( Just pkesk
                            , wc
                            , (probe, cs) : filter ((/= probe) . fst) ec
                            )
                        pure cs
                let priorFailures = length (reqPreviousFailures req)
                case drop priorFailures candidates of
                    [] -> pure ResolveSkip
                    (rk : _) -> pure (ResolveWith rk)
  where
    matchingTKsForRecipient :: KeyIdentifier -> [TK 'SecretTK]
    matchingTKsForRecipient keyIdentifier =
        case keyIdentifier of
            KeyIdentifierWildcard -> IxSet.toList kr
            KeyIdentifierEightOctet rid -> IxSet.toList (kr IxSet.@= rid)
            KeyIdentifierFingerprint rid ->
                let indexedMatches = IxSet.toList (kr IxSet.@= rid)
                 in if null indexedMatches
                        then filter (tkMatchesRecipientFingerprint rid) (IxSet.toList kr)
                        else indexedMatches

    tkMatchesRecipientFingerprint
        :: Fingerprint -> TK 'SecretTK -> Bool
    tkMatchesRecipientFingerprint rid tk =
        any
            (keyPktMatchesRecipientFingerprint rid)
            (_tkPrimaryKey tk : map fst (_tkSubs tk))

    keyPktMatchesRecipientFingerprint
        :: Fingerprint -> KeyPkt 'SecretPkt -> Bool
    keyPktMatchesRecipientFingerprint rid (KeyPktSecretPrimary pkp _) =
        pkPayloadMatchesRecipientFingerprint rid pkp
    keyPktMatchesRecipientFingerprint rid (KeyPktSecretSubkey pkp _) =
        pkPayloadMatchesRecipientFingerprint rid pkp

    pkPayloadMatchesRecipientFingerprint
        :: Fingerprint -> SomePKPayload -> Bool
    pkPayloadMatchesRecipientFingerprint rid pkp =
        fingerprint pkp `elem` recipientFingerprintMatchVariants rid

    recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint]
    recipientFingerprintMatchVariants (Fingerprint rid)
        | BL.length rid == 20 =
            [Fingerprint rid, Fingerprint (BL.cons 0x04 rid)]
        | BL.length rid == 21 && BL.head rid == 0x04 =
            [Fingerprint rid, Fingerprint (BL.tail rid)]
        | BL.length rid == 32 =
            [Fingerprint rid, Fingerprint (BL.cons 0x06 rid)]
        | BL.length rid == 33 && BL.head rid == 0x06 =
            [Fingerprint rid, Fingerprint (BL.tail rid)]
        | otherwise = [Fingerprint rid]

    keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey]
    keyringCandidates tks = concat <$> mapM tkCandidates tks

    tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey]
    tkCandidates tk =
        fmap catMaybes . mapM resolveKeyPair $
            _tkPrimaryKey tk : map fst (_tkSubs tk)

    resolveKeyPair
        :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey)
    resolveKeyPair (KeyPktSecretPrimary pkp (SUUnencrypted sk _)) =
        pure $
            Just
                PKESKRecipientKey
                    { pkeskRecipientPKPayload = Just pkp
                    , pkeskRecipientSKey = sk
                    }
    resolveKeyPair (KeyPktSecretSubkey pkp (SUUnencrypted sk _)) =
        pure $
            Just
                PKESKRecipientKey
                    { pkeskRecipientPKPayload = Just pkp
                    , pkeskRecipientSKey = sk
                    }
    resolveKeyPair (KeyPktSecretPrimary pkp ska) = unlockProtected pkp ska
    resolveKeyPair (KeyPktSecretSubkey pkp ska) = unlockProtected pkp ska

    unlockProtected
        :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey)
    unlockProtected pkp ska =
        case maybePassphraseCb of
            Nothing -> pure Nothing
            Just passphraseCb -> do
                mPassphrase <- passphraseCb pkp
                case mPassphrase of
                    Nothing -> pure Nothing
                    Just passphrase ->
                        case decryptPrivateKey (pkp, ska) passphrase of
                            Left _ -> pure Nothing
                            Right (SUUnencrypted sk _) ->
                                pure $
                                    Just
                                        PKESKRecipientKey
                                            { pkeskRecipientPKPayload = Just pkp
                                            , pkeskRecipientSKey = sk
                                            }
                            Right _ -> pure Nothing

buildUnwrapCandidatesResolver
    :: (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
    -> IO (PKESKResolver IO)
buildUnwrapCandidatesResolver cb = do
    stateRef <-
        newIORef
            ( Nothing :: Maybe PKESKPayload
            , [] :: [(Pkt, [PKESKRecipientKey])]
            , [] :: [SKey]
            )
    pure $ \req -> do
        let pkesk = reqPKESK req
            probePkt = reqProbePacket req
        (lastPKESK, probeState, seenSKeys) <- readIORef stateRef
        let freshPKESK = Just pkesk /= lastPKESK
        when freshPKESK $ writeIORef stateRef (Just pkesk, [], [])
        let state0 = if freshPKESK then [] else probeState
            seen0 = if freshPKESK then [] else seenSKeys
        case lookup probePkt state0 of
            Just (next : rest) -> do
                writeIORef
                    stateRef
                    ( Just pkesk
                    , updateProbeState probePkt rest state0
                    , pkeskRecipientSKey next : seen0
                    )
                pure (ResolveWith next)
            Just [] ->
                pure ResolveSkip
            Nothing -> do
                candidates <-
                    filterFreshCandidates seen0 <$> callbackCandidates probePkt
                case candidates of
                    [] -> do
                        writeIORef
                            stateRef
                            (Just pkesk, updateProbeState probePkt [] state0, seen0)
                        pure ResolveSkip
                    (next : rest) -> do
                        writeIORef
                            stateRef
                            ( Just pkesk
                            , updateProbeState probePkt rest state0
                            , pkeskRecipientSKey next : seen0
                            )
                        pure (ResolveWith next)
  where
    callbackCandidates probePkt =
        cb
            (extractProbeKeyIdentifier probePkt)
            (extractProbePKA probePkt)

    updateProbeState probePkt remaining state0 =
        (probePkt, remaining) : filter ((/= probePkt) . fst) state0

    filterFreshCandidates seenSKeys =
        filter
            (\candidate -> pkeskRecipientSKey candidate `notElem` seenSKeys)

-- | Extract the recipient identifier from a PKESK probe packet.
extractProbeKeyIdentifier :: Pkt -> KeyIdentifier
extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid _ _)))
    | isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard
    | otherwise = KeyIdentifierEightOctet rid
extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)))
    | BL.null rid = KeyIdentifierWildcard
    | otherwise = KeyIdentifierFingerprint (Fingerprint rid)
extractProbeKeyIdentifier _ = KeyIdentifierWildcard

isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId (EightOctetKeyId rid) =
    BL.length rid == 8 && BL.all (== 0) rid

-- | Extract the public-key algorithm from a PKESK probe packet.
extractProbePKA :: Pkt -> PubKeyAlgorithm
extractProbePKA (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) = pka
extractProbePKA (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ pka _))) = pka
extractProbePKA _ = RSA -- fallback; should not be reached

-- | Core implementation: manual await loop so we can return a 'DecryptOutcome'.
conduitDecryptChecked'
    :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecryptChecked' rs0 allowManualPKESKPrompt pkcb cb reportRef =
    loop (SomeDecryptStreamState (ActiveDecryptState rs0))
  where
    loop
        :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
        => SomeDecryptStreamState -> ConduitT Pkt Pkt m DecryptOutcome
    loop streamState = do
        case streamState of
            SomeDecryptStreamState (MalformedDecryptState _ reason) ->
                return (DecryptMalformedStructure reason)
            SomeDecryptStreamState state -> do
                mpkt <- await
                case mpkt of
                    Nothing -> return (finalOutcome state)
                    Just pkt -> do
                        (state', pkts) <- lift (push pkt state)
                        mapM_ yield pkts
                        loop state'

    push
        :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
        => Pkt
        -> DecryptStreamState phase
        -> m (SomeDecryptStreamState, [Pkt])
    push i (ActiveDecryptState s)
        | _depth s > 42 = fail "I think we've been quine-attacked"
        | hasPendingESKPrelude s && not (packetCanFollowESKPrelude i) =
            return
                ( SomeDecryptStreamState
                    ( MalformedDecryptState
                        s
                        "Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data"
                    )
                , []
                )
        | otherwise =
            let dp = _decryptPolicy s
             in case i of
                    SKESKPkt payload ->
                        do
                            when (decryptRejectDeprecatedSKESK dp) $
                                case skeskPayloadS2K payload of
                                    Simple _ ->
                                        fail
                                            "SKESK uses Simple S2K specifier, which is deprecated by RFC9580 policy"
                                    Salted _ _ ->
                                        fail
                                            "SKESK uses Salted S2K specifier, which is deprecated by RFC9580 policy"
                                    _ -> pure ()
                            return
                                ( SomeDecryptStreamState
                                    ( ActiveDecryptState
                                        (s {_pendingESKs = PendingSKESK payload : _pendingESKs s})
                                    )
                                , []
                                )
                    PKESKPkt p ->
                        return
                            ( SomeDecryptStreamState
                                ( ActiveDecryptState
                                    (s {_pendingESKs = PendingPKESK p : _pendingESKs s})
                                )
                            , []
                            )
                    (SymEncDataPkt bs) ->
                        if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s
                            then
                                return
                                    ( SomeDecryptStreamState
                                        ( MalformedDecryptState
                                            s
                                            ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with "
                                                ++ "legacy SED payload"
                                            )
                                        )
                                    , []
                                    )
                            else do
                                when (not (decryptAllowSEDNoIntegrity dp)) $
                                    fail
                                        "Received unauthenticated SED (Symmetrically Encrypted Data) packet; \
                                        \RFC9580 policy requires integrity-protected SEIPD. \
                                        \Use lenientDecryptPolicy to permit legacy messages."
                                (symalgo, sessionKey) <-
                                    resolveSessionKey
                                        s
                                        allowManualPKESKPrompt
                                        pkcb
                                        cb
                                        LegacyEncryptedPayload
                                        reportRef
                                checkDecryptSymmetricAlgo dp symalgo
                                d <-
                                    decryptSEDP
                                        s {_pendingESKs = []}
                                        allowManualPKESKPrompt
                                        pkcb
                                        cb
                                        reportRef
                                        symalgo
                                        sessionKey
                                        bs
                                -- SED is the terminal outer-stream packet.
                                return (finalizeOuterEncryptedPayload s d)
                    (SymEncIntegrityProtectedDataPkt (SEIPD1 _ bs)) ->
                        if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s
                            then
                                return
                                    ( SomeDecryptStreamState
                                        ( MalformedDecryptState
                                            s
                                            ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with "
                                                ++ "SEIPDv1 payload"
                                            )
                                        )
                                    , []
                                    )
                            else do
                                when (not (decryptAllowSEIPDv1 dp)) $
                                    fail
                                        "Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only."
                                (symalgo, sessionKey) <-
                                    resolveSessionKey
                                        s
                                        allowManualPKESKPrompt
                                        pkcb
                                        cb
                                        LegacyEncryptedPayload
                                        reportRef
                                checkDecryptSymmetricAlgo dp symalgo
                                d <-
                                    decryptSEIPDP
                                        s {_pendingESKs = []}
                                        allowManualPKESKPrompt
                                        pkcb
                                        cb
                                        reportRef
                                        symalgo
                                        sessionKey
                                        bs
                                -- The outer SEIPD1 packet is terminal; inner MDC is handled by
                                -- the recursive conduit's own _seenMessageEnd tracking.
                                return (finalizeOuterEncryptedPayload s d)
                    (SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) ->
                        if hasESKPayloadVersionMismatch dp (SEIPDv2EncryptedPayload sa aa) s
                            then
                                return
                                    ( SomeDecryptStreamState
                                        ( MalformedDecryptState
                                            s
                                            ( "ESK/payload version mismatch: ESK packets present but none are version-aligned with "
                                                ++ "SEIPDv2 payload"
                                            )
                                        )
                                    , []
                                    )
                            else do
                                checkDecryptSymmetricAlgo dp sa
                                checkDecryptAEADAlgo dp aa
                                (_, sessionKey) <-
                                    resolveSessionKey
                                        s
                                        allowManualPKESKPrompt
                                        pkcb
                                        cb
                                        (SEIPDv2EncryptedPayload sa aa)
                                        reportRef
                                d <-
                                    decryptSEIPDv2P
                                        s {_pendingESKs = []}
                                        allowManualPKESKPrompt
                                        pkcb
                                        cb
                                        reportRef
                                        sa
                                        aa
                                        chunkSize
                                        salt
                                        sessionKey
                                        bs
                                -- SEIPD2 final AEAD tag was verified inside decryptSEIPDv2P.
                                return (finalizeOuterEncryptedPayload s d)
                    m@(ModificationDetectionCodePkt mdc) -> do
                        when (isNothing (_lastClearText s)) $ fail "MDC with no referent"
                        let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s
                        expectedMdc <-
                            case mcalculated of
                                Nothing -> fail "MDC with no nonce or cleartext"
                                Just Nothing -> fail "MDC referent is too short"
                                Just (Just x) -> return x
                        when (expectedMdc /= mdc) $
                            fail $
                                "MDC indicates tampering: "
                                    ++ show mdc
                                    ++ " versus "
                                    ++ maybe "<empty>" show mcalculated
                                    ++ "  ... "
                                    ++ show (_lastNonce s)
                                    ++ " / "
                                    ++ show (_lastClearText s)
                        -- MDC is the integrity boundary inside a SEIPD1 inner stream.
                        return
                            ( SomeDecryptStreamState (FinishedDecryptState s False)
                            , [m]
                            )
                    -- RFC9580 Padding Packet (tag 21) can be ignored after decryption.
                    (PaddingPkt _) ->
                        return (SomeDecryptStreamState (ActiveDecryptState s), [])
                    (OtherPacketPkt t _)
                        | t < 40 ->
                            fail
                                ("Unknown critical packet type in packet sequence: " ++ show t)
                    (OtherPacketPkt _ _) ->
                        return (SomeDecryptStreamState (ActiveDecryptState s), [])
                    p ->
                        return (SomeDecryptStreamState (ActiveDecryptState s), [p])
    push i (FinishedDecryptState s hadTrailing) =
        if decryptRejectTrailingData (_decryptPolicy s)
            then
                return
                    ( SomeDecryptStreamState
                        ( MalformedDecryptState
                            s
                            "packet received after message integrity boundary"
                        )
                    , []
                    )
            else
                return
                    (SomeDecryptStreamState (FinishedDecryptState s True), [i])
    push _ malformedState@(MalformedDecryptState _ _) =
        return (SomeDecryptStreamState malformedState, [])

    hasPendingESKPrelude s = not (null (_pendingESKs s))

    hasESKPayloadVersionMismatch dp payloadFlavor state =
        decryptRejectESKVersionMismatch dp
            && hasPendingESKPrelude state
            && null (alignedPrecedingESKs payloadFlavor (_pendingESKs state))

    finalizeOuterEncryptedPayload state decryptedPkts =
        ( SomeDecryptStreamState
            (FinishedDecryptState (state {_pendingESKs = []}) False)
        , decryptedPkts
        )

    finalOutcome :: DecryptStreamState phase -> DecryptOutcome
    finalOutcome (ActiveDecryptState _) = DecryptTruncated
    finalOutcome (FinishedDecryptState _ hadTrailing) =
        if hadTrailing
            then DecryptTrailingData
            else DecryptClean
    finalOutcome (MalformedDecryptState _ reason) =
        DecryptMalformedStructure reason

    packetCanFollowESKPrelude pkt =
        case pkt of
            SKESKPkt _ -> True
            PKESKPkt _ -> True
            SymEncDataPkt _ -> True
            SymEncIntegrityProtectedDataPkt _ -> True
            MarkerPkt _ -> True
            OtherPacketPkt 21 _ -> True
            _ -> False

{- | Describes what integrity-terminating marker (if any) an inner packet
stream is expected to contain.  Passed to 'checkInnerOutcome' to
distinguish a legitimate end-of-stream from a missing marker.
-}
data InnerIntegrityExpectation
    = {- | The inner stream has no integrity-terminating packet.  SED has none
      by design; SEIPD2 authenticates via AEAD before the conduit runs.
      'DecryptTruncated' is the normal end-of-stream outcome.
      -}
      NoIntegrityMarker

{- | Propagate non-clean inner-stream outcomes as a 'fail'.  Called after each
recursive decrypt helper so that structural violations and (for SEIPD1) a
missing MDC are not silently swallowed.
-}
checkInnerOutcome
    :: MonadFail m
    => InnerIntegrityExpectation -> DecryptOutcome -> m ()
checkInnerOutcome _ DecryptClean = pure ()
checkInnerOutcome _ DecryptTrailingData = pure ()
checkInnerOutcome NoIntegrityMarker DecryptTruncated = pure ()
checkInnerOutcome _ (DecryptMalformedStructure reason) =
    fail
        ("Inner encrypted payload had malformed structure: " ++ reason)

decryptSEDP
    :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> SymmetricAlgorithm
    -> SessionKey
    -> BL.ByteString
    -> m [Pkt]
decryptSEDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do
    decrypted <-
        case decryptOpenPGPCfb symalgo (BL.toStrict bs) sessionKey of
            Left e -> fail (renderCipherError e)
            Right x -> pure x
    (innerOutcome, pkts) <-
        decryptInnerPackets
            rs
            allowManualPKESKPrompt
            pkcb
            cb
            reportRef
            decrypted
    checkInnerOutcome NoIntegrityMarker innerOutcome
    pure pkts

decryptSEIPDP
    :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> SymmetricAlgorithm
    -> SessionKey
    -> BL.ByteString
    -> m [Pkt]
decryptSEIPDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do
    (nonce, decrypted) <-
        case decryptPreservingNonce symalgo (BL.toStrict bs) sessionKey of
            Left e -> fail (renderCipherError e)
            Right x -> pure x
    decryptedWithoutMDC <-
        case validateSEIPD1MDC nonce decrypted of
            Left err -> fail err
            Right x -> pure x
    (innerOutcome, pkts) <-
        decryptInnerPackets
            rs
            allowManualPKESKPrompt
            pkcb
            cb
            reportRef
            decryptedWithoutMDC
    checkInnerOutcome NoIntegrityMarker innerOutcome
    pure pkts

decryptSEIPDv2P
    :: (MonadFail m, MonadIO m, MonadThrow m, MonadUnliftIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> SessionKey
    -> BL.ByteString
    -> m [Pkt]
decryptSEIPDv2P rs allowManualPKESKPrompt pkcb cb reportRef symalgo aeadalgo chunkSize salt sessionKey bs = do
    let decrypted =
            decryptSEIPDv2Payload
                symalgo
                aeadalgo
                chunkSize
                salt
                (BL.toStrict bs)
                sessionKey
    case decrypted of
        Left e -> fail e
        Right cleartext -> do
            (innerOutcome, pkts) <-
                decryptInnerPackets
                    rs
                    allowManualPKESKPrompt
                    pkcb
                    cb
                    reportRef
                    cleartext
            checkInnerOutcome NoIntegrityMarker innerOutcome
            pure pkts

decryptInnerPackets
    :: (MonadFail m, MonadThrow m, MonadUnliftIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> B.ByteString
    -> m (DecryptOutcome, [Pkt])
decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext =
    runConduitRes $
        CB.sourceLbs (BL.fromStrict cleartext)
            .| conduitGet get
            .| conduitDecompress
            .| fuseBoth
                ( conduitDecryptChecked'
                    rs {_depth = _depth rs + 1}
                    allowManualPKESKPrompt
                    pkcb
                    cb
                    reportRef
                )
                CL.consume

decryptSEIPDv2Payload
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> B.ByteString
    -> SessionKey
    -> Either String B.ByteString
decryptSEIPDv2Payload symalgo aeadalgo chunkSize salt encrypted (SessionKey sessionKey) = do
    when (chunkSize > 16) $
        Left "SEIPD v2 chunk size octet must be between 0 and 16"
    (mode, nonceSize) <- aeadModeAndNonceSize aeadalgo
    keyLen <- symKeySize symalgo
    let outputLen = keyLen + nonceSize - 8
    when (B.length (unSalt salt) /= 32) $
        Left "SEIPD v2 salt must be exactly 32 octets"
    when (B.length encrypted < 32) $
        Left
            "SEIPD v2 ciphertext must include at least one chunk tag and a final tag"
    let info =
            B.pack
                [0xd2, 2, fromFVal symalgo, fromFVal aeadalgo, chunkSize]
        prk = extract @CHA.SHA256 (unSalt salt) sessionKey
        okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString
        messageKey = B.take keyLen okm
        noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm)
    decryptSEIPDv2WithKey
        symalgo
        mode
        chunkSize
        info
        noncePrefix
        messageKey
        encrypted

decryptSEIPDv2WithKey
    :: SymmetricAlgorithm
    -> CCT.AEADMode
    -> Word8
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> B.ByteString
    -> Either String B.ByteString
decryptSEIPDv2WithKey symalgo mode chunkSize info noncePrefix sessionKey encrypted =
    withAESCipher
        "SEIPD v2 decrypt currently supports AES-128/192/256 only"
        symalgo
        sessionKey
        (decryptChunks mode info chunkSize noncePrefix encrypted)

decryptChunks
    :: CCT.BlockCipher cipher
    => CCT.AEADMode
    -> B.ByteString
    -> Word8
    -> B.ByteString
    -> B.ByteString
    -> cipher
    -> Either String B.ByteString
decryptChunks mode info chunkSize noncePrefix encrypted cipher =
    let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher
     in runReaderT decryptChunksWithReader ctx
  where
    decryptChunksWithReader
        :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString
    decryptChunksWithReader = go 0 encrypted [] 0
      where
        chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6)
        tagLen = 16

        go idx remaining acc totalPlain
            | B.length remaining < 2 * tagLen =
                lift $
                    Left
                        "SEIPD v2 ciphertext is too short for chunk and final authentication tags"
            | otherwise = do
                let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen
                    currentChunkLen =
                        if hasMoreChunks
                            then chunkLen
                            else B.length remaining - 2 * tagLen
                when (currentChunkLen < 0) $
                    lift $
                        Left "SEIPD v2 malformed chunk lengths"
                let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining
                    (chunkTag, r2) = B.splitAt tagLen r1
                plainChunk <-
                    decryptChunkWithContext idx chunkCiphertext chunkTag
                if hasMoreChunks
                    then
                        go
                            (idx + 1)
                            r2
                            (plainChunk : acc)
                            (totalPlain + B.length plainChunk)
                    else do
                        when (B.length r2 /= tagLen) $
                            lift $
                                Left "SEIPD v2 missing final authentication tag"
                        verifyFinalTagWithContext
                            (idx + 1)
                            (totalPlain + B.length plainChunk)
                            r2
                        return (B.concat (reverse (plainChunk : acc)))

        decryptChunkWithContext idx chunkCiphertext chunkTag = do
            AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask
            if mode' == CCT.AEAD_OCB
                then
                    lift $
                        decryptWithOCBRFC7253With
                            (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed")
                            cipher'
                            (noncePrefix' <> encodeWord64be idx)
                            info
                            chunkCiphertext
                            (mkAuthTag chunkTag)
                else do
                    aead <- initAEADWithContext idx
                    let mPlain =
                            CCT.aeadSimpleDecrypt
                                aead
                                info
                                chunkCiphertext
                                (mkAuthTag chunkTag)
                    case mPlain of
                        Nothing -> lift $ Left "SEIPD v2 chunk authentication failed"
                        Just p -> return p

        verifyFinalTagWithContext idx totalPlain finalTag = do
            AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask
            if mode' == CCT.AEAD_OCB
                then do
                    plain <-
                        lift $
                            decryptWithOCBRFC7253With
                                (\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed")
                                cipher'
                                (noncePrefix' <> encodeWord64be idx)
                                (info <> encodeWord64be (fromIntegral totalPlain))
                                B.empty
                                (mkAuthTag finalTag)
                    if B.null plain
                        then return ()
                        else
                            lift $
                                Left "SEIPD v2 final authentication tag verification failed"
                else do
                    aead <- initAEADWithContext idx
                    let mEmpty =
                            CCT.aeadSimpleDecrypt
                                aead
                                (info <> encodeWord64be (fromIntegral totalPlain))
                                B.empty
                                (mkAuthTag finalTag)
                    case mEmpty of
                        Just p | B.null p -> return ()
                        _ ->
                            lift $
                                Left "SEIPD v2 final authentication tag verification failed"

        initAEADWithContext idx = do
            AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask
            lift $
                first show . CE.eitherCryptoError $
                    CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx)

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

symKeySize :: SymmetricAlgorithm -> Either String Int
symKeySize =
    seipdv2SymmetricKeySize
        "SEIPD v2 decrypt currently supports AES-128/192/256 only"

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

mkAuthTag :: B.ByteString -> CCT.AuthTag
mkAuthTag = CCT.AuthTag . BA.convert

checkDecryptSymmetricAlgo
    :: MonadFail m => DecryptPolicy -> SymmetricAlgorithm -> m ()
checkDecryptSymmetricAlgo dp sa =
    case decryptAllowedSymmetricAlgos dp of
        Nothing -> pure ()
        Just allowed
            | sa `elem` allowed -> pure ()
            | otherwise ->
                fail $
                    "Decrypt policy rejects symmetric algorithm "
                        ++ show sa
                        ++ "; allowed: "
                        ++ show allowed

checkDecryptAEADAlgo
    :: MonadFail m => DecryptPolicy -> AEADAlgorithm -> m ()
checkDecryptAEADAlgo dp aa =
    case decryptAllowedAEADAlgos dp of
        Nothing -> pure ()
        Just allowed
            | aa `elem` allowed -> pure ()
            | otherwise ->
                fail $
                    "Decrypt policy rejects AEAD algorithm "
                        ++ show aa
                        ++ "; allowed: "
                        ++ show allowed

skeskPayloadSymmetricAlgorithm
    :: SKESKPayload -> SymmetricAlgorithm
skeskPayloadSymmetricAlgorithm payload =
    case classifySKESKPayload payload of
        ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa _ _) -> sa
        ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa _ _ _ _ _) -> sa

skeskPayloadS2K :: SKESKPayload -> S2K
skeskPayloadS2K payload =
    case classifySKESKPayload payload of
        ClassifiedSKESKPayloadV4 (SKESKPayloadV4 _ s2k _) -> s2k
        ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ _ s2k _ _ _) -> s2k

skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm
skeskPayloadAEADAlgorithm payload =
    case classifySKESKPayload payload of
        ClassifiedSKESKPayloadV4 _ -> Nothing
        ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa

resolveSKESKSessionKey
    :: BL.ByteString -> SKESKPayload -> Either String B.ByteString
resolveSKESKSessionKey passphrase payload =
    first renderSKESKSessionKeyResolutionError $
        resolveSKESKSessionKeyTyped
            passphrase
            (classifySKESKPayload payload)

data SKESKSessionKeyResolutionError
    = SKESKSessionKeyS2KError S2KError
    | SKESKSessionKeyOtherError String
    deriving (Eq, Show)

renderSKESKSessionKeyResolutionError
    :: SKESKSessionKeyResolutionError -> String
renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err
renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err

resolveSKESKSessionKeyTyped
    :: BL.ByteString
    -> ClassifiedSKESKPayload
    -> Either SKESKSessionKeyResolutionError B.ByteString
resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) =
    first
        SKESKSessionKeyS2KError
        (skesk2Key (SKESK4Packet sa s2k Nothing) passphrase)
resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) =
    first
        SKESKSessionKeyS2KError
        ( snd
            <$> skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase
        )
resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do
    keyLen <-
        first
            (SKESKSessionKeyS2KError . S2KUnsupportedAlgorithm)
            (keySize sa)
    ikm <-
        first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase)
    kek <-
        first SKESKSessionKeyOtherError (deriveSKESK6KEK sa aead ikm)
    first
        SKESKSessionKeyOtherError
        ( decryptSKESK6SessionKey
            sa
            aead
            kek
            (BL.toStrict iv)
            (BL.toStrict esk)
            (BL.toStrict tag)
        )

data ClassifiedSKESKPayload where
    ClassifiedSKESKPayloadV4
        :: SKESKPayloadV4 -> ClassifiedSKESKPayload
    ClassifiedSKESKPayloadV6
        :: SKESKPayloadV6 -> ClassifiedSKESKPayload

classifySKESKPayload :: SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload (SKESKPayloadV4Packet payloadV4) =
    ClassifiedSKESKPayloadV4 payloadV4
classifySKESKPayload (SKESKPayloadV6Packet payloadV6) =
    ClassifiedSKESKPayloadV6 payloadV6

resolveSessionKey
    :: (MonadFail m, MonadIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> EncryptedPayloadFlavor v
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> m (SymmetricAlgorithm, SessionKey)
resolveSessionKey rs allowManualPKESKPrompt pkcb cb payloadFlavor reportRef =
    case precedingCandidates of
        [] ->
            if null (_pendingESKs rs)
                then
                    fail
                        "Encrypted data packet has no preceding SKESK or PKESK packet"
                else
                    fail
                        "Encrypted data packet has no preceding SKESK or PKESK packet aligned with payload version"
        candidates ->
            case skeskCandidates candidates of
                [] -> resolvePKESKCandidates (pkeskCandidates candidates) [] [] []
                skesks -> do
                    passphrase <- liftIO $ cb "Input the passphrase I want"
                    resolveSKESKCandidates
                        passphrase
                        skesks
                        (pkeskCandidates candidates)
                        []
  where
    precedingCandidates
        | strictAlignment = alignedByVersion
        | null alignedByVersion = _pendingESKs rs
        | otherwise = alignedByVersion

    strictAlignment = decryptRejectESKVersionMismatch (_decryptPolicy rs)
    alignedByVersion = pendingESKsFromAligned alignedStrict
    alignedStrict = alignedPrecedingESKs payloadFlavor (_pendingESKs rs)

    skeskCandidates esks = [skesk | PendingSKESK skesk <- esks]

    pkeskCandidates esks = [pkesk | PendingPKESK pkesk <- esks]

    resolveSKESKCandidates
        :: (MonadFail m, MonadIO m)
        => BL.ByteString
        -> [SKESKPayload]
        -> [PKESKPayload]
        -> [String]
        -> m (SymmetricAlgorithm, SessionKey)
    resolveSKESKCandidates _ [] pkesks skeskErrs =
        resolvePKESKCandidates pkesks skeskErrs [] []
    resolveSKESKCandidates passphrase (skesk : rest) pkesks skeskErrs =
        case resolveSKESKCandidate passphrase skesk of
            Left err ->
                resolveSKESKCandidates
                    passphrase
                    rest
                    pkesks
                    ((skeskErrPrefix skesk ++ err) : skeskErrs)
            Right resolved -> do
                emitResolutionReport
                    (mkResolutionReport DecryptResolvedViaSKESK skeskErrs [] [])
                pure resolved

    resolveSKESKCandidate
        :: BL.ByteString
        -> SKESKPayload
        -> Either String (SymmetricAlgorithm, SessionKey)
    resolveSKESKCandidate passphrase skesk = do
        let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk
            expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor
        sessionKeyBytes <- resolveSKESKSessionKey passphrase skesk
        case expectedSymAlgo of
            Just expected
                | expected /= skeskSymAlgo ->
                    Left "SKESK/encrypted-payload symmetric algorithm mismatch"
            _ ->
                case ( payloadExpectedAEADAlgorithm payloadFlavor
                     , skeskPayloadAEADAlgorithm skesk
                     ) of
                    (Just expectedAEAD, Just skeskAEAD)
                        | expectedAEAD /= skeskAEAD ->
                            Left "SKESK/encrypted-payload AEAD algorithm mismatch"
                    _ -> Right (skeskSymAlgo, SessionKey sessionKeyBytes)

    skeskErrPrefix skesk = "[" ++ describeSKESK skesk ++ "] "

    resolvePKESKCandidates
        :: (MonadFail m, MonadIO m)
        => [PKESKPayload]
        -> [String]
        -> [String]
        -> [PKESKResolverAttempt]
        -> m (SymmetricAlgorithm, SessionKey)
    resolvePKESKCandidates [] [] [] _ =
        fail
            "Encrypted data packet has no usable preceding SKESK or PKESK packet"
    resolvePKESKCandidates [] skeskErrs [] _ =
        fail
            ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; "
                ++ "candidate errors: "
                ++ unwords (reverse skeskErrs)
            )
    resolvePKESKCandidates [] skeskErrs pkeskErrs resolverAttempts =
        if allowManualPKESKPrompt
            then do
                let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor
                    errs = skeskErrs ++ pkeskErrs
                encodedSessionKey <-
                    BL.toStrict
                        <$> liftIO
                            ( cb
                                "Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)"
                            )
                case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of
                    Left manualErr ->
                        fail
                            ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; "
                                ++ "candidate errors: "
                                ++ unwords (reverse errs)
                                ++ "; manual input failed: "
                                ++ manualErr
                            )
                    Right (sa, k) -> do
                        emitResolutionReport
                            ( mkResolutionReport
                                DecryptResolvedViaManualPKESKInput
                                skeskErrs
                                pkeskErrs
                                resolverAttempts
                            )
                        pure (sa, SessionKey k)
            else
                fail
                    ( "Encrypted data packet has no usable preceding SKESK or PKESK packet; "
                        ++ "candidate errors: "
                        ++ unwords (reverse (skeskErrs ++ pkeskErrs))
                    )
    resolvePKESKCandidates (pkesk : rest) skeskErrs pkeskErrs resolverAttempts = do
        let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor
            errPrefix = "[" ++ describePKESK pkesk ++ "] "
        attemptPKESKCandidate
            []
            []
            0
            expectedSymAlgo
            errPrefix
            resolverAttempts
      where
        attemptPKESKCandidate attemptedSKeys previousFailures attemptIndex expectedSymAlgo errPrefix resolverAttemptsAcc = do
            let callbackProbeSummary = describeCallbackProbeSummary pkesk
            resolverResult <-
                liftIO
                    (resolvePKESKRecipientKey pkesk previousFailures attemptIndex)
            case resolverResult of
                Left resolverErr ->
                    fail (errPrefix ++ resolverErr)
                Right (Nothing, _, newAttempts) ->
                    let resolverAttempts' = resolverAttemptsAcc ++ newAttempts
                        terminalError =
                            case reverse previousFailures of
                                (latestFailure : _) -> errPrefix ++ pkeskAttemptFailureReason latestFailure
                                [] ->
                                    errPrefix
                                        ++ "no matching key context (callback probes: "
                                        ++ callbackProbeSummary
                                        ++ ")"
                     in resolvePKESKCandidates
                            rest
                            skeskErrs
                            (terminalError : pkeskErrs)
                            resolverAttempts'
                Right (Just keyInfo, nextAttemptIndex, newAttempts)
                    | pkeskRecipientSKey keyInfo `elem` attemptedSKeys ->
                        let resolverAttempts' = resolverAttemptsAcc ++ newAttempts
                            terminalError =
                                case reverse previousFailures of
                                    (latestFailure : _) -> errPrefix ++ pkeskAttemptFailureReason latestFailure
                                    [] ->
                                        errPrefix
                                            ++ "key context callback repeated without yielding a usable key"
                         in resolvePKESKCandidates
                                rest
                                skeskErrs
                                (terminalError : pkeskErrs)
                                resolverAttempts'
                    | otherwise -> do
                        let resolverAttempts' = resolverAttemptsAcc ++ newAttempts
                        unwrapped <- liftIO (tryUnwrapPKESKSessionMaterial pkesk keyInfo)
                        case unwrapped of
                            Left err ->
                                attemptPKESKCandidate
                                    (pkeskRecipientSKey keyInfo : attemptedSKeys)
                                    ( previousFailures
                                        ++ [mkAttemptFailure keyInfo PKESKAttemptUnwrapFailed err]
                                    )
                                    nextAttemptIndex
                                    expectedSymAlgo
                                    errPrefix
                                    resolverAttempts'
                            Right encodedSessionKey ->
                                case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of
                                    Left err ->
                                        attemptPKESKCandidate
                                            (pkeskRecipientSKey keyInfo : attemptedSKeys)
                                            ( previousFailures
                                                ++ [ mkAttemptFailure
                                                        keyInfo
                                                        PKESKAttemptSessionMaterialDecodeFailed
                                                        err
                                                   ]
                                            )
                                            nextAttemptIndex
                                            expectedSymAlgo
                                            errPrefix
                                            resolverAttempts'
                                    Right (sa, k) -> do
                                        emitResolutionReport
                                            ( mkResolutionReport
                                                DecryptResolvedViaPKESK
                                                skeskErrs
                                                pkeskErrs
                                                resolverAttempts'
                                            )
                                        pure (sa, SessionKey k)

    emitResolutionReport
        :: MonadIO m => DecryptSessionKeyResolutionReport -> m ()
    emitResolutionReport report =
        case reportRef of
            Nothing -> pure ()
            Just ref -> liftIO (modifyIORef' ref (report :))

    mkResolutionReport
        :: DecryptSessionKeyResolutionPath
        -> [String]
        -> [String]
        -> [PKESKResolverAttempt]
        -> DecryptSessionKeyResolutionReport
    mkResolutionReport path skeskErrs pkeskErrs resolverAttempts =
        DecryptSessionKeyResolutionReport
            { decryptSessionResolutionPath = path
            , decryptSessionResolutionSKESKErrors = reverse skeskErrs
            , decryptSessionResolutionPKESKErrors = reverse pkeskErrs
            , decryptSessionResolutionResolverAttempts = resolverAttempts
            }

    mkAttemptFailure keyInfo failureKind reason =
        PKESKAttemptFailure
            { pkeskAttemptFailureKeyContext =
                recipientKeyContext keyInfo
            , pkeskAttemptFailureKind = failureKind
            , pkeskAttemptFailureReason = reason
            }

    recipientKeyContext
        :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm)
    recipientKeyContext keyInfo =
        fmap
            (\pk -> (_keyVersion pk, _pkalgo pk))
            (pkeskRecipientPKPayload keyInfo)

    renderPKESKResolverError (ResolverPolicyDenied reason) =
        "resolver policy denied candidate selection: " ++ reason
    renderPKESKResolverError (ResolverBackendUnavailable reason) =
        "resolver backend unavailable: " ++ reason
    renderPKESKResolverError (ResolverInvalidResponse reason) =
        "resolver returned an invalid response: " ++ reason

    resolvePKESKRecipientKey payload previousFailures attemptIndex0 =
        probePacketVariants
            attemptIndex0
            []
            (pkeskCallbackPackets payload)
      where
        probePacketVariants attemptIndex attemptsAcc [] =
            pure (Right (Nothing, attemptIndex, reverse attemptsAcc))
        probePacketVariants attemptIndex attemptsAcc (probePkt : restProbePkts) = do
            let request =
                    PKESKResolveRequest
                        { reqPKESK = payload
                        , reqProbePacket = probePkt
                        , reqIsWildcardRecipient = isWildcardPKESKPayload payload
                        , reqAttemptIndex = attemptIndex
                        , reqPreviousFailures = previousFailures
                        }
            resolveAction <-
                pkcb request
            let attemptRecord =
                    PKESKResolverAttempt
                        { pkeskResolverAttemptPreviousFailures = previousFailures
                        , pkeskResolverAttemptAction =
                            case resolveAction of
                                ResolveWith keyInfo ->
                                    ResolverAttemptResolveWith (recipientKeyContext keyInfo)
                                ResolveSkip -> ResolverAttemptSkip
                                ResolveExhausted -> ResolverAttemptExhausted
                                ResolveFail resolverErr -> ResolverAttemptFail resolverErr
                        }
            case resolveAction of
                ResolveWith keyInfo ->
                    pure
                        ( Right
                            ( Just keyInfo
                            , attemptIndex + 1
                            , reverse (attemptRecord : attemptsAcc)
                            )
                        )
                ResolveSkip ->
                    probePacketVariants
                        (attemptIndex + 1)
                        (attemptRecord : attemptsAcc)
                        restProbePkts
                ResolveExhausted ->
                    pure
                        ( Right
                            ( Nothing
                            , attemptIndex + 1
                            , reverse (attemptRecord : attemptsAcc)
                            )
                        )
                ResolveFail resolverErr ->
                    pure (Left (renderPKESKResolverError resolverErr))

    pkeskCallbackPackets payload =
        nub $
            case payload of
                PKESKPayloadV3Packet (PKESKPayloadV3 v rid pka mpis) ->
                    map
                        ( \ridVariant ->
                            PKESKPkt
                                (PKESKPayloadV3Packet (PKESKPayloadV3 v ridVariant pka mpis))
                        )
                        (recipientIdCallbackVariantsV3 rid)
                PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk) ->
                    map
                        ( \ridVariant ->
                            PKESKPkt
                                (PKESKPayloadV6Packet (PKESKPayloadV6 ridVariant pka esk))
                        )
                        (recipientIdCallbackVariants rid)

    describeCallbackProbeSummary payload =
        intercalate
            ", "
            (map describePKESKCallbackProbe (pkeskCallbackPackets payload))

    describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) =
        "PKESK3 "
            ++ show pka
            ++ " rid="
            ++ show rid
            ++ if isWildcardV3RecipientKeyId rid
                then " (wildcard)"
                else ""
    describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) =
        "PKESK6 " ++ show pka ++ " rid=" ++ show rid
    describePKESKCallbackProbe pkt = show pkt

    recipientIdCallbackVariantsV3 rid
        | isWildcardV3RecipientKeyId rid = [rid]
        | otherwise = [rid, EightOctetKeyId (BL.replicate 8 0)]

    recipientIdCallbackVariants rid
        | BL.length rid == 20 = [rid, BL.cons 0x04 rid]
        | BL.length rid == 21 && BL.head rid == 0x04 = [rid, BL.tail rid]
        | BL.length rid == 32 = [rid, BL.cons 0x06 rid]
        | BL.length rid == 33 && BL.head rid == 0x06 = [rid, BL.tail rid]
        | otherwise = [rid]

    isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) =
        isWildcardV3RecipientKeyId (EightOctetKeyId rid)
    isWildcardPKESKPayload _ = False
    describePKESK payload =
        case classifyPKESKPayload payload of
            ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ rid pka _) ->
                "PKESK3 " ++ show pka ++ " rid=" ++ show rid
            ClassifiedPKESKPayloadV6 (PKESKPayloadV6 rid pka _) ->
                "PKESK6 " ++ show pka ++ " rid=" ++ show rid

    describeSKESK payload =
        case classifySKESKPayload payload of
            ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k _) ->
                "SKESK4 " ++ show sa ++ " s2k=" ++ show s2k
            ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aa s2k _ _ _) ->
                "SKESK6 " ++ show sa ++ "/" ++ show aa ++ " s2k=" ++ show s2k

data AlignedPendingESK (v :: EncryptedPayloadVersion) where
    LegacyAlignedSKESK
        :: SKESKPayloadV4
        -> AlignedPendingESK 'LegacyEncryptedPayloadVersion
    LegacyAlignedPKESK
        :: PKESKPayloadV3
        -> AlignedPendingESK 'LegacyEncryptedPayloadVersion
    SEIPDv2AlignedSKESK
        :: SKESKPayloadV6
        -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
    SEIPDv2AlignedPKESK
        :: PKESKPayloadV6
        -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
    {- | A version 3 PKESK that precedes a SEIPDv2 payload.

    RFC 9580 §5.13 explicitly permits version 3 PKESKs before a version 2
    SEIPD packet, as a backward-compatibility allowance for implementations
    that cannot yet produce v6 key material.  The v3 PKESK carries the
    session key wrapped with legacy (v3) asymmetric key wrapping; the SEIPD
    v2 payload itself is still authenticated with modern AEAD.  This
    constructor therefore counts as "aligned" for SEIPDv2 — it does not
    indicate a mis-assembled message — even though the PKESK version does
    not match the SEIPD version.
    -}
    SEIPDv2AlignedLegacyPKESK
        :: PKESKPayloadV3
        -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion

alignedPrecedingESKs
    :: EncryptedPayloadFlavor v
    -> [PendingESK]
    -> [AlignedPendingESK v]
alignedPrecedingESKs LegacyEncryptedPayload =
    mapMaybe
        ( \esk ->
            case esk of
                PendingSKESK (SKESKPayloadV4Packet skesk4) -> Just (LegacyAlignedSKESK skesk4)
                PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (LegacyAlignedPKESK pkesk3)
                _ -> Nothing
        )
alignedPrecedingESKs (SEIPDv2EncryptedPayload _ _) =
    mapMaybe
        ( \esk ->
            case esk of
                PendingSKESK (SKESKPayloadV6Packet skesk6) -> Just (SEIPDv2AlignedSKESK skesk6)
                PendingPKESK (PKESKPayloadV6Packet pkesk6) -> Just (SEIPDv2AlignedPKESK pkesk6)
                -- v3 PKESK before SEIPDv2 is explicitly allowed by RFC 9580 §5.13;
                -- see 'SEIPDv2AlignedLegacyPKESK' for details.
                PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (SEIPDv2AlignedLegacyPKESK pkesk3)
                _ -> Nothing
        )

pendingESKsFromAligned :: [AlignedPendingESK v] -> [PendingESK]
pendingESKsFromAligned =
    map
        ( \esk ->
            case esk of
                LegacyAlignedSKESK skesk4 -> PendingSKESK (SKESKPayloadV4Packet skesk4)
                LegacyAlignedPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3)
                SEIPDv2AlignedSKESK skesk6 -> PendingSKESK (SKESKPayloadV6Packet skesk6)
                SEIPDv2AlignedPKESK pkesk6 -> PendingPKESK (PKESKPayloadV6Packet pkesk6)
                SEIPDv2AlignedLegacyPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3)
        )

payloadExpectedSymmetricAlgorithm
    :: EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm
payloadExpectedSymmetricAlgorithm LegacyEncryptedPayload = Nothing
payloadExpectedSymmetricAlgorithm (SEIPDv2EncryptedPayload sa _) = Just sa

payloadExpectedAEADAlgorithm
    :: EncryptedPayloadFlavor v -> Maybe AEADAlgorithm
payloadExpectedAEADAlgorithm LegacyEncryptedPayload = Nothing
payloadExpectedAEADAlgorithm (SEIPDv2EncryptedPayload _ aa) = Just aa

tryUnwrapPKESKSessionMaterial
    :: PKESKPayload
    -> PKESKRecipientKey
    -> IO (Either String B.ByteString)
tryUnwrapPKESKSessionMaterial pkesk keyInfo = do
    attempted <-
        try @SomeException
            (unwrapPKESKSessionMaterial pkesk keyInfo :: IO B.ByteString)
    pure (first displayException attempted)

data PKESKUnwrapCase where
    PKESKUnwrapV3RSA :: RSATypes.PrivateKey -> MPI -> PKESKUnwrapCase
    PKESKUnwrapV6RSA
        :: RSATypes.PrivateKey -> B.ByteString -> PKESKUnwrapCase
    PKESKUnwrapV6ECDH
        :: PKESKRecipientKey
        -> PubKeyAlgorithm
        -> B.ByteString
        -> ECDSA.PrivateKey
        -> PKESKUnwrapCase
    PKESKUnwrapV6XDHRaw
        :: PKESKRecipientKey
        -> PubKeyAlgorithm
        -> B.ByteString
        -> B.ByteString
        -> PKESKUnwrapCase
    PKESKUnwrapV3X25519FromECDH
        :: PKESKRecipientKey
        -> NonEmpty MPI
        -> ECDSA.PrivateKey
        -> PKESKUnwrapCase
    PKESKUnwrapV3X25519Raw
        :: PKESKRecipientKey
        -> NonEmpty MPI
        -> B.ByteString
        -> PKESKUnwrapCase
    PKESKUnwrapV3ECDH
        :: PKESKRecipientKey
        -> PubKeyAlgorithm
        -> NonEmpty MPI
        -> ECDSA.PrivateKey
        -> PKESKUnwrapCase

data ClassifiedPKESKPayload where
    ClassifiedPKESKPayloadV3
        :: PKESKPayloadV3 -> ClassifiedPKESKPayload
    ClassifiedPKESKPayloadV6
        :: PKESKPayloadV6 -> ClassifiedPKESKPayload

data ClassifiedPKESKRecipientKey where
    ClassifiedPKESKRecipientRSA
        :: PKESKRecipientKey
        -> RSATypes.PrivateKey
        -> ClassifiedPKESKRecipientKey
    ClassifiedPKESKRecipientECDH
        :: PKESKRecipientKey
        -> ECDSA.PrivateKey
        -> ClassifiedPKESKRecipientKey
    ClassifiedPKESKRecipientX25519
        :: PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey
    ClassifiedPKESKRecipientX448
        :: PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey
    ClassifiedPKESKRecipientUnsupported
        :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey

classifyPKESKPayload :: PKESKPayload -> ClassifiedPKESKPayload
classifyPKESKPayload (PKESKPayloadV3Packet payloadV3) =
    ClassifiedPKESKPayloadV3 payloadV3
classifyPKESKPayload (PKESKPayloadV6Packet payloadV6) =
    ClassifiedPKESKPayloadV6 payloadV6

classifyPKESKRecipientKey
    :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (RSAPrivateKey (RSA_PrivateKey privateKey))) =
    ClassifiedPKESKRecipientRSA keyInfo privateKey
classifyPKESKRecipientKey
    keyInfo@( PKESKRecipientKey
                    _
                    (ECDHPrivateKey (ECDSA_PrivateKey privateKey))
                ) =
        ClassifiedPKESKRecipientECDH keyInfo privateKey
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X25519PrivateKey privateKeyRaw)) =
    ClassifiedPKESKRecipientX25519 keyInfo privateKeyRaw
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X448PrivateKey privateKeyRaw)) =
    ClassifiedPKESKRecipientX448 keyInfo privateKeyRaw
classifyPKESKRecipientKey keyInfo =
    ClassifiedPKESKRecipientUnsupported keyInfo

pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm
pkeskPayloadAlgorithm payload =
    case classifyPKESKPayload payload of
        ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _) -> pka
        ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _) -> pka

classifyPKESKUnwrapCase
    :: PKESKPayload
    -> PKESKRecipientKey
    -> Either String PKESKUnwrapCase
classifyPKESKUnwrapCase payload keyInfo =
    case (classifyPKESKPayload payload, classifyPKESKRecipientKey keyInfo) of
        ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka (mpi :| []))
            , ClassifiedPKESKRecipientRSA _ privateKey
            )
                | pka == RSA || pka == DeprecatedRSAEncryptOnly ->
                    Right (PKESKUnwrapV3RSA privateKey mpi)
        ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
            , ClassifiedPKESKRecipientRSA _ privateKey
            )
                | pka == RSA ->
                    Right (PKESKUnwrapV6RSA privateKey (BL.toStrict esk))
        ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
            , ClassifiedPKESKRecipientECDH recipientCtx privateKey
            )
                | pka == ECDH || pka == X25519 ->
                    Right
                        (PKESKUnwrapV6ECDH recipientCtx pka (BL.toStrict esk) privateKey)
        ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
            , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw
            )
                | pka == X25519 ->
                    Right
                        ( PKESKUnwrapV6XDHRaw
                            recipientCtx
                            pka
                            (BL.toStrict esk)
                            privateKeyRaw
                        )
        ( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
            , ClassifiedPKESKRecipientX448 recipientCtx privateKeyRaw
            )
                | pka == X448 ->
                    Right
                        ( PKESKUnwrapV6XDHRaw
                            recipientCtx
                            pka
                            (BL.toStrict esk)
                            privateKeyRaw
                        )
        ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
            , ClassifiedPKESKRecipientECDH recipientCtx privateKey
            )
                | pka == X25519 ->
                    Right (PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey)
        ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
            , ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw
            )
                | pka == X25519 ->
                    Right (PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw)
        ( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
            , ClassifiedPKESKRecipientECDH recipientCtx privateKey
            )
                | pka == ECDH || pka == X25519 ->
                    Right (PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey)
        (ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _), _) ->
            Left
                ("PKESK key unwrap unsupported for packet algorithm " ++ show pka)
        (ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _), _) ->
            Left
                ( "PKESKv6 key unwrap unsupported for packet algorithm "
                    ++ show pka
                    ++ " with secret key "
                    ++ show (pkeskRecipientSKey keyInfo)
                )

unwrapPKESKSessionMaterial
    :: (MonadFail m, MonadIO m)
    => PKESKPayload -> PKESKRecipientKey -> m B.ByteString
unwrapPKESKSessionMaterial pkesk keyInfo = do
    either fail pure (validateTable30Policy pkesk keyInfo)
    unwrapCase <-
        either fail pure (classifyPKESKUnwrapCase pkesk keyInfo)
    case unwrapCase of
        PKESKUnwrapV3RSA privateKey mpi ->
            rsaUnwrap
                privateKey
                (leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi)))
        PKESKUnwrapV6RSA privateKey esk -> do
            normalized <-
                either fail pure (normalizePKESKv6RSAEsk privateKey esk)
            rsaUnwrap privateKey normalized
        PKESKUnwrapV6ECDH recipientCtx pka esk privateKey ->
            ecdhUnwrapV6 recipientCtx pka esk privateKey
        PKESKUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw ->
            ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw
        PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey -> do
            recipientPKP <-
                maybe
                    ( fail
                        "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                    )
                    pure
                    (pkeskRecipientPKPayload recipientCtx)
            recipientSecretRaw <-
                either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
            x25519UnwrapV3 recipientCtx mpis recipientSecretRaw
        PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw ->
            x25519UnwrapV3 recipientCtx mpis privateKeyRaw
        PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey ->
            ecdhUnwrap recipientCtx pka mpis privateKey
  where
    validateTable30Policy
        :: PKESKPayload -> PKESKRecipientKey -> Either String ()
    validateTable30Policy payload recipientCtx =
        case pkeskRecipientPKPayload recipientCtx of
            Nothing -> Right ()
            Just recipientPKP ->
                case (pkeskPayloadAlgorithm payload, _pubkey recipientPKP) of
                    (ECDH, ECDHPubKey _ kdfHA kdfSA) ->
                        validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA
                    _ -> Right ()

    rsaUnwrap privateKey encryptedSessionMaterial = do
        decrypted <-
            liftIO
                ( P15.decryptSafer privateKey encryptedSessionMaterial
                    :: IO (Either RSATypes.Error B.ByteString)
                )
        case decrypted of
            Left err -> fail ("RSA PKESK decrypt failed: " ++ show err)
            Right decoded -> pure decoded

    normalizePKESKv6RSAEsk
        :: RSATypes.PrivateKey
        -> B.ByteString
        -> Either String B.ByteString
    normalizePKESKv6RSAEsk privateKey esk = do
        when (B.length esk < 2) $
            Left "PKESKv6 RSA ESK is too short to contain an MPI"
        let mpiBits =
                fromIntegral (B.index esk 0) `shiftL` 8
                    + fromIntegral (B.index esk 1)
            mpiLen = (mpiBits + 7) `div` 8
        when (B.length esk /= 2 + mpiLen) $
            Left
                ( "PKESKv6 RSA ESK MPI length mismatch: expected "
                    ++ show (2 + mpiLen)
                    ++ " octets, got "
                    ++ show (B.length esk)
                )
        let mpiPayload = B.drop 2 esk
        when (mpiBits > 0) $ do
            when (B.null mpiPayload) $
                Left
                    "PKESKv6 RSA ESK MPI has non-zero bit length but empty payload"
            let firstOctet = B.head mpiPayload
                actualBits =
                    (B.length mpiPayload - 1) * 8
                        + (8 - countLeadingZeros firstOctet)
            when (actualBits /= mpiBits) $
                Left
                    ( "PKESKv6 RSA ESK MPI bit-length mismatch: declared "
                        ++ show mpiBits
                        ++ ", actual "
                        ++ show actualBits
                    )
        let modulusLen = rsaModulusBytes privateKey
        when (B.length mpiPayload > modulusLen) $
            Left
                ( "PKESKv6 RSA ESK MPI payload exceeds recipient modulus size: "
                    ++ show (B.length mpiPayload)
                    ++ " > "
                    ++ show modulusLen
                )
        pure (leftPadTo modulusLen mpiPayload)

    ecdhUnwrap recipientCtx pka mpis privateKey = do
        recipientPKP <-
            maybe
                ( fail
                    "ECDH PKESK unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                pure
                (pkeskRecipientPKPayload recipientCtx)
        case _pubkey recipientPKP of
            ECDHPubKey ecdhPub kdfHA kdfSA -> do
                (ephemeralBytes, wrappedSessionKeyBytes) <-
                    either fail pure (parseECDHPKESKMPIs mpis)
                sharedSecret <-
                    case ecdhPub of
                        ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do
                            ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes
                            pure
                                ( BA.convert
                                    (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint)
                                    :: B.ByteString
                                )
                        EdDSAPubKey EdSigningCurve25519 _ -> do
                            recipientSecretRaw <-
                                either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
                            recipientSecret <-
                                either fail pure
                                    . first show
                                    . CE.eitherCryptoError
                                    $ C25519.secretKey recipientSecretRaw
                            ephBytes <-
                                either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
                            ephPub <-
                                either fail pure
                                    . first show
                                    . CE.eitherCryptoError
                                    $ C25519.publicKey ephBytes
                            pure . BA.convert $ C25519.dh ephPub recipientSecret
                        EdDSAPubKey EdSigningCurve448 _ ->
                            fail
                                "legacy ECDH PKESK unwrap does not support Curve448Legacy recipients"
                        _ ->
                            fail
                                "ECDH PKESK unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible"
                param <-
                    either
                        fail
                        pure
                        (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
                kek <-
                    either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param)
                let wrappedCandidates =
                        candidateWrappedRFC3394CiphertextsForLegacyECDH
                            (LegacyECDHWrappedRFC3394Ciphertext wrappedSessionKeyBytes)
                    validUnwraps =
                        [ material
                        | wrappedCandidate <- wrappedCandidates
                        , Right decoded <-
                            [ aesKeyUnwrapRFC3394
                                kdfSA
                                kek
                                (unLegacyECDHWrappedRFC3394Ciphertext wrappedCandidate)
                            ]
                        , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded]
                        ]
                case validUnwraps of
                    (material : _) -> pure (encodeLegacyECDHSessionMaterial material)
                    [] ->
                        case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of
                            Left err -> fail err
                            Right _ ->
                                fail
                                    "legacy ECDH wrapped session key decrypted but decoded session material is malformed"
            _ ->
                fail
                    "ECDH PKESK unwrap requires recipient PKPayload with ECDHPubKey parameters"

    ecdhUnwrapV6 recipientCtx pka esk privateKey = do
        recipientPKP <-
            maybe
                ( fail
                    "ECDH PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                pure
                (pkeskRecipientPKPayload recipientCtx)
        if pka == X25519
            then do
                recipientSecretRaw <-
                    either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
                v6X25519Unwrap recipientPKP recipientSecretRaw esk
            else
                if pka == X448
                    then
                        fail
                            "X448 PKESKv6 unwrap requires an X448PrivateKey recipient secret key and recipient PKPayload context"
                    else case _pubkey recipientPKP of
                        ECDHPubKey ecdhPub kdfHA kdfSA -> do
                            (ephemeralBytes, wrappedSessionKeyBytes) <-
                                either fail pure (parsePKESKv6ECDHEsk pka esk)
                            case ecdhPub of
                                ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do
                                    ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes
                                    let sharedSecret =
                                            BA.convert
                                                (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint)
                                                :: B.ByteString
                                    param <-
                                        either
                                            fail
                                            pure
                                            (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
                                    kek <-
                                        either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param)
                                    case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of
                                        Left err -> fail err
                                        Right decoded -> pure decoded
                                EdDSAPubKey EdSigningCurve25519 _ -> do
                                    recipientSecretRaw <-
                                        either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
                                    recipientSecret <-
                                        either fail pure
                                            . first show
                                            . CE.eitherCryptoError
                                            $ C25519.secretKey recipientSecretRaw
                                    ephBytes <-
                                        either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
                                    ephPub <-
                                        either fail pure
                                            . first show
                                            . CE.eitherCryptoError
                                            $ C25519.publicKey ephBytes
                                    let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString
                                    param <-
                                        either
                                            fail
                                            pure
                                            (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
                                    let rfc6637Result =
                                            do
                                                kek <- deriveECDHKek kdfHA kdfSA sharedSecret param
                                                aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes
                                    case rfc6637Result of
                                        Right decoded -> pure decoded
                                        Left rfc6637Err -> do
                                            recipientPublicRaw <-
                                                either fail pure (extractX25519RecipientPublic recipientPKP)
                                            let kekX25519 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret
                                            case aesKeyUnwrapRFC3394 AES128 kekX25519 wrappedSessionKeyBytes of
                                                Right decoded -> pure decoded
                                                Left x25519Err ->
                                                    fail
                                                        ( "ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: "
                                                            ++ rfc6637Err
                                                            ++ ", X25519: "
                                                            ++ x25519Err
                                                            ++ ")"
                                                        )
                                EdDSAPubKey EdSigningCurve448 _ ->
                                    fail
                                        "ECDH PKESKv6 unwrap does not support Curve448Legacy recipients; use X448 PKESKv6 packets"
                                _ ->
                                    fail
                                        "ECDH PKESKv6 unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible"
                        _ ->
                            fail
                                "ECDH PKESKv6 unwrap requires recipient PKPayload with ECDHPubKey parameters"

    ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw = do
        recipientPKP <-
            maybe
                ( fail
                    "X25519/X448 PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                pure
                (pkeskRecipientPKPayload recipientCtx)
        case pka of
            X25519 -> v6X25519Unwrap recipientPKP (leftPadTo 32 privateKeyRaw) esk
            X448 -> v6X448Unwrap recipientPKP (leftPadTo 56 privateKeyRaw) esk
            _ ->
                fail
                    ( "X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got "
                        ++ show pka
                    )

    v6X25519Unwrap recipientPKP recipientSecretRaw esk = do
        recipientPublicRaw <-
            either fail pure (extractX25519RecipientPublic recipientPKP)
        (ephemeralBytes, wrappedSessionKeyBytes) <-
            either fail pure (parsePKESKv6ECDHEsk X25519 esk)
        ephBytes <-
            either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
        recipientSecret <-
            either fail pure
                . first show
                . CE.eitherCryptoError
                $ C25519.secretKey (leftPadTo 32 recipientSecretRaw)
        ephPub <-
            either fail pure
                . first show
                . CE.eitherCryptoError
                $ C25519.publicKey ephBytes
        let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString
            kek = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret
        case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of
            Left err -> fail err
            Right decoded -> pure decoded

    extractX25519RecipientPublic recipientPKP =
        case _pubkey recipientPKP of
            EdDSAPubKey EdSigningCurve25519 point ->
                normalizeX25519EphemeralPublic (edPointBytes point)
            ECDHPubKey (EdDSAPubKey EdSigningCurve25519 point) _ _ ->
                normalizeX25519EphemeralPublic (edPointBytes point)
            other ->
                Left
                    ( "X25519 PKESKv6 unwrap requires an X25519 recipient public key, got "
                        ++ show other
                    )

    extractX448RecipientPublic recipientPKP =
        case _pubkey recipientPKP of
            EdDSAPubKey EdSigningCurve448 point ->
                normalizeX448EphemeralPublic (edPointBytes point)
            ECDHPubKey (EdDSAPubKey EdSigningCurve448 point) _ _ ->
                normalizeX448EphemeralPublic (edPointBytes point)
            other ->
                Left
                    ( "X448 PKESKv6 unwrap requires an X448 recipient public key, got "
                        ++ show other
                    )

    resolveX25519SecretRaw recipientPKP privateKey = do
        recipientPublicRaw <- extractX25519RecipientPublic recipientPKP
        let secretBE = leftPadTo 32 (i2osp (ECDSA.private_d privateKey))
            candidates = [secretBE, B.reverse secretBE]
            matchesCandidate candidate =
                case CE.eitherCryptoError (C25519.secretKey candidate) of
                    Right sk ->
                        let derivedPub = BA.convert (C25519.toPublic sk) :: B.ByteString
                         in derivedPub == recipientPublicRaw
                    Left _ -> False
        case filter matchesCandidate candidates of
            (candidate : _) -> Right candidate
            [] -> Right secretBE

    v6X448Unwrap recipientPKP recipientSecretRaw esk = do
        recipientPublicRaw <-
            either fail pure (extractX448RecipientPublic recipientPKP)
        (ephemeralBytes, wrappedSessionKeyBytes) <-
            either fail pure (parsePKESKv6ECDHEsk X448 esk)
        ephBytes <-
            either fail pure (normalizeX448EphemeralPublic ephemeralBytes)
        recipientSecret <-
            either fail pure
                . first show
                . CE.eitherCryptoError
                $ C448.secretKey (leftPadTo 56 recipientSecretRaw)
        ephPub <-
            either fail pure
                . first show
                . CE.eitherCryptoError
                $ C448.publicKey ephBytes
        let sharedSecret = BA.convert (C448.dh ephPub recipientSecret) :: B.ByteString
            kek = deriveX448Kek ephBytes recipientPublicRaw sharedSecret
        case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of
            Left err -> fail err
            Right decoded -> pure decoded

    x25519UnwrapV3 recipientCtx mpis recipientSecretRaw = do
        recipientPKP <-
            maybe
                ( fail
                    "X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                pure
                (pkeskRecipientPKPayload recipientCtx)
        recipientPublicRaw <-
            either fail pure (extractX25519RecipientPublic recipientPKP)
        (ephemeralBytes, eskBytes) <-
            either fail pure (parseECDHPKESKMPIs mpis)
        ephBytes <-
            either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
        recipientSecret <-
            either fail pure
                . first show
                . CE.eitherCryptoError
                $ C25519.secretKey (leftPadTo 32 recipientSecretRaw)
        ephPub <-
            either fail pure
                . first show
                . CE.eitherCryptoError
                $ C25519.publicKey ephBytes
        let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString
            kek9580 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret
            -- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key)
            rfc9580Result = do
                (sessionAlgorithm, wrappedKey) <-
                    parsePKESKv3X25519EskBytes eskBytes
                rawKey <- aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey
                expectedLen <- symmetricKeyLength sessionAlgorithm
                when (B.length rawKey /= expectedLen) $
                    Left
                        ( "X25519 PKESKv3 unwrapped session key length mismatch for "
                            ++ show sessionAlgorithm
                            ++ ": expected "
                            ++ show expectedLen
                            ++ ", got "
                            ++ show (B.length rawKey)
                        )
                Right
                    ( B.singleton (fromIntegral (fromFVal sessionAlgorithm))
                        <> rawKey
                        <> checksum16Bytes rawKey
                    )
        case rfc9580Result of
            Right result -> pure result
            Left rfc9580Err ->
                -- Fallback: legacy ECDH interpretation where the full eskBytes is
                -- AES-KW(algo || key || checksum || padding).  Try with the RFC9580
                -- X25519 KEK and, when available, the RFC6637 ECDH KEK derived from
                -- any ECDH parameters on the recipient public key.
                let kekPairs =
                        (kek9580, AES128)
                            : x25519LegacyECDHKekCandidates recipientPKP sharedSecret
                    wrapped = LegacyECDHWrappedRFC3394Ciphertext eskBytes
                    candidates = candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped
                    validResults =
                        [ encodeLegacyECDHSessionMaterial material
                        | (kek, kekSA) <- kekPairs
                        , candidate <- candidates
                        , Right decoded <-
                            [ aesKeyUnwrapRFC3394
                                kekSA
                                kek
                                (unLegacyECDHWrappedRFC3394Ciphertext candidate)
                            ]
                        , Right material <- [parseLegacyECDHDecodedSessionMaterial decoded]
                        ]
                 in case validResults of
                        (result : _) -> pure result
                        [] ->
                            fail
                                ( "X25519 PKESKv3 unwrap failed (RFC9580: "
                                    ++ rfc9580Err
                                    ++ "; legacy ECDH-style fallback also failed)"
                                )

    -- \| Derive RFC6637 ECDH KEK candidates for legacy X25519 PKESKv3 fallback.
    -- Returns @(kek, kekAlgorithm)@ pairs for each plausible ECDH KDF
    -- parameterisation found on the recipient public key.
    x25519LegacyECDHKekCandidates
        :: SomePKPayload
        -> B.ByteString
        -> [(B.ByteString, SymmetricAlgorithm)]
    x25519LegacyECDHKekCandidates pkPayload sharedSecret =
        case _pubkey pkPayload of
            ECDHPubKey ecdhPub kdfHA kdfSA ->
                [ (kek, kdfSA)
                | Right param <-
                    [buildECDHKDFParam pkPayload X25519 ecdhPub kdfHA kdfSA]
                , Right kek <- [deriveECDHKek kdfHA kdfSA sharedSecret param]
                ]
            _ -> []

rsaModulusBytes :: RSATypes.PrivateKey -> Int
rsaModulusBytes
    ( RSATypes.PrivateKey
            (RSATypes.PublicKey sizeField _ _)
            _
            _
            _
            _
            _
            _
        ) =
        sizeField

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

parseECDHPKESKMPIs
    :: NonEmpty MPI -> Either String (B.ByteString, B.ByteString)
parseECDHPKESKMPIs (ephemeralMPI :| [wrappedMPI]) =
    Right (i2osp (unMPI ephemeralMPI), i2osp (unMPI wrappedMPI))
parseECDHPKESKMPIs _ =
    Left
        "ECDH PKESK must contain exactly two MPIs (ephemeral key, wrapped session key)"

newtype LegacyECDHWrappedRFC3394Ciphertext
    = LegacyECDHWrappedRFC3394Ciphertext
    { unLegacyECDHWrappedRFC3394Ciphertext :: B.ByteString
    }
    deriving (Eq)

newtype LegacyECDHSessionKey = LegacyECDHSessionKey {unLegacyECDHSessionKey :: B.ByteString}

newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding
    {unLegacyECDHSessionPadding :: B.ByteString}

data LegacyECDHDecodedSessionMaterial
    = LegacyECDHDecodedSessionMaterial
    { legacyECDHSessionAlgorithm :: SymmetricAlgorithm
    , legacyECDHSessionKey :: LegacyECDHSessionKey
    , legacyECDHSessionPadding :: LegacyECDHSessionPadding
    }

candidateWrappedRFC3394CiphertextsForLegacyECDH
    :: LegacyECDHWrappedRFC3394Ciphertext
    -> [LegacyECDHWrappedRFC3394Ciphertext]
candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped =
    let observedLen = B.length (unLegacyECDHWrappedRFC3394Ciphertext wrapped)
        plausibleWrappedLens = legacyECDHRFC3394WrappedLengths
        reconstructed =
            [ LegacyECDHWrappedRFC3394Ciphertext
                ( if observedLen == targetLen
                    then unLegacyECDHWrappedRFC3394Ciphertext wrapped
                    else
                        leftPadTo
                            targetLen
                            (unLegacyECDHWrappedRFC3394Ciphertext wrapped)
                )
            | targetLen <- plausibleWrappedLens
            , targetLen >= observedLen
            ]
     in nub (wrapped : reconstructed)

legacyECDHRFC3394WrappedLengths :: [Int]
legacyECDHRFC3394WrappedLengths =
    map legacyRFC3394WrappedLenForKeyLen [16, 24, 32]
  where
    legacyRFC3394WrappedLenForKeyLen keyLen =
        let encodedLen = 1 + keyLen + 2
            paddedLen = ((encodedLen + 7) `div` 8) * 8
         in paddedLen + 8

parseLegacyECDHDecodedSessionMaterial
    :: B.ByteString -> Either String LegacyECDHDecodedSessionMaterial
parseLegacyECDHDecodedSessionMaterial decoded = do
    when (B.length decoded < 3) $
        Left "legacy ECDH decoded session material is too short"
    let sessionAlgorithm = toFVal (B.head decoded)
    sessionKeyLen <- symmetricKeyLength sessionAlgorithm
    let payload = B.tail decoded
    when (B.length payload < sessionKeyLen + 2) $
        Left
            "legacy ECDH decoded session material does not contain full key and checksum"
    let (sessionKey, checksumAndPad) = B.splitAt sessionKeyLen payload
        (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad
        expectedChecksum =
            fromIntegral (B.index checksumBytes 0) `shiftL` 8
                + fromIntegral (B.index checksumBytes 1)
        actualChecksum = checksum16 sessionKey
    when (actualChecksum /= expectedChecksum) $
        Left "legacy ECDH decoded session-key checksum mismatch"
    if B.null padBytes || B.all (== 0) padBytes
        then
            Right
                ( LegacyECDHDecodedSessionMaterial
                    sessionAlgorithm
                    (LegacyECDHSessionKey sessionKey)
                    (LegacyECDHSessionPadding padBytes)
                )
        else do
            validatePKCS7Padding padBytes
            Right
                ( LegacyECDHDecodedSessionMaterial
                    sessionAlgorithm
                    (LegacyECDHSessionKey sessionKey)
                    (LegacyECDHSessionPadding padBytes)
                )

encodeLegacyECDHSessionMaterial
    :: LegacyECDHDecodedSessionMaterial -> B.ByteString
encodeLegacyECDHSessionMaterial
    ( LegacyECDHDecodedSessionMaterial
            sessionAlgorithm
            (LegacyECDHSessionKey sessionKey)
            _
        ) =
        B.singleton (fromIntegral (fromFVal sessionAlgorithm))
            <> sessionKey
            <> checksum16Bytes sessionKey

parsePKESKv6ECDHEsk
    :: PubKeyAlgorithm
    -> B.ByteString
    -> Either String (B.ByteString, B.ByteString)
parsePKESKv6ECDHEsk pka esk
    | pka == X25519 =
        case parseFixedEphemeralWithWrappedLen 32 esk of
            Right parsed -> Right parsed
            Left _ -> parseLenPrefixedEphemeral 32 esk
    | pka == X448 =
        case parseFixedEphemeralWithWrappedLen 56 esk of
            Right parsed -> Right parsed
            Left _ -> parseLenPrefixedEphemeral 56 esk
    | B.length esk < 33 =
        Left "PKESKv6 ECDH ESK is too short"
    | otherwise =
        let withLen =
                let ephLen = fromIntegral (B.head esk)
                    rest = B.tail esk
                 in if ephLen > 0 && B.length rest > ephLen
                        then
                            let (eph, wrapped) = B.splitAt ephLen rest
                             in if validWrappedPayload wrapped
                                    then Just (eph, wrapped)
                                    else Nothing
                        else Nothing
            fixed32WithWrappedLen = parseFixedEphemeralWithWrappedLenMaybe 32 esk
            fixed32 =
                let (eph, wrapped) = B.splitAt 32 esk
                 in if validWrappedPayload wrapped
                        then Just (eph, wrapped)
                        else Nothing
            mpiWithWrappedLen =
                if B.length esk >= 4
                    then
                        let mpiBits =
                                fromIntegral (B.index esk 0) `shiftL` 8
                                    + fromIntegral (B.index esk 1)
                            mpiLen = (mpiBits + 7) `div` 8
                            rest = B.drop (2 + mpiLen) esk
                         in if mpiLen > 0 && B.length esk > 2 + mpiLen && not (B.null rest)
                                then
                                    let eph = B.take mpiLen (B.drop 2 esk)
                                        wrappedLen = fromIntegral (B.head rest)
                                        wrapped = B.tail rest
                                     in if wrappedLen == B.length wrapped && validWrappedPayload wrapped
                                            then Just (eph, wrapped)
                                            else Nothing
                                else Nothing
                    else Nothing
         in case fixed32WithWrappedLen
                <|> withLen
                <|> fixed32
                <|> mpiWithWrappedLen of
                Just x -> Right x
                Nothing ->
                    Left
                        "PKESKv6 ECDH ESK could not be parsed as {ephemeral32||len||wrapped}, {len||ephemeral||wrapped}, {ephemeral32||wrapped}, or {mpi(ephemeral)||len||wrapped}"
  where
    validWrappedPayload wrapped = B.length wrapped >= 24 && B.length wrapped `mod` 8 == 0

    parseFixedEphemeralWithWrappedLenMaybe ephLen payload =
        let (eph, rest) = B.splitAt ephLen payload
         in if B.length rest >= 2
                then
                    let wrappedLen = fromIntegral (B.head rest)
                        wrapped = B.tail rest
                     in if wrappedLen == B.length wrapped && validWrappedPayload wrapped
                            then Just (eph, wrapped)
                            else Nothing
                else Nothing

    parseFixedEphemeralWithWrappedLen ephLen payload =
        maybe
            ( Left
                ( "PKESKv6 XDH ESK expected {ephemeral"
                    ++ show ephLen
                    ++ "||len||wrapped} framing"
                )
            )
            Right
            (parseFixedEphemeralWithWrappedLenMaybe ephLen payload)

    parseLenPrefixedEphemeral expectedLen payload =
        if B.null payload
            then Left "PKESKv6 XDH ESK is empty"
            else
                let ephLen = fromIntegral (B.head payload)
                    rest = B.tail payload
                 in if ephLen == expectedLen && B.length rest > ephLen
                        then
                            let (eph, wrapped) = B.splitAt ephLen rest
                             in if validWrappedPayload wrapped
                                    then Right (eph, wrapped)
                                    else Left "PKESKv6 XDH ESK wrapped payload has invalid length"
                        else
                            Left
                                ( "PKESKv6 XDH ESK expected "
                                    ++ show expectedLen
                                    ++ "-octet ephemeral value"
                                )

normalizeX25519EphemeralPublic
    :: B.ByteString -> Either String B.ByteString
normalizeX25519EphemeralPublic =
    normalizeMontgomeryPublic
        32
        "invalid X25519 ephemeral public key length/prefix: "

normalizeX448EphemeralPublic
    :: B.ByteString -> Either String B.ByteString
normalizeX448EphemeralPublic =
    normalizeMontgomeryPublic
        56
        "invalid X448 ephemeral public key length/prefix: "

parseUncompressedPointForCurve
    :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point
parseUncompressedPointForCurve curve bs
    | B.length bs < 1 = fail "ECDH ephemeral point is empty"
    | Just expectedLen <- expectedUncompressedPointLength curve
    , B.length bs /= expectedLen =
        fail
            ( "ECDH ephemeral point has invalid length for recipient curve: expected "
                ++ show expectedLen
                ++ ", got "
                ++ show (B.length bs)
            )
    | B.head bs /= 0x04 =
        fail "ECDH ephemeral point must be uncompressed (0x04)"
    | otherwise =
        let xy = B.tail bs
         in if odd (B.length xy)
                then fail "ECDH ephemeral point has malformed coordinate length"
                else
                    let (xb, yb) = B.splitAt (B.length xy `div` 2) xy
                     in pure (ECCT.Point (os2ip xb) (os2ip yb))

expectedUncompressedPointLength :: ECCT.Curve -> Maybe Int
expectedUncompressedPointLength curve
    | curve == ECCT.getCurveByName ECCT.SEC_p256r1 = Just 65
    | curve == ECCT.getCurveByName ECCT.SEC_p384r1 = Just 97
    | curve == ECCT.getCurveByName ECCT.SEC_p521r1 = Just 133
    | otherwise = Nothing

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

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

aesKeyUnwrapRFC3394
    :: SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> Either String B.ByteString
aesKeyUnwrapRFC3394 sa kek wrapped =
    withAESCipher
        "ECDH PKESK currently supports AES KEK algorithms only"
        sa
        kek
        unwrapWithCipher
  where
    unwrapWithCipher
        :: CCT.BlockCipher cipher
        => cipher
        -> Either String B.ByteString
    unwrapWithCipher cipher = do
        when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $
            Left
                "ECDH wrapped session key must be at least 24 octets and a multiple of 8"
        let (a0, rBytes) = B.splitAt 8 wrapped
            rs = chunksOf8 rBytes
        when (length rs < 2) $
            Left
                "ECDH wrapped session key must contain at least two 64-bit blocks"
        (aFinal, rFinal) <- unwrapRounds cipher a0 rs
        when (aFinal /= B.replicate 8 0xA6) $
            Left "ECDH wrapped session key integrity check failed"
        Right (B.concat rFinal)

    unwrapRounds
        :: CCT.BlockCipher cipher
        => cipher
        -> B.ByteString
        -> [B.ByteString]
        -> Either String (B.ByteString, [B.ByteString])
    unwrapRounds cipher aInit rsInit = goJ 5 aInit rsInit
      where
        n = length rsInit
        goJ j aState rsState
            | j < 0 = Right (aState, rsState)
            | otherwise = do
                (a', rs') <- goI n aState rsState
                goJ (j - 1) a' rs'
          where
            goI i aCurrent rsCurrent
                | i <= 0 = Right (aCurrent, rsCurrent)
                | otherwise = do
                    let t = fromIntegral (n * j + i) :: Word64
                        aXorT = xorBS aCurrent (encodeWord64be t)
                        rI = rsCurrent !! (i - 1)
                        block = CCT.ecbDecrypt cipher (aXorT <> rI)
                        (aNext, rNext) = B.splitAt 8 block
                        rsNext = (ix (i - 1) .~ rNext) rsCurrent
                    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)

decodePKESKSessionKey
    :: Maybe SymmetricAlgorithm
    -> B.ByteString
    -> Either String (SymmetricAlgorithm, B.ByteString)
decodePKESKSessionKey expectedSymAlgo encodedSessionKey =
    case decodeOpenPGPEncodedSessionKey encodedSessionKey of
        Right (symalgo, sessionKey) ->
            case expectedSymAlgo of
                Just expected
                    | expected /= symalgo ->
                        Left "Decrypted PKESK symmetric algorithm does not match payload"
                _ -> Right (symalgo, sessionKey)
        Left decodeErr ->
            case expectedSymAlgo of
                Nothing ->
                    Left
                        ( "PKESK session key material must be OpenPGP encoded when payload algorithm is unknown: "
                            ++ renderEncodedSessionKeyError decodeErr
                        )
                Just expected -> do
                    expectedLen <- symmetricKeyLength expected
                    case decodeExpectedRawOrPaddedSessionKey
                        expected
                        expectedLen
                        encodedSessionKey of
                        Left err -> Left err
                        Right sessionKey -> Right (expected, sessionKey)

parsePKESKv3X25519EskBytes
    :: B.ByteString -> Either String (SymmetricAlgorithm, B.ByteString)
parsePKESKv3X25519EskBytes eskBytes = do
    when (B.length eskBytes < 2) $
        Left "PKESKv3 X25519 ESK field is too short"
    let sessionAlgorithm = toFVal (B.head eskBytes)
        wrappedSessionKeyBytes = B.tail eskBytes
    when (sessionAlgorithm `notElem` [AES128, AES192, AES256]) $
        Left
            "PKESKv3 X25519 ESK field uses unsupported symmetric algorithm"
    when
        ( B.length wrappedSessionKeyBytes < 24
            || B.length wrappedSessionKeyBytes `mod` 8 /= 0
        )
        $ Left
            "PKESKv3 X25519 wrapped session key must be at least 24 octets and a multiple of 8"
    pure (sessionAlgorithm, wrappedSessionKeyBytes)

decodeExpectedRawOrPaddedSessionKey
    :: SymmetricAlgorithm
    -> Int
    -> B.ByteString
    -> Either String B.ByteString
decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey
    | B.length encodedSessionKey == expectedLen =
        Right encodedSessionKey
    | otherwise =
        case decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey of
            Right sessionKey -> Right sessionKey
            Left _ ->
                case decodeV6PaddedSessionKeyWithAlgo
                    expected
                    expectedLen
                    encodedSessionKey of
                    Right sessionKey -> Right sessionKey
                    Left _ ->
                        Left
                            "PKESK raw session key length does not match payload algorithm"

decodeV6PaddedSessionKeyWithoutAlgo
    :: Int -> B.ByteString -> Either String B.ByteString
decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey = do
    when (B.length encodedSessionKey < expectedLen + 2) $
        Left "v6 ECDH decoded session material is too short"
    let (sessionKey, rest) = B.splitAt expectedLen encodedSessionKey
        (checksumBytes, padBytes) = B.splitAt 2 rest
        expectedChecksum =
            fromIntegral (B.index checksumBytes 0) `shiftL` 8
                + fromIntegral (B.index checksumBytes 1)
        actualChecksum = checksum16 sessionKey
    when (actualChecksum /= expectedChecksum) $
        Left "v6 ECDH decoded session-key checksum mismatch"
    validatePKCS7Padding padBytes
    Right sessionKey

decodeV6PaddedSessionKeyWithAlgo
    :: SymmetricAlgorithm
    -> Int
    -> B.ByteString
    -> Either String B.ByteString
decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey = do
    when (B.length encodedSessionKey < expectedLen + 3) $
        Left
            "v6 ECDH decoded session material with algorithm octet is too short"
    let algOctet = B.head encodedSessionKey
    when (toFVal algOctet /= expected) $
        Left "v6 ECDH decoded session material algorithm mismatch"
    let rest = B.tail encodedSessionKey
        (sessionKey, checksumAndPad) = B.splitAt expectedLen rest
        (checksumBytes, padBytes) = B.splitAt 2 checksumAndPad
        expectedChecksum =
            fromIntegral (B.index checksumBytes 0) `shiftL` 8
                + fromIntegral (B.index checksumBytes 1)
        actualChecksum = checksum16 sessionKey
    when (actualChecksum /= expectedChecksum) $
        Left "v6 ECDH decoded session-key checksum mismatch"
    validatePKCS7Padding padBytes
    Right sessionKey

validatePKCS7Padding :: B.ByteString -> Either String ()
validatePKCS7Padding padBytes
    | B.null padBytes = Right ()
    | otherwise = do
        let padLen = fromIntegral (B.last padBytes) :: Int
        when (padLen <= 0 || padLen > 8 || B.length padBytes /= padLen) $
            Left
                "v6 ECDH decoded session material has invalid PKCS#7-style padding length"
        when (B.any (/= fromIntegral padLen) padBytes) $
            Left
                "v6 ECDH decoded session material has invalid PKCS#7-style padding bytes"

symmetricKeyLength :: SymmetricAlgorithm -> Either String Int
symmetricKeyLength = first renderCipherError . keySize

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

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