hOpenPGP-3.0.0: Data/Conduit/OpenPGP/Decrypt.hs
-- Decrypt.hs: OpenPGP (RFC9580) recursive packet decryption
-- Copyright © 2013-2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE TypeApplications #-}
module Data.Conduit.OpenPGP.Decrypt
( conduitDecrypt
, conduitDecryptWithReport
, DecryptOptions(..)
, DecryptKeyResolution(..)
, PKESKRecipientKey(..)
, PKESKAttemptFailureKind(..)
, PKESKAttemptFailure(..)
, DecryptOutcome(..)
, DecryptReport(..)
, DecryptSessionKeyResolutionReport(..)
, DecryptSessionKeyResolutionPath(..)
, PKESKResolverAttempt(..)
, PKESKResolverAttemptAction(..)
, decryptSEIPDv2Payload
) where
import Codec.Encryption.OpenPGP.BlockCipher (renderCipherError, keySize)
import Control.Exception (SomeException, displayException, try)
import Control.Applicative ((<|>))
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.IO.Unlift (MonadUnliftIO)
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import qualified "crypton" Crypto.Cipher.Types as CCT
import qualified Crypto.Error as CE
import qualified Crypto.Hash as CH
import qualified Crypto.Hash.Algorithms as CHA
import Crypto.KDF.HKDF (expand, extract)
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.Curve25519 as C25519
import qualified Crypto.PubKey.Curve448 as C448
import qualified Crypto.PubKey.ECC.DH as ECCDH
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import qualified Crypto.PubKey.RSA.Types as RSATypes
import Data.Binary (get)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bits (countLeadingZeros, shiftL, shiftR, xor)
import Data.Bifunctor (first)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Conduit
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Compression (conduitDecompress)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef)
import Data.List (intercalate, nub)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (catMaybes, isNothing, mapMaybe)
import Data.Word (Word16, Word8, Word64)
import Codec.Encryption.OpenPGP.CFB (decryptOpenPGPCfb, decryptPreservingNonce, validateSEIPD1MDC, calculateMDC)
import Codec.Encryption.OpenPGP.Internal (leftPadTo)
import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)
import Codec.Encryption.OpenPGP.Internal.CryptoECDH
( normalizeMontgomeryPublic
, buildECDHKDFParam
, deriveECDHKek
)
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
( aeadModeAndNonceSizeForSEIPDv2
, decryptSKESK6SessionKey
, deriveSKESK6KEK
, seipdv2SymmetricKeySize
)
import Codec.Encryption.OpenPGP.Policy
( DecryptPolicy(..)
, defaultDecryptPolicy
, validateTable30PolicyForRecipient
)
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (decryptWithOCBRFC7253With)
import Codec.Encryption.OpenPGP.S2K
( decodeOpenPGPEncodedSessionKey
, renderEncodedSessionKeyError
, renderS2KError
, S2KError(..)
, skesk2Key
, skesk2SessionKey
, string2Key
)
import Codec.Encryption.OpenPGP.Types
import Codec.Encryption.OpenPGP.SecretKey (decryptPrivateKey)
import Control.Lens ((.~), ix)
import Data.Conduit.OpenPGP.Keyring.Instances ()
import qualified Data.IxSet.Typed as IxSet
data RecursorState =
RecursorState
{ _depth :: Int
, _pendingESKs :: [PendingESK]
, _lastNonce :: Maybe B.ByteString
, _lastClearText :: Maybe B.ByteString
, _decryptPolicy :: DecryptPolicy
}
deriving (Eq, Show)
def :: RecursorState
def = RecursorState 0 [] Nothing Nothing defaultDecryptPolicy
data DecryptStreamPhase
= ActiveDecryptPhase
| FinishedDecryptPhase
| MalformedDecryptPhase
data DecryptStreamState (phase :: DecryptStreamPhase) where
ActiveDecryptState ::
RecursorState
-> DecryptStreamState 'ActiveDecryptPhase
FinishedDecryptState ::
RecursorState
-> Bool
-> DecryptStreamState 'FinishedDecryptPhase
MalformedDecryptState ::
RecursorState
-> String
-> DecryptStreamState 'MalformedDecryptPhase
data SomeDecryptStreamState where
SomeDecryptStreamState ::
DecryptStreamState phase
-> SomeDecryptStreamState
data PendingESK
= PendingPKESK PKESKPayload
| PendingSKESK SKESKPayload
deriving (Eq, Show)
data EncryptedPayloadVersion
= LegacyEncryptedPayloadVersion
| SEIPDv2EncryptedPayloadVersion
data EncryptedPayloadFlavor (v :: EncryptedPayloadVersion) where
LegacyEncryptedPayload :: EncryptedPayloadFlavor 'LegacyEncryptedPayloadVersion
SEIPDv2EncryptedPayload ::
SymmetricAlgorithm
-> AEADAlgorithm
-> EncryptedPayloadFlavor 'SEIPDv2EncryptedPayloadVersion
type InputCallback m = String -> m BL.ByteString
data PKESKRecipientKey =
PKESKRecipientKey
{ pkeskRecipientPKPayload :: Maybe SomePKPayload
-- ^ Public key payload for the recipient. Required for X25519, X448,
-- and ECDH unwrap paths; may be 'Nothing' for RSA.
, pkeskRecipientSKey :: SKey
-- ^ Corresponding secret key.
}
data PKESKAttemptFailure =
PKESKAttemptFailure
{ pkeskAttemptFailureKeyContext :: Maybe (KeyVersion, PubKeyAlgorithm)
, pkeskAttemptFailureKind :: PKESKAttemptFailureKind
, pkeskAttemptFailureReason :: String
}
deriving (Eq, Show)
data PKESKAttemptFailureKind
= PKESKAttemptUnwrapFailed
| PKESKAttemptSessionMaterialDecodeFailed
deriving (Eq, Show)
data PKESKResolverError
= ResolverPolicyDenied String
| ResolverBackendUnavailable String
| ResolverInvalidResponse String
deriving (Eq, Show)
data PKESKResolveRequest =
PKESKResolveRequest
{ reqPKESK :: PKESKPayload
, reqProbePacket :: Pkt
, reqIsWildcardRecipient :: Bool
, reqAttemptIndex :: Int
, reqPreviousFailures :: [PKESKAttemptFailure]
}
deriving (Eq, Show)
data PKESKResolveAction
= ResolveWith PKESKRecipientKey
| ResolveSkip
| ResolveExhausted
| ResolveFail PKESKResolverError
type PKESKResolver m = PKESKResolveRequest -> m PKESKResolveAction
-- | Build a stateful 'PKESKResolver' that iterates over a pre-populated
-- candidate list. The returned resolver yields candidates in order and
-- returns 'ResolveExhausted' once the list is depleted.
-- | How to resolve secret keys for PKESK-encrypted messages.
data DecryptKeyResolution
= DecryptWithoutPKESK
-- ^ Do not attempt PKESK decryption; fall through to manual session-key
-- input via the passphrase callback instead.
| DecryptWithKeyring SecretKeyring
-- ^ Resolve secret keys from a 'SecretKeyring'. Only unencrypted secret
-- keys (not passphrase-protected) are used. For passphrase-protected keys,
-- use 'DecryptWithKeyringAndPassphrase'.
| DecryptWithKeyringAndPassphrase SecretKeyring (SomePKPayload -> IO (Maybe BL.ByteString))
-- ^ Resolve secret keys from a 'SecretKeyring', unlocking passphrase-
-- protected keys using the provided callback. The callback receives the
-- public key payload and returns the passphrase, or 'Nothing' to skip.
| DecryptWithUnwrapCandidatesCallback (KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
-- ^ Preferred callback form for non-keyring key material. The callback
-- receives a typed key identifier (8-octet key ID, fingerprint, or
-- wildcard) plus the packet public-key algorithm, then returns all
-- matching candidates in priority order. hOpenPGP iterates candidates
-- deterministically without re-calling the callback for each retry.
-- | Canonical decrypt configuration.
--
-- Most callers should prefer 'conduitDecrypt' and set:
--
-- * 'decryptOptionsKeyResolution' to 'DecryptWithKeyring' or 'DecryptWithKeyringAndPassphrase'
-- * 'decryptOptionsPolicy' to strict ('defaultDecryptPolicy') or lenient
-- * 'decryptOptionsPassphraseCallback' for SKESK passphrase lookup
data DecryptOptions =
DecryptOptions
{ decryptOptionsKeyResolution :: DecryptKeyResolution
, decryptOptionsPolicy :: DecryptPolicy
, decryptOptionsPassphraseCallback :: InputCallback IO
}
-- | Outcome of a checked decrypt conduit run.
--
-- Use 'conduitDecrypt' to obtain this value. Because
-- 'Data.Conduit..|' preserves the
-- /rightmost/ conduit's return value, callers who also need the decrypted
-- packet stream should use 'Data.Conduit.fuseBoth':
--
-- @
-- (outcome, pkts) \<- runConduit $ source .| fuseBoth (conduitDecrypt opts) CL.consume
-- @
data DecryptOutcome
= DecryptClean
-- ^ The integrity-terminating marker (MDC or SEIPD v2 final AEAD tag)
-- was seen and no further packets arrived. The message was
-- well-formed end-to-end.
| DecryptTruncated
-- ^ The input stream ended before any integrity-terminating marker was
-- seen. The ciphertext was incomplete.
| DecryptTrailingData
-- ^ An integrity-terminating marker was seen, but additional packets
-- followed it. Only possible with 'lenientDecryptPolicy' (strict
-- policy reports 'DecryptMalformedStructure' instead). The trailing
-- packets were forwarded downstream unchanged.
| DecryptMalformedStructure String
-- ^ A structural packet-sequencing violation was detected. The
-- 'String' describes the specific violation:
--
-- * PKESK version does not match the SEIPD version (e.g. a v6 PKESK
-- preceding a SEIPDv1 payload, or a v4 SKESK preceding a SEIPDv2
-- payload).
--
-- * ESK packets arrived in the wrong order relative to the encrypted
-- data packet (e.g. a literal-data packet appeared between a PKESK
-- and the SEIPD it was intended to protect).
--
-- * A packet arrived after the message integrity boundary (trailing
-- data). Under 'defaultDecryptPolicy' this is reported here; under
-- 'lenientDecryptPolicy' it is reported as 'DecryptTrailingData'
-- instead.
deriving (Eq, Show)
data DecryptSessionKeyResolutionPath
= DecryptResolvedViaSKESK
| DecryptResolvedViaPKESK
| DecryptResolvedViaManualPKESKInput
deriving (Eq, Show)
data PKESKResolverAttemptAction
= ResolverAttemptResolveWith (Maybe (KeyVersion, PubKeyAlgorithm))
| ResolverAttemptSkip
| ResolverAttemptExhausted
| ResolverAttemptFail PKESKResolverError
deriving (Eq, Show)
data PKESKResolverAttempt =
PKESKResolverAttempt
{ pkeskResolverAttemptPreviousFailures :: [PKESKAttemptFailure]
-- ^ Failures from earlier attempts on the same PKESK packet.
, pkeskResolverAttemptAction :: PKESKResolverAttemptAction
}
deriving (Eq, Show)
data DecryptSessionKeyResolutionReport =
DecryptSessionKeyResolutionReport
{ decryptSessionResolutionPath :: DecryptSessionKeyResolutionPath
, decryptSessionResolutionSKESKErrors :: [String]
, decryptSessionResolutionPKESKErrors :: [String]
, decryptSessionResolutionResolverAttempts :: [PKESKResolverAttempt]
}
deriving (Eq, Show)
data DecryptReport =
DecryptReport
{ decryptReportOutcome :: DecryptOutcome
, decryptReportSessionKeyResolutions :: [DecryptSessionKeyResolutionReport]
}
deriving (Eq, Show)
-- | AEAD decryption context (Reader monad eliminates parameter threading)
data AEADDecryptContext cipher =
AEADDecryptContext
{ aeadMode :: CCT.AEADMode
, aeadInfo :: B.ByteString
, aeadChunkSize :: Word8
, aeadNoncePrefix :: B.ByteString
, aeadCipher :: cipher
}
-- | ReaderT wrapper for AEAD decryption computations
type AEADDecrypt cipher = ReaderT (AEADDecryptContext cipher) (Either String)
conduitDecrypt ::
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
=> DecryptOptions
-> ConduitT Pkt Pkt m DecryptOutcome
conduitDecrypt opts =
decryptReportOutcome <$> conduitDecryptWithReport opts
conduitDecryptWithReport ::
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
=> DecryptOptions
-> ConduitT Pkt Pkt m DecryptReport
conduitDecryptWithReport opts = do
reportRef <- liftIO (newIORef [])
resolver <- liftIO (buildDecryptResolver (decryptOptionsKeyResolution opts))
let allowManualPKESKPrompt =
case decryptOptionsKeyResolution opts of
DecryptWithoutPKESK -> True
_ -> False
outcome <-
conduitDecryptChecked'
(def {_decryptPolicy = decryptOptionsPolicy opts})
allowManualPKESKPrompt
resolver
(decryptOptionsPassphraseCallback opts)
(Just reportRef)
resolutions <- reverse <$> liftIO (readIORef reportRef)
pure
DecryptReport
{ decryptReportOutcome = outcome
, decryptReportSessionKeyResolutions = resolutions
}
-- | Build an internal 'PKESKResolver' from the public 'DecryptKeyResolution'.
buildDecryptResolver :: DecryptKeyResolution -> IO (PKESKResolver IO)
buildDecryptResolver DecryptWithoutPKESK =
pure (\_ -> pure ResolveExhausted)
buildDecryptResolver (DecryptWithKeyring kr) =
buildKeyringResolver kr Nothing
buildDecryptResolver (DecryptWithKeyringAndPassphrase kr cb) =
buildKeyringResolver kr (Just cb)
buildDecryptResolver (DecryptWithUnwrapCandidatesCallback cb) =
buildUnwrapCandidatesResolver cb
-- | Build a stateful resolver that looks up keys from a 'SecretKeyring'.
buildKeyringResolver ::
SecretKeyring
-> Maybe (SomePKPayload -> IO (Maybe BL.ByteString))
-> IO (PKESKResolver IO)
buildKeyringResolver kr maybePassphraseCb = do
-- Tracks (last PKESK, remaining wildcard candidates once initialized).
stateRef <- newIORef (Nothing :: Maybe PKESKPayload, Nothing :: Maybe [PKESKRecipientKey])
pure $ \req -> do
let pkesk = reqPKESK req
probe = reqProbePacket req
(lastPKESK, wildcardState) <- readIORef stateRef
let freshPKESK = Just pkesk /= lastPKESK
when freshPKESK $ writeIORef stateRef (Just pkesk, Nothing)
let wc = if freshPKESK then Nothing else wildcardState
case extractProbeKeyIdentifier probe of
KeyIdentifierWildcard -> do
-- Wildcard probe: iterate all keys
candidates <- case wc of
Nothing -> keyringCandidates (IxSet.toList kr)
Just cs -> pure cs
case candidates of
[] -> do
writeIORef stateRef (Just pkesk, Just [])
pure ResolveExhausted
(rk:rest) -> do
writeIORef stateRef (Just pkesk, Just rest)
pure (ResolveWith rk)
keyIdentifier -> do
-- Exact probe: direct lookup by key ID or fingerprint
let matchingTKs = matchingTKsForRecipient keyIdentifier
priorFailures = length (reqPreviousFailures req)
candidates <- keyringCandidates matchingTKs
case drop priorFailures candidates of
[] -> pure ResolveSkip
(rk:_) -> pure (ResolveWith rk)
where
matchingTKsForRecipient :: KeyIdentifier -> [TK 'SecretTK]
matchingTKsForRecipient keyIdentifier =
case keyIdentifier of
KeyIdentifierWildcard -> IxSet.toList kr
KeyIdentifierEightOctet rid -> IxSet.toList (kr IxSet.@= rid)
KeyIdentifierFingerprint rid ->
let indexedMatches = IxSet.toList (kr IxSet.@= rid)
in if null indexedMatches
then filter (tkMatchesRecipientFingerprint rid) (IxSet.toList kr)
else indexedMatches
tkMatchesRecipientFingerprint :: Fingerprint -> TK 'SecretTK -> Bool
tkMatchesRecipientFingerprint rid tk =
any
(keyPktMatchesRecipientFingerprint rid)
(_tkPrimaryKey tk : map fst (_tkSubs tk))
keyPktMatchesRecipientFingerprint ::
Fingerprint -> KeyPkt 'SecretPkt -> Bool
keyPktMatchesRecipientFingerprint rid (KeyPktSecretPrimary pkp _) =
pkPayloadMatchesRecipientFingerprint rid pkp
keyPktMatchesRecipientFingerprint rid (KeyPktSecretSubkey pkp _) =
pkPayloadMatchesRecipientFingerprint rid pkp
pkPayloadMatchesRecipientFingerprint :: Fingerprint -> SomePKPayload -> Bool
pkPayloadMatchesRecipientFingerprint rid pkp =
fingerprint pkp `elem` recipientFingerprintMatchVariants rid
recipientFingerprintMatchVariants :: Fingerprint -> [Fingerprint]
recipientFingerprintMatchVariants (Fingerprint rid)
| BL.length rid == 20 = [Fingerprint rid, Fingerprint (BL.cons 0x04 rid)]
| BL.length rid == 21 && BL.head rid == 0x04 = [Fingerprint rid, Fingerprint (BL.tail rid)]
| BL.length rid == 32 = [Fingerprint rid, Fingerprint (BL.cons 0x06 rid)]
| BL.length rid == 33 && BL.head rid == 0x06 = [Fingerprint rid, Fingerprint (BL.tail rid)]
| otherwise = [Fingerprint rid]
keyringCandidates :: [TK 'SecretTK] -> IO [PKESKRecipientKey]
keyringCandidates tks = concat <$> mapM tkCandidates tks
tkCandidates :: TK 'SecretTK -> IO [PKESKRecipientKey]
tkCandidates tk =
fmap catMaybes . mapM resolveKeyPair $
_tkPrimaryKey tk : map fst (_tkSubs tk)
resolveKeyPair :: KeyPkt 'SecretPkt -> IO (Maybe PKESKRecipientKey)
resolveKeyPair (KeyPktSecretPrimary pkp (SUUnencrypted sk _)) =
pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk}
resolveKeyPair (KeyPktSecretSubkey pkp (SUUnencrypted sk _)) =
pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk}
resolveKeyPair (KeyPktSecretPrimary pkp ska) = unlockProtected pkp ska
resolveKeyPair (KeyPktSecretSubkey pkp ska) = unlockProtected pkp ska
unlockProtected :: SomePKPayload -> SKAddendum -> IO (Maybe PKESKRecipientKey)
unlockProtected pkp ska =
case maybePassphraseCb of
Nothing -> pure Nothing
Just passphraseCb -> do
mPassphrase <- passphraseCb pkp
case mPassphrase of
Nothing -> pure Nothing
Just passphrase ->
case decryptPrivateKey (pkp, ska) passphrase of
Left _ -> pure Nothing
Right (SUUnencrypted sk _) ->
pure $ Just PKESKRecipientKey {pkeskRecipientPKPayload = Just pkp, pkeskRecipientSKey = sk}
Right _ -> pure Nothing
buildUnwrapCandidatesResolver ::
(KeyIdentifier -> PubKeyAlgorithm -> IO [PKESKRecipientKey])
-> IO (PKESKResolver IO)
buildUnwrapCandidatesResolver cb = do
stateRef <- newIORef (Nothing :: Maybe PKESKPayload, [] :: [(Pkt, [PKESKRecipientKey])], [] :: [SKey])
pure $ \req -> do
let pkesk = reqPKESK req
probePkt = reqProbePacket req
(lastPKESK, probeState, seenSKeys) <- readIORef stateRef
let freshPKESK = Just pkesk /= lastPKESK
when freshPKESK $ writeIORef stateRef (Just pkesk, [], [])
let state0 = if freshPKESK then [] else probeState
seen0 = if freshPKESK then [] else seenSKeys
case lookup probePkt state0 of
Just (next:rest) -> do
writeIORef
stateRef
( Just pkesk
, updateProbeState probePkt rest state0
, pkeskRecipientSKey next : seen0
)
pure (ResolveWith next)
Just [] ->
pure ResolveSkip
Nothing -> do
candidates <- filterFreshCandidates seen0 <$> callbackCandidates probePkt
case candidates of
[] -> do
writeIORef stateRef (Just pkesk, updateProbeState probePkt [] state0, seen0)
pure ResolveSkip
(next:rest) -> do
writeIORef
stateRef
( Just pkesk
, updateProbeState probePkt rest state0
, pkeskRecipientSKey next : seen0
)
pure (ResolveWith next)
where
callbackCandidates probePkt =
cb (extractProbeKeyIdentifier probePkt) (extractProbePKA probePkt)
updateProbeState probePkt remaining state0 =
(probePkt, remaining) : filter ((/= probePkt) . fst) state0
filterFreshCandidates seenSKeys =
filter (\candidate -> pkeskRecipientSKey candidate `notElem` seenSKeys)
-- | Extract the recipient identifier from a PKESK probe packet.
extractProbeKeyIdentifier :: Pkt -> KeyIdentifier
extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid _ _)))
| isWildcardV3RecipientKeyId rid = KeyIdentifierWildcard
| otherwise = KeyIdentifierEightOctet rid
extractProbeKeyIdentifier (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid _ _)))
| BL.null rid = KeyIdentifierWildcard
| otherwise = KeyIdentifierFingerprint (Fingerprint rid)
extractProbeKeyIdentifier _ = KeyIdentifierWildcard
isWildcardV3RecipientKeyId :: EightOctetKeyId -> Bool
isWildcardV3RecipientKeyId (EightOctetKeyId rid) =
BL.length rid == 8 && BL.all (== 0) rid
-- | Extract the public-key algorithm from a PKESK probe packet.
extractProbePKA :: Pkt -> PubKeyAlgorithm
extractProbePKA (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ pka _))) = pka
extractProbePKA (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 _ pka _))) = pka
extractProbePKA _ = RSA -- fallback; should not be reached
-- | Core implementation: manual await loop so we can return a 'DecryptOutcome'.
conduitDecryptChecked' ::
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
=> RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> ConduitT Pkt Pkt m DecryptOutcome
conduitDecryptChecked' rs0 allowManualPKESKPrompt pkcb cb reportRef =
loop (SomeDecryptStreamState (ActiveDecryptState rs0))
where
loop ::
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
=> SomeDecryptStreamState -> ConduitT Pkt Pkt m DecryptOutcome
loop streamState = do
case streamState of
SomeDecryptStreamState (MalformedDecryptState _ reason) ->
return (DecryptMalformedStructure reason)
SomeDecryptStreamState state -> do
mpkt <- await
case mpkt of
Nothing -> return (finalOutcome state)
Just pkt -> do
(state', pkts) <- lift (push pkt state)
mapM_ yield pkts
loop state'
push ::
(MonadFail m, MonadUnliftIO m, MonadResource m, MonadThrow m)
=> Pkt
-> DecryptStreamState phase
-> m (SomeDecryptStreamState, [Pkt])
push i (ActiveDecryptState s)
| _depth s > 42 = fail "I think we've been quine-attacked"
| hasPendingESKPrelude s && not (packetCanFollowESKPrelude i) =
return
( SomeDecryptStreamState
(MalformedDecryptState
s
"Malformed encrypted packet sequence: ESK packets must immediately precede encrypted data")
, [] )
| otherwise =
let dp = _decryptPolicy s
in case i of
SKESKPkt payload ->
do
when (decryptRejectDeprecatedSKESK dp) $
case skeskPayloadS2K payload of
Simple _ ->
fail "SKESK uses Simple S2K specifier, which is deprecated by RFC9580 policy"
Salted _ _ ->
fail "SKESK uses Salted S2K specifier, which is deprecated by RFC9580 policy"
_ -> pure ()
return
( SomeDecryptStreamState
(ActiveDecryptState
(s {_pendingESKs = _pendingESKs s ++ [PendingSKESK payload]}))
, [] )
PKESKPkt p ->
return
( SomeDecryptStreamState
(ActiveDecryptState
(s {_pendingESKs = _pendingESKs s ++ [PendingPKESK p]}))
, [] )
(SymEncDataPkt bs) ->
if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s
then
return
( SomeDecryptStreamState
(MalformedDecryptState
s
("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++
"legacy SED payload"))
, [] )
else do
when (not (decryptAllowSEDNoIntegrity dp)) $
fail
"Received unauthenticated SED (Symmetrically Encrypted Data) packet; \
\RFC9580 policy requires integrity-protected SEIPD. \
\Use lenientDecryptPolicy to permit legacy messages."
(symalgo, sessionKey) <-
resolveSessionKey
s
allowManualPKESKPrompt
pkcb
cb
LegacyEncryptedPayload
reportRef
checkDecryptSymmetricAlgo dp symalgo
d <-
decryptSEDP
s {_pendingESKs = []}
allowManualPKESKPrompt
pkcb
cb
reportRef
symalgo
sessionKey
bs
-- SED is the terminal outer-stream packet.
return (finalizeOuterEncryptedPayload s d)
(SymEncIntegrityProtectedDataPkt (SEIPD1 _ bs)) ->
if hasESKPayloadVersionMismatch dp LegacyEncryptedPayload s
then
return
( SomeDecryptStreamState
(MalformedDecryptState
s
("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++
"SEIPDv1 payload"))
, [] )
else do
when (not (decryptAllowSEIPDv1 dp)) $
fail
"Received SEIPDv1 packet; decrypt policy requires SEIPDv2 only."
(symalgo, sessionKey) <-
resolveSessionKey
s
allowManualPKESKPrompt
pkcb
cb
LegacyEncryptedPayload
reportRef
checkDecryptSymmetricAlgo dp symalgo
d <-
decryptSEIPDP
s {_pendingESKs = []}
allowManualPKESKPrompt
pkcb
cb
reportRef
symalgo
sessionKey
bs
-- The outer SEIPD1 packet is terminal; inner MDC is handled by
-- the recursive conduit's own _seenMessageEnd tracking.
return (finalizeOuterEncryptedPayload s d)
(SymEncIntegrityProtectedDataPkt (SEIPD2 sa aa chunkSize salt bs)) ->
if hasESKPayloadVersionMismatch dp (SEIPDv2EncryptedPayload sa aa) s
then
return
( SomeDecryptStreamState
(MalformedDecryptState
s
("ESK/payload version mismatch: ESK packets present but none are version-aligned with " ++
"SEIPDv2 payload"))
, [] )
else do
checkDecryptSymmetricAlgo dp sa
checkDecryptAEADAlgo dp aa
(_, sessionKey) <-
resolveSessionKey
s
allowManualPKESKPrompt
pkcb
cb
(SEIPDv2EncryptedPayload sa aa)
reportRef
d <-
decryptSEIPDv2P
s {_pendingESKs = []}
allowManualPKESKPrompt
pkcb
cb
reportRef
sa
aa
chunkSize
salt
sessionKey
bs
-- SEIPD2 final AEAD tag was verified inside decryptSEIPDv2P.
return (finalizeOuterEncryptedPayload s d)
m@(ModificationDetectionCodePkt mdc) -> do
when (isNothing (_lastClearText s)) $ fail "MDC with no referent"
let mcalculated = calculateMDC <$> _lastNonce s <*> _lastClearText s
expectedMdc <-
case mcalculated of
Nothing -> fail "MDC with no nonce or cleartext"
Just Nothing -> fail "MDC referent is too short"
Just (Just x) -> return x
when (expectedMdc /= mdc) $
fail $
"MDC indicates tampering: " ++
show mdc ++
" versus " ++
maybe "<empty>" show mcalculated ++
" ... " ++
show (_lastNonce s) ++ " / " ++ show (_lastClearText s)
-- MDC is the integrity boundary inside a SEIPD1 inner stream.
return
( SomeDecryptStreamState (FinishedDecryptState s False)
, [m] )
-- RFC9580 Padding Packet (tag 21) can be ignored after decryption.
(OtherPacketPkt 21 _) ->
return (SomeDecryptStreamState (ActiveDecryptState s), [])
(OtherPacketPkt t _) | t < 40 ->
fail ("Unknown critical packet type in packet sequence: " ++ show t)
(OtherPacketPkt _ _) ->
return (SomeDecryptStreamState (ActiveDecryptState s), [])
p ->
return (SomeDecryptStreamState (ActiveDecryptState s), [p])
push i (FinishedDecryptState s hadTrailing) =
if decryptRejectTrailingData (_decryptPolicy s)
then
return
( SomeDecryptStreamState
(MalformedDecryptState
s
"packet received after message integrity boundary")
, [] )
else
return
(SomeDecryptStreamState (FinishedDecryptState s True), [i])
push _ malformedState@(MalformedDecryptState _ _) =
return (SomeDecryptStreamState malformedState, [])
hasPendingESKPrelude s = not (null (_pendingESKs s))
hasESKPayloadVersionMismatch dp payloadFlavor state =
decryptRejectESKVersionMismatch dp
&& hasPendingESKPrelude state
&& null (alignedPrecedingESKs payloadFlavor (_pendingESKs state))
finalizeOuterEncryptedPayload state decryptedPkts =
( SomeDecryptStreamState
(FinishedDecryptState (state { _pendingESKs = [] }) False)
, decryptedPkts )
finalOutcome :: DecryptStreamState phase -> DecryptOutcome
finalOutcome (ActiveDecryptState _) = DecryptTruncated
finalOutcome (FinishedDecryptState _ hadTrailing) =
if hadTrailing
then DecryptTrailingData
else DecryptClean
finalOutcome (MalformedDecryptState _ reason) =
DecryptMalformedStructure reason
packetCanFollowESKPrelude pkt =
case pkt of
SKESKPkt _ -> True
PKESKPkt _ -> True
SymEncDataPkt _ -> True
SymEncIntegrityProtectedDataPkt _ -> True
MarkerPkt _ -> True
OtherPacketPkt 21 _ -> True
_ -> False
-- | Describes what integrity-terminating marker (if any) an inner packet
-- stream is expected to contain. Passed to 'checkInnerOutcome' to
-- distinguish a legitimate end-of-stream from a missing marker.
data InnerIntegrityExpectation
= NoIntegrityMarker
-- ^ The inner stream has no integrity-terminating packet. SED has none
-- by design; SEIPD2 authenticates via AEAD before the conduit runs.
-- 'DecryptTruncated' is the normal end-of-stream outcome.
-- | Propagate non-clean inner-stream outcomes as a 'fail'. Called after each
-- recursive decrypt helper so that structural violations and (for SEIPD1) a
-- missing MDC are not silently swallowed.
checkInnerOutcome :: MonadFail m => InnerIntegrityExpectation -> DecryptOutcome -> m ()
checkInnerOutcome _ DecryptClean = pure ()
checkInnerOutcome _ DecryptTrailingData = pure ()
checkInnerOutcome NoIntegrityMarker DecryptTruncated = pure ()
checkInnerOutcome _ (DecryptMalformedStructure reason) =
fail ("Inner encrypted payload had malformed structure: " ++ reason)
decryptSEDP ::
(MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m)
=> RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> SymmetricAlgorithm
-> SessionKey
-> BL.ByteString
-> m [Pkt]
decryptSEDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do
decrypted <-
case decryptOpenPGPCfb symalgo (BL.toStrict bs) sessionKey of
Left e -> fail (renderCipherError e)
Right x -> pure x
(innerOutcome, pkts) <- decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef decrypted
checkInnerOutcome NoIntegrityMarker innerOutcome
pure pkts
decryptSEIPDP ::
(MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m)
=> RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> SymmetricAlgorithm
-> SessionKey
-> BL.ByteString
-> m [Pkt]
decryptSEIPDP rs allowManualPKESKPrompt pkcb cb reportRef symalgo (SessionKey sessionKey) bs = do
(nonce, decrypted) <-
case decryptPreservingNonce symalgo (BL.toStrict bs) sessionKey of
Left e -> fail (renderCipherError e)
Right x -> pure x
decryptedWithoutMDC <-
case validateSEIPD1MDC nonce decrypted of
Left err -> fail err
Right x -> pure x
(innerOutcome, pkts) <- decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef decryptedWithoutMDC
checkInnerOutcome NoIntegrityMarker innerOutcome
pure pkts
decryptSEIPDv2P ::
(MonadFail m, MonadUnliftIO m, MonadIO m, MonadThrow m)
=> RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> SessionKey
-> BL.ByteString
-> m [Pkt]
decryptSEIPDv2P rs allowManualPKESKPrompt pkcb cb reportRef symalgo aeadalgo chunkSize salt sessionKey bs = do
let decrypted =
decryptSEIPDv2Payload
symalgo
aeadalgo
chunkSize
salt
(BL.toStrict bs)
sessionKey
case decrypted of
Left e -> fail e
Right cleartext -> do
(innerOutcome, pkts) <-
decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext
checkInnerOutcome NoIntegrityMarker innerOutcome
pure pkts
decryptInnerPackets ::
(MonadFail m, MonadUnliftIO m, MonadThrow m)
=> RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> B.ByteString
-> m (DecryptOutcome, [Pkt])
decryptInnerPackets rs allowManualPKESKPrompt pkcb cb reportRef cleartext =
runConduitRes $
CB.sourceLbs (BL.fromStrict cleartext) .| conduitGet get .| conduitDecompress .|
fuseBoth
(conduitDecryptChecked'
rs {_depth = _depth rs + 1}
allowManualPKESKPrompt
pkcb
cb
reportRef)
CL.consume
decryptSEIPDv2Payload ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> B.ByteString
-> SessionKey
-> Either String B.ByteString
decryptSEIPDv2Payload symalgo aeadalgo chunkSize salt encrypted (SessionKey sessionKey) = do
when (chunkSize > 16) $
Left "SEIPD v2 chunk size octet must be between 0 and 16"
(mode, nonceSize) <- aeadModeAndNonceSize aeadalgo
keyLen <- symKeySize symalgo
let outputLen = keyLen + nonceSize - 8
when (B.length (unSalt salt) /= 32) $
Left "SEIPD v2 salt must be exactly 32 octets"
when (B.length encrypted < 32) $
Left "SEIPD v2 ciphertext must include at least one chunk tag and a final tag"
let info =
B.pack
[0xd2, 2, fromFVal symalgo, fromFVal aeadalgo, chunkSize]
prk = extract @CHA.SHA256 (unSalt salt) sessionKey
okm = expand @CHA.SHA256 prk info outputLen :: B.ByteString
messageKey = B.take keyLen okm
noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm)
decryptSEIPDv2WithKey
symalgo
mode
chunkSize
info
noncePrefix
messageKey
encrypted
decryptSEIPDv2WithKey ::
SymmetricAlgorithm
-> CCT.AEADMode
-> Word8
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> B.ByteString
-> Either String B.ByteString
decryptSEIPDv2WithKey symalgo mode chunkSize info noncePrefix sessionKey encrypted =
withAESCipher
"SEIPD v2 decrypt currently supports AES-128/192/256 only"
symalgo
sessionKey
(decryptChunks mode info chunkSize noncePrefix encrypted)
decryptChunks ::
CCT.BlockCipher cipher
=> CCT.AEADMode
-> B.ByteString
-> Word8
-> B.ByteString
-> B.ByteString
-> cipher
-> Either String B.ByteString
decryptChunks mode info chunkSize noncePrefix encrypted cipher =
let ctx = AEADDecryptContext mode info chunkSize noncePrefix cipher
in runReaderT decryptChunksWithReader ctx
where
decryptChunksWithReader :: CCT.BlockCipher cipher => AEADDecrypt cipher B.ByteString
decryptChunksWithReader = go 0 encrypted [] 0
where
chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6)
tagLen = 16
go idx remaining acc totalPlain
| B.length remaining < 2 * tagLen =
lift $ Left "SEIPD v2 ciphertext is too short for chunk and final authentication tags"
| otherwise = do
let hasMoreChunks = B.length remaining > chunkLen + 2 * tagLen
currentChunkLen =
if hasMoreChunks
then chunkLen
else B.length remaining - 2 * tagLen
when (currentChunkLen < 0) $
lift $ Left "SEIPD v2 malformed chunk lengths"
let (chunkCiphertext, r1) = B.splitAt currentChunkLen remaining
(chunkTag, r2) = B.splitAt tagLen r1
plainChunk <- decryptChunkWithContext idx chunkCiphertext chunkTag
if hasMoreChunks
then go
(idx + 1)
r2
(plainChunk : acc)
(totalPlain + B.length plainChunk)
else do
when (B.length r2 /= tagLen) $
lift $ Left "SEIPD v2 missing final authentication tag"
verifyFinalTagWithContext
(idx + 1)
(totalPlain + B.length plainChunk)
r2
return (B.concat (reverse (plainChunk : acc)))
decryptChunkWithContext idx chunkCiphertext chunkTag = do
AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask
if mode' == CCT.AEAD_OCB
then
lift $
decryptWithOCBRFC7253With
(\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed")
cipher'
(noncePrefix' <> encodeWord64be idx)
info
chunkCiphertext
(mkAuthTag chunkTag)
else do
aead <- initAEADWithContext idx
let mPlain =
CCT.aeadSimpleDecrypt
aead
info
chunkCiphertext
(mkAuthTag chunkTag)
case mPlain of
Nothing -> lift $ Left "SEIPD v2 chunk authentication failed"
Just p -> return p
verifyFinalTagWithContext idx totalPlain finalTag = do
AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask
if mode' == CCT.AEAD_OCB
then do
plain <-
lift $
decryptWithOCBRFC7253With
(\_ _ _ _ _ _ -> "SEIPD v2 chunk authentication failed")
cipher'
(noncePrefix' <> encodeWord64be idx)
(info <> encodeWord64be (fromIntegral totalPlain))
B.empty
(mkAuthTag finalTag)
if B.null plain
then return ()
else lift $ Left "SEIPD v2 final authentication tag verification failed"
else do
aead <- initAEADWithContext idx
let mEmpty =
CCT.aeadSimpleDecrypt
aead
(info <> encodeWord64be (fromIntegral totalPlain))
B.empty
(mkAuthTag finalTag)
case mEmpty of
Just p | B.null p -> return ()
_ -> lift $ Left "SEIPD v2 final authentication tag verification failed"
initAEADWithContext idx = do
AEADDecryptContext mode' _ _ noncePrefix' cipher' <- ask
lift $ first show . CE.eitherCryptoError $
CCT.aeadInit mode' cipher' (noncePrefix' <> encodeWord64be idx)
aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int)
aeadModeAndNonceSize =
aeadModeAndNonceSizeForSEIPDv2
"Unknown AEAD algorithm for SEIPD v2 decrypt"
symKeySize :: SymmetricAlgorithm -> Either String Int
symKeySize =
seipdv2SymmetricKeySize
"SEIPD v2 decrypt currently supports AES-128/192/256 only"
encodeWord64be :: Word64 -> B.ByteString
encodeWord64be = BL.toStrict . runPut . putWord64be
mkAuthTag :: B.ByteString -> CCT.AuthTag
mkAuthTag = CCT.AuthTag . BA.convert
checkDecryptSymmetricAlgo :: MonadFail m => DecryptPolicy -> SymmetricAlgorithm -> m ()
checkDecryptSymmetricAlgo dp sa =
case decryptAllowedSymmetricAlgos dp of
Nothing -> pure ()
Just allowed
| sa `elem` allowed -> pure ()
| otherwise ->
fail $
"Decrypt policy rejects symmetric algorithm " ++
show sa ++
"; allowed: " ++
show allowed
checkDecryptAEADAlgo :: MonadFail m => DecryptPolicy -> AEADAlgorithm -> m ()
checkDecryptAEADAlgo dp aa =
case decryptAllowedAEADAlgos dp of
Nothing -> pure ()
Just allowed
| aa `elem` allowed -> pure ()
| otherwise ->
fail $
"Decrypt policy rejects AEAD algorithm " ++
show aa ++
"; allowed: " ++
show allowed
skeskPayloadSymmetricAlgorithm :: SKESKPayload -> SymmetricAlgorithm
skeskPayloadSymmetricAlgorithm payload =
case classifySKESKPayload payload of
ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa _ _) -> sa
ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa _ _ _ _ _) -> sa
skeskPayloadS2K :: SKESKPayload -> S2K
skeskPayloadS2K payload =
case classifySKESKPayload payload of
ClassifiedSKESKPayloadV4 (SKESKPayloadV4 _ s2k _) -> s2k
ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ _ s2k _ _ _) -> s2k
skeskPayloadAEADAlgorithm :: SKESKPayload -> Maybe AEADAlgorithm
skeskPayloadAEADAlgorithm payload =
case classifySKESKPayload payload of
ClassifiedSKESKPayloadV4 _ -> Nothing
ClassifiedSKESKPayloadV6 (SKESKPayloadV6 _ aa _ _ _ _) -> Just aa
resolveSKESKSessionKey :: BL.ByteString -> SKESKPayload -> Either String B.ByteString
resolveSKESKSessionKey passphrase payload =
first renderSKESKSessionKeyResolutionError $
resolveSKESKSessionKeyTyped passphrase (classifySKESKPayload payload)
data SKESKSessionKeyResolutionError
= SKESKSessionKeyS2KError S2KError
| SKESKSessionKeyOtherError String
deriving (Eq, Show)
renderSKESKSessionKeyResolutionError :: SKESKSessionKeyResolutionError -> String
renderSKESKSessionKeyResolutionError (SKESKSessionKeyS2KError err) = renderS2KError err
renderSKESKSessionKeyResolutionError (SKESKSessionKeyOtherError err) = err
resolveSKESKSessionKeyTyped ::
BL.ByteString
-> ClassifiedSKESKPayload
-> Either SKESKSessionKeyResolutionError B.ByteString
resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k Nothing)) =
first
SKESKSessionKeyS2KError
(skesk2Key (SKESK4Packet sa s2k Nothing) passphrase)
resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k (Just esk))) =
first
SKESKSessionKeyS2KError
(snd <$> skesk2SessionKey (SKESK4Packet sa s2k (Just esk)) passphrase)
resolveSKESKSessionKeyTyped passphrase (ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aead s2k iv esk tag)) = do
keyLen <- first (SKESKSessionKeyS2KError . S2KUnsupportedAlgorithm) (keySize sa)
ikm <- first SKESKSessionKeyS2KError (string2Key s2k keyLen passphrase)
kek <- first SKESKSessionKeyOtherError (deriveSKESK6KEK sa aead ikm)
first
SKESKSessionKeyOtherError
(decryptSKESK6SessionKey sa aead kek (BL.toStrict iv) (BL.toStrict esk) (BL.toStrict tag))
data ClassifiedSKESKPayload where
ClassifiedSKESKPayloadV4 :: SKESKPayloadV4 -> ClassifiedSKESKPayload
ClassifiedSKESKPayloadV6 :: SKESKPayloadV6 -> ClassifiedSKESKPayload
classifySKESKPayload :: SKESKPayload -> ClassifiedSKESKPayload
classifySKESKPayload (SKESKPayloadV4Packet payloadV4) =
ClassifiedSKESKPayloadV4 payloadV4
classifySKESKPayload (SKESKPayloadV6Packet payloadV6) =
ClassifiedSKESKPayloadV6 payloadV6
resolveSessionKey ::
(MonadFail m, MonadIO m)
=> RecursorState
-> Bool
-> PKESKResolver IO
-> InputCallback IO
-> EncryptedPayloadFlavor v
-> Maybe (IORef [DecryptSessionKeyResolutionReport])
-> m (SymmetricAlgorithm, SessionKey)
resolveSessionKey rs allowManualPKESKPrompt pkcb cb payloadFlavor reportRef =
case precedingCandidates of
[] ->
if null (_pendingESKs rs)
then fail "Encrypted data packet has no preceding SKESK or PKESK packet"
else
fail
"Encrypted data packet has no preceding SKESK or PKESK packet aligned with payload version"
candidates ->
case skeskCandidates candidates of
[] -> resolvePKESKCandidates (pkeskCandidates candidates) [] [] []
skesks -> do
passphrase <- liftIO $ cb "Input the passphrase I want"
resolveSKESKCandidates passphrase skesks (pkeskCandidates candidates) []
where
precedingCandidates
| strictAlignment = alignedByVersion
| null alignedByVersion = _pendingESKs rs
| otherwise = alignedByVersion
strictAlignment = decryptRejectESKVersionMismatch (_decryptPolicy rs)
alignedByVersion = pendingESKsFromAligned alignedStrict
alignedStrict = alignedPrecedingESKs payloadFlavor (_pendingESKs rs)
skeskCandidates esks = reverse [skesk | PendingSKESK skesk <- esks]
pkeskCandidates esks = reverse [pkesk | PendingPKESK pkesk <- esks]
resolveSKESKCandidates ::
(MonadFail m, MonadIO m)
=> BL.ByteString
-> [SKESKPayload]
-> [PKESKPayload]
-> [String]
-> m (SymmetricAlgorithm, SessionKey)
resolveSKESKCandidates _ [] pkesks skeskErrs =
resolvePKESKCandidates pkesks skeskErrs [] []
resolveSKESKCandidates passphrase (skesk:rest) pkesks skeskErrs =
case resolveSKESKCandidate passphrase skesk of
Left err ->
resolveSKESKCandidates
passphrase
rest
pkesks
((skeskErrPrefix skesk ++ err) : skeskErrs)
Right resolved -> do
emitResolutionReport
(mkResolutionReport DecryptResolvedViaSKESK skeskErrs [] [])
pure resolved
resolveSKESKCandidate ::
BL.ByteString
-> SKESKPayload
-> Either String (SymmetricAlgorithm, SessionKey)
resolveSKESKCandidate passphrase skesk = do
let skeskSymAlgo = skeskPayloadSymmetricAlgorithm skesk
expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor
sessionKeyBytes <- resolveSKESKSessionKey passphrase skesk
case expectedSymAlgo of
Just expected | expected /= skeskSymAlgo ->
Left "SKESK/encrypted-payload symmetric algorithm mismatch"
_ ->
case (payloadExpectedAEADAlgorithm payloadFlavor, skeskPayloadAEADAlgorithm skesk) of
(Just expectedAEAD, Just skeskAEAD)
| expectedAEAD /= skeskAEAD ->
Left "SKESK/encrypted-payload AEAD algorithm mismatch"
_ -> Right (skeskSymAlgo, SessionKey sessionKeyBytes)
skeskErrPrefix skesk = "[" ++ describeSKESK skesk ++ "] "
resolvePKESKCandidates ::
(MonadFail m, MonadIO m)
=> [PKESKPayload]
-> [String]
-> [String]
-> [PKESKResolverAttempt]
-> m (SymmetricAlgorithm, SessionKey)
resolvePKESKCandidates [] [] [] _ =
fail "Encrypted data packet has no usable preceding SKESK or PKESK packet"
resolvePKESKCandidates [] skeskErrs [] _ =
fail
("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++
"candidate errors: " ++ unwords (reverse skeskErrs))
resolvePKESKCandidates [] skeskErrs pkeskErrs resolverAttempts =
if allowManualPKESKPrompt
then do
let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor
errs = skeskErrs ++ pkeskErrs
encodedSessionKey <-
BL.toStrict <$>
liftIO
(cb
"Input decrypted PKESK session key material (OpenPGP encoded or raw key bytes)")
case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of
Left manualErr ->
fail
("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++
"candidate errors: " ++
unwords (reverse errs) ++
"; manual input failed: " ++ manualErr)
Right (sa, k) -> do
emitResolutionReport
(mkResolutionReport
DecryptResolvedViaManualPKESKInput
skeskErrs
pkeskErrs
resolverAttempts)
pure (sa, SessionKey k)
else
fail
("Encrypted data packet has no usable preceding SKESK or PKESK packet; " ++
"candidate errors: " ++
unwords (reverse (skeskErrs ++ pkeskErrs)))
resolvePKESKCandidates (pkesk:rest) skeskErrs pkeskErrs resolverAttempts = do
let expectedSymAlgo = payloadExpectedSymmetricAlgorithm payloadFlavor
errPrefix = "[" ++ describePKESK pkesk ++ "] "
attemptPKESKCandidate [] [] 0 expectedSymAlgo errPrefix resolverAttempts
where
attemptPKESKCandidate attemptedSKeys previousFailures attemptIndex expectedSymAlgo errPrefix resolverAttemptsAcc = do
let callbackProbeSummary = describeCallbackProbeSummary pkesk
resolverResult <-
liftIO (resolvePKESKRecipientKey pkesk previousFailures attemptIndex)
case resolverResult of
Left resolverErr ->
fail (errPrefix ++ resolverErr)
Right (Nothing, _, newAttempts) ->
let resolverAttempts' = resolverAttemptsAcc ++ newAttempts
terminalError =
case reverse previousFailures of
(latestFailure:_) -> errPrefix ++ pkeskAttemptFailureReason latestFailure
[] ->
errPrefix ++
"no matching key context (callback probes: " ++
callbackProbeSummary ++
")"
in
resolvePKESKCandidates
rest
skeskErrs
(terminalError : pkeskErrs)
resolverAttempts'
Right (Just keyInfo, nextAttemptIndex, newAttempts)
| pkeskRecipientSKey keyInfo `elem` attemptedSKeys ->
let resolverAttempts' = resolverAttemptsAcc ++ newAttempts
terminalError =
case reverse previousFailures of
(latestFailure:_) -> errPrefix ++ pkeskAttemptFailureReason latestFailure
[] ->
errPrefix ++
"key context callback repeated without yielding a usable key"
in
resolvePKESKCandidates
rest
skeskErrs
(terminalError : pkeskErrs)
resolverAttempts'
| otherwise -> do
let resolverAttempts' = resolverAttemptsAcc ++ newAttempts
unwrapped <- liftIO (tryUnwrapPKESKSessionMaterial pkesk keyInfo)
case unwrapped of
Left err ->
attemptPKESKCandidate
(pkeskRecipientSKey keyInfo : attemptedSKeys)
(previousFailures ++ [mkAttemptFailure keyInfo PKESKAttemptUnwrapFailed err])
nextAttemptIndex
expectedSymAlgo
errPrefix
resolverAttempts'
Right encodedSessionKey ->
case decodePKESKSessionKey expectedSymAlgo encodedSessionKey of
Left err ->
attemptPKESKCandidate
(pkeskRecipientSKey keyInfo : attemptedSKeys)
(previousFailures ++
[ mkAttemptFailure
keyInfo
PKESKAttemptSessionMaterialDecodeFailed
err
])
nextAttemptIndex
expectedSymAlgo
errPrefix
resolverAttempts'
Right (sa, k) -> do
emitResolutionReport
(mkResolutionReport
DecryptResolvedViaPKESK
skeskErrs
pkeskErrs
resolverAttempts')
pure (sa, SessionKey k)
emitResolutionReport :: MonadIO m => DecryptSessionKeyResolutionReport -> m ()
emitResolutionReport report =
case reportRef of
Nothing -> pure ()
Just ref -> liftIO (modifyIORef' ref (report :))
mkResolutionReport ::
DecryptSessionKeyResolutionPath
-> [String]
-> [String]
-> [PKESKResolverAttempt]
-> DecryptSessionKeyResolutionReport
mkResolutionReport path skeskErrs pkeskErrs resolverAttempts =
DecryptSessionKeyResolutionReport
{ decryptSessionResolutionPath = path
, decryptSessionResolutionSKESKErrors = reverse skeskErrs
, decryptSessionResolutionPKESKErrors = reverse pkeskErrs
, decryptSessionResolutionResolverAttempts = resolverAttempts
}
mkAttemptFailure keyInfo failureKind reason =
PKESKAttemptFailure
{ pkeskAttemptFailureKeyContext =
recipientKeyContext keyInfo
, pkeskAttemptFailureKind = failureKind
, pkeskAttemptFailureReason = reason
}
recipientKeyContext :: PKESKRecipientKey -> Maybe (KeyVersion, PubKeyAlgorithm)
recipientKeyContext keyInfo =
fmap (\pk -> (_keyVersion pk, _pkalgo pk)) (pkeskRecipientPKPayload keyInfo)
renderPKESKResolverError (ResolverPolicyDenied reason) =
"resolver policy denied candidate selection: " ++ reason
renderPKESKResolverError (ResolverBackendUnavailable reason) =
"resolver backend unavailable: " ++ reason
renderPKESKResolverError (ResolverInvalidResponse reason) =
"resolver returned an invalid response: " ++ reason
resolvePKESKRecipientKey payload previousFailures attemptIndex0 =
probePacketVariants attemptIndex0 [] (pkeskCallbackPackets payload)
where
probePacketVariants attemptIndex attemptsAcc [] =
pure (Right (Nothing, attemptIndex, reverse attemptsAcc))
probePacketVariants attemptIndex attemptsAcc (probePkt:restProbePkts) = do
let request =
PKESKResolveRequest
{ reqPKESK = payload
, reqProbePacket = probePkt
, reqIsWildcardRecipient = isWildcardPKESKPayload payload
, reqAttemptIndex = attemptIndex
, reqPreviousFailures = previousFailures
}
resolveAction <-
pkcb request
let attemptRecord =
PKESKResolverAttempt
{ pkeskResolverAttemptPreviousFailures = previousFailures
, pkeskResolverAttemptAction =
case resolveAction of
ResolveWith keyInfo ->
ResolverAttemptResolveWith (recipientKeyContext keyInfo)
ResolveSkip -> ResolverAttemptSkip
ResolveExhausted -> ResolverAttemptExhausted
ResolveFail resolverErr -> ResolverAttemptFail resolverErr
}
case resolveAction of
ResolveWith keyInfo ->
pure
(Right (Just keyInfo, attemptIndex + 1, reverse (attemptRecord : attemptsAcc)))
ResolveSkip ->
probePacketVariants
(attemptIndex + 1)
(attemptRecord : attemptsAcc)
restProbePkts
ResolveExhausted ->
pure
(Right (Nothing, attemptIndex + 1, reverse (attemptRecord : attemptsAcc)))
ResolveFail resolverErr ->
pure (Left (renderPKESKResolverError resolverErr))
pkeskCallbackPackets payload =
nub $
case payload of
PKESKPayloadV3Packet (PKESKPayloadV3 v rid pka mpis) ->
map
(\ridVariant ->
PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 v ridVariant pka mpis)))
(recipientIdCallbackVariantsV3 rid)
PKESKPayloadV6Packet (PKESKPayloadV6 rid pka esk) ->
map
(\ridVariant ->
PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 ridVariant pka esk)))
(recipientIdCallbackVariants rid)
describeCallbackProbeSummary payload =
intercalate ", " (map describePKESKCallbackProbe (pkeskCallbackPackets payload))
describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 _ rid pka _))) =
"PKESK3 " ++
show pka ++
" rid=" ++
show rid ++
if isWildcardV3RecipientKeyId rid
then " (wildcard)"
else ""
describePKESKCallbackProbe (PKESKPkt (PKESKPayloadV6Packet (PKESKPayloadV6 rid pka _))) =
"PKESK6 " ++ show pka ++ " rid=" ++ show rid
describePKESKCallbackProbe pkt = show pkt
recipientIdCallbackVariantsV3 rid
| isWildcardV3RecipientKeyId rid = [rid]
| otherwise = [rid, EightOctetKeyId (BL.replicate 8 0)]
isWildcardV3RecipientKeyId (EightOctetKeyId rid) =
BL.length rid == 8 && BL.all (== 0) rid
recipientIdCallbackVariants rid
| BL.length rid == 20 = [rid, BL.cons 0x04 rid]
| BL.length rid == 21 && BL.head rid == 0x04 = [rid, BL.tail rid]
| BL.length rid == 32 = [rid, BL.cons 0x06 rid]
| BL.length rid == 33 && BL.head rid == 0x06 = [rid, BL.tail rid]
| otherwise = [rid]
isWildcardPKESKPayload (PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _)) =
isWildcardV3RecipientKeyId (EightOctetKeyId rid)
isWildcardPKESKPayload _ = False
describePKESK payload =
case classifyPKESKPayload payload of
ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ rid pka _) ->
"PKESK3 " ++ show pka ++ " rid=" ++ show rid
ClassifiedPKESKPayloadV6 (PKESKPayloadV6 rid pka _) ->
"PKESK6 " ++ show pka ++ " rid=" ++ show rid
describeSKESK payload =
case classifySKESKPayload payload of
ClassifiedSKESKPayloadV4 (SKESKPayloadV4 sa s2k _) ->
"SKESK4 " ++ show sa ++ " s2k=" ++ show s2k
ClassifiedSKESKPayloadV6 (SKESKPayloadV6 sa aa s2k _ _ _) ->
"SKESK6 " ++ show sa ++ "/" ++ show aa ++ " s2k=" ++ show s2k
data AlignedPendingESK (v :: EncryptedPayloadVersion) where
LegacyAlignedSKESK :: SKESKPayloadV4 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion
LegacyAlignedPKESK :: PKESKPayloadV3 -> AlignedPendingESK 'LegacyEncryptedPayloadVersion
SEIPDv2AlignedSKESK :: SKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
SEIPDv2AlignedPKESK :: PKESKPayloadV6 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
-- | A version 3 PKESK that precedes a SEIPDv2 payload.
--
-- RFC 9580 §5.13 explicitly permits version 3 PKESKs before a version 2
-- SEIPD packet, as a backward-compatibility allowance for implementations
-- that cannot yet produce v6 key material. The v3 PKESK carries the
-- session key wrapped with legacy (v3) asymmetric key wrapping; the SEIPD
-- v2 payload itself is still authenticated with modern AEAD. This
-- constructor therefore counts as "aligned" for SEIPDv2 — it does not
-- indicate a mis-assembled message — even though the PKESK version does
-- not match the SEIPD version.
SEIPDv2AlignedLegacyPKESK :: PKESKPayloadV3 -> AlignedPendingESK 'SEIPDv2EncryptedPayloadVersion
alignedPrecedingESKs ::
EncryptedPayloadFlavor v
-> [PendingESK]
-> [AlignedPendingESK v]
alignedPrecedingESKs LegacyEncryptedPayload =
mapMaybe
(\esk ->
case esk of
PendingSKESK (SKESKPayloadV4Packet skesk4) -> Just (LegacyAlignedSKESK skesk4)
PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (LegacyAlignedPKESK pkesk3)
_ -> Nothing)
alignedPrecedingESKs (SEIPDv2EncryptedPayload _ _) =
mapMaybe
(\esk ->
case esk of
PendingSKESK (SKESKPayloadV6Packet skesk6) -> Just (SEIPDv2AlignedSKESK skesk6)
PendingPKESK (PKESKPayloadV6Packet pkesk6) -> Just (SEIPDv2AlignedPKESK pkesk6)
-- v3 PKESK before SEIPDv2 is explicitly allowed by RFC 9580 §5.13;
-- see 'SEIPDv2AlignedLegacyPKESK' for details.
PendingPKESK (PKESKPayloadV3Packet pkesk3) -> Just (SEIPDv2AlignedLegacyPKESK pkesk3)
_ -> Nothing)
pendingESKsFromAligned :: [AlignedPendingESK v] -> [PendingESK]
pendingESKsFromAligned =
map
(\esk ->
case esk of
LegacyAlignedSKESK skesk4 -> PendingSKESK (SKESKPayloadV4Packet skesk4)
LegacyAlignedPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3)
SEIPDv2AlignedSKESK skesk6 -> PendingSKESK (SKESKPayloadV6Packet skesk6)
SEIPDv2AlignedPKESK pkesk6 -> PendingPKESK (PKESKPayloadV6Packet pkesk6)
SEIPDv2AlignedLegacyPKESK pkesk3 -> PendingPKESK (PKESKPayloadV3Packet pkesk3))
payloadExpectedSymmetricAlgorithm :: EncryptedPayloadFlavor v -> Maybe SymmetricAlgorithm
payloadExpectedSymmetricAlgorithm LegacyEncryptedPayload = Nothing
payloadExpectedSymmetricAlgorithm (SEIPDv2EncryptedPayload sa _) = Just sa
payloadExpectedAEADAlgorithm :: EncryptedPayloadFlavor v -> Maybe AEADAlgorithm
payloadExpectedAEADAlgorithm LegacyEncryptedPayload = Nothing
payloadExpectedAEADAlgorithm (SEIPDv2EncryptedPayload _ aa) = Just aa
tryUnwrapPKESKSessionMaterial ::
PKESKPayload -> PKESKRecipientKey -> IO (Either String B.ByteString)
tryUnwrapPKESKSessionMaterial pkesk keyInfo = do
attempted <- try @SomeException (unwrapPKESKSessionMaterial pkesk keyInfo :: IO B.ByteString)
pure (first displayException attempted)
data PKESKUnwrapCase where
PKESKUnwrapV3RSA :: RSATypes.PrivateKey -> MPI -> PKESKUnwrapCase
PKESKUnwrapV6RSA :: RSATypes.PrivateKey -> B.ByteString -> PKESKUnwrapCase
PKESKUnwrapV6ECDH ::
PKESKRecipientKey
-> PubKeyAlgorithm
-> B.ByteString
-> ECDSA.PrivateKey
-> PKESKUnwrapCase
PKESKUnwrapV6XDHRaw ::
PKESKRecipientKey
-> PubKeyAlgorithm
-> B.ByteString
-> B.ByteString
-> PKESKUnwrapCase
PKESKUnwrapV3X25519FromECDH ::
PKESKRecipientKey
-> NonEmpty MPI
-> ECDSA.PrivateKey
-> PKESKUnwrapCase
PKESKUnwrapV3X25519Raw ::
PKESKRecipientKey
-> NonEmpty MPI
-> B.ByteString
-> PKESKUnwrapCase
PKESKUnwrapV3ECDH ::
PKESKRecipientKey
-> PubKeyAlgorithm
-> NonEmpty MPI
-> ECDSA.PrivateKey
-> PKESKUnwrapCase
data ClassifiedPKESKPayload where
ClassifiedPKESKPayloadV3 :: PKESKPayloadV3 -> ClassifiedPKESKPayload
ClassifiedPKESKPayloadV6 :: PKESKPayloadV6 -> ClassifiedPKESKPayload
data ClassifiedPKESKRecipientKey where
ClassifiedPKESKRecipientRSA ::
PKESKRecipientKey -> RSATypes.PrivateKey -> ClassifiedPKESKRecipientKey
ClassifiedPKESKRecipientECDH ::
PKESKRecipientKey -> ECDSA.PrivateKey -> ClassifiedPKESKRecipientKey
ClassifiedPKESKRecipientX25519 ::
PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey
ClassifiedPKESKRecipientX448 ::
PKESKRecipientKey -> B.ByteString -> ClassifiedPKESKRecipientKey
ClassifiedPKESKRecipientUnsupported ::
PKESKRecipientKey -> ClassifiedPKESKRecipientKey
classifyPKESKPayload :: PKESKPayload -> ClassifiedPKESKPayload
classifyPKESKPayload (PKESKPayloadV3Packet payloadV3) =
ClassifiedPKESKPayloadV3 payloadV3
classifyPKESKPayload (PKESKPayloadV6Packet payloadV6) =
ClassifiedPKESKPayloadV6 payloadV6
classifyPKESKRecipientKey :: PKESKRecipientKey -> ClassifiedPKESKRecipientKey
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (RSAPrivateKey (RSA_PrivateKey privateKey))) =
ClassifiedPKESKRecipientRSA keyInfo privateKey
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (ECDHPrivateKey (ECDSA_PrivateKey privateKey))) =
ClassifiedPKESKRecipientECDH keyInfo privateKey
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X25519PrivateKey privateKeyRaw)) =
ClassifiedPKESKRecipientX25519 keyInfo privateKeyRaw
classifyPKESKRecipientKey keyInfo@(PKESKRecipientKey _ (X448PrivateKey privateKeyRaw)) =
ClassifiedPKESKRecipientX448 keyInfo privateKeyRaw
classifyPKESKRecipientKey keyInfo =
ClassifiedPKESKRecipientUnsupported keyInfo
pkeskPayloadAlgorithm :: PKESKPayload -> PubKeyAlgorithm
pkeskPayloadAlgorithm payload =
case classifyPKESKPayload payload of
ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _) -> pka
ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _) -> pka
classifyPKESKUnwrapCase ::
PKESKPayload
-> PKESKRecipientKey
-> Either String PKESKUnwrapCase
classifyPKESKUnwrapCase payload keyInfo =
case (classifyPKESKPayload payload, classifyPKESKRecipientKey keyInfo) of
( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka (mpi :| []))
, ClassifiedPKESKRecipientRSA _ privateKey)
| pka == RSA || pka == DeprecatedRSAEncryptOnly ->
Right (PKESKUnwrapV3RSA privateKey mpi)
( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
, ClassifiedPKESKRecipientRSA _ privateKey)
| pka == RSA ->
Right (PKESKUnwrapV6RSA privateKey (BL.toStrict esk))
( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
, ClassifiedPKESKRecipientECDH recipientCtx privateKey)
| pka == ECDH || pka == X25519 ->
Right (PKESKUnwrapV6ECDH recipientCtx pka (BL.toStrict esk) privateKey)
( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
, ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw)
| pka == X25519 ->
Right (PKESKUnwrapV6XDHRaw recipientCtx pka (BL.toStrict esk) privateKeyRaw)
( ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka esk)
, ClassifiedPKESKRecipientX448 recipientCtx privateKeyRaw)
| pka == X448 ->
Right (PKESKUnwrapV6XDHRaw recipientCtx pka (BL.toStrict esk) privateKeyRaw)
( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
, ClassifiedPKESKRecipientECDH recipientCtx privateKey)
| pka == X25519 ->
Right (PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey)
( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
, ClassifiedPKESKRecipientX25519 recipientCtx privateKeyRaw)
| pka == X25519 ->
Right (PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw)
( ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka mpis)
, ClassifiedPKESKRecipientECDH recipientCtx privateKey)
| pka == ECDH || pka == X25519 ->
Right (PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey)
(ClassifiedPKESKPayloadV3 (PKESKPayloadV3 _ _ pka _), _) ->
Left ("PKESK key unwrap unsupported for packet algorithm " ++ show pka)
(ClassifiedPKESKPayloadV6 (PKESKPayloadV6 _ pka _), _) ->
Left
("PKESKv6 key unwrap unsupported for packet algorithm " ++
show pka ++ " with secret key " ++ show (pkeskRecipientSKey keyInfo))
unwrapPKESKSessionMaterial ::
(MonadFail m, MonadIO m) => PKESKPayload -> PKESKRecipientKey -> m B.ByteString
unwrapPKESKSessionMaterial pkesk keyInfo = do
either fail pure (validateTable30Policy pkesk keyInfo)
unwrapCase <- either fail pure (classifyPKESKUnwrapCase pkesk keyInfo)
case unwrapCase of
PKESKUnwrapV3RSA privateKey mpi ->
rsaUnwrap
privateKey
(leftPadTo (rsaModulusBytes privateKey) (i2osp (unMPI mpi)))
PKESKUnwrapV6RSA privateKey esk -> do
normalized <- either fail pure (normalizePKESKv6RSAEsk privateKey esk)
rsaUnwrap privateKey normalized
PKESKUnwrapV6ECDH recipientCtx pka esk privateKey ->
ecdhUnwrapV6 recipientCtx pka esk privateKey
PKESKUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw ->
ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw
PKESKUnwrapV3X25519FromECDH recipientCtx mpis privateKey -> do
recipientPKP <-
maybe
(fail
"X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback")
pure
(pkeskRecipientPKPayload recipientCtx)
recipientSecretRaw <-
either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
x25519UnwrapV3 recipientCtx mpis recipientSecretRaw
PKESKUnwrapV3X25519Raw recipientCtx mpis privateKeyRaw ->
x25519UnwrapV3 recipientCtx mpis privateKeyRaw
PKESKUnwrapV3ECDH recipientCtx pka mpis privateKey ->
ecdhUnwrap recipientCtx pka mpis privateKey
where
validateTable30Policy :: PKESKPayload -> PKESKRecipientKey -> Either String ()
validateTable30Policy payload recipientCtx =
case pkeskRecipientPKPayload recipientCtx of
Nothing -> Right ()
Just recipientPKP ->
case (pkeskPayloadAlgorithm payload, _pubkey recipientPKP) of
(ECDH, ECDHPubKey _ kdfHA kdfSA) ->
validateTable30PolicyForRecipient recipientPKP kdfHA kdfSA
_ -> Right ()
rsaUnwrap privateKey encryptedSessionMaterial = do
decrypted <-
liftIO
(P15.decryptSafer privateKey encryptedSessionMaterial ::
IO (Either RSATypes.Error B.ByteString))
case decrypted of
Left err -> fail ("RSA PKESK decrypt failed: " ++ show err)
Right decoded -> pure decoded
normalizePKESKv6RSAEsk ::
RSATypes.PrivateKey
-> B.ByteString
-> Either String B.ByteString
normalizePKESKv6RSAEsk privateKey esk = do
when (B.length esk < 2) $
Left "PKESKv6 RSA ESK is too short to contain an MPI"
let mpiBits =
fromIntegral (B.index esk 0) `shiftL` 8 +
fromIntegral (B.index esk 1)
mpiLen = (mpiBits + 7) `div` 8
when (B.length esk /= 2 + mpiLen) $
Left
("PKESKv6 RSA ESK MPI length mismatch: expected " ++
show (2 + mpiLen) ++ " octets, got " ++ show (B.length esk))
let mpiPayload = B.drop 2 esk
when (mpiBits > 0) $ do
when (B.null mpiPayload) $
Left "PKESKv6 RSA ESK MPI has non-zero bit length but empty payload"
let firstOctet = B.head mpiPayload
actualBits =
(B.length mpiPayload - 1) * 8 + (8 - countLeadingZeros firstOctet)
when (actualBits /= mpiBits) $
Left
("PKESKv6 RSA ESK MPI bit-length mismatch: declared " ++
show mpiBits ++ ", actual " ++ show actualBits)
let modulusLen = rsaModulusBytes privateKey
when (B.length mpiPayload > modulusLen) $
Left
("PKESKv6 RSA ESK MPI payload exceeds recipient modulus size: " ++
show (B.length mpiPayload) ++ " > " ++ show modulusLen)
pure (leftPadTo modulusLen mpiPayload)
ecdhUnwrap recipientCtx pka mpis privateKey = do
recipientPKP <-
maybe
(fail
"ECDH PKESK unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback")
pure
(pkeskRecipientPKPayload recipientCtx)
case _pubkey recipientPKP of
ECDHPubKey ecdhPub kdfHA kdfSA -> do
(ephemeralBytes, wrappedSessionKeyBytes) <-
either fail pure (parseECDHPKESKMPIs mpis)
sharedSecret <-
case ecdhPub of
ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do
ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes
pure
(BA.convert
(ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) ::
B.ByteString)
EdDSAPubKey Ed25519 _ -> do
recipientSecretRaw <-
either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
recipientSecret <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.secretKey recipientSecretRaw
ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
ephPub <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.publicKey ephBytes
pure . BA.convert $ C25519.dh ephPub recipientSecret
EdDSAPubKey Ed448 _ ->
fail
"legacy ECDH PKESK unwrap does not support Curve448Legacy recipients"
_ ->
fail
"ECDH PKESK unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible"
param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param)
let wrappedCandidates =
candidateWrappedRFC3394CiphertextsForLegacyECDH
(LegacyECDHWrappedRFC3394Ciphertext wrappedSessionKeyBytes)
validUnwraps =
[ material
| wrappedCandidate <- wrappedCandidates
, Right decoded <- [aesKeyUnwrapRFC3394 kdfSA kek (unLegacyECDHWrappedRFC3394Ciphertext wrappedCandidate)]
, Right material <- [parseLegacyECDHDecodedSessionMaterial decoded]
]
case validUnwraps of
(material:_) -> pure (encodeLegacyECDHSessionMaterial material)
[] ->
case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of
Left err -> fail err
Right _ ->
fail
"legacy ECDH wrapped session key decrypted but decoded session material is malformed"
_ ->
fail
"ECDH PKESK unwrap requires recipient PKPayload with ECDHPubKey parameters"
ecdhUnwrapV6 recipientCtx pka esk privateKey = do
recipientPKP <-
maybe
(fail
"ECDH PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback")
pure
(pkeskRecipientPKPayload recipientCtx)
if pka == X25519
then do
recipientSecretRaw <-
either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
v6X25519Unwrap recipientPKP recipientSecretRaw esk
else
if pka == X448
then
fail
"X448 PKESKv6 unwrap requires an X448PrivateKey recipient secret key and recipient PKPayload context"
else
case _pubkey recipientPKP of
ECDHPubKey ecdhPub kdfHA kdfSA -> do
(ephemeralBytes, wrappedSessionKeyBytes) <-
either fail pure (parsePKESKv6ECDHEsk pka esk)
case ecdhPub of
ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)) -> do
ephPoint <- parseUncompressedPointForCurve curve ephemeralBytes
let sharedSecret =
BA.convert
(ECCDH.getShared curve (ECDSA.private_d privateKey) ephPoint) ::
B.ByteString
param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
kek <- either fail pure (deriveECDHKek kdfHA kdfSA sharedSecret param)
case aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes of
Left err -> fail err
Right decoded -> pure decoded
EdDSAPubKey Ed25519 _ -> do
recipientSecretRaw <-
either fail pure (resolveX25519SecretRaw recipientPKP privateKey)
recipientSecret <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.secretKey recipientSecretRaw
ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
ephPub <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.publicKey ephBytes
let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString
param <- either fail pure (buildECDHKDFParam recipientPKP pka ecdhPub kdfHA kdfSA)
let rfc6637Result =
do kek <- deriveECDHKek kdfHA kdfSA sharedSecret param
aesKeyUnwrapRFC3394 kdfSA kek wrappedSessionKeyBytes
case rfc6637Result of
Right decoded -> pure decoded
Left rfc6637Err -> do
recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP)
let kekX25519 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret
case aesKeyUnwrapRFC3394 AES128 kekX25519 wrappedSessionKeyBytes of
Right decoded -> pure decoded
Left x25519Err ->
fail
("ECDH PKESKv6 Curve25519 unwrap failed (RFC6637: " ++
rfc6637Err ++ ", X25519: " ++ x25519Err ++ ")")
EdDSAPubKey Ed448 _ ->
fail
"ECDH PKESKv6 unwrap does not support Curve448Legacy recipients; use X448 PKESKv6 packets"
_ ->
fail
"ECDH PKESKv6 unwrap requires recipient ECDH public key to be ECDSA or X25519-compatible"
_ ->
fail
"ECDH PKESKv6 unwrap requires recipient PKPayload with ECDHPubKey parameters"
ecdhUnwrapV6XDHRaw recipientCtx pka esk privateKeyRaw = do
recipientPKP <-
maybe
(fail
"X25519/X448 PKESKv6 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback")
pure
(pkeskRecipientPKPayload recipientCtx)
case pka of
X25519 -> v6X25519Unwrap recipientPKP (leftPadTo 32 privateKeyRaw) esk
X448 -> v6X448Unwrap recipientPKP (leftPadTo 56 privateKeyRaw) esk
_ ->
fail
("X25519/X448 PKESKv6 unwrap only supports X25519/X448 packets; got " ++
show pka)
v6X25519Unwrap recipientPKP recipientSecretRaw esk = do
recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP)
(ephemeralBytes, wrappedSessionKeyBytes) <-
either fail pure (parsePKESKv6ECDHEsk X25519 esk)
ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
recipientSecret <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.secretKey (leftPadTo 32 recipientSecretRaw)
ephPub <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.publicKey ephBytes
let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString
kek = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret
case aesKeyUnwrapRFC3394 AES128 kek wrappedSessionKeyBytes of
Left err -> fail err
Right decoded -> pure decoded
extractX25519RecipientPublic recipientPKP =
case _pubkey recipientPKP of
EdDSAPubKey Ed25519 point ->
normalizeX25519EphemeralPublic (edPointBytes point)
ECDHPubKey (EdDSAPubKey Ed25519 point) _ _ ->
normalizeX25519EphemeralPublic (edPointBytes point)
other ->
Left
("X25519 PKESKv6 unwrap requires an X25519 recipient public key, got " ++
show other)
extractX448RecipientPublic recipientPKP =
case _pubkey recipientPKP of
EdDSAPubKey Ed448 point ->
normalizeX448EphemeralPublic (edPointBytes point)
ECDHPubKey (EdDSAPubKey Ed448 point) _ _ ->
normalizeX448EphemeralPublic (edPointBytes point)
other ->
Left
("X448 PKESKv6 unwrap requires an X448 recipient public key, got " ++
show other)
resolveX25519SecretRaw recipientPKP privateKey = do
recipientPublicRaw <- extractX25519RecipientPublic recipientPKP
let secretBE = leftPadTo 32 (i2osp (ECDSA.private_d privateKey))
candidates = [secretBE, B.reverse secretBE]
matchesCandidate candidate =
case CE.eitherCryptoError (C25519.secretKey candidate) of
Right sk ->
let derivedPub = BA.convert (C25519.toPublic sk) :: B.ByteString
in derivedPub == recipientPublicRaw
Left _ -> False
case filter matchesCandidate candidates of
(candidate:_) -> Right candidate
[] -> Right secretBE
v6X448Unwrap recipientPKP recipientSecretRaw esk = do
recipientPublicRaw <- either fail pure (extractX448RecipientPublic recipientPKP)
(ephemeralBytes, wrappedSessionKeyBytes) <-
either fail pure (parsePKESKv6ECDHEsk X448 esk)
ephBytes <- either fail pure (normalizeX448EphemeralPublic ephemeralBytes)
recipientSecret <-
either fail pure .
first show . CE.eitherCryptoError $
C448.secretKey (leftPadTo 56 recipientSecretRaw)
ephPub <-
either fail pure .
first show . CE.eitherCryptoError $
C448.publicKey ephBytes
let sharedSecret = BA.convert (C448.dh ephPub recipientSecret) :: B.ByteString
kek = deriveX448Kek ephBytes recipientPublicRaw sharedSecret
case aesKeyUnwrapRFC3394 AES256 kek wrappedSessionKeyBytes of
Left err -> fail err
Right decoded -> pure decoded
x25519UnwrapV3 recipientCtx mpis recipientSecretRaw = do
recipientPKP <-
maybe
(fail
"X25519 PKESKv3 unwrap requires recipient PKPayload context; use conduitDecrypt with DecryptWithKeyring or DecryptWithUnwrapCandidatesCallback")
pure
(pkeskRecipientPKPayload recipientCtx)
recipientPublicRaw <- either fail pure (extractX25519RecipientPublic recipientPKP)
(ephemeralBytes, eskBytes) <-
either fail pure (parseECDHPKESKMPIs mpis)
ephBytes <- either fail pure (normalizeX25519EphemeralPublic ephemeralBytes)
recipientSecret <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.secretKey (leftPadTo 32 recipientSecretRaw)
ephPub <-
either fail pure .
first show . CE.eitherCryptoError $
C25519.publicKey ephBytes
let sharedSecret = BA.convert (C25519.dh ephPub recipientSecret) :: B.ByteString
kek9580 = deriveX25519Kek ephBytes recipientPublicRaw sharedSecret
-- RFC9580 interpretation: eskBytes = algo_byte || AES-KW(raw_session_key)
rfc9580Result = do
(sessionAlgorithm, wrappedKey) <- parsePKESKv3X25519EskBytes eskBytes
rawKey <- aesKeyUnwrapRFC3394 AES128 kek9580 wrappedKey
expectedLen <- symmetricKeyLength sessionAlgorithm
when (B.length rawKey /= expectedLen) $
Left
("X25519 PKESKv3 unwrapped session key length mismatch for " ++
show sessionAlgorithm ++
": expected " ++ show expectedLen ++ ", got " ++ show (B.length rawKey))
Right
(B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <>
rawKey <>
checksum16Bytes rawKey)
case rfc9580Result of
Right result -> pure result
Left rfc9580Err ->
-- Fallback: legacy ECDH interpretation where the full eskBytes is
-- AES-KW(algo || key || checksum || padding). Try with the RFC9580
-- X25519 KEK and, when available, the RFC6637 ECDH KEK derived from
-- any ECDH parameters on the recipient public key.
let kekPairs = (kek9580, AES128) : x25519LegacyECDHKekCandidates recipientPKP sharedSecret
wrapped = LegacyECDHWrappedRFC3394Ciphertext eskBytes
candidates = candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped
validResults =
[ encodeLegacyECDHSessionMaterial material
| (kek, kekSA) <- kekPairs
, candidate <- candidates
, Right decoded <-
[aesKeyUnwrapRFC3394 kekSA kek (unLegacyECDHWrappedRFC3394Ciphertext candidate)]
, Right material <- [parseLegacyECDHDecodedSessionMaterial decoded]
]
in case validResults of
(result:_) -> pure result
[] ->
fail
("X25519 PKESKv3 unwrap failed (RFC9580: " ++
rfc9580Err ++
"; legacy ECDH-style fallback also failed)")
-- | Derive RFC6637 ECDH KEK candidates for legacy X25519 PKESKv3 fallback.
-- Returns @(kek, kekAlgorithm)@ pairs for each plausible ECDH KDF
-- parameterisation found on the recipient public key.
x25519LegacyECDHKekCandidates ::
SomePKPayload
-> B.ByteString
-> [(B.ByteString, SymmetricAlgorithm)]
x25519LegacyECDHKekCandidates pkPayload sharedSecret =
case _pubkey pkPayload of
ECDHPubKey ecdhPub kdfHA kdfSA ->
[ (kek, kdfSA)
| Right param <- [buildECDHKDFParam pkPayload X25519 ecdhPub kdfHA kdfSA]
, Right kek <- [deriveECDHKek kdfHA kdfSA sharedSecret param]
]
_ -> []
rsaModulusBytes :: RSATypes.PrivateKey -> Int
rsaModulusBytes (RSATypes.PrivateKey (RSATypes.PublicKey sizeField _ _) _ _ _ _ _ _) =
if sizeField > 512
then (sizeField + 7) `div` 8
else sizeField
edPointBytes :: EdPoint -> B.ByteString
edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x
edPointBytes (NativeEPoint (EPoint x)) = i2osp x
parseECDHPKESKMPIs :: NonEmpty MPI -> Either String (B.ByteString, B.ByteString)
parseECDHPKESKMPIs (ephemeralMPI :| [wrappedMPI]) =
Right (i2osp (unMPI ephemeralMPI), i2osp (unMPI wrappedMPI))
parseECDHPKESKMPIs _ =
Left "ECDH PKESK must contain exactly two MPIs (ephemeral key, wrapped session key)"
newtype LegacyECDHWrappedRFC3394Ciphertext =
LegacyECDHWrappedRFC3394Ciphertext
{ unLegacyECDHWrappedRFC3394Ciphertext :: B.ByteString
}
deriving (Eq)
newtype LegacyECDHSessionKey = LegacyECDHSessionKey { unLegacyECDHSessionKey :: B.ByteString }
newtype LegacyECDHSessionPadding = LegacyECDHSessionPadding { unLegacyECDHSessionPadding :: B.ByteString }
data LegacyECDHDecodedSessionMaterial =
LegacyECDHDecodedSessionMaterial
{ legacyECDHSessionAlgorithm :: SymmetricAlgorithm
, legacyECDHSessionKey :: LegacyECDHSessionKey
, legacyECDHSessionPadding :: LegacyECDHSessionPadding
}
candidateWrappedRFC3394CiphertextsForLegacyECDH ::
LegacyECDHWrappedRFC3394Ciphertext -> [LegacyECDHWrappedRFC3394Ciphertext]
candidateWrappedRFC3394CiphertextsForLegacyECDH wrapped =
let observedLen = B.length (unLegacyECDHWrappedRFC3394Ciphertext wrapped)
plausibleWrappedLens = legacyECDHRFC3394WrappedLengths
reconstructed =
[ LegacyECDHWrappedRFC3394Ciphertext
(if observedLen == targetLen
then unLegacyECDHWrappedRFC3394Ciphertext wrapped
else leftPadTo targetLen (unLegacyECDHWrappedRFC3394Ciphertext wrapped))
| targetLen <- plausibleWrappedLens
, targetLen >= observedLen
]
in nub (wrapped : reconstructed)
legacyECDHRFC3394WrappedLengths :: [Int]
legacyECDHRFC3394WrappedLengths =
map legacyRFC3394WrappedLenForKeyLen [16, 24, 32]
where
legacyRFC3394WrappedLenForKeyLen keyLen =
let encodedLen = 1 + keyLen + 2
paddedLen = ((encodedLen + 7) `div` 8) * 8
in paddedLen + 8
parseLegacyECDHDecodedSessionMaterial ::
B.ByteString -> Either String LegacyECDHDecodedSessionMaterial
parseLegacyECDHDecodedSessionMaterial decoded = do
when (B.length decoded < 3) $
Left "legacy ECDH decoded session material is too short"
let sessionAlgorithm = toFVal (B.head decoded)
sessionKeyLen <- symmetricKeyLength sessionAlgorithm
let payload = B.tail decoded
when (B.length payload < sessionKeyLen + 2) $
Left "legacy ECDH decoded session material does not contain full key and checksum"
let (sessionKey, checksumAndPad) = B.splitAt sessionKeyLen payload
(checksumBytes, padBytes) = B.splitAt 2 checksumAndPad
expectedChecksum =
fromIntegral (B.index checksumBytes 0) `shiftL` 8 +
fromIntegral (B.index checksumBytes 1)
actualChecksum = checksum16 sessionKey
when (actualChecksum /= expectedChecksum) $
Left "legacy ECDH decoded session-key checksum mismatch"
if B.null padBytes || B.all (== 0) padBytes
then
Right
(LegacyECDHDecodedSessionMaterial
sessionAlgorithm
(LegacyECDHSessionKey sessionKey)
(LegacyECDHSessionPadding padBytes))
else do
validatePKCS7Padding padBytes
Right
(LegacyECDHDecodedSessionMaterial
sessionAlgorithm
(LegacyECDHSessionKey sessionKey)
(LegacyECDHSessionPadding padBytes))
encodeLegacyECDHSessionMaterial :: LegacyECDHDecodedSessionMaterial -> B.ByteString
encodeLegacyECDHSessionMaterial
(LegacyECDHDecodedSessionMaterial sessionAlgorithm (LegacyECDHSessionKey sessionKey) _) =
B.singleton (fromIntegral (fromFVal sessionAlgorithm)) <>
sessionKey <>
checksum16Bytes sessionKey
parsePKESKv6ECDHEsk :: PubKeyAlgorithm -> B.ByteString -> Either String (B.ByteString, B.ByteString)
parsePKESKv6ECDHEsk pka esk
| pka == X25519 =
case parseFixedEphemeralWithWrappedLen 32 esk of
Right parsed -> Right parsed
Left _ -> parseLenPrefixedEphemeral 32 esk
| pka == X448 =
case parseFixedEphemeralWithWrappedLen 56 esk of
Right parsed -> Right parsed
Left _ -> parseLenPrefixedEphemeral 56 esk
| B.length esk < 33 =
Left "PKESKv6 ECDH ESK is too short"
| otherwise =
let withLen =
let ephLen = fromIntegral (B.head esk)
rest = B.tail esk
in if ephLen > 0 && B.length rest > ephLen
then
let (eph, wrapped) = B.splitAt ephLen rest
in if validWrappedPayload wrapped
then Just (eph, wrapped)
else Nothing
else Nothing
fixed32WithWrappedLen = parseFixedEphemeralWithWrappedLenMaybe 32 esk
fixed32 =
let (eph, wrapped) = B.splitAt 32 esk
in if validWrappedPayload wrapped
then Just (eph, wrapped)
else Nothing
mpiWithWrappedLen =
if B.length esk >= 4
then
let mpiBits = fromIntegral (B.index esk 0) `shiftL` 8 + fromIntegral (B.index esk 1)
mpiLen = (mpiBits + 7) `div` 8
rest = B.drop (2 + mpiLen) esk
in if mpiLen > 0 && B.length esk > 2 + mpiLen && not (B.null rest)
then
let eph = B.take mpiLen (B.drop 2 esk)
wrappedLen = fromIntegral (B.head rest)
wrapped = B.tail rest
in if wrappedLen == B.length wrapped && validWrappedPayload wrapped
then Just (eph, wrapped)
else Nothing
else Nothing
else Nothing
in case fixed32WithWrappedLen <|> withLen <|> fixed32 <|> mpiWithWrappedLen of
Just x -> Right x
Nothing ->
Left
"PKESKv6 ECDH ESK could not be parsed as {ephemeral32||len||wrapped}, {len||ephemeral||wrapped}, {ephemeral32||wrapped}, or {mpi(ephemeral)||len||wrapped}"
where
validWrappedPayload wrapped = B.length wrapped >= 24 && B.length wrapped `mod` 8 == 0
parseFixedEphemeralWithWrappedLenMaybe ephLen payload =
let (eph, rest) = B.splitAt ephLen payload
in if B.length rest >= 2
then
let wrappedLen = fromIntegral (B.head rest)
wrapped = B.tail rest
in if wrappedLen == B.length wrapped && validWrappedPayload wrapped
then Just (eph, wrapped)
else Nothing
else Nothing
parseFixedEphemeralWithWrappedLen ephLen payload =
maybe
(Left
("PKESKv6 XDH ESK expected {ephemeral" ++
show ephLen ++ "||len||wrapped} framing"))
Right
(parseFixedEphemeralWithWrappedLenMaybe ephLen payload)
parseLenPrefixedEphemeral expectedLen payload =
if B.null payload
then Left "PKESKv6 XDH ESK is empty"
else
let ephLen = fromIntegral (B.head payload)
rest = B.tail payload
in if ephLen == expectedLen && B.length rest > ephLen
then
let (eph, wrapped) = B.splitAt ephLen rest
in if validWrappedPayload wrapped
then Right (eph, wrapped)
else Left "PKESKv6 XDH ESK wrapped payload has invalid length"
else
Left
("PKESKv6 XDH ESK expected " ++
show expectedLen ++ "-octet ephemeral value")
normalizeX25519EphemeralPublic :: B.ByteString -> Either String B.ByteString
normalizeX25519EphemeralPublic =
normalizeMontgomeryPublic
32
"invalid X25519 ephemeral public key length/prefix: "
normalizeX448EphemeralPublic :: B.ByteString -> Either String B.ByteString
normalizeX448EphemeralPublic =
normalizeMontgomeryPublic
56
"invalid X448 ephemeral public key length/prefix: "
parseUncompressedPointForCurve :: MonadFail m => ECCT.Curve -> B.ByteString -> m ECCT.Point
parseUncompressedPointForCurve curve bs
| B.length bs < 1 = fail "ECDH ephemeral point is empty"
| Just expectedLen <- expectedUncompressedPointLength curve
, B.length bs /= expectedLen =
fail
("ECDH ephemeral point has invalid length for recipient curve: expected " ++
show expectedLen ++ ", got " ++ show (B.length bs))
| B.head bs /= 0x04 = fail "ECDH ephemeral point must be uncompressed (0x04)"
| otherwise =
let xy = B.tail bs
in if odd (B.length xy)
then fail "ECDH ephemeral point has malformed coordinate length"
else
let (xb, yb) = B.splitAt (B.length xy `div` 2) xy
in pure (ECCT.Point (os2ip xb) (os2ip yb))
expectedUncompressedPointLength :: ECCT.Curve -> Maybe Int
expectedUncompressedPointLength curve
| curve == ECCT.getCurveByName ECCT.SEC_p256r1 = Just 65
| curve == ECCT.getCurveByName ECCT.SEC_p384r1 = Just 97
| curve == ECCT.getCurveByName ECCT.SEC_p521r1 = Just 133
| otherwise = Nothing
deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX25519Kek ephemeralPublic recipientPublic sharedSecret =
let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
prk = extract @CHA.SHA256 B.empty ikm
info :: B.ByteString
info = "OpenPGP X25519"
okm :: B.ByteString
okm = expand @CHA.SHA256 prk info 16
in okm
deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX448Kek ephemeralPublic recipientPublic sharedSecret =
let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
prk = extract @CHA.SHA512 B.empty ikm
info :: B.ByteString
info = "OpenPGP X448"
okm :: B.ByteString
okm = expand @CHA.SHA512 prk info 32
in okm
aesKeyUnwrapRFC3394 ::
SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString
aesKeyUnwrapRFC3394 sa kek wrapped =
withAESCipher "ECDH PKESK currently supports AES KEK algorithms only" sa kek unwrapWithCipher
where
unwrapWithCipher ::
CCT.BlockCipher cipher
=> cipher
-> Either String B.ByteString
unwrapWithCipher cipher = do
when (B.length wrapped < 24 || B.length wrapped `mod` 8 /= 0) $
Left "ECDH wrapped session key must be at least 24 octets and a multiple of 8"
let (a0, rBytes) = B.splitAt 8 wrapped
rs = chunksOf8 rBytes
when (length rs < 2) $
Left "ECDH wrapped session key must contain at least two 64-bit blocks"
(aFinal, rFinal) <- unwrapRounds cipher a0 rs
when (aFinal /= B.replicate 8 0xA6) $
Left "ECDH wrapped session key integrity check failed"
Right (B.concat rFinal)
unwrapRounds ::
CCT.BlockCipher cipher
=> cipher
-> B.ByteString
-> [B.ByteString]
-> Either String (B.ByteString, [B.ByteString])
unwrapRounds cipher aInit rsInit = goJ 5 aInit rsInit
where
n = length rsInit
goJ j aState rsState
| j < 0 = Right (aState, rsState)
| otherwise = do
(a', rs') <- goI n aState rsState
goJ (j - 1) a' rs'
where
goI i aCurrent rsCurrent
| i <= 0 = Right (aCurrent, rsCurrent)
| otherwise = do
let t = fromIntegral (n * j + i) :: Word64
aXorT = xorBS aCurrent (encodeWord64be t)
rI = rsCurrent !! (i - 1)
block = CCT.ecbDecrypt cipher (aXorT <> rI)
(aNext, rNext) = B.splitAt 8 block
rsNext = (ix (i - 1) .~ rNext) rsCurrent
goI (i - 1) aNext rsNext
chunksOf8 :: B.ByteString -> [B.ByteString]
chunksOf8 bs
| B.null bs = []
| otherwise =
let (h, t) = B.splitAt 8 bs
in h : chunksOf8 t
xorBS :: B.ByteString -> B.ByteString -> B.ByteString
xorBS a b = B.pack (B.zipWith xor a b)
decodePKESKSessionKey ::
Maybe SymmetricAlgorithm
-> B.ByteString
-> Either String (SymmetricAlgorithm, B.ByteString)
decodePKESKSessionKey expectedSymAlgo encodedSessionKey =
case decodeOpenPGPEncodedSessionKey encodedSessionKey of
Right (symalgo, sessionKey) ->
case expectedSymAlgo of
Just expected | expected /= symalgo ->
Left "Decrypted PKESK symmetric algorithm does not match payload"
_ -> Right (symalgo, sessionKey)
Left decodeErr ->
case expectedSymAlgo of
Nothing ->
Left
("PKESK session key material must be OpenPGP encoded when payload algorithm is unknown: " ++
renderEncodedSessionKeyError decodeErr)
Just expected -> do
expectedLen <- symmetricKeyLength expected
case decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey of
Left err -> Left err
Right sessionKey -> Right (expected, sessionKey)
parsePKESKv3X25519EskBytes ::
B.ByteString -> Either String (SymmetricAlgorithm, B.ByteString)
parsePKESKv3X25519EskBytes eskBytes = do
when (B.length eskBytes < 2) $
Left "PKESKv3 X25519 ESK field is too short"
let sessionAlgorithm = toFVal (B.head eskBytes)
wrappedSessionKeyBytes = B.tail eskBytes
when (sessionAlgorithm `notElem` [AES128, AES192, AES256]) $
Left "PKESKv3 X25519 ESK field uses unsupported symmetric algorithm"
when (B.length wrappedSessionKeyBytes < 24 || B.length wrappedSessionKeyBytes `mod` 8 /= 0) $
Left "PKESKv3 X25519 wrapped session key must be at least 24 octets and a multiple of 8"
pure (sessionAlgorithm, wrappedSessionKeyBytes)
decodeExpectedRawOrPaddedSessionKey ::
SymmetricAlgorithm -> Int -> B.ByteString -> Either String B.ByteString
decodeExpectedRawOrPaddedSessionKey expected expectedLen encodedSessionKey
| B.length encodedSessionKey == expectedLen = Right encodedSessionKey
| otherwise =
case decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey of
Right sessionKey -> Right sessionKey
Left _ ->
case decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey of
Right sessionKey -> Right sessionKey
Left _ ->
Left "PKESK raw session key length does not match payload algorithm"
decodeV6PaddedSessionKeyWithoutAlgo :: Int -> B.ByteString -> Either String B.ByteString
decodeV6PaddedSessionKeyWithoutAlgo expectedLen encodedSessionKey = do
when (B.length encodedSessionKey < expectedLen + 2) $
Left "v6 ECDH decoded session material is too short"
let (sessionKey, rest) = B.splitAt expectedLen encodedSessionKey
(checksumBytes, padBytes) = B.splitAt 2 rest
expectedChecksum =
fromIntegral (B.index checksumBytes 0) `shiftL` 8 +
fromIntegral (B.index checksumBytes 1)
actualChecksum = checksum16 sessionKey
when (actualChecksum /= expectedChecksum) $
Left "v6 ECDH decoded session-key checksum mismatch"
validatePKCS7Padding padBytes
Right sessionKey
decodeV6PaddedSessionKeyWithAlgo ::
SymmetricAlgorithm -> Int -> B.ByteString -> Either String B.ByteString
decodeV6PaddedSessionKeyWithAlgo expected expectedLen encodedSessionKey = do
when (B.length encodedSessionKey < expectedLen + 3) $
Left "v6 ECDH decoded session material with algorithm octet is too short"
let algOctet = B.head encodedSessionKey
when (toFVal algOctet /= expected) $
Left "v6 ECDH decoded session material algorithm mismatch"
let rest = B.tail encodedSessionKey
(sessionKey, checksumAndPad) = B.splitAt expectedLen rest
(checksumBytes, padBytes) = B.splitAt 2 checksumAndPad
expectedChecksum =
fromIntegral (B.index checksumBytes 0) `shiftL` 8 +
fromIntegral (B.index checksumBytes 1)
actualChecksum = checksum16 sessionKey
when (actualChecksum /= expectedChecksum) $
Left "v6 ECDH decoded session-key checksum mismatch"
validatePKCS7Padding padBytes
Right sessionKey
validatePKCS7Padding :: B.ByteString -> Either String ()
validatePKCS7Padding padBytes
| B.null padBytes = Right ()
| otherwise = do
let padLen = fromIntegral (B.last padBytes) :: Int
when (padLen <= 0 || padLen > 8 || B.length padBytes /= padLen) $
Left "v6 ECDH decoded session material has invalid PKCS#7-style padding length"
when (B.any (/= fromIntegral padLen) padBytes) $
Left "v6 ECDH decoded session material has invalid PKCS#7-style padding bytes"
symmetricKeyLength :: SymmetricAlgorithm -> Either String Int
symmetricKeyLength = first renderCipherError . keySize
checksum16 :: B.ByteString -> Word16
checksum16 =
fromIntegral .
B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0
checksum16Bytes :: B.ByteString -> B.ByteString
checksum16Bytes sessionKey =
B.pack [fromIntegral (chk `shiftR` 8), fromIntegral chk]
where
chk = checksum16 sessionKey