-- Decrypt.hs: OpenPGP (RFC9580) recursive packet decryption
-- Copyright © 2013-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}

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

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

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

data RecursorState =
  RecursorState
    { 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
 = DecryptWithoutPKESK
   -- ^ Do not attempt PKESK decryption; fall through to manual session-key
   -- input via the passphrase callback instead.
 | DecryptWithKeyring SecretKeyring
   -- ^ Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret
   -- keys (not passphrase-protected) are used. For passphrase-protected keys,
   -- use 'DecryptWithKeyringAndPassphrase'.
 | DecryptWithKeyringAndPassphrase SecretKeyring (SomePKPayload -> IO (Maybe BL.ByteString))
   -- ^ Resolve secret keys from a 'SecretKeyring', unlocking passphrase-
   -- protected keys using the provided callback. The callback receives the
   -- public key payload and returns the passphrase, or 'Nothing' to skip.
 | DecryptWithUnwrapCandidatesCallback (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
   -- ^ Preferred callback form for non-keyring key material. The callback
   -- receives a typed key identifier (8-octet key ID, fingerprint, or
   -- wildcard) plus the packet public-key algorithm, then returns all
   -- matching candidates in priority order. hOpenPGP iterates candidates
   -- deterministically without re-calling the callback for each retry.

-- | Canonical decrypt configuration.
--
-- Most callers should prefer 'conduitDecrypt' and set:
--
-- * 'decryptOptionsKeyResolution' to 'DecryptWithKeyring' or 'DecryptWithKeyringAndPassphrase'
-- * 'decryptOptionsPolicy' to strict ('defaultDecryptPolicy') or lenient
-- * 'decryptOptionsPassphraseCallback' for SKESK passphrase lookup
data DecryptOptions =
  DecryptOptions
    { 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
  = DecryptClean
    -- ^ The integrity-terminating marker (MDC or SEIPD v2 final AEAD tag)
    -- was seen and no further packets arrived.  The message was
    -- well-formed end-to-end.
  | DecryptTruncated
    -- ^ The input stream ended before any integrity-terminating marker was
    -- seen.  The ciphertext was incomplete.
  | DecryptTrailingData
    -- ^ An integrity-terminating marker was seen, but additional packets
    -- followed it.  Only possible with 'lenientDecryptPolicy' (strict
    -- policy reports 'DecryptMalformedStructure' instead).  The trailing
    -- packets were forwarded downstream unchanged.
  | DecryptMalformedStructure String
    -- ^ A structural packet-sequencing violation was detected.  The
    -- 'String' describes the specific violation:
    --
    -- * PKESK version does not match the SEIPD version (e.g. a v6 PKESK
    --   preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2
    --   payload).
    --
    -- * ESK packets arrived in the wrong order relative to the encrypted
    --   data packet (e.g. a literal-data packet appeared between a PKESK
    --   and the SEIPD it was intended to protect).
    --
    -- * A packet arrived after the message integrity boundary (trailing
    --   data).  Under 'defaultDecryptPolicy' this is reported here; under
    --   'lenientDecryptPolicy' it is reported as 'DecryptTrailingData'
    --   instead.
  deriving (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, MonadUnliftIO m, MonadResource m, MonadThrow m)
  => DecryptOptions
  -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecrypt :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow m) =>
DecryptOptions -> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport DecryptOptions
opts

conduitDecryptWithReport ::
     (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
  => DecryptOptions
  -> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow 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])
-> IO (IORef (Maybe PKESKPayload, Maybe [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])
  pure $ \PKESKResolveRequest
req -> do
    let pkesk :: PKESKPayload
pkesk = PKESKResolveRequest -> PKESKPayload
reqPKESK PKESKResolveRequest
req
        probe :: Pkt
probe = PKESKResolveRequest -> Pkt
reqProbePacket PKESKResolveRequest
req
    (lastPKESK, wildcardState) <- IORef (Maybe PKESKPayload, Maybe [PKESKRecipientKey])
-> IO (Maybe PKESKPayload, Maybe [PKESKRecipientKey])
forall a. IORef a -> IO a
readIORef IORef (Maybe PKESKPayload, Maybe [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
    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])
-> (Maybe PKESKPayload, Maybe [PKESKRecipientKey]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe PKESKPayload, Maybe [PKESKRecipientKey])
stateRef (PKESKPayload -> Maybe PKESKPayload
forall a. a -> Maybe a
Just PKESKPayload
pkesk, [PKESKRecipientKey] -> Maybe [PKESKRecipientKey]
forall a. a -> Maybe a
Just [])
            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])
-> (Maybe PKESKPayload, Maybe [PKESKRecipientKey]) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe PKESKPayload, Maybe [PKESKRecipientKey])
stateRef (PKESKPayload -> Maybe PKESKPayload
forall a. a -> Maybe a
Just PKESKPayload
pkesk, [PKESKRecipientKey] -> Maybe [PKESKRecipientKey]
forall a. a -> Maybe a
Just [PKESKRecipientKey]
rest)
            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
        let matchingTKs :: [TK 'SecretTK]
matchingTKs = KeyIdentifier -> [TK 'SecretTK]
matchingTKsForRecipient KeyIdentifier
keyIdentifier
            priorFailures :: Int
priorFailures = [PKESKAttemptFailure] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (PKESKResolveRequest -> [PKESKAttemptFailure]
reqPreviousFailures PKESKResolveRequest
req)
        candidates <- [TK 'SecretTK] -> IO [PKESKRecipientKey]
keyringCandidates [TK 'SecretTK]
matchingTKs
        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, MonadUnliftIO m, MonadResource m, MonadThrow m)
  => RecursorState
  -> Bool
  -> PKESKResolver IO
  -> InputCallback IO
  -> Maybe (IORef [DecryptSessionKeyResolutionReport])
  -> ConduitT Pkt Pkt m DecryptOutcome
conduitDecryptChecked' :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow m)
      => SomeDecryptStreamState -> ConduitT Pkt Pkt m DecryptOutcome
    loop :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow m) =>
Pkt
-> DecryptStreamState phase -> m (SomeDecryptStreamState, [Pkt])
push Pkt
pkt DecryptStreamState phase
state)
              mapM_ yield pkts
              loop state'

    push ::
         (MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
      => Pkt
      -> DecryptStreamState phase
      -> m (SomeDecryptStreamState, [Pkt])
    push :: forall (m :: * -> *) (phase :: DecryptStreamPhase).
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow 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 = _pendingESKs s ++ [PendingSKESK payload]}))
                , [] )
          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 = _pendingESKs s ++ [PendingPKESK p]}))
              , [] )
          (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.
          (OtherPacketPkt Word8
21 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
  = NoIntegrityMarker
    -- ^ The inner stream has no integrity-terminating packet.  SED has none
    -- by design; SEIPD2 authenticates via AEAD before the conduit runs.
    -- 'DecryptTruncated' is the normal end-of-stream outcome.

-- | Propagate non-clean inner-stream outcomes as a 'fail'.  Called after each
-- recursive decrypt helper so that structural violations and (for SEIPD1) a
-- missing MDC are not silently swallowed.
checkInnerOutcome :: MonadFail m => InnerIntegrityExpectation -> DecryptOutcome -> m ()
checkInnerOutcome :: 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, MonadUnliftIO m, MonadIO m, MonadThrow m)
  => RecursorState
  -> Bool
  -> PKESKResolver IO
  -> InputCallback IO
  -> Maybe (IORef [DecryptSessionKeyResolutionReport])
  -> SymmetricAlgorithm
  -> SessionKey
  -> BL.ByteString
  -> m [Pkt]
decryptSEDP :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow 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, MonadUnliftIO m, MonadIO m, MonadThrow m)
  => RecursorState
  -> Bool
  -> PKESKResolver IO
  -> InputCallback IO
  -> Maybe (IORef [DecryptSessionKeyResolutionReport])
  -> SymmetricAlgorithm
  -> SessionKey
  -> BL.ByteString
  -> m [Pkt]
decryptSEIPDP :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow 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, MonadUnliftIO m, MonadIO m, MonadThrow m)
  => RecursorState
  -> Bool
  -> PKESKResolver IO
  -> InputCallback IO
  -> Maybe (IORef [DecryptSessionKeyResolutionReport])
  -> SymmetricAlgorithm
  -> AEADAlgorithm
  -> Word8
  -> Salt
  -> SessionKey
  -> BL.ByteString
  -> m [Pkt]
decryptSEIPDv2P :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow 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, MonadUnliftIO m, MonadThrow 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, MonadUnliftIO m, MonadThrow m)
  => RecursorState
  -> Bool
  -> PKESKResolver IO
  -> InputCallback IO
  -> Maybe (IORef [DecryptSessionKeyResolutionReport])
  -> B.ByteString
  -> m (DecryptOutcome, [Pkt])
decryptInnerPackets :: forall (m :: * -> *).
(MonadFail m, MonadUnliftIO m, MonadThrow 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, MonadUnliftIO m, MonadResource m, MonadThrow 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] -> [SKESKPayload]
forall a. [a] -> [a]
reverse [SKESKPayload
skesk | PendingSKESK SKESKPayload
skesk <- [PendingESK]
esks]

    pkeskCandidates :: [PendingESK] -> [PKESKPayload]
pkeskCandidates [PendingESK]
esks = [PKESKPayload] -> [PKESKPayload]
forall a. [a] -> [a]
reverse [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)]

    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

    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
Ed25519 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
Ed448 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
Ed25519 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
Ed448 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
Ed25519 EdPoint
point ->
          ByteString -> Either String ByteString
normalizeX25519EphemeralPublic (EdPoint -> ByteString
edPointBytes EdPoint
point)
        ECDHPubKey (EdDSAPubKey EdSigningCurve
Ed25519 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
Ed448 EdPoint
point ->
          ByteString -> Either String ByteString
normalizeX448EphemeralPublic (EdPoint -> ByteString
edPointBytes EdPoint
point)
        ECDHPubKey (EdDSAPubKey EdSigningCurve
Ed448 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
_) =
  if Int
sizeField Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
512
    then (Int
sizeField 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
    else 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