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

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

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

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

data RecursorState
    = RecursorState
    { RecursorState -> Int
_depth :: Int
    , RecursorState -> [PendingESK]
_pendingESKs :: [PendingESK]
    , RecursorState -> Maybe ByteString
_lastNonce :: Maybe B.ByteString
    , RecursorState -> Maybe ByteString
_lastClearText :: Maybe B.ByteString
    , RecursorState -> DecryptPolicy
_decryptPolicy :: DecryptPolicy
    }
    deriving (RecursorState -> RecursorState -> Bool
(RecursorState -> RecursorState -> Bool)
-> (RecursorState -> RecursorState -> Bool) -> Eq RecursorState
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RecursorState -> RecursorState -> Bool
== :: RecursorState -> RecursorState -> Bool
$c/= :: RecursorState -> RecursorState -> Bool
/= :: RecursorState -> RecursorState -> Bool
Eq, Int -> RecursorState -> ShowS
[RecursorState] -> ShowS
RecursorState -> String
(Int -> RecursorState -> ShowS)
-> (RecursorState -> String)
-> ([RecursorState] -> ShowS)
-> Show RecursorState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RecursorState -> ShowS
showsPrec :: Int -> RecursorState -> ShowS
$cshow :: RecursorState -> String
show :: RecursorState -> String
$cshowList :: [RecursorState] -> ShowS
showList :: [RecursorState] -> ShowS
Show)

def :: RecursorState
def :: RecursorState
def = Int
-> [PendingESK]
-> Maybe ByteString
-> Maybe ByteString
-> DecryptPolicy
-> RecursorState
RecursorState Int
0 [] Maybe ByteString
forall a. Maybe a
Nothing Maybe ByteString
forall a. Maybe a
Nothing DecryptPolicy
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 (PendingESK -> PendingESK -> Bool
(PendingESK -> PendingESK -> Bool)
-> (PendingESK -> PendingESK -> Bool) -> Eq PendingESK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PendingESK -> PendingESK -> Bool
== :: PendingESK -> PendingESK -> Bool
$c/= :: PendingESK -> PendingESK -> Bool
/= :: PendingESK -> PendingESK -> Bool
Eq, Int -> PendingESK -> ShowS
[PendingESK] -> ShowS
PendingESK -> String
(Int -> PendingESK -> ShowS)
-> (PendingESK -> String)
-> ([PendingESK] -> ShowS)
-> Show PendingESK
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PendingESK -> ShowS
showsPrec :: Int -> PendingESK -> ShowS
$cshow :: PendingESK -> String
show :: PendingESK -> String
$cshowList :: [PendingESK] -> ShowS
showList :: [PendingESK] -> ShowS
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
    { PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload :: Maybe SomePKPayload
    {- ^ Public key payload for the recipient.  Required for X25519, X448,
    and ECDH unwrap paths; may be 'Nothing' for RSA.
    -}
    , PKESKRecipientKey -> SKey
pkeskRecipientSKey :: SKey
    -- ^ Corresponding secret key.
    }

data PKESKAttemptFailure
    = PKESKAttemptFailure
    { PKESKAttemptFailure -> Maybe (KeyVersion, PubKeyAlgorithm)
pkeskAttemptFailureKeyContext
        :: Maybe (KeyVersion, PubKeyAlgorithm)
    , PKESKAttemptFailure -> PKESKAttemptFailureKind
pkeskAttemptFailureKind :: PKESKAttemptFailureKind
    , PKESKAttemptFailure -> String
pkeskAttemptFailureReason :: String
    }
    deriving (PKESKAttemptFailure -> PKESKAttemptFailure -> Bool
(PKESKAttemptFailure -> PKESKAttemptFailure -> Bool)
-> (PKESKAttemptFailure -> PKESKAttemptFailure -> Bool)
-> Eq PKESKAttemptFailure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKAttemptFailure -> PKESKAttemptFailure -> Bool
== :: PKESKAttemptFailure -> PKESKAttemptFailure -> Bool
$c/= :: PKESKAttemptFailure -> PKESKAttemptFailure -> Bool
/= :: PKESKAttemptFailure -> PKESKAttemptFailure -> Bool
Eq, Int -> PKESKAttemptFailure -> ShowS
[PKESKAttemptFailure] -> ShowS
PKESKAttemptFailure -> String
(Int -> PKESKAttemptFailure -> ShowS)
-> (PKESKAttemptFailure -> String)
-> ([PKESKAttemptFailure] -> ShowS)
-> Show PKESKAttemptFailure
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKAttemptFailure -> ShowS
showsPrec :: Int -> PKESKAttemptFailure -> ShowS
$cshow :: PKESKAttemptFailure -> String
show :: PKESKAttemptFailure -> String
$cshowList :: [PKESKAttemptFailure] -> ShowS
showList :: [PKESKAttemptFailure] -> ShowS
Show)

data PKESKAttemptFailureKind
    = PKESKAttemptUnwrapFailed
    | PKESKAttemptSessionMaterialDecodeFailed
    deriving (PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool
(PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool)
-> (PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool)
-> Eq PKESKAttemptFailureKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool
== :: PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool
$c/= :: PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool
/= :: PKESKAttemptFailureKind -> PKESKAttemptFailureKind -> Bool
Eq, Int -> PKESKAttemptFailureKind -> ShowS
[PKESKAttemptFailureKind] -> ShowS
PKESKAttemptFailureKind -> String
(Int -> PKESKAttemptFailureKind -> ShowS)
-> (PKESKAttemptFailureKind -> String)
-> ([PKESKAttemptFailureKind] -> ShowS)
-> Show PKESKAttemptFailureKind
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKAttemptFailureKind -> ShowS
showsPrec :: Int -> PKESKAttemptFailureKind -> ShowS
$cshow :: PKESKAttemptFailureKind -> String
show :: PKESKAttemptFailureKind -> String
$cshowList :: [PKESKAttemptFailureKind] -> ShowS
showList :: [PKESKAttemptFailureKind] -> ShowS
Show)

data PKESKResolverError
    = ResolverPolicyDenied String
    | ResolverBackendUnavailable String
    | ResolverInvalidResponse String
    deriving (PKESKResolverError -> PKESKResolverError -> Bool
(PKESKResolverError -> PKESKResolverError -> Bool)
-> (PKESKResolverError -> PKESKResolverError -> Bool)
-> Eq PKESKResolverError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKResolverError -> PKESKResolverError -> Bool
== :: PKESKResolverError -> PKESKResolverError -> Bool
$c/= :: PKESKResolverError -> PKESKResolverError -> Bool
/= :: PKESKResolverError -> PKESKResolverError -> Bool
Eq, Int -> PKESKResolverError -> ShowS
[PKESKResolverError] -> ShowS
PKESKResolverError -> String
(Int -> PKESKResolverError -> ShowS)
-> (PKESKResolverError -> String)
-> ([PKESKResolverError] -> ShowS)
-> Show PKESKResolverError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKResolverError -> ShowS
showsPrec :: Int -> PKESKResolverError -> ShowS
$cshow :: PKESKResolverError -> String
show :: PKESKResolverError -> String
$cshowList :: [PKESKResolverError] -> ShowS
showList :: [PKESKResolverError] -> ShowS
Show)

data PKESKResolveRequest
    = PKESKResolveRequest
    { PKESKResolveRequest -> PKESKPayload
reqPKESK :: PKESKPayload
    , PKESKResolveRequest -> Pkt
reqProbePacket :: Pkt
    , PKESKResolveRequest -> Bool
reqIsWildcardRecipient :: Bool
    , PKESKResolveRequest -> Int
reqAttemptIndex :: Int
    , PKESKResolveRequest -> [PKESKAttemptFailure]
reqPreviousFailures :: [PKESKAttemptFailure]
    }
    deriving (PKESKResolveRequest -> PKESKResolveRequest -> Bool
(PKESKResolveRequest -> PKESKResolveRequest -> Bool)
-> (PKESKResolveRequest -> PKESKResolveRequest -> Bool)
-> Eq PKESKResolveRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKResolveRequest -> PKESKResolveRequest -> Bool
== :: PKESKResolveRequest -> PKESKResolveRequest -> Bool
$c/= :: PKESKResolveRequest -> PKESKResolveRequest -> Bool
/= :: PKESKResolveRequest -> PKESKResolveRequest -> Bool
Eq, Int -> PKESKResolveRequest -> ShowS
[PKESKResolveRequest] -> ShowS
PKESKResolveRequest -> String
(Int -> PKESKResolveRequest -> ShowS)
-> (PKESKResolveRequest -> String)
-> ([PKESKResolveRequest] -> ShowS)
-> Show PKESKResolveRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKResolveRequest -> ShowS
showsPrec :: Int -> PKESKResolveRequest -> ShowS
$cshow :: PKESKResolveRequest -> String
show :: PKESKResolveRequest -> String
$cshowList :: [PKESKResolveRequest] -> ShowS
showList :: [PKESKResolveRequest] -> ShowS
Show)

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

type PKESKResolver m =
    PKESKResolveRequest -> m PKESKResolveAction

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

{- | Canonical decrypt configuration.

Most callers should prefer 'conduitDecrypt' and set:

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

{- | Outcome of a checked decrypt conduit run.

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

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

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

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

      * A packet arrived after the message integrity boundary (trailing
      data).  Under 'defaultDecryptPolicy' this is reported here; under
      'lenientDecryptPolicy' it is reported as 'DecryptTrailingData'
      instead.
      -}
      DecryptMalformedStructure String
    deriving (DecryptOutcome -> DecryptOutcome -> Bool
(DecryptOutcome -> DecryptOutcome -> Bool)
-> (DecryptOutcome -> DecryptOutcome -> Bool) -> Eq DecryptOutcome
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecryptOutcome -> DecryptOutcome -> Bool
== :: DecryptOutcome -> DecryptOutcome -> Bool
$c/= :: DecryptOutcome -> DecryptOutcome -> Bool
/= :: DecryptOutcome -> DecryptOutcome -> Bool
Eq, Int -> DecryptOutcome -> ShowS
[DecryptOutcome] -> ShowS
DecryptOutcome -> String
(Int -> DecryptOutcome -> ShowS)
-> (DecryptOutcome -> String)
-> ([DecryptOutcome] -> ShowS)
-> Show DecryptOutcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecryptOutcome -> ShowS
showsPrec :: Int -> DecryptOutcome -> ShowS
$cshow :: DecryptOutcome -> String
show :: DecryptOutcome -> String
$cshowList :: [DecryptOutcome] -> ShowS
showList :: [DecryptOutcome] -> ShowS
Show)

data DecryptSessionKeyResolutionPath
    = DecryptResolvedViaSKESK
    | DecryptResolvedViaPKESK
    | DecryptResolvedViaManualPKESKInput
    deriving (DecryptSessionKeyResolutionPath
-> DecryptSessionKeyResolutionPath -> Bool
(DecryptSessionKeyResolutionPath
 -> DecryptSessionKeyResolutionPath -> Bool)
-> (DecryptSessionKeyResolutionPath
    -> DecryptSessionKeyResolutionPath -> Bool)
-> Eq DecryptSessionKeyResolutionPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecryptSessionKeyResolutionPath
-> DecryptSessionKeyResolutionPath -> Bool
== :: DecryptSessionKeyResolutionPath
-> DecryptSessionKeyResolutionPath -> Bool
$c/= :: DecryptSessionKeyResolutionPath
-> DecryptSessionKeyResolutionPath -> Bool
/= :: DecryptSessionKeyResolutionPath
-> DecryptSessionKeyResolutionPath -> Bool
Eq, Int -> DecryptSessionKeyResolutionPath -> ShowS
[DecryptSessionKeyResolutionPath] -> ShowS
DecryptSessionKeyResolutionPath -> String
(Int -> DecryptSessionKeyResolutionPath -> ShowS)
-> (DecryptSessionKeyResolutionPath -> String)
-> ([DecryptSessionKeyResolutionPath] -> ShowS)
-> Show DecryptSessionKeyResolutionPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecryptSessionKeyResolutionPath -> ShowS
showsPrec :: Int -> DecryptSessionKeyResolutionPath -> ShowS
$cshow :: DecryptSessionKeyResolutionPath -> String
show :: DecryptSessionKeyResolutionPath -> String
$cshowList :: [DecryptSessionKeyResolutionPath] -> ShowS
showList :: [DecryptSessionKeyResolutionPath] -> ShowS
Show)

data PKESKResolverAttemptAction
    = ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm))
    | ResolverAttemptSkip
    | ResolverAttemptExhausted
    | ResolverAttemptFail PKESKResolverError
    deriving (PKESKResolverAttemptAction -> PKESKResolverAttemptAction -> Bool
(PKESKResolverAttemptAction -> PKESKResolverAttemptAction -> Bool)
-> (PKESKResolverAttemptAction
    -> PKESKResolverAttemptAction -> Bool)
-> Eq PKESKResolverAttemptAction
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKResolverAttemptAction -> PKESKResolverAttemptAction -> Bool
== :: PKESKResolverAttemptAction -> PKESKResolverAttemptAction -> Bool
$c/= :: PKESKResolverAttemptAction -> PKESKResolverAttemptAction -> Bool
/= :: PKESKResolverAttemptAction -> PKESKResolverAttemptAction -> Bool
Eq, Int -> PKESKResolverAttemptAction -> ShowS
[PKESKResolverAttemptAction] -> ShowS
PKESKResolverAttemptAction -> String
(Int -> PKESKResolverAttemptAction -> ShowS)
-> (PKESKResolverAttemptAction -> String)
-> ([PKESKResolverAttemptAction] -> ShowS)
-> Show PKESKResolverAttemptAction
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKResolverAttemptAction -> ShowS
showsPrec :: Int -> PKESKResolverAttemptAction -> ShowS
$cshow :: PKESKResolverAttemptAction -> String
show :: PKESKResolverAttemptAction -> String
$cshowList :: [PKESKResolverAttemptAction] -> ShowS
showList :: [PKESKResolverAttemptAction] -> ShowS
Show)

data PKESKResolverAttempt
    = PKESKResolverAttempt
    { PKESKResolverAttempt -> [PKESKAttemptFailure]
pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure]
    -- ^ Failures from earlier attempts on the same PKESK packet.
    , PKESKResolverAttempt -> PKESKResolverAttemptAction
pkeskResolverAttemptAction :: PKESKResolverAttemptAction
    }
    deriving (PKESKResolverAttempt -> PKESKResolverAttempt -> Bool
(PKESKResolverAttempt -> PKESKResolverAttempt -> Bool)
-> (PKESKResolverAttempt -> PKESKResolverAttempt -> Bool)
-> Eq PKESKResolverAttempt
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PKESKResolverAttempt -> PKESKResolverAttempt -> Bool
== :: PKESKResolverAttempt -> PKESKResolverAttempt -> Bool
$c/= :: PKESKResolverAttempt -> PKESKResolverAttempt -> Bool
/= :: PKESKResolverAttempt -> PKESKResolverAttempt -> Bool
Eq, Int -> PKESKResolverAttempt -> ShowS
[PKESKResolverAttempt] -> ShowS
PKESKResolverAttempt -> String
(Int -> PKESKResolverAttempt -> ShowS)
-> (PKESKResolverAttempt -> String)
-> ([PKESKResolverAttempt] -> ShowS)
-> Show PKESKResolverAttempt
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> PKESKResolverAttempt -> ShowS
showsPrec :: Int -> PKESKResolverAttempt -> ShowS
$cshow :: PKESKResolverAttempt -> String
show :: PKESKResolverAttempt -> String
$cshowList :: [PKESKResolverAttempt] -> ShowS
showList :: [PKESKResolverAttempt] -> ShowS
Show)

data DecryptSessionKeyResolutionReport
    = DecryptSessionKeyResolutionReport
    { DecryptSessionKeyResolutionReport
-> DecryptSessionKeyResolutionPath
decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath
    , DecryptSessionKeyResolutionReport -> [String]
decryptSessionResolutionSKESKErrors :: [String]
    , DecryptSessionKeyResolutionReport -> [String]
decryptSessionResolutionPKESKErrors :: [String]
    , DecryptSessionKeyResolutionReport -> [PKESKResolverAttempt]
decryptSessionResolutionResolverAttempts
        :: [PKESKResolverAttempt]
    }
    deriving (DecryptSessionKeyResolutionReport
-> DecryptSessionKeyResolutionReport -> Bool
(DecryptSessionKeyResolutionReport
 -> DecryptSessionKeyResolutionReport -> Bool)
-> (DecryptSessionKeyResolutionReport
    -> DecryptSessionKeyResolutionReport -> Bool)
-> Eq DecryptSessionKeyResolutionReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecryptSessionKeyResolutionReport
-> DecryptSessionKeyResolutionReport -> Bool
== :: DecryptSessionKeyResolutionReport
-> DecryptSessionKeyResolutionReport -> Bool
$c/= :: DecryptSessionKeyResolutionReport
-> DecryptSessionKeyResolutionReport -> Bool
/= :: DecryptSessionKeyResolutionReport
-> DecryptSessionKeyResolutionReport -> Bool
Eq, Int -> DecryptSessionKeyResolutionReport -> ShowS
[DecryptSessionKeyResolutionReport] -> ShowS
DecryptSessionKeyResolutionReport -> String
(Int -> DecryptSessionKeyResolutionReport -> ShowS)
-> (DecryptSessionKeyResolutionReport -> String)
-> ([DecryptSessionKeyResolutionReport] -> ShowS)
-> Show DecryptSessionKeyResolutionReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecryptSessionKeyResolutionReport -> ShowS
showsPrec :: Int -> DecryptSessionKeyResolutionReport -> ShowS
$cshow :: DecryptSessionKeyResolutionReport -> String
show :: DecryptSessionKeyResolutionReport -> String
$cshowList :: [DecryptSessionKeyResolutionReport] -> ShowS
showList :: [DecryptSessionKeyResolutionReport] -> ShowS
Show)

data DecryptReport
    = DecryptReport
    { DecryptReport -> DecryptOutcome
decryptReportOutcome :: DecryptOutcome
    , DecryptReport -> [DecryptSessionKeyResolutionReport]
decryptReportSessionKeyResolutions
        :: [DecryptSessionKeyResolutionReport]
    }
    deriving (DecryptReport -> DecryptReport -> Bool
(DecryptReport -> DecryptReport -> Bool)
-> (DecryptReport -> DecryptReport -> Bool) -> Eq DecryptReport
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DecryptReport -> DecryptReport -> Bool
== :: DecryptReport -> DecryptReport -> Bool
$c/= :: DecryptReport -> DecryptReport -> Bool
/= :: DecryptReport -> DecryptReport -> Bool
Eq, Int -> DecryptReport -> ShowS
[DecryptReport] -> ShowS
DecryptReport -> String
(Int -> DecryptReport -> ShowS)
-> (DecryptReport -> String)
-> ([DecryptReport] -> ShowS)
-> Show DecryptReport
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DecryptReport -> ShowS
showsPrec :: Int -> DecryptReport -> ShowS
$cshow :: DecryptReport -> String
show :: DecryptReport -> String
$cshowList :: [DecryptReport] -> ShowS
showList :: [DecryptReport] -> ShowS
Show)

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

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

conduitDecrypt
    :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
    => DecryptOptions
    -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecrypt :: forall (m :: * -> *).
(MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) =>
DecryptOptions -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecrypt DecryptOptions
opts =
    DecryptReport -> DecryptOutcome
decryptReportOutcome (DecryptReport -> DecryptOutcome)
-> ConduitT Pkt Pkt m DecryptReport
-> ConduitT Pkt Pkt m DecryptOutcome
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DecryptOptions -> ConduitT Pkt Pkt m DecryptReport
forall (m :: * -> *).
(MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) =>
DecryptOptions -> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport DecryptOptions
opts

conduitDecryptWithReport
    :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
    => DecryptOptions
    -> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport :: forall (m :: * -> *).
(MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) =>
DecryptOptions -> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport DecryptOptions
opts = do
    reportRef <- IO (IORef [DecryptSessionKeyResolutionReport])
-> ConduitT Pkt Pkt m (IORef [DecryptSessionKeyResolutionReport])
forall a. IO a -> ConduitT Pkt Pkt m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO ([DecryptSessionKeyResolutionReport]
-> IO (IORef [DecryptSessionKeyResolutionReport])
forall a. a -> IO (IORef a)
newIORef [])
    resolver <-
        liftIO (buildDecryptResolver (decryptOptionsKeyResolution opts))
    let allowManualPKESKPrompt =
            case DecryptOptions -> DecryptKeyResolution
decryptOptionsKeyResolution DecryptOptions
opts of
                DecryptKeyResolution
DecryptWithoutPKESK -> Bool
True
                DecryptKeyResolution
_ -> Bool
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 :: DecryptKeyResolution -> IO (PKESKResolver IO)
buildDecryptResolver DecryptKeyResolution
DecryptWithoutPKESK =
    PKESKResolver IO -> IO (PKESKResolver IO)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (\PKESKResolveRequest
_ -> PKESKResolveAction -> IO PKESKResolveAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PKESKResolveAction
ResolveExhausted)
buildDecryptResolver (DecryptWithKeyring SecretKeyring
kr) =
    SecretKeyring
-> Maybe (SomePKPayload -> IO (Maybe ByteString))
-> IO (PKESKResolver IO)
buildKeyringResolver SecretKeyring
kr Maybe (SomePKPayload -> IO (Maybe ByteString))
forall a. Maybe a
Nothing
buildDecryptResolver (DecryptWithKeyringAndPassphrase SecretKeyring
kr SomePKPayload -> IO (Maybe ByteString)
cb) =
    SecretKeyring
-> Maybe (SomePKPayload -> IO (Maybe ByteString))
-> IO (PKESKResolver IO)
buildKeyringResolver SecretKeyring
kr ((SomePKPayload -> IO (Maybe ByteString))
-> Maybe (SomePKPayload -> IO (Maybe ByteString))
forall a. a -> Maybe a
Just SomePKPayload -> IO (Maybe ByteString)
cb)
buildDecryptResolver (DecryptWithUnwrapCandidatesCallback KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]
cb) =
    (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
-> IO (PKESKResolver IO)
buildUnwrapCandidatesResolver KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]
cb

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

    tkMatchesRecipientFingerprint
        :: Fingerprint -> TK 'SecretTK -> Bool
    tkMatchesRecipientFingerprint :: Fingerprint -> TK 'SecretTK -> Bool
tkMatchesRecipientFingerprint Fingerprint
rid TK 'SecretTK
tk =
        (KeyPkt 'SecretPkt -> Bool) -> [KeyPkt 'SecretPkt] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any
            (Fingerprint -> KeyPkt 'SecretPkt -> Bool
keyPktMatchesRecipientFingerprint Fingerprint
rid)
            (TK 'SecretTK -> KeyPkt (TKKindToKeyPktKind 'SecretTK)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK 'SecretTK
tk KeyPkt 'SecretPkt -> [KeyPkt 'SecretPkt] -> [KeyPkt 'SecretPkt]
forall a. a -> [a] -> [a]
: ((KeyPkt 'SecretPkt, [SignaturePayload]) -> KeyPkt 'SecretPkt)
-> [(KeyPkt 'SecretPkt, [SignaturePayload])] -> [KeyPkt 'SecretPkt]
forall a b. (a -> b) -> [a] -> [b]
map (KeyPkt 'SecretPkt, [SignaturePayload]) -> KeyPkt 'SecretPkt
forall a b. (a, b) -> a
fst (TK 'SecretTK
-> [(KeyPkt (TKKindToKeyPktKind 'SecretTK), [SignaturePayload])]
forall (k :: TKKind).
TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
_tkSubs TK 'SecretTK
tk))

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

    pkPayloadMatchesRecipientFingerprint
        :: Fingerprint -> SomePKPayload -> Bool
    pkPayloadMatchesRecipientFingerprint :: Fingerprint -> SomePKPayload -> Bool
pkPayloadMatchesRecipientFingerprint Fingerprint
rid SomePKPayload
pkp =
        SomePKPayload -> Fingerprint
fingerprint SomePKPayload
pkp Fingerprint -> [Fingerprint] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Fingerprint -> [Fingerprint]
recipientFingerprintMatchVariants Fingerprint
rid

    recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint]
    recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint]
recipientFingerprintMatchVariants (Fingerprint ByteString
rid)
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
20 =
            [ByteString -> Fingerprint
Fingerprint ByteString
rid, ByteString -> Fingerprint
Fingerprint (Word8 -> ByteString -> ByteString
BL.cons Word8
0x04 ByteString
rid)]
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
21 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
rid Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x04 =
            [ByteString -> Fingerprint
Fingerprint ByteString
rid, ByteString -> Fingerprint
Fingerprint (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BL.tail ByteString
rid)]
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
32 =
            [ByteString -> Fingerprint
Fingerprint ByteString
rid, ByteString -> Fingerprint
Fingerprint (Word8 -> ByteString -> ByteString
BL.cons Word8
0x06 ByteString
rid)]
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
33 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
rid Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x06 =
            [ByteString -> Fingerprint
Fingerprint ByteString
rid, ByteString -> Fingerprint
Fingerprint (HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BL.tail ByteString
rid)]
        | Bool
otherwise = [ByteString -> Fingerprint
Fingerprint ByteString
rid]

    keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey]
    keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey]
keyringCandidates [TK 'SecretTK]
tks = [[PKESKRecipientKey]] -> [PKESKRecipientKey]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[PKESKRecipientKey]] -> [PKESKRecipientKey])
-> IO [[PKESKRecipientKey]] -> IO [PKESKRecipientKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TK 'SecretTK -> IO [PKESKRecipientKey])
-> [TK 'SecretTK] -> IO [[PKESKRecipientKey]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM TK 'SecretTK -> IO [PKESKRecipientKey]
tkCandidates [TK 'SecretTK]
tks

    tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey]
    tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey]
tkCandidates TK 'SecretTK
tk =
        ([Maybe PKESKRecipientKey] -> [PKESKRecipientKey])
-> IO [Maybe PKESKRecipientKey] -> IO [PKESKRecipientKey]
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe PKESKRecipientKey] -> [PKESKRecipientKey]
forall a. [Maybe a] -> [a]
catMaybes (IO [Maybe PKESKRecipientKey] -> IO [PKESKRecipientKey])
-> ([KeyPkt 'SecretPkt] -> IO [Maybe PKESKRecipientKey])
-> [KeyPkt 'SecretPkt]
-> IO [PKESKRecipientKey]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey))
-> [KeyPkt 'SecretPkt] -> IO [Maybe PKESKRecipientKey]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey)
resolveKeyPair ([KeyPkt 'SecretPkt] -> IO [PKESKRecipientKey])
-> [KeyPkt 'SecretPkt] -> IO [PKESKRecipientKey]
forall a b. (a -> b) -> a -> b
$
            TK 'SecretTK -> KeyPkt (TKKindToKeyPktKind 'SecretTK)
forall (k :: TKKind). TK k -> KeyPkt (TKKindToKeyPktKind k)
_tkPrimaryKey TK 'SecretTK
tk KeyPkt 'SecretPkt -> [KeyPkt 'SecretPkt] -> [KeyPkt 'SecretPkt]
forall a. a -> [a] -> [a]
: ((KeyPkt 'SecretPkt, [SignaturePayload]) -> KeyPkt 'SecretPkt)
-> [(KeyPkt 'SecretPkt, [SignaturePayload])] -> [KeyPkt 'SecretPkt]
forall a b. (a -> b) -> [a] -> [b]
map (KeyPkt 'SecretPkt, [SignaturePayload]) -> KeyPkt 'SecretPkt
forall a b. (a, b) -> a
fst (TK 'SecretTK
-> [(KeyPkt (TKKindToKeyPktKind 'SecretTK), [SignaturePayload])]
forall (k :: TKKind).
TK k -> [(KeyPkt (TKKindToKeyPktKind k), [SignaturePayload])]
_tkSubs TK 'SecretTK
tk)

    resolveKeyPair
        :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey)
    resolveKeyPair :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey)
resolveKeyPair (KeyPktSecretPrimary SomePKPayload
pkp (SUUnencrypted SKey
sk Word16
_)) =
        Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey))
-> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a b. (a -> b) -> a -> b
$
            PKESKRecipientKey -> Maybe PKESKRecipientKey
forall a. a -> Maybe a
Just
                PKESKRecipientKey
                    { pkeskRecipientPKPayload :: Maybe SomePKPayload
pkeskRecipientPKPayload = SomePKPayload -> Maybe SomePKPayload
forall a. a -> Maybe a
Just SomePKPayload
pkp
                    , pkeskRecipientSKey :: SKey
pkeskRecipientSKey = SKey
sk
                    }
    resolveKeyPair (KeyPktSecretSubkey SomePKPayload
pkp (SUUnencrypted SKey
sk Word16
_)) =
        Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey))
-> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a b. (a -> b) -> a -> b
$
            PKESKRecipientKey -> Maybe PKESKRecipientKey
forall a. a -> Maybe a
Just
                PKESKRecipientKey
                    { pkeskRecipientPKPayload :: Maybe SomePKPayload
pkeskRecipientPKPayload = SomePKPayload -> Maybe SomePKPayload
forall a. a -> Maybe a
Just SomePKPayload
pkp
                    , pkeskRecipientSKey :: SKey
pkeskRecipientSKey = SKey
sk
                    }
    resolveKeyPair (KeyPktSecretPrimary SomePKPayload
pkp SKAddendum
ska) = SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey)
unlockProtected SomePKPayload
pkp SKAddendum
ska
    resolveKeyPair (KeyPktSecretSubkey SomePKPayload
pkp SKAddendum
ska) = SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey)
unlockProtected SomePKPayload
pkp SKAddendum
ska

    unlockProtected
        :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey)
    unlockProtected :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey)
unlockProtected SomePKPayload
pkp SKAddendum
ska =
        case Maybe (SomePKPayload -> IO (Maybe ByteString))
maybePassphraseCb of
            Maybe (SomePKPayload -> IO (Maybe ByteString))
Nothing -> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PKESKRecipientKey
forall a. Maybe a
Nothing
            Just SomePKPayload -> IO (Maybe ByteString)
passphraseCb -> do
                mPassphrase <- SomePKPayload -> IO (Maybe ByteString)
passphraseCb SomePKPayload
pkp
                case mPassphrase of
                    Maybe ByteString
Nothing -> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PKESKRecipientKey
forall a. Maybe a
Nothing
                    Just ByteString
passphrase ->
                        case (SomePKPayload, SKAddendum)
-> ByteString -> Either String SKAddendum
decryptPrivateKey (SomePKPayload
pkp, SKAddendum
ska) ByteString
passphrase of
                            Left String
_ -> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PKESKRecipientKey
forall a. Maybe a
Nothing
                            Right (SUUnencrypted SKey
sk Word16
_) ->
                                Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey))
-> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a b. (a -> b) -> a -> b
$
                                    PKESKRecipientKey -> Maybe PKESKRecipientKey
forall a. a -> Maybe a
Just
                                        PKESKRecipientKey
                                            { pkeskRecipientPKPayload :: Maybe SomePKPayload
pkeskRecipientPKPayload = SomePKPayload -> Maybe SomePKPayload
forall a. a -> Maybe a
Just SomePKPayload
pkp
                                            , pkeskRecipientSKey :: SKey
pkeskRecipientSKey = SKey
sk
                                            }
                            Right SKAddendum
_ -> Maybe PKESKRecipientKey -> IO (Maybe PKESKRecipientKey)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe PKESKRecipientKey
forall a. Maybe a
Nothing

buildUnwrapCandidatesResolver
    :: (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
    -> IO (PKESKResolver IO)
buildUnwrapCandidatesResolver :: (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
-> IO (PKESKResolver IO)
buildUnwrapCandidatesResolver KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]
cb = do
    stateRef <-
        (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> IO
     (IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey]))
forall a. a -> IO (IORef a)
newIORef
            ( Maybe PKESKPayload
forall a. Maybe a
Nothing :: Maybe PKESKPayload
            , [] :: [(Pkt, [PKESKRecipientKey])]
            , [] :: [SKey]
            )
    pure $ \PKESKResolveRequest
req -> do
        let pkesk :: PKESKPayload
pkesk = PKESKResolveRequest -> PKESKPayload
reqPKESK PKESKResolveRequest
req
            probePkt :: Pkt
probePkt = PKESKResolveRequest -> Pkt
reqProbePacket PKESKResolveRequest
req
        (lastPKESK, probeState, seenSKeys) <- IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> IO (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
forall a. IORef a -> IO a
readIORef IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
stateRef
        let freshPKESK = PKESKPayload -> Maybe PKESKPayload
forall a. a -> Maybe a
Just PKESKPayload
pkesk Maybe PKESKPayload -> Maybe PKESKPayload -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe PKESKPayload
lastPKESK
        when freshPKESK $ writeIORef stateRef (Just pkesk, [], [])
        let state0 = if Bool
freshPKESK then [] else [(Pkt, [PKESKRecipientKey])]
probeState
            seen0 = if Bool
freshPKESK then [] else [SKey]
seenSKeys
        case lookup probePkt state0 of
            Just (PKESKRecipientKey
next : [PKESKRecipientKey]
rest) -> do
                IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef
                    IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
stateRef
                    ( PKESKPayload -> Maybe PKESKPayload
forall a. a -> Maybe a
Just PKESKPayload
pkesk
                    , Pkt
-> [PKESKRecipientKey]
-> [(Pkt, [PKESKRecipientKey])]
-> [(Pkt, [PKESKRecipientKey])]
forall {b} {b}. Eq b => b -> b -> [(b, b)] -> [(b, b)]
updateProbeState Pkt
probePkt [PKESKRecipientKey]
rest [(Pkt, [PKESKRecipientKey])]
state0
                    , PKESKRecipientKey -> SKey
pkeskRecipientSKey PKESKRecipientKey
next SKey -> [SKey] -> [SKey]
forall a. a -> [a] -> [a]
: [SKey]
seen0
                    )
                PKESKResolveAction -> IO PKESKResolveAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKRecipientKey -> PKESKResolveAction
ResolveWith PKESKRecipientKey
next)
            Just [] ->
                PKESKResolveAction -> IO PKESKResolveAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PKESKResolveAction
ResolveSkip
            Maybe [PKESKRecipientKey]
Nothing -> do
                candidates <-
                    [SKey] -> [PKESKRecipientKey] -> [PKESKRecipientKey]
forall {t :: * -> *}.
Foldable t =>
t SKey -> [PKESKRecipientKey] -> [PKESKRecipientKey]
filterFreshCandidates [SKey]
seen0 ([PKESKRecipientKey] -> [PKESKRecipientKey])
-> IO [PKESKRecipientKey] -> IO [PKESKRecipientKey]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Pkt -> IO [PKESKRecipientKey]
callbackCandidates Pkt
probePkt
                case candidates of
                    [] -> do
                        IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef
                            IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
stateRef
                            (PKESKPayload -> Maybe PKESKPayload
forall a. a -> Maybe a
Just PKESKPayload
pkesk, Pkt
-> [PKESKRecipientKey]
-> [(Pkt, [PKESKRecipientKey])]
-> [(Pkt, [PKESKRecipientKey])]
forall {b} {b}. Eq b => b -> b -> [(b, b)] -> [(b, b)]
updateProbeState Pkt
probePkt [] [(Pkt, [PKESKRecipientKey])]
state0, [SKey]
seen0)
                        PKESKResolveAction -> IO PKESKResolveAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PKESKResolveAction
ResolveSkip
                    (PKESKRecipientKey
next : [PKESKRecipientKey]
rest) -> do
                        IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
-> IO ()
forall a. IORef a -> a -> IO ()
writeIORef
                            IORef (Maybe PKESKPayload, [(Pkt, [PKESKRecipientKey])], [SKey])
stateRef
                            ( PKESKPayload -> Maybe PKESKPayload
forall a. a -> Maybe a
Just PKESKPayload
pkesk
                            , Pkt
-> [PKESKRecipientKey]
-> [(Pkt, [PKESKRecipientKey])]
-> [(Pkt, [PKESKRecipientKey])]
forall {b} {b}. Eq b => b -> b -> [(b, b)] -> [(b, b)]
updateProbeState Pkt
probePkt [PKESKRecipientKey]
rest [(Pkt, [PKESKRecipientKey])]
state0
                            , PKESKRecipientKey -> SKey
pkeskRecipientSKey PKESKRecipientKey
next SKey -> [SKey] -> [SKey]
forall a. a -> [a] -> [a]
: [SKey]
seen0
                            )
                        PKESKResolveAction -> IO PKESKResolveAction
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKRecipientKey -> PKESKResolveAction
ResolveWith PKESKRecipientKey
next)
  where
    callbackCandidates :: Pkt -> IO [PKESKRecipientKey]
callbackCandidates Pkt
probePkt =
        KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey]
cb
            (Pkt -> KeyIdentifier
extractProbeKeyIdentifier Pkt
probePkt)
            (Pkt -> PubKeyAlgorithm
extractProbePKA Pkt
probePkt)

    updateProbeState :: b -> b -> [(b, b)] -> [(b, b)]
updateProbeState b
probePkt b
remaining [(b, b)]
state0 =
        (b
probePkt, b
remaining) (b, b) -> [(b, b)] -> [(b, b)]
forall a. a -> [a] -> [a]
: ((b, b) -> Bool) -> [(b, b)] -> [(b, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((b -> b -> Bool
forall a. Eq a => a -> a -> Bool
/= b
probePkt) (b -> Bool) -> ((b, b) -> b) -> (b, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (b, b) -> b
forall a b. (a, b) -> a
fst) [(b, b)]
state0

    filterFreshCandidates :: t SKey -> [PKESKRecipientKey] -> [PKESKRecipientKey]
filterFreshCandidates t SKey
seenSKeys =
        (PKESKRecipientKey -> Bool)
-> [PKESKRecipientKey] -> [PKESKRecipientKey]
forall a. (a -> Bool) -> [a] -> [a]
filter
            (\PKESKRecipientKey
candidate -> PKESKRecipientKey -> SKey
pkeskRecipientSKey PKESKRecipientKey
candidate SKey -> t SKey -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t SKey
seenSKeys)

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

isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId (EightOctetKeyId ByteString
rid) =
    ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
8 Bool -> Bool -> Bool
&& (Word8 -> Bool) -> ByteString -> Bool
BL.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
rid

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

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

    push
        :: (MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m)
        => Pkt
        -> DecryptStreamState phase
        -> m (SomeDecryptStreamState, [Pkt])
    push :: forall (m :: * -> *) (phase :: DecryptStreamPhase).
(MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) =>
Pkt
-> DecryptStreamState phase -> m (SomeDecryptStreamState, [Pkt])
push Pkt
i (ActiveDecryptState RecursorState
s)
        | RecursorState -> Int
_depth RecursorState
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
42 = String -> m (SomeDecryptStreamState, [Pkt])
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"I think we've been quine-attacked"
        | RecursorState -> Bool
hasPendingESKPrelude RecursorState
s Bool -> Bool -> Bool
&& Bool -> Bool
not (Pkt -> Bool
packetCanFollowESKPrelude Pkt
i) =
            (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                ( DecryptStreamState 'MalformedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                    ( RecursorState
-> String -> DecryptStreamState 'MalformedDecryptPhase
MalformedDecryptState
                        RecursorState
s
                        String
"Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data"
                    )
                , []
                )
        | Bool
otherwise =
            let dp :: DecryptPolicy
dp = RecursorState -> DecryptPolicy
_decryptPolicy RecursorState
s
             in case Pkt
i of
                    SKESKPkt SKESKPayload
payload ->
                        do
                            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DecryptPolicy -> Bool
decryptRejectDeprecatedSKESK DecryptPolicy
dp) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                                case SKESKPayload -> S2K
skeskPayloadS2K SKESKPayload
payload of
                                    Simple HashAlgorithm
_ ->
                                        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                            String
"SKESK uses Simple S2K specifier, which is deprecated by RFC9580 policy"
                                    Salted HashAlgorithm
_ Salt8
_ ->
                                        String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                            String
"SKESK uses Salted S2K specifier, which is deprecated by RFC9580 policy"
                                    S2K
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                            (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                ( DecryptStreamState 'ActiveDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                                    ( RecursorState -> DecryptStreamState 'ActiveDecryptPhase
ActiveDecryptState
                                        (RecursorState
s {_pendingESKs = PendingSKESK payload : _pendingESKs s})
                                    )
                                , []
                                )
                    PKESKPkt PKESKPayload
p ->
                        (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                            ( DecryptStreamState 'ActiveDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                                ( RecursorState -> DecryptStreamState 'ActiveDecryptPhase
ActiveDecryptState
                                    (RecursorState
s {_pendingESKs = PendingPKESK p : _pendingESKs s})
                                )
                            , []
                            )
                    (SymEncDataPkt ByteString
bs) ->
                        if DecryptPolicy
-> EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
-> RecursorState
-> Bool
forall {v :: EncryptedPayloadVersion}.
DecryptPolicy -> EncryptedPayloadFlavor v -> RecursorState -> Bool
hasESKPayloadVersionMismatch DecryptPolicy
dp EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
LegacyEncryptedPayload RecursorState
s
                            then
                                (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                    ( DecryptStreamState 'MalformedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                                        ( RecursorState
-> String -> DecryptStreamState 'MalformedDecryptPhase
MalformedDecryptState
                                            RecursorState
s
                                            ( String
"ESK/payload version mismatch: ESK packets present but none are version-aligned with "
                                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"legacy SED payload"
                                            )
                                        )
                                    , []
                                    )
                            else do
                                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DecryptPolicy -> Bool
decryptAllowSEDNoIntegrity DecryptPolicy
dp)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                                    String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                        String
"Received unauthenticated SED (Symmetrically Encrypted Data) packet; \
                                        \RFC9580 policy requires integrity-protected SEIPD. \
                                        \Use lenientDecryptPolicy to permit legacy messages."
                                (symalgo, sessionKey) <-
                                    RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
forall (m :: * -> *) (v :: EncryptedPayloadVersion).
(MonadFail m, MonadIO m) =>
RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor v
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
resolveSessionKey
                                        RecursorState
s
                                        Bool
allowManualPKESKPrompt
                                        PKESKResolver IO
pkcb
                                        InputCallback IO
cb
                                        EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
LegacyEncryptedPayload
                                        Maybe (IORef [DecryptSessionKeyResolutionReport])
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 Word8
_ ByteString
bs)) ->
                        if DecryptPolicy
-> EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
-> RecursorState
-> Bool
forall {v :: EncryptedPayloadVersion}.
DecryptPolicy -> EncryptedPayloadFlavor v -> RecursorState -> Bool
hasESKPayloadVersionMismatch DecryptPolicy
dp EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
LegacyEncryptedPayload RecursorState
s
                            then
                                (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                    ( DecryptStreamState 'MalformedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                                        ( RecursorState
-> String -> DecryptStreamState 'MalformedDecryptPhase
MalformedDecryptState
                                            RecursorState
s
                                            ( String
"ESK/payload version mismatch: ESK packets present but none are version-aligned with "
                                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"SEIPDv1 payload"
                                            )
                                        )
                                    , []
                                    )
                            else do
                                Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DecryptPolicy -> Bool
decryptAllowSEIPDv1 DecryptPolicy
dp)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                                    String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                        String
"Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only."
                                (symalgo, sessionKey) <-
                                    RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
forall (m :: * -> *) (v :: EncryptedPayloadVersion).
(MonadFail m, MonadIO m) =>
RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor v
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
resolveSessionKey
                                        RecursorState
s
                                        Bool
allowManualPKESKPrompt
                                        PKESKResolver IO
pkcb
                                        InputCallback IO
cb
                                        EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
LegacyEncryptedPayload
                                        Maybe (IORef [DecryptSessionKeyResolutionReport])
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 SymmetricAlgorithm
sa AEADAlgorithm
aa Word8
chunkSize Salt
salt ByteString
bs)) ->
                        if DecryptPolicy
-> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion
-> RecursorState
-> Bool
forall {v :: EncryptedPayloadVersion}.
DecryptPolicy -> EncryptedPayloadFlavor v -> RecursorState -> Bool
hasESKPayloadVersionMismatch DecryptPolicy
dp (SymmetricAlgorithm
-> AEADAlgorithm
-> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion
SEIPDv2EncryptedPayload SymmetricAlgorithm
sa AEADAlgorithm
aa) RecursorState
s
                            then
                                (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                                    ( DecryptStreamState 'MalformedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                                        ( RecursorState
-> String -> DecryptStreamState 'MalformedDecryptPhase
MalformedDecryptState
                                            RecursorState
s
                                            ( String
"ESK/payload version mismatch: ESK packets present but none are version-aligned with "
                                                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"SEIPDv2 payload"
                                            )
                                        )
                                    , []
                                    )
                            else do
                                DecryptPolicy -> SymmetricAlgorithm -> m ()
forall (m :: * -> *).
MonadFail m =>
DecryptPolicy -> SymmetricAlgorithm -> m ()
checkDecryptSymmetricAlgo DecryptPolicy
dp SymmetricAlgorithm
sa
                                DecryptPolicy -> AEADAlgorithm -> m ()
forall (m :: * -> *).
MonadFail m =>
DecryptPolicy -> AEADAlgorithm -> m ()
checkDecryptAEADAlgo DecryptPolicy
dp AEADAlgorithm
aa
                                (_, sessionKey) <-
                                    RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
forall (m :: * -> *) (v :: EncryptedPayloadVersion).
(MonadFail m, MonadIO m) =>
RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor v
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
resolveSessionKey
                                        RecursorState
s
                                        Bool
allowManualPKESKPrompt
                                        PKESKResolver IO
pkcb
                                        InputCallback IO
cb
                                        (SymmetricAlgorithm
-> AEADAlgorithm
-> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion
SEIPDv2EncryptedPayload SymmetricAlgorithm
sa AEADAlgorithm
aa)
                                        Maybe (IORef [DecryptSessionKeyResolutionReport])
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 :: Pkt
m@(ModificationDetectionCodePkt ByteString
mdc) -> do
                        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isNothing (RecursorState -> Maybe ByteString
_lastClearText RecursorState
s)) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MDC with no referent"
                        let mcalculated :: Maybe (Maybe ByteString)
mcalculated = ByteString -> ByteString -> Maybe ByteString
calculateMDC (ByteString -> ByteString -> Maybe ByteString)
-> Maybe ByteString -> Maybe (ByteString -> Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RecursorState -> Maybe ByteString
_lastNonce RecursorState
s Maybe (ByteString -> Maybe ByteString)
-> Maybe ByteString -> Maybe (Maybe ByteString)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RecursorState -> Maybe ByteString
_lastClearText RecursorState
s
                        expectedMdc <-
                            case Maybe (Maybe ByteString)
mcalculated of
                                Maybe (Maybe ByteString)
Nothing -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MDC with no nonce or cleartext"
                                Just Maybe ByteString
Nothing -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"MDC referent is too short"
                                Just (Just ByteString
x) -> ByteString -> m ByteString
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
                        when (expectedMdc /= mdc) $
                            fail $
                                "MDC indicates tampering: "
                                    ++ show mdc
                                    ++ " versus "
                                    ++ maybe "<empty>" show mcalculated
                                    ++ "  ... "
                                    ++ show (_lastNonce s)
                                    ++ " / "
                                    ++ show (_lastClearText s)
                        -- MDC is the integrity boundary inside a SEIPD1 inner stream.
                        return
                            ( SomeDecryptStreamState (FinishedDecryptState s False)
                            , [m]
                            )
                    -- RFC9580 Padding Packet (tag 21) can be ignored after decryption.
                    (PaddingPkt ByteString
_) ->
                        (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecryptStreamState 'ActiveDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState (RecursorState -> DecryptStreamState 'ActiveDecryptPhase
ActiveDecryptState RecursorState
s), [])
                    (OtherPacketPkt Word8
t ByteString
_)
                        | Word8
t Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
< Word8
40 ->
                            String -> m (SomeDecryptStreamState, [Pkt])
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                (String
"Unknown critical packet type in packet sequence: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
t)
                    (OtherPacketPkt Word8
_ ByteString
_) ->
                        (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecryptStreamState 'ActiveDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState (RecursorState -> DecryptStreamState 'ActiveDecryptPhase
ActiveDecryptState RecursorState
s), [])
                    Pkt
p ->
                        (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecryptStreamState 'ActiveDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState (RecursorState -> DecryptStreamState 'ActiveDecryptPhase
ActiveDecryptState RecursorState
s), [Pkt
p])
    push Pkt
i (FinishedDecryptState RecursorState
s Bool
hadTrailing) =
        if DecryptPolicy -> Bool
decryptRejectTrailingData (RecursorState -> DecryptPolicy
_decryptPolicy RecursorState
s)
            then
                (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                    ( DecryptStreamState 'MalformedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
                        ( RecursorState
-> String -> DecryptStreamState 'MalformedDecryptPhase
MalformedDecryptState
                            RecursorState
s
                            String
"packet received after message integrity boundary"
                        )
                    , []
                    )
            else
                (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
                    (DecryptStreamState 'FinishedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState (RecursorState -> Bool -> DecryptStreamState 'FinishedDecryptPhase
FinishedDecryptState RecursorState
s Bool
True), [Pkt
i])
    push Pkt
_ malformedState :: DecryptStreamState phase
malformedState@(MalformedDecryptState RecursorState
_ String
_) =
        (SomeDecryptStreamState, [Pkt])
-> m (SomeDecryptStreamState, [Pkt])
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecryptStreamState phase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState DecryptStreamState phase
malformedState, [])

    hasPendingESKPrelude :: RecursorState -> Bool
hasPendingESKPrelude RecursorState
s = Bool -> Bool
not ([PendingESK] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (RecursorState -> [PendingESK]
_pendingESKs RecursorState
s))

    hasESKPayloadVersionMismatch :: DecryptPolicy -> EncryptedPayloadFlavor v -> RecursorState -> Bool
hasESKPayloadVersionMismatch DecryptPolicy
dp EncryptedPayloadFlavor v
payloadFlavor RecursorState
state =
        DecryptPolicy -> Bool
decryptRejectESKVersionMismatch DecryptPolicy
dp
            Bool -> Bool -> Bool
&& RecursorState -> Bool
hasPendingESKPrelude RecursorState
state
            Bool -> Bool -> Bool
&& [AlignedPendingESK v] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (EncryptedPayloadFlavor v -> [PendingESK] -> [AlignedPendingESK v]
forall (v :: EncryptedPayloadVersion).
EncryptedPayloadFlavor v -> [PendingESK] -> [AlignedPendingESK v]
alignedPrecedingESKs EncryptedPayloadFlavor v
payloadFlavor (RecursorState -> [PendingESK]
_pendingESKs RecursorState
state))

    finalizeOuterEncryptedPayload :: RecursorState -> b -> (SomeDecryptStreamState, b)
finalizeOuterEncryptedPayload RecursorState
state b
decryptedPkts =
        ( DecryptStreamState 'FinishedDecryptPhase -> SomeDecryptStreamState
forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> SomeDecryptStreamState
SomeDecryptStreamState
            (RecursorState -> Bool -> DecryptStreamState 'FinishedDecryptPhase
FinishedDecryptState (RecursorState
state {_pendingESKs = []}) Bool
False)
        , b
decryptedPkts
        )

    finalOutcome :: DecryptStreamState phase -> DecryptOutcome
    finalOutcome :: forall (phase :: DecryptStreamPhase).
DecryptStreamState phase -> DecryptOutcome
finalOutcome (ActiveDecryptState RecursorState
_) = DecryptOutcome
DecryptTruncated
    finalOutcome (FinishedDecryptState RecursorState
_ Bool
hadTrailing) =
        if Bool
hadTrailing
            then DecryptOutcome
DecryptTrailingData
            else DecryptOutcome
DecryptClean
    finalOutcome (MalformedDecryptState RecursorState
_ String
reason) =
        String -> DecryptOutcome
DecryptMalformedStructure String
reason

    packetCanFollowESKPrelude :: Pkt -> Bool
packetCanFollowESKPrelude Pkt
pkt =
        case Pkt
pkt of
            SKESKPkt SKESKPayload
_ -> Bool
True
            PKESKPkt PKESKPayload
_ -> Bool
True
            SymEncDataPkt ByteString
_ -> Bool
True
            SymEncIntegrityProtectedDataPkt SEIPDPayload
_ -> Bool
True
            MarkerPkt ByteString
_ -> Bool
True
            OtherPacketPkt Word8
21 ByteString
_ -> Bool
True
            Pkt
_ -> Bool
False

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

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

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

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

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

decryptInnerPackets
    :: (MonadFail m, MonadThrow m, MonadUnliftIO m)
    => RecursorState
    -> Bool
    -> PKESKResolver IO
    -> InputCallback IO
    -> Maybe (IORef [DecryptSessionKeyResolutionReport])
    -> B.ByteString
    -> m (DecryptOutcome, [Pkt])
decryptInnerPackets :: forall (m :: * -> *).
(MonadFail m, MonadThrow m, MonadUnliftIO m) =>
RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> ByteString
-> m (DecryptOutcome, [Pkt])
decryptInnerPackets RecursorState
rs Bool
allowManualPKESKPrompt PKESKResolver IO
pkcb InputCallback IO
cb Maybe (IORef [DecryptSessionKeyResolutionReport])
reportRef ByteString
cleartext =
    ConduitT () Void (ResourceT m) (DecryptOutcome, [Pkt])
-> m (DecryptOutcome, [Pkt])
forall (m :: * -> *) r.
MonadUnliftIO m =>
ConduitT () Void (ResourceT m) r -> m r
runConduitRes (ConduitT () Void (ResourceT m) (DecryptOutcome, [Pkt])
 -> m (DecryptOutcome, [Pkt]))
-> ConduitT () Void (ResourceT m) (DecryptOutcome, [Pkt])
-> m (DecryptOutcome, [Pkt])
forall a b. (a -> b) -> a -> b
$
        ByteString -> ConduitT () ByteString (ResourceT m) ()
forall (m :: * -> *) i.
Monad m =>
ByteString -> ConduitT i ByteString m ()
CB.sourceLbs (ByteString -> ByteString
BL.fromStrict ByteString
cleartext)
            ConduitT () ByteString (ResourceT m) ()
-> ConduitT ByteString Void (ResourceT m) (DecryptOutcome, [Pkt])
-> ConduitT () Void (ResourceT m) (DecryptOutcome, [Pkt])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| Get Pkt -> ConduitT ByteString Pkt (ResourceT m) ()
forall (m :: * -> *) b.
MonadThrow m =>
Get b -> ConduitT ByteString b m ()
conduitGet Get Pkt
forall t. Binary t => Get t
get
            ConduitT ByteString Pkt (ResourceT m) ()
-> ConduitT Pkt Void (ResourceT m) (DecryptOutcome, [Pkt])
-> ConduitT ByteString Void (ResourceT m) (DecryptOutcome, [Pkt])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Pkt Pkt (ResourceT m) ()
forall (m :: * -> *). MonadThrow m => ConduitT Pkt Pkt m ()
conduitDecompress
            ConduitT Pkt Pkt (ResourceT m) ()
-> ConduitT Pkt Void (ResourceT m) (DecryptOutcome, [Pkt])
-> ConduitT Pkt Void (ResourceT m) (DecryptOutcome, [Pkt])
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Pkt Pkt (ResourceT m) DecryptOutcome
-> ConduitT Pkt Void (ResourceT m) [Pkt]
-> ConduitT Pkt Void (ResourceT m) (DecryptOutcome, [Pkt])
forall (m :: * -> *) a b r1 c r2.
Monad m =>
ConduitT a b m r1 -> ConduitT b c m r2 -> ConduitT a c m (r1, r2)
fuseBoth
                ( RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> ConduitT Pkt Pkt (ResourceT m) DecryptOutcome
forall (m :: * -> *).
(MonadFail m, MonadResource m, MonadThrow m, MonadUnliftIO m) =>
RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> ConduitT Pkt Pkt m DecryptOutcome
conduitDecryptChecked'
                    RecursorState
rs {_depth = _depth rs + 1}
                    Bool
allowManualPKESKPrompt
                    PKESKResolver IO
pkcb
                    InputCallback IO
cb
                    Maybe (IORef [DecryptSessionKeyResolutionReport])
reportRef
                )
                ConduitT Pkt Void (ResourceT m) [Pkt]
forall (m :: * -> *) a o. Monad m => ConduitT a o m [a]
CL.consume

decryptSEIPDv2Payload
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> B.ByteString
    -> SessionKey
    -> Either String B.ByteString
decryptSEIPDv2Payload :: SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> ByteString
-> SessionKey
-> Either String ByteString
decryptSEIPDv2Payload SymmetricAlgorithm
symalgo AEADAlgorithm
aeadalgo Word8
chunkSize Salt
salt ByteString
encrypted (SessionKey ByteString
sessionKey) = do
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
chunkSize Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
> Word8
16) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left String
"SEIPD v2 chunk size octet must be between 0 and 16"
    (mode, nonceSize) <- AEADAlgorithm -> Either String (AEADMode, Int)
aeadModeAndNonceSize AEADAlgorithm
aeadalgo
    keyLen <- symKeySize symalgo
    let outputLen = Int
keyLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nonceSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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 =
            [Word8] -> ByteString
B.pack
                [Word8
0xd2, Word8
2, SymmetricAlgorithm -> Word8
forall a. FutureVal a => a -> Word8
fromFVal SymmetricAlgorithm
symalgo, AEADAlgorithm -> Word8
forall a. FutureVal a => a -> Word8
fromFVal AEADAlgorithm
aeadalgo, Word8
chunkSize]
        prk = forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
extract @CHA.SHA256 (Salt -> ByteString
unSalt Salt
salt) ByteString
sessionKey
        okm = forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
expand @CHA.SHA256 PRK SHA256
prk ByteString
info Int
outputLen :: B.ByteString
        messageKey = Int -> ByteString -> ByteString
B.take Int
keyLen ByteString
okm
        noncePrefix = Int -> ByteString -> ByteString
B.take (Int
nonceSize Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8) (Int -> ByteString -> ByteString
B.drop Int
keyLen ByteString
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 :: SymmetricAlgorithm
-> AEADMode
-> Word8
-> ByteString
-> ByteString
-> ByteString
-> ByteString
-> Either String ByteString
decryptSEIPDv2WithKey SymmetricAlgorithm
symalgo AEADMode
mode Word8
chunkSize ByteString
info ByteString
noncePrefix ByteString
sessionKey ByteString
encrypted =
    String
-> SymmetricAlgorithm
-> ByteString
-> (forall cipher.
    BlockCipher cipher =>
    cipher -> Either String ByteString)
-> Either String ByteString
forall a.
String
-> SymmetricAlgorithm
-> ByteString
-> (forall cipher. BlockCipher cipher => cipher -> Either String a)
-> Either String a
withAESCipher
        String
"SEIPD v2 decrypt currently supports AES-128/192/256 only"
        SymmetricAlgorithm
symalgo
        ByteString
sessionKey
        (AEADMode
-> ByteString
-> Word8
-> ByteString
-> ByteString
-> cipher
-> Either String ByteString
forall cipher.
BlockCipher cipher =>
AEADMode
-> ByteString
-> Word8
-> ByteString
-> ByteString
-> cipher
-> Either String ByteString
decryptChunks AEADMode
mode ByteString
info Word8
chunkSize ByteString
noncePrefix ByteString
encrypted)

decryptChunks
    :: CCT.BlockCipher cipher
    => CCT.AEADMode
    -> B.ByteString
    -> Word8
    -> B.ByteString
    -> B.ByteString
    -> cipher
    -> Either String B.ByteString
decryptChunks :: forall cipher.
BlockCipher cipher =>
AEADMode
-> ByteString
-> Word8
-> ByteString
-> ByteString
-> cipher
-> Either String ByteString
decryptChunks AEADMode
mode ByteString
info Word8
chunkSize ByteString
noncePrefix ByteString
encrypted cipher
cipher =
    let ctx :: AEADDecryptContext cipher
ctx = AEADMode
-> ByteString
-> Word8
-> ByteString
-> cipher
-> AEADDecryptContext cipher
forall cipher.
AEADMode
-> ByteString
-> Word8
-> ByteString
-> cipher
-> AEADDecryptContext cipher
AEADDecryptContext AEADMode
mode ByteString
info Word8
chunkSize ByteString
noncePrefix cipher
cipher
     in ReaderT (AEADDecryptContext cipher) (Either String) ByteString
-> AEADDecryptContext cipher -> Either String ByteString
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT (AEADDecryptContext cipher) (Either String) ByteString
forall cipher. BlockCipher cipher => AEADDecrypt cipher ByteString
decryptChunksWithReader AEADDecryptContext cipher
ctx
  where
    decryptChunksWithReader
        :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString
    decryptChunksWithReader :: forall cipher. BlockCipher cipher => AEADDecrypt cipher ByteString
decryptChunksWithReader = Word64
-> ByteString
-> [ByteString]
-> Int
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
go Word64
0 ByteString
encrypted [] Int
0
      where
        chunkLen :: Int
chunkLen = Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
chunkSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
6)
        tagLen :: Int
tagLen = Int
16

        go :: Word64
-> ByteString
-> [ByteString]
-> Int
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
go Word64
idx ByteString
remaining [ByteString]
acc Int
totalPlain
            | ByteString -> Int
B.length ByteString
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tagLen =
                Either String ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (AEADDecryptContext cipher) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String ByteString
 -> ReaderT (AEADDecryptContext cipher) (Either String) ByteString)
-> Either String ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
forall a b. (a -> b) -> a -> b
$
                    String -> Either String ByteString
forall a b. a -> Either a b
Left
                        String
"SEIPD v2 ciphertext is too short for chunk and final authentication tags"
            | Bool
otherwise = do
                let hasMoreChunks :: Bool
hasMoreChunks = ByteString -> Int
B.length ByteString
remaining Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
chunkLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tagLen
                    currentChunkLen :: Int
currentChunkLen =
                        if Bool
hasMoreChunks
                            then Int
chunkLen
                            else ByteString -> Int
B.length ByteString
remaining Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
tagLen
                Bool
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
currentChunkLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0) (ReaderT (AEADDecryptContext cipher) (Either String) ()
 -> ReaderT (AEADDecryptContext cipher) (Either String) ())
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall a b. (a -> b) -> a -> b
$
                    Either String ()
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (AEADDecryptContext cipher) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String ()
 -> ReaderT (AEADDecryptContext cipher) (Either String) ())
-> Either String ()
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall a b. (a -> b) -> a -> b
$
                        String -> Either String ()
forall a b. a -> Either a b
Left String
"SEIPD v2 malformed chunk lengths"
                let (ByteString
chunkCiphertext, ByteString
r1) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
currentChunkLen ByteString
remaining
                    (ByteString
chunkTag, ByteString
r2) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
tagLen ByteString
r1
                plainChunk <-
                    Word64
-> ByteString
-> ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
decryptChunkWithContext Word64
idx ByteString
chunkCiphertext ByteString
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 :: Word64
-> ByteString
-> ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
decryptChunkWithContext Word64
idx ByteString
chunkCiphertext ByteString
chunkTag = do
            AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ReaderT
  (AEADDecryptContext cipher)
  (Either String)
  (AEADDecryptContext cipher)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            if mode' == CCT.AEAD_OCB
                then
                    lift $
                        decryptWithOCBRFC7253With
                            (\ByteString
_ ByteString
_ ByteString
_ ByteString
_ ByteString
_ ByteString
_ -> String
"SEIPD v2 chunk authentication failed")
                            cipher'
                            (noncePrefix' <> encodeWord64be idx)
                            info
                            chunkCiphertext
                            (mkAuthTag chunkTag)
                else do
                    aead <- initAEADWithContext idx
                    let mPlain =
                            AEAD cipher
-> ByteString -> ByteString -> AuthTag -> Maybe ByteString
forall aad ba a.
(ByteArrayAccess aad, ByteArray ba) =>
AEAD a -> aad -> ba -> AuthTag -> Maybe ba
CCT.aeadSimpleDecrypt
                                AEAD cipher
aead
                                ByteString
info
                                ByteString
chunkCiphertext
                                (ByteString -> AuthTag
mkAuthTag ByteString
chunkTag)
                    case mPlain of
                        Maybe ByteString
Nothing -> Either String ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (AEADDecryptContext cipher) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String ByteString
 -> ReaderT (AEADDecryptContext cipher) (Either String) ByteString)
-> Either String ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
forall a b. (a -> b) -> a -> b
$ String -> Either String ByteString
forall a b. a -> Either a b
Left String
"SEIPD v2 chunk authentication failed"
                        Just ByteString
p -> ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ByteString
forall a.
a -> ReaderT (AEADDecryptContext cipher) (Either String) a
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
p

        verifyFinalTagWithContext :: Word64
-> Int
-> ByteString
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
verifyFinalTagWithContext Word64
idx Int
totalPlain ByteString
finalTag = do
            AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ReaderT
  (AEADDecryptContext cipher)
  (Either String)
  (AEADDecryptContext cipher)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            if mode' == CCT.AEAD_OCB
                then do
                    plain <-
                        lift $
                            decryptWithOCBRFC7253With
                                (\ByteString
_ ByteString
_ ByteString
_ ByteString
_ ByteString
_ ByteString
_ -> String
"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 =
                            AEAD cipher
-> ByteString -> ByteString -> AuthTag -> Maybe ByteString
forall aad ba a.
(ByteArrayAccess aad, ByteArray ba) =>
AEAD a -> aad -> ba -> AuthTag -> Maybe ba
CCT.aeadSimpleDecrypt
                                AEAD cipher
aead
                                (ByteString
info ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Word64 -> ByteString
encodeWord64be (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalPlain))
                                ByteString
B.empty
                                (ByteString -> AuthTag
mkAuthTag ByteString
finalTag)
                    case mEmpty of
                        Just ByteString
p | ByteString -> Bool
B.null ByteString
p -> () -> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall a.
a -> ReaderT (AEADDecryptContext cipher) (Either String) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Maybe ByteString
_ ->
                            Either String ()
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (AEADDecryptContext cipher) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either String ()
 -> ReaderT (AEADDecryptContext cipher) (Either String) ())
-> Either String ()
-> ReaderT (AEADDecryptContext cipher) (Either String) ()
forall a b. (a -> b) -> a -> b
$
                                String -> Either String ()
forall a b. a -> Either a b
Left String
"SEIPD v2 final authentication tag verification failed"

        initAEADWithContext :: Word64
-> ReaderT
     (AEADDecryptContext cipher) (Either String) (AEAD cipher)
initAEADWithContext Word64
idx = do
            AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ReaderT
  (AEADDecryptContext cipher)
  (Either String)
  (AEADDecryptContext cipher)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
            lift $
                first show . CE.eitherCryptoError $
                    CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx)

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

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

encodeWord64be :: Word64 -> B.ByteString
encodeWord64be :: Word64 -> ByteString
encodeWord64be = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString)
-> (Word64 -> ByteString) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut (Put -> ByteString) -> (Word64 -> Put) -> Word64 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Put
putWord64be

mkAuthTag :: B.ByteString -> CCT.AuthTag
mkAuthTag :: ByteString -> AuthTag
mkAuthTag = Bytes -> AuthTag
CCT.AuthTag (Bytes -> AuthTag)
-> (ByteString -> Bytes) -> ByteString -> AuthTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bytes
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert

checkDecryptSymmetricAlgo
    :: MonadFail m => DecryptPolicy -> SymmetricAlgorithm -> m ()
checkDecryptSymmetricAlgo :: forall (m :: * -> *).
MonadFail m =>
DecryptPolicy -> SymmetricAlgorithm -> m ()
checkDecryptSymmetricAlgo DecryptPolicy
dp SymmetricAlgorithm
sa =
    case DecryptPolicy -> Maybe [SymmetricAlgorithm]
decryptAllowedSymmetricAlgos DecryptPolicy
dp of
        Maybe [SymmetricAlgorithm]
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just [SymmetricAlgorithm]
allowed
            | SymmetricAlgorithm
sa SymmetricAlgorithm -> [SymmetricAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SymmetricAlgorithm]
allowed -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise ->
                String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
                    String
"Decrypt policy rejects symmetric algorithm "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymmetricAlgorithm -> String
forall a. Show a => a -> String
show SymmetricAlgorithm
sa
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; allowed: "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ [SymmetricAlgorithm] -> String
forall a. Show a => a -> String
show [SymmetricAlgorithm]
allowed

checkDecryptAEADAlgo
    :: MonadFail m => DecryptPolicy -> AEADAlgorithm -> m ()
checkDecryptAEADAlgo :: forall (m :: * -> *).
MonadFail m =>
DecryptPolicy -> AEADAlgorithm -> m ()
checkDecryptAEADAlgo DecryptPolicy
dp AEADAlgorithm
aa =
    case DecryptPolicy -> Maybe [AEADAlgorithm]
decryptAllowedAEADAlgos DecryptPolicy
dp of
        Maybe [AEADAlgorithm]
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just [AEADAlgorithm]
allowed
            | AEADAlgorithm
aa AEADAlgorithm -> [AEADAlgorithm] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AEADAlgorithm]
allowed -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            | Bool
otherwise ->
                String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
                    String
"Decrypt policy rejects AEAD algorithm "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ AEADAlgorithm -> String
forall a. Show a => a -> String
show AEADAlgorithm
aa
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; allowed: "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ [AEADAlgorithm] -> String
forall a. Show a => a -> String
show [AEADAlgorithm]
allowed

skeskPayloadSymmetricAlgorithm
    :: SKESKPayload -> SymmetricAlgorithm
skeskPayloadSymmetricAlgorithm :: SKESKPayload -> SymmetricAlgorithm
skeskPayloadSymmetricAlgorithm SKESKPayload
payload =
    case SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload SKESKPayload
payload of
        ClassifiedSKESKPayloadV4 (SKESKPayloadV4 SymmetricAlgorithm
sa S2K
_ Maybe ByteString
_) -> SymmetricAlgorithm
sa
        ClassifiedSKESKPayloadV6 (SKESKPayloadV6 SymmetricAlgorithm
sa AEADAlgorithm
_ S2K
_ ByteString
_ ByteString
_ ByteString
_) -> SymmetricAlgorithm
sa

skeskPayloadS2K :: SKESKPayload -> S2K
skeskPayloadS2K :: SKESKPayload -> S2K
skeskPayloadS2K SKESKPayload
payload =
    case SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload SKESKPayload
payload of
        ClassifiedSKESKPayloadV4 (SKESKPayloadV4 SymmetricAlgorithm
_ S2K
s2k Maybe ByteString
_) -> S2K
s2k
        ClassifiedSKESKPayloadV6 (SKESKPayloadV6 SymmetricAlgorithm
_ AEADAlgorithm
_ S2K
s2k ByteString
_ ByteString
_ ByteString
_) -> S2K
s2k

skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm
skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm
skeskPayloadAEADAlgorithm SKESKPayload
payload =
    case SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload SKESKPayload
payload of
        ClassifiedSKESKPayloadV4 SKESKPayloadV4
_ -> Maybe AEADAlgorithm
forall a. Maybe a
Nothing
        ClassifiedSKESKPayloadV6 (SKESKPayloadV6 SymmetricAlgorithm
_ AEADAlgorithm
aa S2K
_ ByteString
_ ByteString
_ ByteString
_) -> AEADAlgorithm -> Maybe AEADAlgorithm
forall a. a -> Maybe a
Just AEADAlgorithm
aa

resolveSKESKSessionKey
    :: BL.ByteString -> SKESKPayload -> Either String B.ByteString
resolveSKESKSessionKey :: ByteString -> SKESKPayload -> Either String ByteString
resolveSKESKSessionKey ByteString
passphrase SKESKPayload
payload =
    (SKESKSessionKeyResolutionError -> String)
-> Either SKESKSessionKeyResolutionError ByteString
-> Either String ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SKESKSessionKeyResolutionError -> String
renderSKESKSessionKeyResolutionError (Either SKESKSessionKeyResolutionError ByteString
 -> Either String ByteString)
-> Either SKESKSessionKeyResolutionError ByteString
-> Either String ByteString
forall a b. (a -> b) -> a -> b
$
        ByteString
-> ClassifiedSKESKPayload
-> Either SKESKSessionKeyResolutionError ByteString
resolveSKESKSessionKeyTyped
            ByteString
passphrase
            (SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload SKESKPayload
payload)

data SKESKSessionKeyResolutionError
    = SKESKSessionKeyS2KError S2KError
    | SKESKSessionKeyOtherError String
    deriving (SKESKSessionKeyResolutionError
-> SKESKSessionKeyResolutionError -> Bool
(SKESKSessionKeyResolutionError
 -> SKESKSessionKeyResolutionError -> Bool)
-> (SKESKSessionKeyResolutionError
    -> SKESKSessionKeyResolutionError -> Bool)
-> Eq SKESKSessionKeyResolutionError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SKESKSessionKeyResolutionError
-> SKESKSessionKeyResolutionError -> Bool
== :: SKESKSessionKeyResolutionError
-> SKESKSessionKeyResolutionError -> Bool
$c/= :: SKESKSessionKeyResolutionError
-> SKESKSessionKeyResolutionError -> Bool
/= :: SKESKSessionKeyResolutionError
-> SKESKSessionKeyResolutionError -> Bool
Eq, Int -> SKESKSessionKeyResolutionError -> ShowS
[SKESKSessionKeyResolutionError] -> ShowS
SKESKSessionKeyResolutionError -> String
(Int -> SKESKSessionKeyResolutionError -> ShowS)
-> (SKESKSessionKeyResolutionError -> String)
-> ([SKESKSessionKeyResolutionError] -> ShowS)
-> Show SKESKSessionKeyResolutionError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SKESKSessionKeyResolutionError -> ShowS
showsPrec :: Int -> SKESKSessionKeyResolutionError -> ShowS
$cshow :: SKESKSessionKeyResolutionError -> String
show :: SKESKSessionKeyResolutionError -> String
$cshowList :: [SKESKSessionKeyResolutionError] -> ShowS
showList :: [SKESKSessionKeyResolutionError] -> ShowS
Show)

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

resolveSKESKSessionKeyTyped
    :: BL.ByteString
    -> ClassifiedSKESKPayload
    -> Either SKESKSessionKeyResolutionError B.ByteString
resolveSKESKSessionKeyTyped :: ByteString
-> ClassifiedSKESKPayload
-> Either SKESKSessionKeyResolutionError ByteString
resolveSKESKSessionKeyTyped ByteString
passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 SymmetricAlgorithm
sa S2K
s2k Maybe ByteString
Nothing)) =
    (S2KError -> SKESKSessionKeyResolutionError)
-> Either S2KError ByteString
-> Either SKESKSessionKeyResolutionError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
        S2KError -> SKESKSessionKeyResolutionError
SKESKSessionKeyS2KError
        (SKESK 'SKESKV4 -> ByteString -> Either S2KError ByteString
skesk2Key (SymmetricAlgorithm -> S2K -> Maybe ByteString -> SKESK 'SKESKV4
SKESK4Packet SymmetricAlgorithm
sa S2K
s2k Maybe ByteString
forall a. Maybe a
Nothing) ByteString
passphrase)
resolveSKESKSessionKeyTyped ByteString
passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 SymmetricAlgorithm
sa S2K
s2k (Just ByteString
esk))) =
    (S2KError -> SKESKSessionKeyResolutionError)
-> Either S2KError ByteString
-> Either SKESKSessionKeyResolutionError ByteString
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
        S2KError -> SKESKSessionKeyResolutionError
SKESKSessionKeyS2KError
        ( (SymmetricAlgorithm, ByteString) -> ByteString
forall a b. (a, b) -> b
snd
            ((SymmetricAlgorithm, ByteString) -> ByteString)
-> Either S2KError (SymmetricAlgorithm, ByteString)
-> Either S2KError ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SKESK 'SKESKV4
-> ByteString -> Either S2KError (SymmetricAlgorithm, ByteString)
skesk2SessionKey (SymmetricAlgorithm -> S2K -> Maybe ByteString -> SKESK 'SKESKV4
SKESK4Packet SymmetricAlgorithm
sa S2K
s2k (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
esk)) ByteString
passphrase
        )
resolveSKESKSessionKeyTyped ByteString
passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 SymmetricAlgorithm
sa AEADAlgorithm
aead S2K
s2k ByteString
iv ByteString
esk ByteString
tag)) = do
    keyLen <-
        (CipherError -> SKESKSessionKeyResolutionError)
-> Either CipherError Int
-> Either SKESKSessionKeyResolutionError Int
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first
            (S2KError -> SKESKSessionKeyResolutionError
SKESKSessionKeyS2KError (S2KError -> SKESKSessionKeyResolutionError)
-> (CipherError -> S2KError)
-> CipherError
-> SKESKSessionKeyResolutionError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CipherError -> S2KError
S2KUnsupportedAlgorithm)
            (SymmetricAlgorithm -> Either CipherError Int
keySize SymmetricAlgorithm
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 :: SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload (SKESKPayloadV4Packet SKESKPayloadV4
payloadV4) =
    SKESKPayloadV4 -> ClassifiedSKESKPayload
ClassifiedSKESKPayloadV4 SKESKPayloadV4
payloadV4
classifySKESKPayload (SKESKPayloadV6Packet SKESKPayloadV6
payloadV6) =
    SKESKPayloadV6 -> ClassifiedSKESKPayload
ClassifiedSKESKPayloadV6 SKESKPayloadV6
payloadV6

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

    strictAlignment :: Bool
strictAlignment = DecryptPolicy -> Bool
decryptRejectESKVersionMismatch (RecursorState -> DecryptPolicy
_decryptPolicy RecursorState
rs)
    alignedByVersion :: [PendingESK]
alignedByVersion = [AlignedPendingESK v] -> [PendingESK]
forall (v :: EncryptedPayloadVersion).
[AlignedPendingESK v] -> [PendingESK]
pendingESKsFromAligned [AlignedPendingESK v]
alignedStrict
    alignedStrict :: [AlignedPendingESK v]
alignedStrict = EncryptedPayloadFlavor v -> [PendingESK] -> [AlignedPendingESK v]
forall (v :: EncryptedPayloadVersion).
EncryptedPayloadFlavor v -> [PendingESK] -> [AlignedPendingESK v]
alignedPrecedingESKs EncryptedPayloadFlavor v
payloadFlavor (RecursorState -> [PendingESK]
_pendingESKs RecursorState
rs)

    skeskCandidates :: [PendingESK] -> [SKESKPayload]
skeskCandidates [PendingESK]
esks = [SKESKPayload
skesk | PendingSKESK SKESKPayload
skesk <- [PendingESK]
esks]

    pkeskCandidates :: [PendingESK] -> [PKESKPayload]
pkeskCandidates [PendingESK]
esks = [PKESKPayload
pkesk | PendingPKESK PKESKPayload
pkesk <- [PendingESK]
esks]

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

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

    skeskErrPrefix :: SKESKPayload -> String
skeskErrPrefix SKESKPayload
skesk = String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ SKESKPayload -> String
describeSKESK SKESKPayload
skesk String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"] "

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

    emitResolutionReport
        :: MonadIO m => DecryptSessionKeyResolutionReport -> m ()
    emitResolutionReport :: forall (m :: * -> *).
MonadIO m =>
DecryptSessionKeyResolutionReport -> m ()
emitResolutionReport DecryptSessionKeyResolutionReport
report =
        case Maybe (IORef [DecryptSessionKeyResolutionReport])
reportRef of
            Maybe (IORef [DecryptSessionKeyResolutionReport])
Nothing -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            Just IORef [DecryptSessionKeyResolutionReport]
ref -> IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IORef [DecryptSessionKeyResolutionReport]
-> ([DecryptSessionKeyResolutionReport]
    -> [DecryptSessionKeyResolutionReport])
-> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef [DecryptSessionKeyResolutionReport]
ref (DecryptSessionKeyResolutionReport
report DecryptSessionKeyResolutionReport
-> [DecryptSessionKeyResolutionReport]
-> [DecryptSessionKeyResolutionReport]
forall a. a -> [a] -> [a]
:))

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

    mkAttemptFailure :: PKESKRecipientKey
-> PKESKAttemptFailureKind -> String -> PKESKAttemptFailure
mkAttemptFailure PKESKRecipientKey
keyInfo PKESKAttemptFailureKind
failureKind String
reason =
        PKESKAttemptFailure
            { pkeskAttemptFailureKeyContext :: Maybe (KeyVersion, PubKeyAlgorithm)
pkeskAttemptFailureKeyContext =
                PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm)
recipientKeyContext PKESKRecipientKey
keyInfo
            , pkeskAttemptFailureKind :: PKESKAttemptFailureKind
pkeskAttemptFailureKind = PKESKAttemptFailureKind
failureKind
            , pkeskAttemptFailureReason :: String
pkeskAttemptFailureReason = String
reason
            }

    recipientKeyContext
        :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm)
    recipientKeyContext :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm)
recipientKeyContext PKESKRecipientKey
keyInfo =
        (SomePKPayload -> (KeyVersion, PubKeyAlgorithm))
-> Maybe SomePKPayload -> Maybe (KeyVersion, PubKeyAlgorithm)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
            (\SomePKPayload
pk -> (SomePKPayload -> KeyVersion
_keyVersion SomePKPayload
pk, SomePKPayload -> PubKeyAlgorithm
_pkalgo SomePKPayload
pk))
            (PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
keyInfo)

    renderPKESKResolverError :: PKESKResolverError -> String
renderPKESKResolverError (ResolverPolicyDenied String
reason) =
        String
"resolver policy denied candidate selection: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
    renderPKESKResolverError (ResolverBackendUnavailable String
reason) =
        String
"resolver backend unavailable: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason
    renderPKESKResolverError (ResolverInvalidResponse String
reason) =
        String
"resolver returned an invalid response: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
reason

    resolvePKESKRecipientKey :: PKESKPayload
-> [PKESKAttemptFailure]
-> Int
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
resolvePKESKRecipientKey PKESKPayload
payload [PKESKAttemptFailure]
previousFailures Int
attemptIndex0 =
        Int
-> [PKESKResolverAttempt]
-> [Pkt]
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
probePacketVariants
            Int
attemptIndex0
            []
            (PKESKPayload -> [Pkt]
pkeskCallbackPackets PKESKPayload
payload)
      where
        probePacketVariants :: Int
-> [PKESKResolverAttempt]
-> [Pkt]
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
probePacketVariants Int
attemptIndex [PKESKResolverAttempt]
attemptsAcc [] =
            Either
  String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> Either
     String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
forall a b. b -> Either a b
Right (Maybe PKESKRecipientKey
forall a. Maybe a
Nothing, Int
attemptIndex, [PKESKResolverAttempt] -> [PKESKResolverAttempt]
forall a. [a] -> [a]
reverse [PKESKResolverAttempt]
attemptsAcc))
        probePacketVariants Int
attemptIndex [PKESKResolverAttempt]
attemptsAcc (Pkt
probePkt : [Pkt]
restProbePkts) = do
            let request :: PKESKResolveRequest
request =
                    PKESKResolveRequest
                        { reqPKESK :: PKESKPayload
reqPKESK = PKESKPayload
payload
                        , reqProbePacket :: Pkt
reqProbePacket = Pkt
probePkt
                        , reqIsWildcardRecipient :: Bool
reqIsWildcardRecipient = PKESKPayload -> Bool
isWildcardPKESKPayload PKESKPayload
payload
                        , reqAttemptIndex :: Int
reqAttemptIndex = Int
attemptIndex
                        , reqPreviousFailures :: [PKESKAttemptFailure]
reqPreviousFailures = [PKESKAttemptFailure]
previousFailures
                        }
            resolveAction <-
                PKESKResolver IO
pkcb PKESKResolveRequest
request
            let attemptRecord =
                    PKESKResolverAttempt
                        { pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure]
pkeskResolverAttemptPreviousFailures = [PKESKAttemptFailure]
previousFailures
                        , pkeskResolverAttemptAction :: PKESKResolverAttemptAction
pkeskResolverAttemptAction =
                            case PKESKResolveAction
resolveAction of
                                ResolveWith PKESKRecipientKey
keyInfo ->
                                    Maybe (KeyVersion, PubKeyAlgorithm) -> PKESKResolverAttemptAction
ResolverAttemptResolveWith (PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm)
recipientKeyContext PKESKRecipientKey
keyInfo)
                                PKESKResolveAction
ResolveSkip -> PKESKResolverAttemptAction
ResolverAttemptSkip
                                PKESKResolveAction
ResolveExhausted -> PKESKResolverAttemptAction
ResolverAttemptExhausted
                                ResolveFail PKESKResolverError
resolverErr -> PKESKResolverError -> PKESKResolverAttemptAction
ResolverAttemptFail PKESKResolverError
resolverErr
                        }
            case resolveAction of
                ResolveWith PKESKRecipientKey
keyInfo ->
                    Either
  String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        ( (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> Either
     String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
forall a b. b -> Either a b
Right
                            ( PKESKRecipientKey -> Maybe PKESKRecipientKey
forall a. a -> Maybe a
Just PKESKRecipientKey
keyInfo
                            , Int
attemptIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                            , [PKESKResolverAttempt] -> [PKESKResolverAttempt]
forall a. [a] -> [a]
reverse (PKESKResolverAttempt
attemptRecord PKESKResolverAttempt
-> [PKESKResolverAttempt] -> [PKESKResolverAttempt]
forall a. a -> [a] -> [a]
: [PKESKResolverAttempt]
attemptsAcc)
                            )
                        )
                PKESKResolveAction
ResolveSkip ->
                    Int
-> [PKESKResolverAttempt]
-> [Pkt]
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
probePacketVariants
                        (Int
attemptIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                        (PKESKResolverAttempt
attemptRecord PKESKResolverAttempt
-> [PKESKResolverAttempt] -> [PKESKResolverAttempt]
forall a. a -> [a] -> [a]
: [PKESKResolverAttempt]
attemptsAcc)
                        [Pkt]
restProbePkts
                PKESKResolveAction
ResolveExhausted ->
                    Either
  String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                        ( (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> Either
     String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
forall a b. b -> Either a b
Right
                            ( Maybe PKESKRecipientKey
forall a. Maybe a
Nothing
                            , Int
attemptIndex Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1
                            , [PKESKResolverAttempt] -> [PKESKResolverAttempt]
forall a. [a] -> [a]
reverse (PKESKResolverAttempt
attemptRecord PKESKResolverAttempt
-> [PKESKResolverAttempt] -> [PKESKResolverAttempt]
forall a. a -> [a] -> [a]
: [PKESKResolverAttempt]
attemptsAcc)
                            )
                        )
                ResolveFail PKESKResolverError
resolverErr ->
                    Either
  String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
-> IO
     (Either
        String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt]))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String
-> Either
     String (Maybe PKESKRecipientKey, Int, [PKESKResolverAttempt])
forall a b. a -> Either a b
Left (PKESKResolverError -> String
renderPKESKResolverError PKESKResolverError
resolverErr))

    pkeskCallbackPackets :: PKESKPayload -> [Pkt]
pkeskCallbackPackets PKESKPayload
payload =
        [Pkt] -> [Pkt]
forall a. Eq a => [a] -> [a]
nub ([Pkt] -> [Pkt]) -> [Pkt] -> [Pkt]
forall a b. (a -> b) -> a -> b
$
            case PKESKPayload
payload of
                PKESKPayloadV3Packet (PKESKPayloadV3 Word8
v EightOctetKeyId
rid PubKeyAlgorithm
pka NonEmpty MPI
mpis) ->
                    (EightOctetKeyId -> Pkt) -> [EightOctetKeyId] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map
                        ( \EightOctetKeyId
ridVariant ->
                            PKESKPayload -> Pkt
PKESKPkt
                                (PKESKPayloadV3 -> PKESKPayload
PKESKPayloadV3Packet (Word8
-> EightOctetKeyId
-> PubKeyAlgorithm
-> NonEmpty MPI
-> PKESKPayloadV3
PKESKPayloadV3 Word8
v EightOctetKeyId
ridVariant PubKeyAlgorithm
pka NonEmpty MPI
mpis))
                        )
                        (EightOctetKeyId -> [EightOctetKeyId]
recipientIdCallbackVariantsV3 EightOctetKeyId
rid)
                PKESKPayloadV6Packet (PKESKPayloadV6 ByteString
rid PubKeyAlgorithm
pka ByteString
esk) ->
                    (ByteString -> Pkt) -> [ByteString] -> [Pkt]
forall a b. (a -> b) -> [a] -> [b]
map
                        ( \ByteString
ridVariant ->
                            PKESKPayload -> Pkt
PKESKPkt
                                (PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet (ByteString -> PubKeyAlgorithm -> ByteString -> PKESKPayloadV6
PKESKPayloadV6 ByteString
ridVariant PubKeyAlgorithm
pka ByteString
esk))
                        )
                        (ByteString -> [ByteString]
recipientIdCallbackVariants ByteString
rid)

    describeCallbackProbeSummary :: PKESKPayload -> String
describeCallbackProbeSummary PKESKPayload
payload =
        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
            String
", "
            ((Pkt -> String) -> [Pkt] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Pkt -> String
describePKESKCallbackProbe (PKESKPayload -> [Pkt]
pkeskCallbackPackets PKESKPayload
payload))

    describePKESKCallbackProbe :: Pkt -> String
describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 Word8
_ EightOctetKeyId
rid PubKeyAlgorithm
pka NonEmpty MPI
_))) =
        String
"PKESK3 "
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
pka
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rid="
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ EightOctetKeyId -> String
forall a. Show a => a -> String
show EightOctetKeyId
rid
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ if EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId EightOctetKeyId
rid
                then String
" (wildcard)"
                else String
""
    describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 ByteString
rid PubKeyAlgorithm
pka ByteString
_))) =
        String
"PKESK6 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
pka String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rid=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
rid
    describePKESKCallbackProbe Pkt
pkt = Pkt -> String
forall a. Show a => a -> String
show Pkt
pkt

    recipientIdCallbackVariantsV3 :: EightOctetKeyId -> [EightOctetKeyId]
recipientIdCallbackVariantsV3 EightOctetKeyId
rid
        | EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId EightOctetKeyId
rid = [EightOctetKeyId
rid]
        | Bool
otherwise = [EightOctetKeyId
rid, ByteString -> EightOctetKeyId
EightOctetKeyId (Int64 -> Word8 -> ByteString
BL.replicate Int64
8 Word8
0)]

    recipientIdCallbackVariants :: ByteString -> [ByteString]
recipientIdCallbackVariants ByteString
rid
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
20 = [ByteString
rid, Word8 -> ByteString -> ByteString
BL.cons Word8
0x04 ByteString
rid]
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
21 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
rid Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x04 = [ByteString
rid, HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BL.tail ByteString
rid]
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
32 = [ByteString
rid, Word8 -> ByteString -> ByteString
BL.cons Word8
0x06 ByteString
rid]
        | ByteString -> Int64
BL.length ByteString
rid Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
33 Bool -> Bool -> Bool
&& HasCallStack => ByteString -> Word8
ByteString -> Word8
BL.head ByteString
rid Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x06 = [ByteString
rid, HasCallStack => ByteString -> ByteString
ByteString -> ByteString
BL.tail ByteString
rid]
        | Bool
otherwise = [ByteString
rid]

    isWildcardPKESKPayload :: PKESKPayload -> Bool
isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 Word8
_ (EightOctetKeyId ByteString
rid) PubKeyAlgorithm
_ NonEmpty MPI
_)) =
        EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId (ByteString -> EightOctetKeyId
EightOctetKeyId ByteString
rid)
    isWildcardPKESKPayload PKESKPayload
_ = Bool
False
    describePKESK :: PKESKPayload -> String
describePKESK PKESKPayload
payload =
        case PKESKPayload -> ClassifiedPKESKPayload
classifyPKESKPayload PKESKPayload
payload of
            ClassifiedPKESKPayloadV3 (PKESKPayloadV3 Word8
_ EightOctetKeyId
rid PubKeyAlgorithm
pka NonEmpty MPI
_) ->
                String
"PKESK3 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
pka String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rid=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ EightOctetKeyId -> String
forall a. Show a => a -> String
show EightOctetKeyId
rid
            ClassifiedPKESKPayloadV6 (PKESKPayloadV6 ByteString
rid PubKeyAlgorithm
pka ByteString
_) ->
                String
"PKESK6 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
pka String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" rid=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
rid

    describeSKESK :: SKESKPayload -> String
describeSKESK SKESKPayload
payload =
        case SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload SKESKPayload
payload of
            ClassifiedSKESKPayloadV4 (SKESKPayloadV4 SymmetricAlgorithm
sa S2K
s2k Maybe ByteString
_) ->
                String
"SKESK4 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymmetricAlgorithm -> String
forall a. Show a => a -> String
show SymmetricAlgorithm
sa String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" s2k=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ S2K -> String
forall a. Show a => a -> String
show S2K
s2k
            ClassifiedSKESKPayloadV6 (SKESKPayloadV6 SymmetricAlgorithm
sa AEADAlgorithm
aa S2K
s2k ByteString
_ ByteString
_ ByteString
_) ->
                String
"SKESK6 " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SymmetricAlgorithm -> String
forall a. Show a => a -> String
show SymmetricAlgorithm
sa String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"/" String -> ShowS
forall a. [a] -> [a] -> [a]
++ AEADAlgorithm -> String
forall a. Show a => a -> String
show AEADAlgorithm
aa String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" s2k=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ S2K -> String
forall a. Show a => a -> String
show S2K
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 :: forall (v :: EncryptedPayloadVersion).
EncryptedPayloadFlavor v -> [PendingESK] -> [AlignedPendingESK v]
alignedPrecedingESKs EncryptedPayloadFlavor v
LegacyEncryptedPayload =
    (PendingESK -> Maybe (AlignedPendingESK v))
-> [PendingESK] -> [AlignedPendingESK v]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \PendingESK
esk ->
            case PendingESK
esk of
                PendingSKESK (SKESKPayloadV4Packet SKESKPayloadV4
skesk4) -> AlignedPendingESK v -> Maybe (AlignedPendingESK v)
forall a. a -> Maybe a
Just (SKESKPayloadV4 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion
LegacyAlignedSKESK SKESKPayloadV4
skesk4)
                PendingPKESK (PKESKPayloadV3Packet PKESKPayloadV3
pkesk3) -> AlignedPendingESK v -> Maybe (AlignedPendingESK v)
forall a. a -> Maybe a
Just (PKESKPayloadV3 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion
LegacyAlignedPKESK PKESKPayloadV3
pkesk3)
                PendingESK
_ -> Maybe (AlignedPendingESK v)
forall a. Maybe a
Nothing
        )
alignedPrecedingESKs (SEIPDv2EncryptedPayload SymmetricAlgorithm
_ AEADAlgorithm
_) =
    (PendingESK -> Maybe (AlignedPendingESK v))
-> [PendingESK] -> [AlignedPendingESK v]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe
        ( \PendingESK
esk ->
            case PendingESK
esk of
                PendingSKESK (SKESKPayloadV6Packet SKESKPayloadV6
skesk6) -> AlignedPendingESK v -> Maybe (AlignedPendingESK v)
forall a. a -> Maybe a
Just (SKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
SEIPDv2AlignedSKESK SKESKPayloadV6
skesk6)
                PendingPKESK (PKESKPayloadV6Packet PKESKPayloadV6
pkesk6) -> AlignedPendingESK v -> Maybe (AlignedPendingESK v)
forall a. a -> Maybe a
Just (PKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
SEIPDv2AlignedPKESK PKESKPayloadV6
pkesk6)
                -- v3 PKESK before SEIPDv2 is explicitly allowed by RFC 9580 §5.13;
                -- see 'SEIPDv2AlignedLegacyPKESK' for details.
                PendingPKESK (PKESKPayloadV3Packet PKESKPayloadV3
pkesk3) -> AlignedPendingESK v -> Maybe (AlignedPendingESK v)
forall a. a -> Maybe a
Just (PKESKPayloadV3 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
SEIPDv2AlignedLegacyPKESK PKESKPayloadV3
pkesk3)
                PendingESK
_ -> Maybe (AlignedPendingESK v)
forall a. Maybe a
Nothing
        )

pendingESKsFromAligned :: [AlignedPendingESK v] -> [PendingESK]
pendingESKsFromAligned :: forall (v :: EncryptedPayloadVersion).
[AlignedPendingESK v] -> [PendingESK]
pendingESKsFromAligned =
    (AlignedPendingESK v -> PendingESK)
-> [AlignedPendingESK v] -> [PendingESK]
forall a b. (a -> b) -> [a] -> [b]
map
        ( \AlignedPendingESK v
esk ->
            case AlignedPendingESK v
esk of
                LegacyAlignedSKESK SKESKPayloadV4
skesk4 -> SKESKPayload -> PendingESK
PendingSKESK (SKESKPayloadV4 -> SKESKPayload
SKESKPayloadV4Packet SKESKPayloadV4
skesk4)
                LegacyAlignedPKESK PKESKPayloadV3
pkesk3 -> PKESKPayload -> PendingESK
PendingPKESK (PKESKPayloadV3 -> PKESKPayload
PKESKPayloadV3Packet PKESKPayloadV3
pkesk3)
                SEIPDv2AlignedSKESK SKESKPayloadV6
skesk6 -> SKESKPayload -> PendingESK
PendingSKESK (SKESKPayloadV6 -> SKESKPayload
SKESKPayloadV6Packet SKESKPayloadV6
skesk6)
                SEIPDv2AlignedPKESK PKESKPayloadV6
pkesk6 -> PKESKPayload -> PendingESK
PendingPKESK (PKESKPayloadV6 -> PKESKPayload
PKESKPayloadV6Packet PKESKPayloadV6
pkesk6)
                SEIPDv2AlignedLegacyPKESK PKESKPayloadV3
pkesk3 -> PKESKPayload -> PendingESK
PendingPKESK (PKESKPayloadV3 -> PKESKPayload
PKESKPayloadV3Packet PKESKPayloadV3
pkesk3)
        )

payloadExpectedSymmetricAlgorithm
    :: EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm
payloadExpectedSymmetricAlgorithm :: forall (v :: EncryptedPayloadVersion).
EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm
payloadExpectedSymmetricAlgorithm EncryptedPayloadFlavor v
LegacyEncryptedPayload = Maybe SymmetricAlgorithm
forall a. Maybe a
Nothing
payloadExpectedSymmetricAlgorithm (SEIPDv2EncryptedPayload SymmetricAlgorithm
sa AEADAlgorithm
_) = SymmetricAlgorithm -> Maybe SymmetricAlgorithm
forall a. a -> Maybe a
Just SymmetricAlgorithm
sa

payloadExpectedAEADAlgorithm
    :: EncryptedPayloadFlavor v -> Maybe AEADAlgorithm
payloadExpectedAEADAlgorithm :: forall (v :: EncryptedPayloadVersion).
EncryptedPayloadFlavor v -> Maybe AEADAlgorithm
payloadExpectedAEADAlgorithm EncryptedPayloadFlavor v
LegacyEncryptedPayload = Maybe AEADAlgorithm
forall a. Maybe a
Nothing
payloadExpectedAEADAlgorithm (SEIPDv2EncryptedPayload SymmetricAlgorithm
_ AEADAlgorithm
aa) = AEADAlgorithm -> Maybe AEADAlgorithm
forall a. a -> Maybe a
Just AEADAlgorithm
aa

tryUnwrapPKESKSessionMaterial
    :: PKESKPayload
    -> PKESKRecipientKey
    -> IO (Either String B.ByteString)
tryUnwrapPKESKSessionMaterial :: PKESKPayload -> PKESKRecipientKey -> IO (Either String ByteString)
tryUnwrapPKESKSessionMaterial PKESKPayload
pkesk PKESKRecipientKey
keyInfo = do
    attempted <-
        forall e a. Exception e => IO a -> IO (Either e a)
try @SomeException
            (PKESKPayload -> PKESKRecipientKey -> IO ByteString
forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
PKESKPayload -> PKESKRecipientKey -> m ByteString
unwrapPKESKSessionMaterial PKESKPayload
pkesk PKESKRecipientKey
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 :: PKESKPayload -> ClassifiedPKESKPayload
classifyPKESKPayload (PKESKPayloadV3Packet PKESKPayloadV3
payloadV3) =
    PKESKPayloadV3 -> ClassifiedPKESKPayload
ClassifiedPKESKPayloadV3 PKESKPayloadV3
payloadV3
classifyPKESKPayload (PKESKPayloadV6Packet PKESKPayloadV6
payloadV6) =
    PKESKPayloadV6 -> ClassifiedPKESKPayload
ClassifiedPKESKPayloadV6 PKESKPayloadV6
payloadV6

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

pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm
pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm
pkeskPayloadAlgorithm PKESKPayload
payload =
    case PKESKPayload -> ClassifiedPKESKPayload
classifyPKESKPayload PKESKPayload
payload of
        ClassifiedPKESKPayloadV3 (PKESKPayloadV3 Word8
_ EightOctetKeyId
_ PubKeyAlgorithm
pka NonEmpty MPI
_) -> PubKeyAlgorithm
pka
        ClassifiedPKESKPayloadV6 (PKESKPayloadV6 ByteString
_ PubKeyAlgorithm
pka ByteString
_) -> PubKeyAlgorithm
pka

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

unwrapPKESKSessionMaterial
    :: (MonadFail m, MonadIO m)
    => PKESKPayload -> PKESKRecipientKey -> m B.ByteString
unwrapPKESKSessionMaterial :: forall (m :: * -> *).
(MonadFail m, MonadIO m) =>
PKESKPayload -> PKESKRecipientKey -> m ByteString
unwrapPKESKSessionMaterial PKESKPayload
pkesk PKESKRecipientKey
keyInfo = do
    (String -> m ()) -> (() -> m ()) -> Either String () -> m ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ()
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKPayload -> PKESKRecipientKey -> Either String ()
validateTable30Policy PKESKPayload
pkesk PKESKRecipientKey
keyInfo)
    unwrapCase <-
        (String -> m PKESKUnwrapCase)
-> (PKESKUnwrapCase -> m PKESKUnwrapCase)
-> Either String PKESKUnwrapCase
-> m PKESKUnwrapCase
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m PKESKUnwrapCase
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail PKESKUnwrapCase -> m PKESKUnwrapCase
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PKESKPayload -> PKESKRecipientKey -> Either String PKESKUnwrapCase
classifyPKESKUnwrapCase PKESKPayload
pkesk PKESKRecipientKey
keyInfo)
    case unwrapCase of
        PKESKUnwrapV3RSA PrivateKey
privateKey MPI
mpi ->
            PrivateKey -> ByteString -> m ByteString
forall {m :: * -> *}.
(MonadIO m, MonadFail m) =>
PrivateKey -> ByteString -> m ByteString
rsaUnwrap
                PrivateKey
privateKey
                (Int -> ByteString -> ByteString
leftPadTo (PrivateKey -> Int
rsaModulusBytes PrivateKey
privateKey) (Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp (MPI -> Integer
unMPI MPI
mpi)))
        PKESKUnwrapV6RSA PrivateKey
privateKey ByteString
esk -> do
            normalized <-
                (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PrivateKey -> ByteString -> Either String ByteString
normalizePKESKv6RSAEsk PrivateKey
privateKey ByteString
esk)
            rsaUnwrap privateKey normalized
        PKESKUnwrapV6ECDH PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka ByteString
esk PrivateKey
privateKey ->
            PKESKRecipientKey
-> PubKeyAlgorithm -> ByteString -> PrivateKey -> m ByteString
forall {m :: * -> *}.
MonadFail m =>
PKESKRecipientKey
-> PubKeyAlgorithm -> ByteString -> PrivateKey -> m ByteString
ecdhUnwrapV6 PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka ByteString
esk PrivateKey
privateKey
        PKESKUnwrapV6XDHRaw PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka ByteString
esk ByteString
privateKeyRaw ->
            PKESKRecipientKey
-> PubKeyAlgorithm -> ByteString -> ByteString -> m ByteString
forall {m :: * -> *}.
MonadFail m =>
PKESKRecipientKey
-> PubKeyAlgorithm -> ByteString -> ByteString -> m ByteString
ecdhUnwrapV6XDHRaw PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka ByteString
esk ByteString
privateKeyRaw
        PKESKUnwrapV3X25519FromECDH PKESKRecipientKey
recipientCtx NonEmpty MPI
mpis PrivateKey
privateKey -> do
            recipientPKP <-
                m SomePKPayload
-> (SomePKPayload -> m SomePKPayload)
-> Maybe SomePKPayload
-> m SomePKPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                    ( String -> m SomePKPayload
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                        String
"X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                    )
                    SomePKPayload -> m SomePKPayload
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                    (PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
recipientCtx)
            recipientSecretRaw <-
                either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
            x25519UnwrapV3 recipientCtx mpis recipientSecretRaw
        PKESKUnwrapV3X25519Raw PKESKRecipientKey
recipientCtx NonEmpty MPI
mpis ByteString
privateKeyRaw ->
            PKESKRecipientKey -> NonEmpty MPI -> ByteString -> m ByteString
forall {m :: * -> *}.
MonadFail m =>
PKESKRecipientKey -> NonEmpty MPI -> ByteString -> m ByteString
x25519UnwrapV3 PKESKRecipientKey
recipientCtx NonEmpty MPI
mpis ByteString
privateKeyRaw
        PKESKUnwrapV3ECDH PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka NonEmpty MPI
mpis PrivateKey
privateKey ->
            PKESKRecipientKey
-> PubKeyAlgorithm -> NonEmpty MPI -> PrivateKey -> m ByteString
forall {m :: * -> *}.
MonadFail m =>
PKESKRecipientKey
-> PubKeyAlgorithm -> NonEmpty MPI -> PrivateKey -> m ByteString
ecdhUnwrap PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka NonEmpty MPI
mpis PrivateKey
privateKey
  where
    validateTable30Policy
        :: PKESKPayload -> PKESKRecipientKey -> Either String ()
    validateTable30Policy :: PKESKPayload -> PKESKRecipientKey -> Either String ()
validateTable30Policy PKESKPayload
payload PKESKRecipientKey
recipientCtx =
        case PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
recipientCtx of
            Maybe SomePKPayload
Nothing -> () -> Either String ()
forall a b. b -> Either a b
Right ()
            Just SomePKPayload
recipientPKP ->
                case (PKESKPayload -> PubKeyAlgorithm
pkeskPayloadAlgorithm PKESKPayload
payload, SomePKPayload -> PKey
_pubkey SomePKPayload
recipientPKP) of
                    (PubKeyAlgorithm
ECDH, ECDHPubKey PKey
_ HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA) ->
                        SomePKPayload
-> HashAlgorithm -> SymmetricAlgorithm -> Either String ()
validateTable30PolicyForRecipient SomePKPayload
recipientPKP HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA
                    (PubKeyAlgorithm, PKey)
_ -> () -> Either String ()
forall a b. b -> Either a b
Right ()

    rsaUnwrap :: PrivateKey -> ByteString -> m ByteString
rsaUnwrap PrivateKey
privateKey ByteString
encryptedSessionMaterial = do
        decrypted <-
            IO (Either Error ByteString) -> m (Either Error ByteString)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
                ( PrivateKey -> ByteString -> IO (Either Error ByteString)
forall (m :: * -> *).
MonadRandom m =>
PrivateKey -> ByteString -> m (Either Error ByteString)
P15.decryptSafer PrivateKey
privateKey ByteString
encryptedSessionMaterial
                    :: IO (Either RSATypes.Error B.ByteString)
                )
        case decrypted of
            Left Error
err -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"RSA PKESK decrypt failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Error -> String
forall a. Show a => a -> String
show Error
err)
            Right ByteString
decoded -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded

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

    ecdhUnwrap :: PKESKRecipientKey
-> PubKeyAlgorithm -> NonEmpty MPI -> PrivateKey -> m ByteString
ecdhUnwrap PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka NonEmpty MPI
mpis PrivateKey
privateKey = do
        recipientPKP <-
            m SomePKPayload
-> (SomePKPayload -> m SomePKPayload)
-> Maybe SomePKPayload
-> m SomePKPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                ( String -> m SomePKPayload
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    String
"ECDH PKESK unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                SomePKPayload -> m SomePKPayload
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
recipientCtx)
        case _pubkey recipientPKP of
            ECDHPubKey PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA -> do
                (ephemeralBytes, wrappedSessionKeyBytes) <-
                    (String -> m (ByteString, ByteString))
-> ((ByteString, ByteString) -> m (ByteString, ByteString))
-> Either String (ByteString, ByteString)
-> m (ByteString, ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m (ByteString, ByteString)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ByteString, ByteString) -> m (ByteString, ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (NonEmpty MPI -> Either String (ByteString, ByteString)
parseECDHPKESKMPIs NonEmpty MPI
mpis)
                sharedSecret <-
                    case ecdhPub of
                        ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey Curve
curve PublicPoint
_)) -> do
                            ephPoint <- Curve -> ByteString -> m PublicPoint
forall (m :: * -> *).
MonadFail m =>
Curve -> ByteString -> m PublicPoint
parseUncompressedPointForCurve Curve
curve ByteString
ephemeralBytes
                            pure
                                ( BA.convert
                                    (ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint)
                                    :: B.ByteString
                                )
                        EdDSAPubKey EdSigningCurve
EdSigningCurve25519 EdPoint
_ -> do
                            recipientSecretRaw <-
                                (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomePKPayload -> PrivateKey -> Either String ByteString
resolveX25519SecretRaw SomePKPayload
recipientPKP PrivateKey
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 EdSigningCurve
EdSigningCurve448 EdPoint
_ ->
                            String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                String
"legacy ECDH PKESK unwrap does not support Curve448Legacy recipients"
                        PKey
_ ->
                            String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                String
"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 =
                        LegacyECDHWrappedRFC3394Ciphertext
-> [LegacyECDHWrappedRFC3394Ciphertext]
candidateWrappedRFC3394CiphertextsForLegacyECDH
                            (ByteString -> LegacyECDHWrappedRFC3394Ciphertext
LegacyECDHWrappedRFC3394Ciphertext ByteString
wrappedSessionKeyBytes)
                    validUnwraps =
                        [ LegacyECDHDecodedSessionMaterial
material
                        | LegacyECDHWrappedRFC3394Ciphertext
wrappedCandidate <- [LegacyECDHWrappedRFC3394Ciphertext]
wrappedCandidates
                        , Right ByteString
decoded <-
                            [ SymmetricAlgorithm
-> ByteString -> ByteString -> Either String ByteString
aesKeyUnwrapRFC3394
                                SymmetricAlgorithm
kdfSA
                                ByteString
kek
                                (LegacyECDHWrappedRFC3394Ciphertext -> ByteString
unLegacyECDHWrappedRFC3394Ciphertext LegacyECDHWrappedRFC3394Ciphertext
wrappedCandidate)
                            ]
                        , Right LegacyECDHDecodedSessionMaterial
material <- [ByteString -> Either String LegacyECDHDecodedSessionMaterial
parseLegacyECDHDecodedSessionMaterial ByteString
decoded]
                        ]
                case validUnwraps of
                    (LegacyECDHDecodedSessionMaterial
material : [LegacyECDHDecodedSessionMaterial]
_) -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LegacyECDHDecodedSessionMaterial -> ByteString
encodeLegacyECDHSessionMaterial LegacyECDHDecodedSessionMaterial
material)
                    [] ->
                        case SymmetricAlgorithm
-> ByteString -> ByteString -> Either String ByteString
aesKeyUnwrapRFC3394 SymmetricAlgorithm
kdfSA ByteString
kek ByteString
wrappedSessionKeyBytes of
                            Left String
err -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
                            Right ByteString
_ ->
                                String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                    String
"legacy ECDH wrapped session key decrypted but decoded session material is malformed"
            PKey
_ ->
                String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    String
"ECDH PKESK unwrap requires recipient PKPayload with ECDHPubKey parameters"

    ecdhUnwrapV6 :: PKESKRecipientKey
-> PubKeyAlgorithm -> ByteString -> PrivateKey -> m ByteString
ecdhUnwrapV6 PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka ByteString
esk PrivateKey
privateKey = do
        recipientPKP <-
            m SomePKPayload
-> (SomePKPayload -> m SomePKPayload)
-> Maybe SomePKPayload
-> m SomePKPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                ( String -> m SomePKPayload
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    String
"ECDH PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                SomePKPayload -> m SomePKPayload
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
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 PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA -> do
                            (ephemeralBytes, wrappedSessionKeyBytes) <-
                                (String -> m (ByteString, ByteString))
-> ((ByteString, ByteString) -> m (ByteString, ByteString))
-> Either String (ByteString, ByteString)
-> m (ByteString, ByteString)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m (ByteString, ByteString)
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (ByteString, ByteString) -> m (ByteString, ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PubKeyAlgorithm
-> ByteString -> Either String (ByteString, ByteString)
parsePKESKv6ECDHEsk PubKeyAlgorithm
pka ByteString
esk)
                            case ecdhPub of
                                ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey Curve
curve PublicPoint
_)) -> do
                                    ephPoint <- Curve -> ByteString -> m PublicPoint
forall (m :: * -> *).
MonadFail m =>
Curve -> ByteString -> m PublicPoint
parseUncompressedPointForCurve Curve
curve ByteString
ephemeralBytes
                                    let sharedSecret =
                                            SharedKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert
                                                (Curve -> Integer -> PublicPoint -> SharedKey
ECCDH.getShared Curve
curve (PrivateKey -> Integer
ECDSA.private_d PrivateKey
privateKey) PublicPoint
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 String
err -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
                                        Right ByteString
decoded -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded
                                EdDSAPubKey EdSigningCurve
EdSigningCurve25519 EdPoint
_ -> do
                                    recipientSecretRaw <-
                                        (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomePKPayload -> PrivateKey -> Either String ByteString
resolveX25519SecretRaw SomePKPayload
recipientPKP PrivateKey
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 = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C25519.dh PublicKey
ephPub SecretKey
recipientSecret) :: B.ByteString
                                    param <-
                                        either
                                            fail
                                            pure
                                            (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
                                    let rfc6637Result =
                                            do
                                                kek <- HashAlgorithm
-> SymmetricAlgorithm
-> ByteString
-> ByteString
-> Either String ByteString
deriveECDHKek HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ByteString
sharedSecret ByteString
param
                                                aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes
                                    case rfc6637Result of
                                        Right ByteString
decoded -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded
                                        Left String
rfc6637Err -> do
                                            recipientPublicRaw <-
                                                (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomePKPayload -> Either String ByteString
extractX25519RecipientPublic SomePKPayload
recipientPKP)
                                            let kekX25519 = ByteString -> ByteString -> ByteString -> ByteString
deriveX25519Kek ByteString
ephBytes ByteString
recipientPublicRaw ByteString
sharedSecret
                                            case aesKeyUnwrapRFC3394 AES128 kekX25519 wrappedSessionKeyBytes of
                                                Right ByteString
decoded -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded
                                                Left String
x25519Err ->
                                                    String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                                        ( String
"ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: "
                                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rfc6637Err
                                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", X25519: "
                                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
x25519Err
                                                            String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
                                                        )
                                EdDSAPubKey EdSigningCurve
EdSigningCurve448 EdPoint
_ ->
                                    String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                        String
"ECDH PKESKv6 unwrap does not support Curve448Legacy recipients; use X448 PKESKv6 packets"
                                PKey
_ ->
                                    String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                        String
"ECDH PKESKv6 unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible"
                        PKey
_ ->
                            String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                String
"ECDH PKESKv6 unwrap requires recipient PKPayload with ECDHPubKey parameters"

    ecdhUnwrapV6XDHRaw :: PKESKRecipientKey
-> PubKeyAlgorithm -> ByteString -> ByteString -> m ByteString
ecdhUnwrapV6XDHRaw PKESKRecipientKey
recipientCtx PubKeyAlgorithm
pka ByteString
esk ByteString
privateKeyRaw = do
        recipientPKP <-
            m SomePKPayload
-> (SomePKPayload -> m SomePKPayload)
-> Maybe SomePKPayload
-> m SomePKPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                ( String -> m SomePKPayload
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    String
"X25519/X448 PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                SomePKPayload -> m SomePKPayload
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
recipientCtx)
        case pka of
            PubKeyAlgorithm
X25519 -> SomePKPayload -> ByteString -> ByteString -> m ByteString
forall {m :: * -> *}.
MonadFail m =>
SomePKPayload -> ByteString -> ByteString -> m ByteString
v6X25519Unwrap SomePKPayload
recipientPKP (Int -> ByteString -> ByteString
leftPadTo Int
32 ByteString
privateKeyRaw) ByteString
esk
            PubKeyAlgorithm
X448 -> SomePKPayload -> ByteString -> ByteString -> m ByteString
forall {m :: * -> *}.
MonadFail m =>
SomePKPayload -> ByteString -> ByteString -> m ByteString
v6X448Unwrap SomePKPayload
recipientPKP (Int -> ByteString -> ByteString
leftPadTo Int
56 ByteString
privateKeyRaw) ByteString
esk
            PubKeyAlgorithm
_ ->
                String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    ( String
"X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ PubKeyAlgorithm -> String
forall a. Show a => a -> String
show PubKeyAlgorithm
pka
                    )

    v6X25519Unwrap :: SomePKPayload -> ByteString -> ByteString -> m ByteString
v6X25519Unwrap SomePKPayload
recipientPKP ByteString
recipientSecretRaw ByteString
esk = do
        recipientPublicRaw <-
            (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomePKPayload -> Either String ByteString
extractX25519RecipientPublic SomePKPayload
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 = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C25519.dh PublicKey
ephPub SecretKey
recipientSecret) :: B.ByteString
            kek = ByteString -> ByteString -> ByteString -> ByteString
deriveX25519Kek ByteString
ephBytes ByteString
recipientPublicRaw ByteString
sharedSecret
        case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of
            Left String
err -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
            Right ByteString
decoded -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded

    extractX25519RecipientPublic :: SomePKPayload -> Either String ByteString
extractX25519RecipientPublic SomePKPayload
recipientPKP =
        case SomePKPayload -> PKey
_pubkey SomePKPayload
recipientPKP of
            EdDSAPubKey EdSigningCurve
EdSigningCurve25519 EdPoint
point ->
                ByteString -> Either String ByteString
normalizeX25519EphemeralPublic (EdPoint -> ByteString
edPointBytes EdPoint
point)
            ECDHPubKey (EdDSAPubKey EdSigningCurve
EdSigningCurve25519 EdPoint
point) HashAlgorithm
_ SymmetricAlgorithm
_ ->
                ByteString -> Either String ByteString
normalizeX25519EphemeralPublic (EdPoint -> ByteString
edPointBytes EdPoint
point)
            PKey
other ->
                String -> Either String ByteString
forall a b. a -> Either a b
Left
                    ( String
"X25519 PKESKv6 unwrap requires an X25519 recipient public key, got "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ PKey -> String
forall a. Show a => a -> String
show PKey
other
                    )

    extractX448RecipientPublic :: SomePKPayload -> Either String ByteString
extractX448RecipientPublic SomePKPayload
recipientPKP =
        case SomePKPayload -> PKey
_pubkey SomePKPayload
recipientPKP of
            EdDSAPubKey EdSigningCurve
EdSigningCurve448 EdPoint
point ->
                ByteString -> Either String ByteString
normalizeX448EphemeralPublic (EdPoint -> ByteString
edPointBytes EdPoint
point)
            ECDHPubKey (EdDSAPubKey EdSigningCurve
EdSigningCurve448 EdPoint
point) HashAlgorithm
_ SymmetricAlgorithm
_ ->
                ByteString -> Either String ByteString
normalizeX448EphemeralPublic (EdPoint -> ByteString
edPointBytes EdPoint
point)
            PKey
other ->
                String -> Either String ByteString
forall a b. a -> Either a b
Left
                    ( String
"X448 PKESKv6 unwrap requires an X448 recipient public key, got "
                        String -> ShowS
forall a. [a] -> [a] -> [a]
++ PKey -> String
forall a. Show a => a -> String
show PKey
other
                    )

    resolveX25519SecretRaw :: SomePKPayload -> PrivateKey -> Either String ByteString
resolveX25519SecretRaw SomePKPayload
recipientPKP PrivateKey
privateKey = do
        recipientPublicRaw <- SomePKPayload -> Either String ByteString
extractX25519RecipientPublic SomePKPayload
recipientPKP
        let secretBE = Int -> ByteString -> ByteString
leftPadTo Int
32 (Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp (PrivateKey -> Integer
ECDSA.private_d PrivateKey
privateKey))
            candidates = [ByteString
secretBE, ByteString -> ByteString
B.reverse ByteString
secretBE]
            matchesCandidate ByteString
candidate =
                case CryptoFailable SecretKey -> Either CryptoError SecretKey
forall a. CryptoFailable a -> Either CryptoError a
CE.eitherCryptoError (ByteString -> CryptoFailable SecretKey
forall bs. ByteArrayAccess bs => bs -> CryptoFailable SecretKey
C25519.secretKey ByteString
candidate) of
                    Right SecretKey
sk ->
                        let derivedPub :: ByteString
derivedPub = PublicKey -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (SecretKey -> PublicKey
C25519.toPublic SecretKey
sk) :: B.ByteString
                         in ByteString
derivedPub ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
recipientPublicRaw
                    Left CryptoError
_ -> Bool
False
        case filter matchesCandidate candidates of
            (ByteString
candidate : [ByteString]
_) -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
candidate
            [] -> ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
secretBE

    v6X448Unwrap :: SomePKPayload -> ByteString -> ByteString -> m ByteString
v6X448Unwrap SomePKPayload
recipientPKP ByteString
recipientSecretRaw ByteString
esk = do
        recipientPublicRaw <-
            (String -> m ByteString)
-> (ByteString -> m ByteString)
-> Either String ByteString
-> m ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomePKPayload -> Either String ByteString
extractX448RecipientPublic SomePKPayload
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 = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C448.dh PublicKey
ephPub SecretKey
recipientSecret) :: B.ByteString
            kek = ByteString -> ByteString -> ByteString -> ByteString
deriveX448Kek ByteString
ephBytes ByteString
recipientPublicRaw ByteString
sharedSecret
        case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of
            Left String
err -> String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
err
            Right ByteString
decoded -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
decoded

    x25519UnwrapV3 :: PKESKRecipientKey -> NonEmpty MPI -> ByteString -> m ByteString
x25519UnwrapV3 PKESKRecipientKey
recipientCtx NonEmpty MPI
mpis ByteString
recipientSecretRaw = do
        recipientPKP <-
            m SomePKPayload
-> (SomePKPayload -> m SomePKPayload)
-> Maybe SomePKPayload
-> m SomePKPayload
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                ( String -> m SomePKPayload
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                    String
"X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback"
                )
                SomePKPayload -> m SomePKPayload
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
                (PKESKRecipientKey -> Maybe SomePKPayload
pkeskRecipientPKPayload PKESKRecipientKey
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 = DhSecret -> ByteString
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
BA.convert (PublicKey -> SecretKey -> DhSecret
C25519.dh PublicKey
ephPub SecretKey
recipientSecret) :: B.ByteString
            kek9580 = ByteString -> ByteString -> ByteString -> ByteString
deriveX25519Kek ByteString
ephBytes ByteString
recipientPublicRaw ByteString
sharedSecret
            -- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key)
            rfc9580Result = do
                (sessionAlgorithm, wrappedKey) <-
                    ByteString -> Either String (SymmetricAlgorithm, ByteString)
parsePKESKv3X25519EskBytes ByteString
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 ByteString
result -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
result
            Left String
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 :: [(ByteString, SymmetricAlgorithm)]
kekPairs =
                        (ByteString
kek9580, SymmetricAlgorithm
AES128)
                            (ByteString, SymmetricAlgorithm)
-> [(ByteString, SymmetricAlgorithm)]
-> [(ByteString, SymmetricAlgorithm)]
forall a. a -> [a] -> [a]
: SomePKPayload -> ByteString -> [(ByteString, SymmetricAlgorithm)]
x25519LegacyECDHKekCandidates SomePKPayload
recipientPKP ByteString
sharedSecret
                    wrapped :: LegacyECDHWrappedRFC3394Ciphertext
wrapped = ByteString -> LegacyECDHWrappedRFC3394Ciphertext
LegacyECDHWrappedRFC3394Ciphertext ByteString
eskBytes
                    candidates :: [LegacyECDHWrappedRFC3394Ciphertext]
candidates = LegacyECDHWrappedRFC3394Ciphertext
-> [LegacyECDHWrappedRFC3394Ciphertext]
candidateWrappedRFC3394CiphertextsForLegacyECDH LegacyECDHWrappedRFC3394Ciphertext
wrapped
                    validResults :: [ByteString]
validResults =
                        [ LegacyECDHDecodedSessionMaterial -> ByteString
encodeLegacyECDHSessionMaterial LegacyECDHDecodedSessionMaterial
material
                        | (ByteString
kek, SymmetricAlgorithm
kekSA) <- [(ByteString, SymmetricAlgorithm)]
kekPairs
                        , LegacyECDHWrappedRFC3394Ciphertext
candidate <- [LegacyECDHWrappedRFC3394Ciphertext]
candidates
                        , Right ByteString
decoded <-
                            [ SymmetricAlgorithm
-> ByteString -> ByteString -> Either String ByteString
aesKeyUnwrapRFC3394
                                SymmetricAlgorithm
kekSA
                                ByteString
kek
                                (LegacyECDHWrappedRFC3394Ciphertext -> ByteString
unLegacyECDHWrappedRFC3394Ciphertext LegacyECDHWrappedRFC3394Ciphertext
candidate)
                            ]
                        , Right LegacyECDHDecodedSessionMaterial
material <- [ByteString -> Either String LegacyECDHDecodedSessionMaterial
parseLegacyECDHDecodedSessionMaterial ByteString
decoded]
                        ]
                 in case [ByteString]
validResults of
                        (ByteString
result : [ByteString]
_) -> ByteString -> m ByteString
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
result
                        [] ->
                            String -> m ByteString
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
                                ( String
"X25519 PKESKv3 unwrap failed (RFC9580: "
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rfc9580Err
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"; 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 :: SomePKPayload -> ByteString -> [(ByteString, SymmetricAlgorithm)]
x25519LegacyECDHKekCandidates SomePKPayload
pkPayload ByteString
sharedSecret =
        case SomePKPayload -> PKey
_pubkey SomePKPayload
pkPayload of
            ECDHPubKey PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ->
                [ (ByteString
kek, SymmetricAlgorithm
kdfSA)
                | Right ByteString
param <-
                    [SomePKPayload
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> Either String ByteString
buildECDHKDFParam SomePKPayload
pkPayload PubKeyAlgorithm
X25519 PKey
ecdhPub HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA]
                , Right ByteString
kek <- [HashAlgorithm
-> SymmetricAlgorithm
-> ByteString
-> ByteString
-> Either String ByteString
deriveECDHKek HashAlgorithm
kdfHA SymmetricAlgorithm
kdfSA ByteString
sharedSecret ByteString
param]
                ]
            PKey
_ -> []

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

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

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

newtype LegacyECDHWrappedRFC3394Ciphertext
    = LegacyECDHWrappedRFC3394Ciphertext
    { LegacyECDHWrappedRFC3394Ciphertext -> ByteString
unLegacyECDHWrappedRFC3394Ciphertext :: B.ByteString
    }
    deriving (LegacyECDHWrappedRFC3394Ciphertext
-> LegacyECDHWrappedRFC3394Ciphertext -> Bool
(LegacyECDHWrappedRFC3394Ciphertext
 -> LegacyECDHWrappedRFC3394Ciphertext -> Bool)
-> (LegacyECDHWrappedRFC3394Ciphertext
    -> LegacyECDHWrappedRFC3394Ciphertext -> Bool)
-> Eq LegacyECDHWrappedRFC3394Ciphertext
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LegacyECDHWrappedRFC3394Ciphertext
-> LegacyECDHWrappedRFC3394Ciphertext -> Bool
== :: LegacyECDHWrappedRFC3394Ciphertext
-> LegacyECDHWrappedRFC3394Ciphertext -> Bool
$c/= :: LegacyECDHWrappedRFC3394Ciphertext
-> LegacyECDHWrappedRFC3394Ciphertext -> Bool
/= :: LegacyECDHWrappedRFC3394Ciphertext
-> LegacyECDHWrappedRFC3394Ciphertext -> Bool
Eq)

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

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

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

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

legacyECDHRFC3394WrappedLengths :: [Int]
legacyECDHRFC3394WrappedLengths :: [Int]
legacyECDHRFC3394WrappedLengths =
    (Int -> Int) -> [Int] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
forall {a}. Integral a => a -> a
legacyRFC3394WrappedLenForKeyLen [Int
16, Int
24, Int
32]
  where
    legacyRFC3394WrappedLenForKeyLen :: a -> a
legacyRFC3394WrappedLenForKeyLen a
keyLen =
        let encodedLen :: a
encodedLen = a
1 a -> a -> a
forall a. Num a => a -> a -> a
+ a
keyLen a -> a -> a
forall a. Num a => a -> a -> a
+ a
2
            paddedLen :: a
paddedLen = ((a
encodedLen a -> a -> a
forall a. Num a => a -> a -> a
+ a
7) a -> a -> a
forall a. Integral a => a -> a -> a
`div` a
8) a -> a -> a
forall a. Num a => a -> a -> a
* a
8
         in a
paddedLen a -> a -> a
forall a. Num a => a -> a -> a
+ a
8

parseLegacyECDHDecodedSessionMaterial
    :: B.ByteString -> Either String LegacyECDHDecodedSessionMaterial
parseLegacyECDHDecodedSessionMaterial :: ByteString -> Either String LegacyECDHDecodedSessionMaterial
parseLegacyECDHDecodedSessionMaterial ByteString
decoded = do
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
decoded Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left String
"legacy ECDH decoded session material is too short"
    let sessionAlgorithm :: SymmetricAlgorithm
sessionAlgorithm = Word8 -> SymmetricAlgorithm
forall a. FutureVal a => Word8 -> a
toFVal (HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
decoded)
    sessionKeyLen <- SymmetricAlgorithm -> Either String Int
symmetricKeyLength SymmetricAlgorithm
sessionAlgorithm
    let payload = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
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 =
            Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
checksumBytes Int
0) Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8
                Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
checksumBytes Int
1)
        actualChecksum = ByteString -> Word16
checksum16 ByteString
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 -> ByteString
encodeLegacyECDHSessionMaterial
    ( LegacyECDHDecodedSessionMaterial
            SymmetricAlgorithm
sessionAlgorithm
            (LegacyECDHSessionKey ByteString
sessionKey)
            LegacyECDHSessionPadding
_
        ) =
        Word8 -> ByteString
B.singleton (Word8 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (SymmetricAlgorithm -> Word8
forall a. FutureVal a => a -> Word8
fromFVal SymmetricAlgorithm
sessionAlgorithm))
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sessionKey
            ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
checksum16Bytes ByteString
sessionKey

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

    parseFixedEphemeralWithWrappedLenMaybe :: Int -> ByteString -> Maybe (ByteString, ByteString)
parseFixedEphemeralWithWrappedLenMaybe Int
ephLen ByteString
payload =
        let (ByteString
eph, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
ephLen ByteString
payload
         in if ByteString -> Int
B.length ByteString
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2
                then
                    let wrappedLen :: Int
wrappedLen = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
rest)
                        wrapped :: ByteString
wrapped = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
rest
                     in if Int
wrappedLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString -> Int
B.length ByteString
wrapped Bool -> Bool -> Bool
&& ByteString -> Bool
validWrappedPayload ByteString
wrapped
                            then (ByteString, ByteString) -> Maybe (ByteString, ByteString)
forall a. a -> Maybe a
Just (ByteString
eph, ByteString
wrapped)
                            else Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing
                else Maybe (ByteString, ByteString)
forall a. Maybe a
Nothing

    parseFixedEphemeralWithWrappedLen :: Int -> ByteString -> Either String (ByteString, ByteString)
parseFixedEphemeralWithWrappedLen Int
ephLen ByteString
payload =
        Either String (ByteString, ByteString)
-> ((ByteString, ByteString)
    -> Either String (ByteString, ByteString))
-> Maybe (ByteString, ByteString)
-> Either String (ByteString, ByteString)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
            ( String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left
                ( String
"PKESKv6 XDH ESK expected {ephemeral"
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
ephLen
                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"||len||wrapped} framing"
                )
            )
            (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall a b. b -> Either a b
Right
            (Int -> ByteString -> Maybe (ByteString, ByteString)
parseFixedEphemeralWithWrappedLenMaybe Int
ephLen ByteString
payload)

    parseLenPrefixedEphemeral :: Int -> ByteString -> Either String (ByteString, ByteString)
parseLenPrefixedEphemeral Int
expectedLen ByteString
payload =
        if ByteString -> Bool
B.null ByteString
payload
            then String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left String
"PKESKv6 XDH ESK is empty"
            else
                let ephLen :: Int
ephLen = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
payload)
                    rest :: ByteString
rest = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
payload
                 in if Int
ephLen Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
expectedLen Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
rest Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
ephLen
                        then
                            let (ByteString
eph, ByteString
wrapped) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
ephLen ByteString
rest
                             in if ByteString -> Bool
validWrappedPayload ByteString
wrapped
                                    then (ByteString, ByteString) -> Either String (ByteString, ByteString)
forall a b. b -> Either a b
Right (ByteString
eph, ByteString
wrapped)
                                    else String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left String
"PKESKv6 XDH ESK wrapped payload has invalid length"
                        else
                            String -> Either String (ByteString, ByteString)
forall a b. a -> Either a b
Left
                                ( String
"PKESKv6 XDH ESK expected "
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expectedLen
                                    String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-octet ephemeral value"
                                )

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

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

parseUncompressedPointForCurve
    :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point
parseUncompressedPointForCurve :: forall (m :: * -> *).
MonadFail m =>
Curve -> ByteString -> m PublicPoint
parseUncompressedPointForCurve Curve
curve ByteString
bs
    | ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
1 = String -> m PublicPoint
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ECDH ephemeral point is empty"
    | Just Int
expectedLen <- Curve -> Maybe Int
expectedUncompressedPointLength Curve
curve
    , ByteString -> Int
B.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
expectedLen =
        String -> m PublicPoint
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail
            ( String
"ECDH ephemeral point has invalid length for recipient curve: expected "
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expectedLen
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
", got "
                String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (ByteString -> Int
B.length ByteString
bs)
            )
    | HasCallStack => ByteString -> Word8
ByteString -> Word8
B.head ByteString
bs Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0x04 =
        String -> m PublicPoint
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ECDH ephemeral point must be uncompressed (0x04)"
    | Bool
otherwise =
        let xy :: ByteString
xy = HasCallStack => ByteString -> ByteString
ByteString -> ByteString
B.tail ByteString
bs
         in if Int -> Bool
forall a. Integral a => a -> Bool
odd (ByteString -> Int
B.length ByteString
xy)
                then String -> m PublicPoint
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"ECDH ephemeral point has malformed coordinate length"
                else
                    let (ByteString
xb, ByteString
yb) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt (ByteString -> Int
B.length ByteString
xy Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2) ByteString
xy
                     in PublicPoint -> m PublicPoint
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> Integer -> PublicPoint
ECCT.Point (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
xb) (ByteString -> Integer
forall ba. ByteArrayAccess ba => ba -> Integer
os2ip ByteString
yb))

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

deriveX25519Kek
    :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX25519Kek :: ByteString -> ByteString -> ByteString -> ByteString
deriveX25519Kek ByteString
ephemeralPublic ByteString
recipientPublic ByteString
sharedSecret =
    let ikm :: ByteString
ikm = ByteString
ephemeralPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
recipientPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sharedSecret
        prk :: PRK SHA256
prk = forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
extract @CHA.SHA256 ByteString
B.empty ByteString
ikm
        info :: B.ByteString
        info :: ByteString
info = ByteString
"OpenPGP X25519"
        okm :: B.ByteString
        okm :: ByteString
okm = forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
expand @CHA.SHA256 PRK SHA256
prk ByteString
info Int
16
     in ByteString
okm

deriveX448Kek
    :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX448Kek :: ByteString -> ByteString -> ByteString -> ByteString
deriveX448Kek ByteString
ephemeralPublic ByteString
recipientPublic ByteString
sharedSecret =
    let ikm :: ByteString
ikm = ByteString
ephemeralPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
recipientPublic ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sharedSecret
        prk :: PRK SHA512
prk = forall a salt ikm.
(HashAlgorithm a, ByteArrayAccess salt, ByteArrayAccess ikm) =>
salt -> ikm -> PRK a
extract @CHA.SHA512 ByteString
B.empty ByteString
ikm
        info :: B.ByteString
        info :: ByteString
info = ByteString
"OpenPGP X448"
        okm :: B.ByteString
        okm :: ByteString
okm = forall a info out.
(HashAlgorithm a, ByteArrayAccess info, ByteArray out) =>
PRK a -> info -> Int -> out
expand @CHA.SHA512 PRK SHA512
prk ByteString
info Int
32
     in ByteString
okm

aesKeyUnwrapRFC3394
    :: SymmetricAlgorithm
    -> B.ByteString
    -> B.ByteString
    -> Either String B.ByteString
aesKeyUnwrapRFC3394 :: SymmetricAlgorithm
-> ByteString -> ByteString -> Either String ByteString
aesKeyUnwrapRFC3394 SymmetricAlgorithm
sa ByteString
kek ByteString
wrapped =
    String
-> SymmetricAlgorithm
-> ByteString
-> (forall cipher.
    BlockCipher cipher =>
    cipher -> Either String ByteString)
-> Either String ByteString
forall a.
String
-> SymmetricAlgorithm
-> ByteString
-> (forall cipher. BlockCipher cipher => cipher -> Either String a)
-> Either String a
withAESCipher
        String
"ECDH PKESK currently supports AES KEK algorithms only"
        SymmetricAlgorithm
sa
        ByteString
kek
        cipher -> Either String ByteString
forall cipher.
BlockCipher cipher =>
cipher -> Either String ByteString
unwrapWithCipher
  where
    unwrapWithCipher
        :: CCT.BlockCipher cipher
        => cipher
        -> Either String B.ByteString
    unwrapWithCipher :: forall cipher.
BlockCipher cipher =>
cipher -> Either String ByteString
unwrapWithCipher cipher
cipher = do
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
wrapped Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
24 Bool -> Bool -> Bool
|| ByteString -> Int
B.length ByteString
wrapped Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
8 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
0) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
            String -> Either String ()
forall a b. a -> Either a b
Left
                String
"ECDH wrapped session key must be at least 24 octets and a multiple of 8"
        let (ByteString
a0, ByteString
rBytes) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
wrapped
            rs :: [ByteString]
rs = ByteString -> [ByteString]
chunksOf8 ByteString
rBytes
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
rs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
            String -> Either String ()
forall a b. a -> Either a b
Left
                String
"ECDH wrapped session key must contain at least two 64-bit blocks"
        (aFinal, rFinal) <- cipher
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
forall cipher.
BlockCipher cipher =>
cipher
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
unwrapRounds cipher
cipher ByteString
a0 [ByteString]
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 :: forall cipher.
BlockCipher cipher =>
cipher
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
unwrapRounds cipher
cipher ByteString
aInit [ByteString]
rsInit = Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goJ Int
5 ByteString
aInit [ByteString]
rsInit
      where
        n :: Int
n = [ByteString] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ByteString]
rsInit
        goJ :: Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goJ Int
j ByteString
aState [ByteString]
rsState
            | Int
j Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (ByteString, [ByteString])
-> Either String (ByteString, [ByteString])
forall a b. b -> Either a b
Right (ByteString
aState, [ByteString]
rsState)
            | Bool
otherwise = do
                (a', rs') <- Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goI Int
n ByteString
aState [ByteString]
rsState
                goJ (j - 1) a' rs'
          where
            goI :: Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goI Int
i ByteString
aCurrent [ByteString]
rsCurrent
                | Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 = (ByteString, [ByteString])
-> Either String (ByteString, [ByteString])
forall a b. b -> Either a b
Right (ByteString
aCurrent, [ByteString]
rsCurrent)
                | Bool
otherwise = do
                    let t :: Word64
t = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
j Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
i) :: Word64
                        aXorT :: ByteString
aXorT = ByteString -> ByteString -> ByteString
xorBS ByteString
aCurrent (Word64 -> ByteString
encodeWord64be Word64
t)
                        rI :: ByteString
rI = [ByteString]
rsCurrent [ByteString] -> Int -> ByteString
forall a. HasCallStack => [a] -> Int -> a
!! (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
                        block :: ByteString
block = cipher -> ByteString -> ByteString
forall cipher ba.
(BlockCipher cipher, ByteArray ba) =>
cipher -> ba -> ba
forall ba. ByteArray ba => cipher -> ba -> ba
CCT.ecbDecrypt cipher
cipher (ByteString
aXorT ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
rI)
                        (ByteString
aNext, ByteString
rNext) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
block
                        rsNext :: [ByteString]
rsNext = (Index [ByteString]
-> Traversal' [ByteString] (IxValue [ByteString])
forall m. Ixed m => Index m -> Traversal' m (IxValue m)
ix (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ((ByteString -> Identity ByteString)
 -> [ByteString] -> Identity [ByteString])
-> ByteString -> [ByteString] -> [ByteString]
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ByteString
rNext) [ByteString]
rsCurrent
                    Int
-> ByteString
-> [ByteString]
-> Either String (ByteString, [ByteString])
goI (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ByteString
aNext [ByteString]
rsNext

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

xorBS :: B.ByteString -> B.ByteString -> B.ByteString
xorBS :: ByteString -> ByteString -> ByteString
xorBS ByteString
a ByteString
b = [Word8] -> ByteString
B.pack ((Word8 -> Word8 -> Word8) -> ByteString -> ByteString -> [Word8]
forall a. (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
B.zipWith Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
xor ByteString
a ByteString
b)

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

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

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

decodeV6PaddedSessionKeyWithoutAlgo
    :: Int -> B.ByteString -> Either String B.ByteString
decodeV6PaddedSessionKeyWithoutAlgo :: Int -> ByteString -> Either String ByteString
decodeV6PaddedSessionKeyWithoutAlgo Int
expectedLen ByteString
encodedSessionKey = do
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
encodedSessionKey Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
expectedLen Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left String
"v6 ECDH decoded session material is too short"
    let (ByteString
sessionKey, ByteString
rest) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
expectedLen ByteString
encodedSessionKey
        (ByteString
checksumBytes, ByteString
padBytes) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
2 ByteString
rest
        expectedChecksum :: Word16
expectedChecksum =
            Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
checksumBytes Int
0) Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftL` Int
8
                Word16 -> Word16 -> Word16
forall a. Num a => a -> a -> a
+ Word8 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
B.index ByteString
checksumBytes Int
1)
        actualChecksum :: Word16
actualChecksum = ByteString -> Word16
checksum16 ByteString
sessionKey
    Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word16
actualChecksum Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
expectedChecksum) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
        String -> Either String ()
forall a b. a -> Either a b
Left String
"v6 ECDH decoded session-key checksum mismatch"
    ByteString -> Either String ()
validatePKCS7Padding ByteString
padBytes
    ByteString -> Either String ByteString
forall a b. b -> Either a b
Right ByteString
sessionKey

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

validatePKCS7Padding :: B.ByteString -> Either String ()
validatePKCS7Padding :: ByteString -> Either String ()
validatePKCS7Padding ByteString
padBytes
    | ByteString -> Bool
B.null ByteString
padBytes = () -> Either String ()
forall a b. b -> Either a b
Right ()
    | Bool
otherwise = do
        let padLen :: Int
padLen = Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (HasCallStack => ByteString -> Word8
ByteString -> Word8
B.last ByteString
padBytes) :: Int
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
padLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0 Bool -> Bool -> Bool
|| Int
padLen Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
8 Bool -> Bool -> Bool
|| ByteString -> Int
B.length ByteString
padBytes Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
padLen) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
            String -> Either String ()
forall a b. a -> Either a b
Left
                String
"v6 ECDH decoded session material has invalid PKCS#7-style padding length"
        Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Word8 -> Bool) -> ByteString -> Bool
B.any (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
padLen) ByteString
padBytes) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$
            String -> Either String ()
forall a b. a -> Either a b
Left
                String
"v6 ECDH decoded session material has invalid PKCS#7-style padding bytes"

symmetricKeyLength :: SymmetricAlgorithm -> Either String Int
symmetricKeyLength :: SymmetricAlgorithm -> Either String Int
symmetricKeyLength = (CipherError -> String)
-> Either CipherError Int -> Either String Int
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first CipherError -> String
renderCipherError (Either CipherError Int -> Either String Int)
-> (SymmetricAlgorithm -> Either CipherError Int)
-> SymmetricAlgorithm
-> Either String Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SymmetricAlgorithm -> Either CipherError Int
keySize

checksum16 :: B.ByteString -> Word16
checksum16 :: ByteString -> Word16
checksum16 =
    Integer -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral
        (Integer -> Word16)
-> (ByteString -> Integer) -> ByteString -> Word16
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> Word8 -> Integer) -> Integer -> ByteString -> Integer
forall a. (a -> Word8 -> a) -> a -> ByteString -> a
B.foldl'
            (\Integer
acc Word8
octet -> (Integer
acc Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word8 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
octet) Integer -> Integer -> Integer
forall a. Integral a => a -> a -> a
`mod` (Integer
65536 :: Integer))
            Integer
0

checksum16Bytes :: B.ByteString -> B.ByteString
checksum16Bytes :: ByteString -> ByteString
checksum16Bytes ByteString
sessionKey =
    [Word8] -> ByteString
B.pack [Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16
chk Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
`shiftR` Int
8), Word16 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
chk]
  where
    chk :: Word16
chk = ByteString -> Word16
checksum16 ByteString
sessionKey