-- 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 Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize)
import Control.Exception (SomeException, displayException, try)
import Control.Applicative ((<|>))
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 "crypton" Crypto.Cipher.Types as CCT
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.Binary (get)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bits (countLeadingZeros, shiftL, shiftR, xor)
import Data.Bifunctor (first)
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.OpenPGP.Compression (conduitDecompress)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.List (intercalate, nub)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import Data.Word (Word16, Word8, Word64)

import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce, validateSEIPD1MDC, calculateMDC)
import Codec.Encryption.OpenPGP.Internal (leftPadTo)
import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)
import Codec.Encryption.OpenPGP.Internal.CryptoECDH
  ( normalizeMontgomeryPublic
  , buildECDHKDFParam
  , deriveECDHKek
  )
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
  ( aeadModeAndNonceSizeForSEIPDv2
  , decryptSKESK6SessionKey
  , deriveSKESK6KEK
  , seipdv2SymmetricKeySize
  )
import Codec.Encryption.OpenPGP.Policy
  ( DecryptPolicy(..)
  , defaultDecryptPolicy
  , validateTable30PolicyForRecipient
  )
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (decryptWithOCBRFC7253With)
import Codec.Encryption.OpenPGP.S2K
  ( decodeOpenPGPEncodedSessionKey
  , renderEncodedSessionKeyError
  , renderS2KError
  , S2KError(..)
  , skesk2Key
  , skesk2SessionKey
  , string2Key
  )
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey)
import Control.Lens ((.~), ix)
import Data.Conduit.OpenPGP.Keyring.Instances ()
import qualified Data.IxSet.Typed as IxSet

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
 = DecryptWithoutPKESK
   -- ^ Do not attempt PKESK decryption; fall through to manual session-key
   -- input via the passphrase callback instead.
 | DecryptWithKeyring SecretKeyring
   -- ^ Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret
   -- keys (not passphrase-protected) are used. For passphrase-protected keys,
   -- use 'DecryptWithKeyringAndPassphrase'.
 | DecryptWithKeyringAndPassphrase SecretKeyring (SomePKPayload -> IO (Maybe BL.ByteString))
   -- ^ 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.
 | DecryptWithUnwrapCandidatesCallback (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
   -- ^ 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.

-- | 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
  = DecryptClean
    -- ^ 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.
  | DecryptTruncated
    -- ^ The input stream ended before any integrity-terminating marker was
    -- seen.  The ciphertext was incomplete.
  | DecryptTrailingData
    -- ^ 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.
  | DecryptMalformedStructure String
    -- ^ 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.
  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, MonadUnliftIO m, MonadResource m, MonadThrow m)
  => DecryptOptions
  -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecrypt opts =
  decryptReportOutcome <$> conduitDecryptWithReport opts

conduitDecryptWithReport ::
     (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow 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])
  pure $ \req -> do
    let pkesk = reqPKESK req
        probe = reqProbePacket req
    (lastPKESK, wildcardState) <- readIORef stateRef
    let freshPKESK = Just pkesk /= lastPKESK
    when freshPKESK $ writeIORef stateRef (Just pkesk, Nothing)
    let wc = if freshPKESK then Nothing else wildcardState
    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 [])
            pure ResolveExhausted
          (rk:rest) -> do
            writeIORef stateRef (Just pkesk, Just rest)
            pure (ResolveWith rk)
      keyIdentifier -> do
        -- Exact probe: direct lookup by key ID or fingerprint
        let matchingTKs = matchingTKsForRecipient keyIdentifier
            priorFailures = length (reqPreviousFailures req)
        candidates <- keyringCandidates matchingTKs
        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, MonadUnliftIO m, MonadResource m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow 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 = _pendingESKs s ++ [PendingSKESK payload]}))
                , [] )
          PKESKPkt p ->
            return
              ( SomeDecryptStreamState
                  (ActiveDecryptState
                     (s {_pendingESKs = _pendingESKs s ++ [PendingPKESK p]}))
              , [] )
          (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.
          (OtherPacketPkt 21 _) ->
            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
  = NoIntegrityMarker
    -- ^ 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.

-- | 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, MonadUnliftIO m, MonadIO m, MonadThrow 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, MonadUnliftIO m, MonadIO m, MonadThrow 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, MonadUnliftIO m, MonadIO m, MonadThrow 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, MonadUnliftIO m, MonadThrow 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 = reverse [skesk | PendingSKESK skesk <- esks]

    pkeskCandidates esks = reverse [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)]

    isWildcardV3RecipientKeyId (EightOctetKeyId rid) =
      BL.length rid == 8 && BL.all (== 0) rid

    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 Ed25519 _ -> 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 Ed448 _ ->
                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 Ed25519 _ -> 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 Ed448 _ ->
                      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 Ed25519 point ->
          normalizeX25519EphemeralPublic (edPointBytes point)
        ECDHPubKey (EdDSAPubKey Ed25519 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 Ed448 point ->
          normalizeX448EphemeralPublic (edPointBytes point)
        ECDHPubKey (EdDSAPubKey Ed448 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 _ _) _ _ _ _ _ _) =
  if sizeField > 512
    then (sizeField + 7) `div` 8
    else 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
