hOpenPGP-3.0.0: Codec/Encryption/OpenPGP/Encrypt.hs
-- Encrypt.hs: OpenPGP (RFC9580) packet-level encryption helpers
-- Copyright © 2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeApplications #-}
module Codec.Encryption.OpenPGP.Encrypt
( PKESKEncryptError(..)
, RecipientCapabilityNegotiationMode(..)
, RecipientCapabilityError(..)
, renderRecipientCapabilityError
, RecipientCapabilities(..)
, recipientCapabilitiesFromSubpacketPayloads
, recipientCapabilitySupportsEncryption
, RecipientTargetRejectionReason(..)
, RecipientEncryptionTargetRejected(..)
, RecipientEncryptionTargetsReport(..)
, recipientEncryptionTargetsReportFromTKAtTimestamp
, recipientEncryptionTargetsReportFromTK
, recipientEncryptionTargetFromTKAtTimestamp
, recipientEncryptionTargetsFromTKAtTimestamp
, recipientEncryptionTargetFromTK
, recipientEncryptionTargetsFromTK
, PKESKVersionPolicy(..)
, RecipientPKESKVersionStrategy(..)
, RecipientPKESKVersionStrategyW(..)
, SomeRecipientPKESKVersionStrategyW(..)
, RecipientPKESKVersionSelector
, RecipientPKESKVersionSelectorTyped
, EncryptCompatibilityProfile(..)
, EncryptCompatibilityProfileW(..)
, SomeEncryptCompatibilityProfileW(..)
, RecipientEncryptionTarget(..)
, recipientEncryptionTarget
, recipientEncryptionTargetWithStrategy
, recipientEncryptionTargetWithCapabilities
, recipientEncryptionTargetWithStrategyTyped
, recipientVersionStrategyForProfile
, recipientVersionStrategyForProfileTyped
, RecipientPayloadShape(..)
, defaultRecipientPayloadShape
, SEIPDVersion(..)
, RecipientEncryptResult(..)
, RecipientEncryptRequest(..)
, RecipientEncryptRequestOverrides(..)
, encryptForRecipients
, encryptForRecipientsLegacy
, encryptForRecipientsWithCapabilityNegotiation
, PKESKV3SessionMaterial
, PKESKV6RawSessionMaterial
, PKESKSessionMaterial
, pkeskSessionAlgorithm
, pkeskSessionKey
, mkPKESKSessionMaterial
, mkPKESKV3SessionMaterial
, mkPKESKV6RawSessionMaterial
, pkeskV3SessionMaterial
, pkeskV6RawSessionMaterial
, encodeOpenPGPSessionMaterial
, generateSessionKeyMaterial
, canonicalizePKESKRecipientId
, canonicalizePKESKPacketRecipientIds
, buildPKESKv3PayloadForRecipient
, buildPKESKv3PktForRecipient
, buildPKESKPayloadForRecipient
, buildPKESKPktForRecipient
, buildPKESKPktsForRecipientTargetsWithSelector
, buildPKESKPktsForRecipientTargetsWithSelectorTyped
, encryptSEIPDv2Payload
, encryptSEIPDv1Payload
, encryptSEIPDv2WithSKESK
, encryptSEIPDv2WithSKESKBlock
, encryptSEIPDv2LiteralDataWithSKESK
, composeMessageWithSEIPDv2
) where
import Codec.Encryption.OpenPGP.BlockCipher (CipherError, renderCipherError, keySize, withSymmetricCipher)
import Codec.Encryption.OpenPGP.CFB
( OpenPGPCFBModeW(..)
, encryptOpenPGPCfbRaw
, mdcTrailerForSEIPDv1
)
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher (HOBlockCipher(..))
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Internal (leftPadTo, point2MBS)
import Codec.Encryption.OpenPGP.Internal.CryptoAES (withAESCipher)
import Codec.Encryption.OpenPGP.Internal.CryptoECDH
( normalizeMontgomeryPublic
, buildECDHKDFParam
, deriveECDHKek
)
import Codec.Encryption.OpenPGP.Internal.CryptoSEIPDv2
( aeadModeAndNonceSizeForSEIPDv2
, deriveSKESK6KEK
, encryptSKESK6SessionKey
, seipdv2SymmetricKeySize
)
import Codec.Encryption.OpenPGP.Policy
( PKESKVersionPolicy(..)
, OpenPGPRFC(..)
, MessageEncryptionPolicy
, policyForRFC
, policyMessageEncryption
, messageDefaultSymmetricAlgorithm
, messageSEIPDv2SymmetricAlgorithms
, messageDefaultAEADAlgorithm
, messageDefaultChunkSize
, defaultPKESKVersionPolicy
)
import Codec.Encryption.OpenPGP.Expirations
( effectiveKeyPreferencesAtTimestamp
, isPKTimeValidWithSelfSignatures
, keyStateAt
, keyStateValid
, signatureEffectiveAt
)
import Codec.Encryption.OpenPGP.Ontology (isSubkeyBindingSig, isSubkeyRevocation)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT, signatureHashedSubpacketsKnown)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes
import Codec.Encryption.OpenPGP.Internal.RFC7253OCB (encryptWithOCBRFC7253)
import Control.Lens ((.~), ix)
import Control.Monad (when)
import Data.List (find, foldl', maximumBy)
import Data.Maybe (fromMaybe, mapMaybe)
import Data.Ord (comparing)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import qualified "crypton" Crypto.Cipher.Types as CCT
import qualified Crypto.Error as CE
import qualified Crypto.Hash.Algorithms as CHAlg
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.Generate as ECCGen
import qualified Crypto.PubKey.RSA.PKCS15 as RSA15
import Crypto.Random.Types (MonadRandom, getRandomBytes)
import Data.Binary (put)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Bits ((.&.), shiftL, shiftR, xor)
import Data.Binary.Put (putWord64be, runPut)
import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.Set as Set
import Data.Word (Word8, Word16, Word64)
import Data.Int (Int64)
-- | Typed failures from one-pass signature packet construction.
data OPSBuildError
= OPSBuildMissingIssuerKeyId
| OPSBuildMissingIssuerFingerprint
| OPSBuildFingerprintWrongLength Int64
| OPSBuildUnsupportedSigVersion PacketVersion
deriving (Eq, Show)
renderOPSBuildError :: OPSBuildError -> String
renderOPSBuildError OPSBuildMissingIssuerKeyId =
"cannot build OPS3 packet from v4 signature without issuer metadata"
renderOPSBuildError OPSBuildMissingIssuerFingerprint =
"cannot build OPS6 packet from v6 signature without issuer fingerprint"
renderOPSBuildError (OPSBuildFingerprintWrongLength n) =
"cannot build OPS6 packet: issuer fingerprint must be 32 octets, got " ++ show n
renderOPSBuildError (OPSBuildUnsupportedSigVersion v) =
"cannot build one-pass signature packet for unsupported signature version " ++ show v
-- | Typed failures surfaced by encrypt-side PKESK and SEIPD-v2 helpers.
data PKESKEncryptError
= UnsupportedSessionKeyAlgorithm SymmetricAlgorithm String
| InvalidSessionKeyLength SymmetricAlgorithm Int Int
| InvalidRecipientIdentifier String
| UnsupportedRecipientAlgorithm PubKeyAlgorithm
| InvalidRecipientKeyMaterial PubKeyAlgorithm String
| RecipientKdfFailure PubKeyAlgorithm String
| RecipientKeyWrapFailure PubKeyAlgorithm String
| RecipientCapabilitySelectionFailure RecipientCapabilityError
| PayloadBuildFailure String
| NoRecipientsProvided
deriving (Eq, Show)
renderPKESKEncryptError :: PKESKEncryptError -> String
renderPKESKEncryptError (UnsupportedSessionKeyAlgorithm algo reason) =
"unsupported session key algorithm " ++ show algo ++ ": " ++ reason
renderPKESKEncryptError (InvalidSessionKeyLength algo expected actual) =
"invalid session key length for " ++ show algo ++ ": expected " ++ show expected ++ ", got " ++ show actual
renderPKESKEncryptError (InvalidRecipientIdentifier reason) =
"invalid recipient identifier: " ++ reason
renderPKESKEncryptError (UnsupportedRecipientAlgorithm algo) =
"unsupported recipient public-key algorithm: " ++ show algo
renderPKESKEncryptError (InvalidRecipientKeyMaterial algo reason) =
"invalid recipient key material for " ++ show algo ++ ": " ++ reason
renderPKESKEncryptError (RecipientKdfFailure algo reason) =
"KDF failure for recipient algorithm " ++ show algo ++ ": " ++ reason
renderPKESKEncryptError (RecipientKeyWrapFailure algo reason) =
"key wrap failure for recipient algorithm " ++ show algo ++ ": " ++ reason
renderPKESKEncryptError (RecipientCapabilitySelectionFailure err) =
renderRecipientCapabilityError err
renderPKESKEncryptError (PayloadBuildFailure reason) =
"payload build failure: " ++ reason
renderPKESKEncryptError NoRecipientsProvided =
"no recipients provided"
data RecipientCapabilityNegotiationMode
= RecipientCapabilityNegotiationOff
| RecipientCapabilityNegotiationOn
deriving (Eq, Show)
data RecipientCapabilityError
= RecipientCapabilityMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag)
| RecipientCapabilityNoEncryptableKeyMaterialInTK
| RecipientCapabilityMissingSEIPDv1Support [SomePKPayload]
| RecipientCapabilityMissingSEIPDv2Support [SomePKPayload]
| RecipientCapabilityNoCommonSymmetricAlgorithms [SymmetricAlgorithm]
| RecipientCapabilityNoCommonAEADAlgorithms [AEADAlgorithm]
deriving (Eq, Show)
renderRecipientCapabilityError :: RecipientCapabilityError -> String
renderRecipientCapabilityError (RecipientCapabilityMissingEncryptionFlags recipient flags) =
"recipient " ++ show (_keyVersion recipient, _pkalgo recipient) ++
" does not advertise encryption-capable key flags; observed flags: " ++
show (Set.toList flags)
renderRecipientCapabilityError RecipientCapabilityNoEncryptableKeyMaterialInTK =
"no encryption-capable primary key or subkey was found in transferable key material"
renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv1Support recipients) =
"recipient set does not advertise SEIPDv1 (MDC) support: " ++
show (map (\r -> (_keyVersion r, _pkalgo r)) recipients)
renderRecipientCapabilityError (RecipientCapabilityMissingSEIPDv2Support recipients) =
"recipient set does not advertise SEIPDv2 support: " ++
show (map (\r -> (_keyVersion r, _pkalgo r)) recipients)
renderRecipientCapabilityError (RecipientCapabilityNoCommonSymmetricAlgorithms syms) =
"no common recipient-supported symmetric algorithms: " ++ show syms
renderRecipientCapabilityError (RecipientCapabilityNoCommonAEADAlgorithms aeads) =
"no common recipient-supported AEAD algorithms: " ++ show aeads
data RecipientCapabilities =
RecipientCapabilities
{ recipientCapabilityKeyVersion :: KeyVersion
, recipientCapabilityPublicKeyAlgorithm :: PubKeyAlgorithm
, recipientCapabilityKeyFlags :: Set.Set KeyFlag
, recipientCapabilityFeatures :: Set.Set FeatureFlag
, recipientCapabilityPreferredSymmetricAlgorithms :: [SymmetricAlgorithm]
, recipientCapabilityPreferredAEADAlgorithms :: [AEADAlgorithm]
}
deriving (Eq, Show)
data RecipientTargetRejectionReason
= RecipientTargetUnsupportedAlgorithm PubKeyAlgorithm
| RecipientTargetMissingEncryptionFlags SomePKPayload (Set.Set KeyFlag)
| RecipientTargetRevoked SomePKPayload
| RecipientTargetNotValidAtTimestamp SomePKPayload ThirtyTwoBitTimeStamp
deriving (Eq, Show)
data RecipientEncryptionTargetRejected =
RecipientEncryptionTargetRejected
{ recipientEncryptionTargetRejectedKey :: SomePKPayload
, recipientEncryptionTargetRejectedCapabilities :: Maybe RecipientCapabilities
, recipientEncryptionTargetRejectedReason :: RecipientTargetRejectionReason
}
deriving (Eq, Show)
data RecipientEncryptionTargetsReport =
RecipientEncryptionTargetsReport
{ recipientEncryptionTargetsAccepted :: [RecipientEncryptionTarget]
, recipientEncryptionTargetsRejected :: [RecipientEncryptionTargetRejected]
}
deriving (Eq, Show)
-- | Extract encrypt-relevant recipient capabilities from effective
-- self-signature subpackets.
--
-- RFC 9580 preferred AEAD ciphersuites are currently carried through
-- 'OtherSigSub' type 39 and decoded into AEAD preferences here.
recipientCapabilitiesFromSubpacketPayloads ::
SomePKPayload
-> [SigSubPacketPayload]
-> RecipientCapabilities
recipientCapabilitiesFromSubpacketPayloads recipient payloads =
foldl' step (emptyRecipientCapabilities recipient) payloads
where
preferredAEADCiphersuitesSubpacketType :: Word8
preferredAEADCiphersuitesSubpacketType = 39
step caps payload =
case payload of
KeyFlags flags ->
caps
{ recipientCapabilityKeyFlags =
recipientCapabilityKeyFlags caps `Set.union` flags
}
Features features ->
caps
{ recipientCapabilityFeatures =
recipientCapabilityFeatures caps `Set.union` features
}
PreferredSymmetricAlgorithms syms ->
caps
{ recipientCapabilityPreferredSymmetricAlgorithms =
recipientCapabilityPreferredSymmetricAlgorithms caps ++ syms
}
OtherSigSub subpacketType rawPayload
| subpacketType == preferredAEADCiphersuitesSubpacketType ->
caps
{ recipientCapabilityPreferredAEADAlgorithms =
recipientCapabilityPreferredAEADAlgorithms caps ++
preferredAEADAlgorithmsFromCiphersuites rawPayload
}
_ -> caps
emptyRecipientCapabilities key =
RecipientCapabilities
{ recipientCapabilityKeyVersion = _keyVersion key
, recipientCapabilityPublicKeyAlgorithm = _pkalgo key
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms = []
, recipientCapabilityPreferredAEADAlgorithms = []
}
preferredAEADAlgorithmsFromCiphersuites :: BL.ByteString -> [AEADAlgorithm]
preferredAEADAlgorithmsFromCiphersuites =
dedupePreservingOrder . parsePairs . BL.unpack
where
parsePairs (_symAlgo:aeadAlgo:rest) =
(toFVal aeadAlgo :: AEADAlgorithm) : parsePairs rest
parsePairs _ = []
dedupePreservingOrder = foldl' addIfMissing []
addIfMissing acc x
| x `elem` acc = acc
| otherwise = acc ++ [x]
recipientCapabilitySupportsEncryption :: RecipientCapabilities -> Bool
recipientCapabilitySupportsEncryption caps =
let flags = recipientCapabilityKeyFlags caps
in Set.null flags ||
Set.member EncryptStorageKey flags ||
Set.member EncryptCommunicationsKey flags
recipientCapabilityAdvertisesSEIPDv1Support :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv1Support caps =
let features = recipientCapabilityFeatures caps
in Set.null features || Set.member FeatureSEIPDv1 features
recipientCapabilityAdvertisesSEIPDv2Support :: RecipientCapabilities -> Bool
recipientCapabilityAdvertisesSEIPDv2Support caps =
recipientCapabilityAdvertisesSEIPDv1Support caps &&
Set.member FeatureSEIPDv2 (recipientCapabilityFeatures caps)
recipientEncryptionTargetFromTKAtTimestamp ::
ThirtyTwoBitTimeStamp
-> TKUnknown
-> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTKAtTimestamp timestamp tk =
case recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk) of
(target:_) -> Right target
[] -> Left RecipientCapabilityNoEncryptableKeyMaterialInTK
recipientEncryptionTargetFromTK :: TK 'PublicTK -> Either RecipientCapabilityError RecipientEncryptionTarget
recipientEncryptionTargetFromTK tk =
recipientEncryptionTargetFromTKAtTimestamp
(_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
(tkToUnknown tk)
recipientEncryptionTargetsFromTKAtTimestamp ::
ThirtyTwoBitTimeStamp
-> TKUnknown
-> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTKAtTimestamp timestamp tk =
recipientEncryptionTargetsAccepted (recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk)
recipientEncryptionTargetsReportFromTKAtTimestamp ::
ThirtyTwoBitTimeStamp
-> TKUnknown
-> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTKAtTimestamp timestamp tk =
foldr classifyCandidate emptyReport (subkeyCandidates ++ [primaryCandidate])
where
emptyReport = RecipientEncryptionTargetsReport [] []
primaryCandidate = fst (_tkuKey tk)
primaryPreferencePayloads =
fromMaybe [] (effectiveKeyPreferencesAtTimestamp timestamp tk)
subkeyCandidates =
mapMaybe
(\(pkt, _) ->
case pkt of
PublicSubkeyPkt pkp -> Just pkp
SecretSubkeyPkt pkp _ -> Just pkp
_ -> Nothing)
(_tkuSubs tk)
classifyCandidate key report =
let caps =
recipientCapabilitiesFromSubpacketPayloads
key
(primaryPreferencePayloads ++ subkeyBindingCapabilityPayloads timestamp tk key)
keyStateRejection = recipientValidityRejectionReason timestamp tk key
in case keyStateRejection of
Just rejectionReason ->
report
{ recipientEncryptionTargetsRejected =
RecipientEncryptionTargetRejected
{ recipientEncryptionTargetRejectedKey = key
, recipientEncryptionTargetRejectedCapabilities = Just caps
, recipientEncryptionTargetRejectedReason = rejectionReason
} :
recipientEncryptionTargetsRejected report
}
Nothing ->
if not (supportsPKESKRecipientAlgorithm key)
then
report
{ recipientEncryptionTargetsRejected =
RecipientEncryptionTargetRejected
{ recipientEncryptionTargetRejectedKey = key
, recipientEncryptionTargetRejectedCapabilities = Just caps
, recipientEncryptionTargetRejectedReason =
RecipientTargetUnsupportedAlgorithm (_pkalgo key)
} :
recipientEncryptionTargetsRejected report
}
else
if recipientCapabilitySupportsEncryption caps
then
report
{ recipientEncryptionTargetsAccepted =
recipientEncryptionTargetWithCapabilities key caps :
recipientEncryptionTargetsAccepted report
}
else
report
{ recipientEncryptionTargetsRejected =
RecipientEncryptionTargetRejected
{ recipientEncryptionTargetRejectedKey = key
, recipientEncryptionTargetRejectedCapabilities = Just caps
, recipientEncryptionTargetRejectedReason =
RecipientTargetMissingEncryptionFlags key (recipientCapabilityKeyFlags caps)
} :
recipientEncryptionTargetsRejected report
}
recipientEncryptionTargetsFromTK :: TK 'PublicTK -> [RecipientEncryptionTarget]
recipientEncryptionTargetsFromTK tk =
recipientEncryptionTargetsFromTKAtTimestamp
(_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
(tkToUnknown tk)
recipientEncryptionTargetsReportFromTK :: TK 'PublicTK -> RecipientEncryptionTargetsReport
recipientEncryptionTargetsReportFromTK tk =
recipientEncryptionTargetsReportFromTKAtTimestamp
(_timestamp (keyPktPKPayload (_tkPrimaryKey tk)))
(tkToUnknown tk)
subkeyBindingCapabilityPayloads ::
ThirtyTwoBitTimeStamp
-> TKUnknown
-> SomePKPayload
-> [SigSubPacketPayload]
subkeyBindingCapabilityPayloads timestamp tk recipient =
maybe [] latestEffectiveBindingPayloads matchingSubkey
where
matchingSubkey =
find
(\(pkt, _) ->
case pkt of
PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient
SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient
_ -> False)
(_tkuSubs tk)
latestEffectiveBindingPayloads (_, sigs) =
maybe [] signaturePayloadsFromSignature (latestEffectiveSubkeyBindingSignature timestamp sigs)
latestEffectiveSubkeyBindingSignature ::
ThirtyTwoBitTimeStamp
-> [SignaturePayload]
-> Maybe SignaturePayload
latestEffectiveSubkeyBindingSignature timestamp sigs =
case filter (isEffectiveSubkeyBindingSignature timestamp) sigs of
[] -> Nothing
candidates -> Just (maximumBy (comparing signatureCreationTimestamp) candidates)
isEffectiveSubkeyBindingSignature ::
ThirtyTwoBitTimeStamp
-> SignaturePayload
-> Bool
isEffectiveSubkeyBindingSignature timestamp sig =
isSubkeyBindingSig sig &&
maybe False
(\created ->
let tsValue = toInteger (unThirtyTwoBitTimeStamp timestamp)
createdValue = toInteger (unThirtyTwoBitTimeStamp created)
in createdValue <= tsValue &&
maybe True
(\duration ->
if unThirtyTwoBitDuration duration == 0
then True
else tsValue < createdValue + toInteger (unThirtyTwoBitDuration duration))
(signatureExpirationDuration sig))
(sigCT sig)
signatureCreationTimestamp :: SignaturePayload -> ThirtyTwoBitTimeStamp
signatureCreationTimestamp sig =
fromMaybe (ThirtyTwoBitTimeStamp 0) (sigCT sig)
signatureExpirationDuration :: SignaturePayload -> Maybe ThirtyTwoBitDuration
signatureExpirationDuration sig =
case signatureHashedSubpacketsKnown sig of
Just hashed ->
foldr
(\subpacket acc ->
case subpacket of
SigSubPacket _ (SigExpirationTime duration) -> Just duration
_ -> acc)
Nothing
hashed
Nothing -> Nothing
signaturePayloadsFromSignature :: SignaturePayload -> [SigSubPacketPayload]
signaturePayloadsFromSignature sig =
case signatureHashedSubpacketsKnown sig of
Just hashed -> map (\(SigSubPacket _ payload) -> payload) hashed
Nothing -> []
recipientValidityRejectionReason ::
ThirtyTwoBitTimeStamp
-> TKUnknown
-> SomePKPayload
-> Maybe RecipientTargetRejectionReason
recipientValidityRejectionReason timestamp tk key
| fingerprint key == fingerprint (fst (_tkuKey tk)) =
if keyStateValid (keyStateAt (timestampToUTC timestamp) tk)
then Nothing
else Just (RecipientTargetNotValidAtTimestamp key timestamp)
| otherwise =
case findMatchingSubkeySignatures tk key of
Nothing -> Nothing
Just sigs
| subkeyRevokedAtTimestamp timestamp sigs ->
Just (RecipientTargetRevoked key)
| isPKTimeValidWithSelfSignatures (timestampToUTC timestamp) key sigs ->
Nothing
| otherwise ->
Just (RecipientTargetNotValidAtTimestamp key timestamp)
findMatchingSubkeySignatures :: TKUnknown -> SomePKPayload -> Maybe [SignaturePayload]
findMatchingSubkeySignatures tk recipient =
snd <$>
find
(\(pkt, _) ->
case pkt of
PublicSubkeyPkt pkp -> fingerprint pkp == fingerprint recipient
SecretSubkeyPkt pkp _ -> fingerprint pkp == fingerprint recipient
_ -> False)
(_tkuSubs tk)
subkeyRevokedAtTimestamp :: ThirtyTwoBitTimeStamp -> [SignaturePayload] -> Bool
subkeyRevokedAtTimestamp timestamp =
any (\sig -> isSubkeyRevocation sig && signatureEffectiveAt (timestampToUTC timestamp) sig)
timestampToUTC :: ThirtyTwoBitTimeStamp -> UTCTime
timestampToUTC =
posixSecondsToUTCTime . realToFrac . unThirtyTwoBitTimeStamp
supportsPKESKRecipientAlgorithm :: SomePKPayload -> Bool
supportsPKESKRecipientAlgorithm recipient =
case _pkalgo recipient of
RSA -> True
DeprecatedRSAEncryptOnly -> True
ECDH -> True
X25519 -> True
X448 -> True
_ -> False
-- | Session-key bundle for PKESK/SKESK packet construction.
newtype PKESKV3SessionMaterial =
PKESKV3SessionMaterial
{ unPKESKV3SessionMaterial :: B.ByteString
}
deriving (Eq, Show)
newtype PKESKV6RawSessionMaterial =
PKESKV6RawSessionMaterial
{ unPKESKV6RawSessionMaterial :: B.ByteString
}
deriving (Eq, Show)
data PKESKSessionMaterial =
PKESKSessionMaterial
{ pkeskSessionAlgorithm :: SymmetricAlgorithm
, pkeskSessionKey :: SessionKey
, pkeskEncodedSessionMaterial :: B.ByteString
}
deriving (Eq, Show)
mkPKESKSessionMaterial ::
SymmetricAlgorithm
-> SessionKey
-> Either PKESKEncryptError PKESKSessionMaterial
mkPKESKSessionMaterial symalgo sessionKey = do
v3Material <- mkPKESKV3SessionMaterial symalgo sessionKey
_v6Material <- mkPKESKV6RawSessionMaterial symalgo sessionKey
pure
PKESKSessionMaterial
{ pkeskSessionAlgorithm = symalgo
, pkeskSessionKey = sessionKey
, pkeskEncodedSessionMaterial = unPKESKV3SessionMaterial v3Material
}
mkPKESKV3SessionMaterial ::
SymmetricAlgorithm
-> SessionKey
-> Either PKESKEncryptError PKESKV3SessionMaterial
mkPKESKV3SessionMaterial symalgo sessionKey = do
keyBytes <- validatedSessionKeyBytes symalgo sessionKey
pure $
PKESKV3SessionMaterial
(B.singleton (fromFVal symalgo) <> keyBytes <> checksum16Bytes keyBytes)
mkPKESKV6RawSessionMaterial ::
SymmetricAlgorithm
-> SessionKey
-> Either PKESKEncryptError PKESKV6RawSessionMaterial
mkPKESKV6RawSessionMaterial symalgo sessionKey =
PKESKV6RawSessionMaterial <$> validatedSessionKeyBytes symalgo sessionKey
pkeskV3SessionMaterial :: PKESKSessionMaterial -> PKESKV3SessionMaterial
pkeskV3SessionMaterial =
PKESKV3SessionMaterial . pkeskEncodedSessionMaterial
pkeskV6RawSessionMaterial :: PKESKSessionMaterial -> PKESKV6RawSessionMaterial
pkeskV6RawSessionMaterial =
PKESKV6RawSessionMaterial . unSessionKey . pkeskSessionKey
validatedSessionKeyBytes ::
SymmetricAlgorithm
-> SessionKey
-> Either PKESKEncryptError B.ByteString
validatedSessionKeyBytes symalgo (SessionKey sessionKey) = do
keyLen <-
first
(UnsupportedSessionKeyAlgorithm symalgo . renderCipherError)
(keySize symalgo)
let actualLen = B.length sessionKey
if actualLen /= keyLen
then Left (InvalidSessionKeyLength symalgo keyLen actualLen)
else Right sessionKey
data RecipientPKESKVersionStrategy
= RecipientPreferV6
| RecipientForceV3Interop
deriving (Eq, Show)
data RecipientPKESKVersionStrategyW (strategy :: RecipientPKESKVersionStrategy) where
RecipientPreferV6W :: RecipientPKESKVersionStrategyW 'RecipientPreferV6
RecipientForceV3InteropW :: RecipientPKESKVersionStrategyW 'RecipientForceV3Interop
data SomeRecipientPKESKVersionStrategyW where
SomeRecipientPKESKVersionStrategyW ::
RecipientPKESKVersionStrategyW strategy
-> SomeRecipientPKESKVersionStrategyW
type RecipientPKESKVersionSelector =
SomePKPayload -> Either PKESKEncryptError RecipientPKESKVersionStrategy
type RecipientPKESKVersionSelectorTyped =
SomePKPayload -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
data EncryptCompatibilityProfile
= EncryptStrictDefault
| EncryptInteropLegacy
deriving (Eq, Show)
data EncryptCompatibilityProfileW (profile :: EncryptCompatibilityProfile) where
EncryptStrictDefaultW :: EncryptCompatibilityProfileW 'EncryptStrictDefault
EncryptInteropLegacyW :: EncryptCompatibilityProfileW 'EncryptInteropLegacy
data SomeEncryptCompatibilityProfileW where
SomeEncryptCompatibilityProfileW ::
EncryptCompatibilityProfileW profile
-> SomeEncryptCompatibilityProfileW
data SEIPDVersion
= SEIPDv1
| SEIPDv2
deriving (Eq, Show)
type family PayloadVersionForProfile (profile :: EncryptCompatibilityProfile) :: SEIPDVersion where
PayloadVersionForProfile 'EncryptStrictDefault = 'SEIPDv2
PayloadVersionForProfile 'EncryptInteropLegacy = 'SEIPDv1
type family ProfileForPayloadVersion (version :: SEIPDVersion) :: EncryptCompatibilityProfile where
ProfileForPayloadVersion 'SEIPDv1 = 'EncryptInteropLegacy
ProfileForPayloadVersion 'SEIPDv2 = 'EncryptStrictDefault
data RecipientEncryptionTarget =
RecipientEncryptionTarget
{ -- | Recipient key packet selected for PKESK wrapping.
recipientEncryptionTargetKey :: SomePKPayload
-- | Optional explicit PKESK version strategy hint.
-- When absent, profile defaults and auto-detection apply.
, recipientEncryptionTargetStrategy :: Maybe RecipientPKESKVersionStrategy
-- | Optional recipient capability hints used by negotiation-enabled
-- encryption to choose common symmetric/AEAD algorithms.
, recipientEncryptionTargetCapabilities :: Maybe RecipientCapabilities
}
deriving (Eq, Show)
recipientEncryptionTarget :: SomePKPayload -> RecipientEncryptionTarget
recipientEncryptionTarget recipient =
RecipientEncryptionTarget recipient Nothing Nothing
recipientEncryptionTargetWithStrategy :: SomePKPayload -> RecipientPKESKVersionStrategy -> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategy recipient strategy =
RecipientEncryptionTarget recipient (Just strategy) Nothing
recipientEncryptionTargetWithCapabilities ::
SomePKPayload
-> RecipientCapabilities
-> RecipientEncryptionTarget
recipientEncryptionTargetWithCapabilities recipient capabilities =
RecipientEncryptionTarget recipient Nothing (Just capabilities)
recipientEncryptionTargetWithStrategyTyped :: SomePKPayload
-> RecipientPKESKVersionStrategyW strategy
-> RecipientEncryptionTarget
recipientEncryptionTargetWithStrategyTyped recipient strategyW =
recipientEncryptionTargetWithStrategy recipient (demoteRecipientStrategy strategyW)
recipientVersionStrategyForProfile ::
EncryptCompatibilityProfile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError RecipientPKESKVersionStrategy
recipientVersionStrategyForProfile profile target =
case promoteEncryptCompatibilityProfile profile of
SomeEncryptCompatibilityProfileW profileW ->
demoteSomeRecipientStrategy <$>
recipientVersionStrategyForProfileTyped profileW target
recipientVersionStrategyForProfileTyped ::
EncryptCompatibilityProfileW profile
-> RecipientEncryptionTarget
-> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW
recipientVersionStrategyForProfileTyped profile target =
Right $
case recipientEncryptionTargetStrategy target of
Just strategy ->
promoteRecipientStrategy strategy
Nothing ->
case profile of
EncryptStrictDefaultW ->
autoDetectRecipientVersionStrategy
(recipientEncryptionTargetKey target)
EncryptInteropLegacyW ->
SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW
profileForPayloadVersionW ::
RecipientEncryptRequestOverrides version
-> EncryptCompatibilityProfileW (ProfileForPayloadVersion version)
profileForPayloadVersionW overrides =
case overrides of
RecipientEncryptRequestSEIPDv2Overrides {} -> EncryptStrictDefaultW
RecipientEncryptRequestSEIPDv1Overrides {} -> EncryptInteropLegacyW
autoDetectRecipientVersionStrategy :: SomePKPayload
-> SomeRecipientPKESKVersionStrategyW
autoDetectRecipientVersionStrategy recipient
| _keyVersion recipient == V6 =
SomeRecipientPKESKVersionStrategyW RecipientPreferV6W
| _pkalgo recipient `elem` [X25519, X448] =
SomeRecipientPKESKVersionStrategyW RecipientPreferV6W
| otherwise =
SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW
data RecipientPayloadShape =
RecipientPayloadShape
{ recipientPayloadDataType :: DataType
, recipientPayloadFileName :: FileName
, recipientPayloadTimestamp :: ThirtyTwoBitTimeStamp
, recipientPayloadUseOnePassSignatures :: Bool
, recipientPayloadSignatures :: [SignaturePayload]
}
deriving (Eq, Show)
defaultRecipientPayloadShape :: RecipientPayloadShape
defaultRecipientPayloadShape =
RecipientPayloadShape
{ recipientPayloadDataType = BinaryData
, recipientPayloadFileName = BL.empty
, recipientPayloadTimestamp = 0
, recipientPayloadUseOnePassSignatures = False
, recipientPayloadSignatures = []
}
data RecipientEncryptResult =
RecipientEncryptResult
{ recipientEncryptPackets :: [Pkt]
, recipientEncryptSessionMaterial :: PKESKSessionMaterial
}
deriving (Eq, Show)
data RecipientEncryptRequestOverrides (v :: SEIPDVersion) where
RecipientEncryptRequestSEIPDv1Overrides ::
{ recipientEncryptRequestIVOverride :: Maybe IV
} -> RecipientEncryptRequestOverrides 'SEIPDv1
-- | For SEIPDv2 requests:
-- - when AEAD override is 'Nothing', encrypt-side capability negotiation
-- selects a common recipient-supported AEAD algorithm (if enabled).
-- - when AEAD override is 'Just', the explicit AEAD wins.
RecipientEncryptRequestSEIPDv2Overrides ::
{ recipientEncryptRequestAEADOverride :: Maybe AEADAlgorithm
, recipientEncryptRequestChunkSizeOverride :: Maybe Word8
, recipientEncryptRequestSaltOverride :: Maybe Salt
} -> RecipientEncryptRequestOverrides 'SEIPDv2
data RecipientEncryptRequest (v :: SEIPDVersion) =
RecipientEncryptRequest
{ -- | Recipient encryption targets. At least one target is required.
recipientEncryptRequestTargets :: [RecipientEncryptionTarget]
, recipientEncryptRequestPayloadShape :: RecipientPayloadShape
, recipientEncryptRequestPayload :: B.ByteString
-- | Explicit symmetric algorithm override. When 'Nothing', the selected
-- mode (negotiated or legacy) determines algorithm selection.
, recipientEncryptRequestSymmetricOverride :: Maybe SymmetricAlgorithm
, recipientEncryptRequestOverrides :: RecipientEncryptRequestOverrides v
}
deriving instance Eq (RecipientEncryptRequestOverrides v)
deriving instance Show (RecipientEncryptRequestOverrides v)
deriving instance Eq (RecipientEncryptRequest v)
deriving instance Show (RecipientEncryptRequest v)
-- | Encode the RFC 9580 PKESK/SKESK session-key material:
-- one-octet algorithm ID, raw session key, then 16-bit checksum.
encodeOpenPGPSessionMaterial ::
SymmetricAlgorithm -> SessionKey -> Either PKESKEncryptError B.ByteString
encodeOpenPGPSessionMaterial symalgo sessionKey =
unPKESKV3SessionMaterial <$> mkPKESKV3SessionMaterial symalgo sessionKey
-- | Generate a fresh session key and return both raw and encoded forms.
generateSessionKeyMaterial ::
MonadRandom m
=> SymmetricAlgorithm
-> m (Either PKESKEncryptError PKESKSessionMaterial)
generateSessionKeyMaterial symalgo =
case keySize symalgo of
Left err -> pure (Left (UnsupportedSessionKeyAlgorithm symalgo (renderCipherError err)))
Right keyLen -> do
sessionKeyBytes <- getRandomBytes keyLen
let sessionKey = SessionKey sessionKeyBytes
pure (mkPKESKSessionMaterial symalgo sessionKey)
canonicalizePKESKRecipientId ::
PKESKPayload -> Either PKESKEncryptError PKESKPayload
canonicalizePKESKRecipientId payload =
case payload of
PKESKPayloadV6Packet payloadV6 ->
PKESKPayloadV6Packet <$> canonicalizePKESKRecipientIdV6 payloadV6
_ -> Right payload
canonicalizePKESKRecipientIdV6 ::
PKESKPayloadV6 -> Either PKESKEncryptError PKESKPayloadV6
canonicalizePKESKRecipientIdV6 (PKESKPayloadV6 rid pka esk) =
(\normalizedRid -> PKESKPayloadV6 normalizedRid pka esk) <$>
canonicalizeRecipientKeyIdentifier rid
canonicalizeRecipientKeyIdentifier ::
BL.ByteString -> Either PKESKEncryptError BL.ByteString
canonicalizeRecipientKeyIdentifier rid
| BL.length rid == 20 || BL.length rid == 32 = Right rid
| BL.length rid == 21 && BL.head rid == 0x04 = Right (BL.tail rid)
| BL.length rid == 33 && BL.head rid == 0x06 = Right (BL.tail rid)
| otherwise =
Left
(InvalidRecipientIdentifier
("unsupported PKESK recipient identifier length/prefix: " ++
show (BL.length rid)))
canonicalizePKESKPacketRecipientIds ::
[Pkt] -> Either PKESKEncryptError [Pkt]
canonicalizePKESKPacketRecipientIds =
mapM
(\pkt ->
case pkt of
PKESKPkt payload -> fmap PKESKPkt (canonicalizePKESKRecipientId payload)
_ -> Right pkt)
-- | Build a v6 PKESK payload for one recipient key according to the selected version policy.
buildPKESKPayloadForRecipient ::
MonadRandom m
=> PKESKVersionPolicy
-> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKPayloadForRecipient policy recipient material =
case policy of
ForceV3Interop ->
buildPKESKv3PayloadForRecipient recipient (pkeskV3SessionMaterial material)
PreferV6 ->
case _pkalgo recipient of
RSA -> fmap (fmap PKESKPayloadV6Packet) (buildRsaPKESKv6 recipient material)
ECDH -> fmap (fmap PKESKPayloadV6Packet) (buildECDHPKESKv6 recipient material)
X25519 ->
fmap
(fmap PKESKPayloadV6Packet)
(buildX25519PKESKv6 recipient (pkeskV6RawSessionMaterial material))
X448 ->
fmap
(fmap PKESKPayloadV6Packet)
(buildX448PKESKv6 recipient (pkeskV6RawSessionMaterial material))
pka -> pure (Left (UnsupportedRecipientAlgorithm pka))
-- | Build a PKESK packet for one recipient key according to the selected version policy.
buildPKESKPktForRecipient ::
MonadRandom m
=> PKESKVersionPolicy
-> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipient policy recipient material =
fmap
(fmap PKESKPkt)
(buildPKESKPayloadForRecipient policy recipient material)
-- | Build a legacy PKESKv3 payload for v4/v3 RSA recipient interop.
buildPKESKv3PayloadForRecipient ::
MonadRandom m
=> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayload)
buildPKESKv3PayloadForRecipient recipient material =
fmap (fmap PKESKPayloadV3Packet) (buildPKESKv3PayloadForRecipientTyped recipient material)
buildPKESKv3PayloadForRecipientTyped ::
MonadRandom m
=> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildPKESKv3PayloadForRecipientTyped recipient material =
case _pkalgo recipient of
RSA -> buildRsaPKESKv3 recipient material
DeprecatedRSAEncryptOnly -> buildRsaPKESKv3 recipient material
ECDH -> buildECDHPKESKv3 recipient material
pka -> pure (Left (UnsupportedRecipientAlgorithm pka))
-- | Build a legacy PKESKv3 packet for v4/v3 RSA recipient interop.
buildPKESKv3PktForRecipient ::
MonadRandom m
=> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError Pkt)
buildPKESKv3PktForRecipient recipient material =
fmap (fmap PKESKPkt) (buildPKESKv3PayloadForRecipient recipient material)
-- | Build PKESK packets for all recipients with a single shared session key.
buildPKESKPktsForRecipientTargetsWithSelector ::
MonadRandom m
=> (RecipientEncryptionTarget -> Either PKESKEncryptError RecipientPKESKVersionStrategy)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelector selector targets material
= buildPKESKPktsForRecipientTargetsWithSelectorTyped
(\target ->
promoteRecipientStrategy <$> selector target)
targets
material
buildPKESKPktsForRecipientTargetsWithSelectorTyped ::
MonadRandom m
=> (RecipientEncryptionTarget -> Either PKESKEncryptError SomeRecipientPKESKVersionStrategyW)
-> [RecipientEncryptionTarget]
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError [Pkt])
buildPKESKPktsForRecipientTargetsWithSelectorTyped selector targets material
| null targets = pure (Left NoRecipientsProvided)
| otherwise =
case preparePKESKVersionedMaterial material of
Left err -> pure (Left err)
Right (v3Material, v6RawMaterial) -> do
pkeskResults <-
mapM
(\target ->
case selector target of
Left err -> pure (Left err)
Right (SomeRecipientPKESKVersionStrategyW RecipientPreferV6W) ->
buildPKESKPktForRecipientWithPreparedPayload
RecipientPreferV6W
(recipientEncryptionTargetKey target)
(RecipientPreferV6Payload material v6RawMaterial)
Right (SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW) ->
buildPKESKPktForRecipientWithPreparedPayload
RecipientForceV3InteropW
(recipientEncryptionTargetKey target)
(RecipientForceV3Payload v3Material))
targets
pure (sequence pkeskResults >>= canonicalizePKESKPacketRecipientIds)
preparePKESKVersionedMaterial ::
PKESKSessionMaterial
-> Either PKESKEncryptError (PKESKV3SessionMaterial, PKESKV6RawSessionMaterial)
preparePKESKVersionedMaterial material = do
v3Material <-
mkPKESKV3SessionMaterial
(pkeskSessionAlgorithm material)
(pkeskSessionKey material)
v6RawMaterial <-
mkPKESKV6RawSessionMaterial
(pkeskSessionAlgorithm material)
(pkeskSessionKey material)
pure (v3Material, v6RawMaterial)
data RecipientPKESKRequestPayload (strategy :: RecipientPKESKVersionStrategy) where
RecipientForceV3Payload ::
PKESKV3SessionMaterial
-> RecipientPKESKRequestPayload 'RecipientForceV3Interop
RecipientPreferV6Payload ::
PKESKSessionMaterial
-> PKESKV6RawSessionMaterial
-> RecipientPKESKRequestPayload 'RecipientPreferV6
buildPKESKPktForRecipientWithPreparedPayload ::
MonadRandom m
=> RecipientPKESKVersionStrategyW strategy
-> SomePKPayload
-> RecipientPKESKRequestPayload strategy
-> m (Either PKESKEncryptError Pkt)
buildPKESKPktForRecipientWithPreparedPayload strategy recipient payload =
fmap fmapPKESKPkt payloadResult
where
fmapPKESKPkt = fmap PKESKPkt
payloadResult =
case (strategy, payload) of
(RecipientForceV3InteropW, RecipientForceV3Payload v3Material) ->
buildPKESKv3PayloadForRecipient recipient v3Material
(RecipientPreferV6W, RecipientPreferV6Payload material v6RawMaterial) ->
case _pkalgo recipient of
RSA ->
fmap (fmap PKESKPayloadV6Packet) (buildRsaPKESKv6 recipient material)
ECDH ->
fmap (fmap PKESKPayloadV6Packet) (buildECDHPKESKv6 recipient material)
X25519 ->
fmap
(fmap PKESKPayloadV6Packet)
(buildX25519PKESKv6 recipient v6RawMaterial)
X448 ->
fmap
(fmap PKESKPayloadV6Packet)
(buildX448PKESKv6 recipient v6RawMaterial)
pka ->
pure (Left (UnsupportedRecipientAlgorithm pka))
-- | Encrypt for recipient targets with capability negotiation enabled.
--
-- By default this negotiates a common symmetric and (for SEIPDv2) AEAD
-- algorithm from recipient capabilities when available. Explicit request
-- overrides still take precedence.
encryptForRecipients ::
MonadRandom m
=> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipients =
encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOn
-- | Encrypt for recipient targets without recipient capability negotiation.
--
-- This preserves legacy behavior by using policy defaults unless request
-- overrides are provided.
encryptForRecipientsLegacy ::
MonadRandom m
=> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsLegacy =
encryptForRecipientsWithCapabilityNegotiation RecipientCapabilityNegotiationOff
-- | Encrypt for recipient targets with an explicit capability-negotiation mode.
--
-- When negotiation is on, symmetric and AEAD selection use the common
-- intersection of recipient preferences constrained by the active policy.
-- When off, policy defaults are used.
encryptForRecipientsWithCapabilityNegotiation ::
MonadRandom m
=> RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> m (Either PKESKEncryptError RecipientEncryptResult)
encryptForRecipientsWithCapabilityNegotiation negotiationMode request
| null targets = pure (Left NoRecipientsProvided)
| otherwise =
case selectSymmetricAlgorithm negotiationMode request messagePolicy targets of
Left err -> pure (Left err)
Right symalgo -> do
sessionMaterialResult <- generateSessionKeyMaterial symalgo
case sessionMaterialResult of
Left err -> pure (Left err)
Right sessionMaterial -> do
pkeskResult <-
buildPKESKPktsForRecipientTargetsWithSelectorTyped
(recipientVersionStrategyForProfileTyped profileW)
targets
sessionMaterial
case pkeskResult of
Left err -> pure (Left err)
Right pkeskPkts -> do
payloadResult <- case recipientEncryptRequestOverrides request of
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = aeadOverride
, recipientEncryptRequestChunkSizeOverride = chunkSizeOverride
, recipientEncryptRequestSaltOverride = saltOverride
} ->
case recipientsMissingSEIPDv2Support targets of
[] -> do
case selectAEADAlgorithm negotiationMode messagePolicy targets aeadOverride of
Left err -> pure (Left err)
Right aead -> do
salt <- maybe (Salt <$> getRandomBytes 32) pure saltOverride
let chunkSize =
maybe
(messageDefaultChunkSize messagePolicy)
id
chunkSizeOverride
pure $
buildEncryptedPacketSequenceWithShape
symalgo
aead
chunkSize
(recipientEncryptRequestPayloadShape request)
salt
(pkeskSessionKey sessionMaterial)
pkeskPkts
(recipientEncryptRequestPayload request)
_missingSEIPDv2 ->
case recipientsMissingSEIPDv1Support targets of
[] ->
buildSEIPDv1PayloadWithIV
symalgo
sessionMaterial
pkeskPkts
Nothing
missingSEIPDv1 ->
pure
(Left
(RecipientCapabilitySelectionFailure
(RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)))
RecipientEncryptRequestSEIPDv1Overrides
{ recipientEncryptRequestIVOverride = ivOverride } ->
case recipientsMissingSEIPDv1Support targets of
[] ->
buildSEIPDv1PayloadWithIV
symalgo
sessionMaterial
pkeskPkts
ivOverride
missingSEIPDv1 ->
pure
(Left
(RecipientCapabilitySelectionFailure
(RecipientCapabilityMissingSEIPDv1Support missingSEIPDv1)))
pure $
fmap
(\pkts ->
RecipientEncryptResult
{ recipientEncryptPackets = pkts
, recipientEncryptSessionMaterial = sessionMaterial
})
payloadResult
where
targets = recipientEncryptRequestTargets request
profileW =
profileForPayloadVersionW (recipientEncryptRequestOverrides request)
messagePolicy =
case profileW of
EncryptStrictDefaultW ->
policyMessageEncryption (policyForRFC RFC9580)
EncryptInteropLegacyW ->
policyMessageEncryption (policyForRFC RFC4880)
buildSEIPDv1PayloadWithIV ::
MonadRandom m
=> SymmetricAlgorithm
-> PKESKSessionMaterial
-> [Pkt]
-> Maybe IV
-> m (Either PKESKEncryptError [Pkt])
buildSEIPDv1PayloadWithIV symalgo sessionMaterial pkeskPkts ivOverride = do
ivResult <-
case ivOverride of
Just iv -> pure (Right iv)
Nothing ->
let keyBytes = unSessionKey (pkeskSessionKey sessionMaterial)
in case withSymmetricCipher symalgo keyBytes (\c -> Right (blockSize c)) of
Left err -> pure (Left (PayloadBuildFailure (renderCipherError err)))
Right n -> fmap (Right . IV) (getRandomBytes n)
case ivResult of
Left err -> pure (Left err)
Right iv ->
pure $
buildEncryptedPacketSequenceWithShapeSEIPDv1
symalgo
iv
(recipientEncryptRequestPayloadShape request)
(pkeskSessionKey sessionMaterial)
pkeskPkts
(recipientEncryptRequestPayload request)
recipientsMissingSEIPDv1Support :: [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv1Support =
map recipientEncryptionTargetKey .
filter (not . targetAdvertisesSEIPDv1Support)
recipientsMissingSEIPDv2Support :: [RecipientEncryptionTarget] -> [SomePKPayload]
recipientsMissingSEIPDv2Support =
map recipientEncryptionTargetKey .
filter (not . targetAdvertisesSEIPDv2Support)
targetAdvertisesSEIPDv1Support :: RecipientEncryptionTarget -> Bool
targetAdvertisesSEIPDv1Support target =
case recipientEncryptionTargetCapabilities target of
Nothing -> True
Just caps -> recipientCapabilityAdvertisesSEIPDv1Support caps
targetAdvertisesSEIPDv2Support :: RecipientEncryptionTarget -> Bool
targetAdvertisesSEIPDv2Support target =
case recipientEncryptionTargetCapabilities target of
Nothing -> True
Just caps -> recipientCapabilityAdvertisesSEIPDv2Support caps
selectSymmetricAlgorithm ::
RecipientCapabilityNegotiationMode
-> RecipientEncryptRequest v
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
selectSymmetricAlgorithm negotiationMode request messagePolicy targets =
case recipientEncryptRequestSymmetricOverride request of
Just override -> Right override
Nothing ->
case negotiationMode of
RecipientCapabilityNegotiationOff ->
Right (messageDefaultSymmetricAlgorithm messagePolicy)
RecipientCapabilityNegotiationOn ->
negotiateSymmetricAlgorithm messagePolicy targets
selectAEADAlgorithm ::
RecipientCapabilityNegotiationMode
-> MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Maybe AEADAlgorithm
-> Either PKESKEncryptError AEADAlgorithm
selectAEADAlgorithm negotiationMode messagePolicy targets override =
case override of
Just explicit -> Right explicit
Nothing ->
case negotiationMode of
RecipientCapabilityNegotiationOff ->
Right (messageDefaultAEADAlgorithm messagePolicy)
RecipientCapabilityNegotiationOn ->
negotiateAEADAlgorithm messagePolicy targets
negotiateSymmetricAlgorithm ::
MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError SymmetricAlgorithm
negotiateSymmetricAlgorithm messagePolicy targets =
chooseCommonAlgorithm
policyOrder
recipientChoices
(RecipientCapabilityNoCommonSymmetricAlgorithms (concat recipientChoices))
where
policyOrder =
case messageSEIPDv2SymmetricAlgorithms messagePolicy of
[] -> [messageDefaultSymmetricAlgorithm messagePolicy]
syms -> syms
recipientChoices = map choicesForTarget targets
choicesForTarget target =
case recipientEncryptionTargetCapabilities target of
Just caps ->
let preferred = recipientCapabilityPreferredSymmetricAlgorithms caps
allowed = [alg | alg <- policyOrder, alg `elem` preferred]
in if null allowed
then policyOrder
else allowed
Nothing -> policyOrder
negotiateAEADAlgorithm ::
MessageEncryptionPolicy
-> [RecipientEncryptionTarget]
-> Either PKESKEncryptError AEADAlgorithm
negotiateAEADAlgorithm messagePolicy targets =
chooseCommonAlgorithm
policyOrder
recipientChoices
(RecipientCapabilityNoCommonAEADAlgorithms (concat recipientChoices))
where
policyOrder = foldl' addIfMissing [] (messageDefaultAEADAlgorithm messagePolicy : [OCB, EAX, GCM])
recipientChoices = map choicesForTarget targets
choicesForTarget target =
case recipientEncryptionTargetCapabilities target of
Just caps ->
let preferred = recipientCapabilityPreferredAEADAlgorithms caps
allowed = [alg | alg <- policyOrder, alg `elem` preferred]
in if null allowed
then policyOrder
else allowed
Nothing -> policyOrder
addIfMissing acc x
| x `elem` acc = acc
| otherwise = acc ++ [x]
chooseCommonAlgorithm ::
Eq a
=> [a]
-> [[a]]
-> RecipientCapabilityError
-> Either PKESKEncryptError a
chooseCommonAlgorithm policyOrder recipientChoices err =
case recipientChoices of
[] -> Left (RecipientCapabilitySelectionFailure err)
(firstChoices:restChoices) ->
let common = foldl' intersectOrdered firstChoices restChoices
orderedCommon = [alg | alg <- policyOrder, alg `elem` common]
in case orderedCommon of
(selected:_) -> Right selected
[] -> Left (RecipientCapabilitySelectionFailure err)
where
intersectOrdered as bs = [a | a <- as, a `elem` bs]
promoteRecipientStrategy ::
RecipientPKESKVersionStrategy
-> SomeRecipientPKESKVersionStrategyW
promoteRecipientStrategy RecipientPreferV6 =
SomeRecipientPKESKVersionStrategyW RecipientPreferV6W
promoteRecipientStrategy RecipientForceV3Interop =
SomeRecipientPKESKVersionStrategyW RecipientForceV3InteropW
demoteRecipientStrategy ::
RecipientPKESKVersionStrategyW strategy
-> RecipientPKESKVersionStrategy
demoteRecipientStrategy RecipientPreferV6W = RecipientPreferV6
demoteRecipientStrategy RecipientForceV3InteropW = RecipientForceV3Interop
demoteSomeRecipientStrategy ::
SomeRecipientPKESKVersionStrategyW
-> RecipientPKESKVersionStrategy
demoteSomeRecipientStrategy (SomeRecipientPKESKVersionStrategyW strategyW) =
demoteRecipientStrategy strategyW
promoteEncryptCompatibilityProfile ::
EncryptCompatibilityProfile
-> SomeEncryptCompatibilityProfileW
promoteEncryptCompatibilityProfile EncryptStrictDefault =
SomeEncryptCompatibilityProfileW EncryptStrictDefaultW
promoteEncryptCompatibilityProfile EncryptInteropLegacy =
SomeEncryptCompatibilityProfileW EncryptInteropLegacyW
-- | High-level encrypt-side helper for public-key recipient encryption.
--
-- Returns a complete packet sequence:
-- @[PKESK ..., SEIPD2 ...]@.
buildEncryptedPacketSequence ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> RecipientPayloadShape
-> Salt
-> SessionKey
-> [Pkt]
-> B.ByteString
-> Either String [Pkt]
buildEncryptedPacketSequence symalgo aead chunkSize payloadShape salt sessionKey pkesks payload =
first renderPKESKEncryptError
(buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload)
buildEncryptedPacketSequenceWithShape ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> RecipientPayloadShape
-> Salt
-> SessionKey
-> [Pkt]
-> B.ByteString
-> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShape symalgo aead chunkSize payloadShape salt sessionKey pkesks payload = do
onePassSignatures <- first (PayloadBuildFailure . renderOPSBuildError) (buildOnePassSignaturePackets payloadShape)
let signatures = recipientPayloadSignatures payloadShape
literalBlock =
Block
(onePassSignatures ++
[ LiteralDataPkt
(recipientPayloadDataType payloadShape)
(recipientPayloadFileName payloadShape)
(recipientPayloadTimestamp payloadShape)
(BL.fromStrict payload)
] ++
map SignaturePkt signatures)
ciphertext <-
first PayloadBuildFailure $
encryptSEIPDv2Payload
symalgo
aead
chunkSize
salt
sessionKey
(BL.toStrict (runPut (put literalBlock)))
Right
(pkesks ++
[SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict ciphertext))])
-- | Encrypt a plaintext block with OpenPGP CFB + MDC to produce a SEIPDv1 ciphertext.
encryptSEIPDv1Payload ::
SymmetricAlgorithm
-> IV
-> SessionKey
-> B.ByteString -- ^ inner packet block plaintext
-> Either String B.ByteString
encryptSEIPDv1Payload symalgo iv (SessionKey keyBytes) plaintext =
let cleartextWithMDC = plaintext <> mdcTrailerForSEIPDv1 iv plaintext
in first
renderCipherError
(encryptOpenPGPCfbRaw OpenPGPCFBNoResyncW symalgo iv cleartextWithMDC keyBytes)
-- | Build a complete RFC 4880-conformant packet sequence using SEIPDv1 (CFB + MDC).
buildEncryptedPacketSequenceWithShapeSEIPDv1 ::
SymmetricAlgorithm
-> IV
-> RecipientPayloadShape
-> SessionKey
-> [Pkt]
-> B.ByteString
-> Either PKESKEncryptError [Pkt]
buildEncryptedPacketSequenceWithShapeSEIPDv1 symalgo iv payloadShape sessionKey pkesks payload = do
onePassSignatures <- first (PayloadBuildFailure . renderOPSBuildError) (buildOnePassSignaturePackets payloadShape)
let signatures = recipientPayloadSignatures payloadShape
literalBlock =
Block
(onePassSignatures ++
[ LiteralDataPkt
(recipientPayloadDataType payloadShape)
(recipientPayloadFileName payloadShape)
(recipientPayloadTimestamp payloadShape)
(BL.fromStrict payload)
] ++
map SignaturePkt signatures)
ciphertext <-
first PayloadBuildFailure $
encryptSEIPDv1Payload symalgo iv sessionKey (BL.toStrict (runPut (put literalBlock)))
Right
(pkesks ++
[SymEncIntegrityProtectedDataPkt (SEIPD1 1 (BL.fromStrict ciphertext))])
buildOnePassSignaturePackets :: RecipientPayloadShape -> Either OPSBuildError [Pkt]
buildOnePassSignaturePackets payloadShape
| not (recipientPayloadUseOnePassSignatures payloadShape) = Right []
| null signatures = Right []
| otherwise =
fmap (map OnePassSignaturePkt) $
sequence (zipWith buildOnePassSignature nestedFlags (reverse signatures))
where
signatures = recipientPayloadSignatures payloadShape
nestedFlags = replicate (length signatures - 1) True ++ [False]
data OnePassSignatureBuildCase where
OnePassSignatureBuildCaseV3 ::
SignaturePayloadV 'SigPayloadV3 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseV4 ::
SignaturePayloadV 'SigPayloadV4 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseV6 ::
SignaturePayloadV 'SigPayloadV6 -> OnePassSignatureBuildCase
OnePassSignatureBuildCaseOther ::
PacketVersion -> OnePassSignatureBuildCase
onePassSignatureBuildCase :: SignaturePayload -> OnePassSignatureBuildCase
onePassSignatureBuildCase sig =
case toSomeSignaturePayload sig of
SomeSignaturePayload (payload@SigPayloadV3Data {}) ->
OnePassSignatureBuildCaseV3 payload
SomeSignaturePayload (payload@SigPayloadV4Data {}) ->
OnePassSignatureBuildCaseV4 payload
SomeSignaturePayload (payload@SigPayloadV6Data {}) ->
OnePassSignatureBuildCaseV6 payload
SomeSignaturePayload (SigPayloadOtherData version _) ->
OnePassSignatureBuildCaseOther version
buildOnePassSignature :: NestedFlag -> SignaturePayload -> Either OPSBuildError OnePassSignaturePayload
buildOnePassSignature nestedFlag sig =
case onePassSignatureBuildCase sig of
OnePassSignatureBuildCaseV3 (SigPayloadV3Data sigType _ issuerKeyId pubkeyAlgo hashAlgo _ _) ->
Right
(OPSPayloadV3Packet
(OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag))
OnePassSignatureBuildCaseV4 (SigPayloadV4Data sigType pubkeyAlgo hashAlgo hashedSubpackets unhashedSubpackets _ _) ->
case signatureIssuerKeyId hashedSubpackets unhashedSubpackets of
Just issuerKeyId ->
Right
(OPSPayloadV3Packet
(OPSPayloadV3 3 sigType hashAlgo pubkeyAlgo issuerKeyId nestedFlag))
Nothing ->
Left OPSBuildMissingIssuerKeyId
OnePassSignatureBuildCaseV6 (SigPayloadV6Data sigType pubkeyAlgo hashAlgo salt hashedSubpackets unhashedSubpackets _ _) ->
case signatureIssuerFingerprint (BTypes.issuerFingerprintVersionToPacketVersion BTypes.IssuerFingerprintV6) hashedSubpackets unhashedSubpackets of
Just signerFingerprint
| BL.length signerFingerprint == 32 ->
Right
(OPSPayloadV6Packet
(OPSPayloadV6 sigType hashAlgo pubkeyAlgo salt signerFingerprint nestedFlag))
| otherwise ->
Left (OPSBuildFingerprintWrongLength (BL.length signerFingerprint))
Nothing ->
Left OPSBuildMissingIssuerFingerprint
OnePassSignatureBuildCaseOther version ->
Left (OPSBuildUnsupportedSigVersion version)
signatureIssuerKeyId :: [SigSubPacket] -> [SigSubPacket] -> Maybe EightOctetKeyId
signatureIssuerKeyId hashedSubpackets unhashedSubpackets =
case findIssuerKeyId hashedSubpackets of
Just issuerKeyId -> Just issuerKeyId
Nothing ->
case findIssuerKeyId unhashedSubpackets of
Just issuerKeyId -> Just issuerKeyId
Nothing ->
case signatureIssuerFingerprint (BTypes.issuerFingerprintVersionToPacketVersion BTypes.IssuerFingerprintV4) hashedSubpackets unhashedSubpackets of
Just issuerFingerprintBytes ->
if BL.length issuerFingerprintBytes >= 8
then
Just
(EightOctetKeyId
(BL.drop (BL.length issuerFingerprintBytes - 8) issuerFingerprintBytes))
else Nothing
Nothing -> Nothing
signatureIssuerFingerprint ::
PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe BL.ByteString
signatureIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets =
unFingerprint <$> findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets
findIssuerKeyId :: [SigSubPacket] -> Maybe EightOctetKeyId
findIssuerKeyId subpackets =
case find isIssuerKeyIdSubpacket subpackets of
Just (SigSubPacket _ (Issuer issuerKeyId)) -> Just issuerKeyId
_ -> Nothing
findIssuerFingerprint ::
PacketVersion -> [SigSubPacket] -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprint expectedVersion hashedSubpackets unhashedSubpackets =
case findIssuerFingerprintIn expectedVersion hashedSubpackets of
Just issuerFingerprint -> Just issuerFingerprint
Nothing -> findIssuerFingerprintIn expectedVersion unhashedSubpackets
findIssuerFingerprintIn :: PacketVersion -> [SigSubPacket] -> Maybe Fingerprint
findIssuerFingerprintIn expectedVersion subpackets =
case find (isIssuerFingerprintSubpacket expectedVersion) subpackets of
Just (SigSubPacket _ (IssuerFingerprint _ issuerFingerprint)) -> Just issuerFingerprint
_ -> Nothing
isIssuerKeyIdSubpacket :: SigSubPacket -> Bool
isIssuerKeyIdSubpacket (SigSubPacket _ (Issuer _)) = True
isIssuerKeyIdSubpacket _ = False
isIssuerFingerprintSubpacket :: PacketVersion -> SigSubPacket -> Bool
isIssuerFingerprintSubpacket expectedVersion (SigSubPacket _ (IssuerFingerprint version _)) =
BTypes.issuerFingerprintVersionToPacketVersion version == expectedVersion
isIssuerFingerprintSubpacket _ _ = False
buildRsaPKESKv6 ::
MonadRandom m
=> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildRsaPKESKv6 recipient material =
case _pubkey recipient of
RSAPubKey (RSA_PublicKey publicKey) -> do
encrypted <- RSA15.encrypt publicKey (pkeskEncodedSessionMaterial material)
pure $
fmap
(\esk ->
let mpiEsk = runPut (put (MPI (os2ip esk)))
in PKESKPayloadV6 (recipientKeyIdentifier recipient) RSA mpiEsk)
(first (RecipientKeyWrapFailure RSA . show) encrypted)
_ ->
pure
(Left
(InvalidRecipientKeyMaterial
RSA
"recipient PKPayload does not contain an RSA public key"))
buildRsaPKESKv3 ::
MonadRandom m
=> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildRsaPKESKv3 recipient material =
case _pubkey recipient of
RSAPubKey (RSA_PublicKey publicKey) ->
case eightOctetKeyID recipient of
Left err ->
pure
(Left
(InvalidRecipientKeyMaterial
(_pkalgo recipient)
("failed to derive PKESKv3 recipient key ID: " ++ err)))
Right eoki -> do
encrypted <- RSA15.encrypt publicKey (unPKESKV3SessionMaterial material)
pure $
fmap
(\esk ->
PKESKPayloadV3
3
eoki
(_pkalgo recipient)
(MPI (os2ip esk) :| []))
(first (RecipientKeyWrapFailure (_pkalgo recipient) . show) encrypted)
_ ->
pure
(Left
(InvalidRecipientKeyMaterial
(_pkalgo recipient)
"recipient PKPayload does not contain an RSA public key"))
buildECDHPKESKv3 ::
MonadRandom m
=> SomePKPayload
-> PKESKV3SessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV3)
buildECDHPKESKv3 recipient material =
case _pubkey recipient of
ECDHPubKey ecdhPub kdfHA kdfSA ->
case eightOctetKeyID recipient of
Left err ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
("failed to derive PKESKv3 recipient key ID: " ++ err)))
Right eoki ->
case ecdhPub of
ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do
(ephemeralPub, ephemeralPriv) <- ECCGen.generate (ECDSA.public_curve recipientPub)
case point2MBS (ECDSA.public_q ephemeralPub) of
Nothing ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
"failed to serialize ECDH ephemeral point"))
Just ephemeralBytes ->
pure $
buildEcdhV3Payload
recipient
eoki
ECDH
ecdhPub
kdfHA
kdfSA
ephemeralBytes
(BA.convert
(ECCDH.getShared
(ECDSA.public_curve recipientPub)
(ECDSA.private_d ephemeralPriv)
(ECDSA.public_q recipientPub)) ::
B.ByteString)
material
EdDSAPubKey Ed25519 recipientPoint -> do
ephSecretRaw <- getRandomBytes 32
pure $
do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint)
ephSecret <-
first (RecipientKeyWrapFailure ECDH . show) .
CE.eitherCryptoError $
C25519.secretKey (leftPadTo 32 ephSecretRaw)
recipientPub <-
first (RecipientKeyWrapFailure ECDH . show) .
CE.eitherCryptoError $
C25519.publicKey recipientPublicBytes
let ephPublicBytes =
B.cons 0x40 (BA.convert (C25519.toPublic ephSecret) :: B.ByteString)
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
buildEcdhV3Payload
recipient
eoki
ECDH
ecdhPub
kdfHA
kdfSA
ephPublicBytes
sharedSecret
material
_ ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
"recipient ECDH public key is not RFC6637-compatible"))
_ ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
"recipient PKPayload does not contain ECDH public key material"))
buildECDHPKESKv6 ::
MonadRandom m
=> SomePKPayload
-> PKESKSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildECDHPKESKv6 recipient material =
case _pubkey recipient of
ECDHPubKey ecdhPub kdfHA kdfSA ->
case ecdhPub of
ECDSAPubKey (ECDSA_PublicKey recipientPub) -> do
(ephemeralPub, ephemeralPriv) <- ECCGen.generate (ECDSA.public_curve recipientPub)
case point2MBS (ECDSA.public_q ephemeralPub) of
Nothing ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
"failed to serialize ECDH ephemeral point"))
Just ephemeralBytes ->
pure $
buildEcdhV6Esk
recipient
ECDH
ecdhPub
kdfHA
kdfSA
ephemeralBytes
(BA.convert
(ECCDH.getShared
(ECDSA.public_curve recipientPub)
(ECDSA.private_d ephemeralPriv)
(ECDSA.public_q recipientPub)) ::
B.ByteString)
material
EdDSAPubKey Ed25519 recipientPoint -> do
ephSecretRaw <- getRandomBytes 32
pure $
do recipientPublicBytes <- normalizeX25519Public (edPointBytes recipientPoint)
ephSecret <-
first (RecipientKeyWrapFailure ECDH . show) .
CE.eitherCryptoError $
C25519.secretKey (leftPadTo 32 ephSecretRaw)
recipientPub <-
first (RecipientKeyWrapFailure ECDH . show) .
CE.eitherCryptoError $
C25519.publicKey recipientPublicBytes
let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material
EdDSAPubKey Ed448 recipientPoint -> do
ephSecretRaw <- getRandomBytes 56
pure $
do recipientPublicBytes <- normalizeX448Public (edPointBytes recipientPoint)
ephSecret <-
first (RecipientKeyWrapFailure ECDH . show) .
CE.eitherCryptoError $
C448.secretKey (leftPadTo 56 ephSecretRaw)
recipientPub <-
first (RecipientKeyWrapFailure ECDH . show) .
CE.eitherCryptoError $
C448.publicKey recipientPublicBytes
let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString
sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString
buildEcdhV6Esk recipient ECDH ecdhPub kdfHA kdfSA ephPublicBytes sharedSecret material
_ ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
"recipient ECDH public key is not ECDSA/X25519/X448-compatible"))
_ ->
pure
(Left
(InvalidRecipientKeyMaterial
ECDH
"recipient PKPayload does not contain ECDH public key material"))
buildX25519PKESKv6 ::
MonadRandom m
=> SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX25519PKESKv6 recipient material = do
ephSecretRaw <- getRandomBytes 32
pure $
do recipientPublic <- extractX25519RecipientPublic recipient
ephSecret <-
first (RecipientKeyWrapFailure X25519 . show) .
CE.eitherCryptoError $
C25519.secretKey (leftPadTo 32 ephSecretRaw)
recipientPub <-
first (RecipientKeyWrapFailure X25519 . show) .
CE.eitherCryptoError $
C25519.publicKey recipientPublic
let ephPublicBytes = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek = deriveX25519Kek ephPublicBytes recipientPublic sharedSecret
wrapped <-
first (RecipientKeyWrapFailure X25519) .
aesKeyWrapRFC3394 AES128 kek $
unPKESKV6RawSessionMaterial material
esk <- encodeV6X25519Esk ephPublicBytes wrapped
Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X25519 (BL.fromStrict esk))
buildX448PKESKv6 ::
MonadRandom m
=> SomePKPayload
-> PKESKV6RawSessionMaterial
-> m (Either PKESKEncryptError PKESKPayloadV6)
buildX448PKESKv6 recipient material = do
ephSecretRaw <- getRandomBytes 56
pure $
do recipientPublic <- extractX448RecipientPublic recipient
ephSecret <-
first (RecipientKeyWrapFailure X448 . show) .
CE.eitherCryptoError $
C448.secretKey (leftPadTo 56 ephSecretRaw)
recipientPub <-
first (RecipientKeyWrapFailure X448 . show) .
CE.eitherCryptoError $
C448.publicKey recipientPublic
let ephPublicBytes = BA.convert (C448.toPublic ephSecret) :: B.ByteString
sharedSecret = BA.convert (C448.dh recipientPub ephSecret) :: B.ByteString
kek = deriveX448Kek ephPublicBytes recipientPublic sharedSecret
wrapped <-
first (RecipientKeyWrapFailure X448) .
aesKeyWrapRFC3394 AES256 kek $
unPKESKV6RawSessionMaterial material
esk <- encodeV6X448Esk ephPublicBytes wrapped
Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) X448 (BL.fromStrict esk))
buildEcdhV6Esk :: SomePKPayload
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> B.ByteString
-> B.ByteString
-> PKESKSessionMaterial
-> Either PKESKEncryptError PKESKPayloadV6
buildEcdhV6Esk recipient pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do
kdfParam <-
first (RecipientKdfFailure pka) $
buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA
kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam
wrapped <-
first (RecipientKeyWrapFailure pka) .
aesKeyWrapRFC3394 kdfSA kek $
padToMultipleOf8 (pkeskEncodedSessionMaterial material)
esk <- encodeV6EcdhEsk ephemeralBytes wrapped
Right (PKESKPayloadV6 (recipientKeyIdentifier recipient) pka (BL.fromStrict esk))
buildEcdhV3Payload :: SomePKPayload
-> EightOctetKeyId
-> PubKeyAlgorithm
-> PKey
-> HashAlgorithm
-> SymmetricAlgorithm
-> B.ByteString
-> B.ByteString
-> PKESKV3SessionMaterial
-> Either PKESKEncryptError PKESKPayloadV3
buildEcdhV3Payload recipient eoki pka ecdhPub kdfHA kdfSA ephemeralBytes sharedSecret material = do
kdfParam <-
first (RecipientKdfFailure pka) $
buildECDHKDFParam recipient pka ecdhPub kdfHA kdfSA
kek <- first (RecipientKdfFailure pka) $ deriveECDHKek kdfHA kdfSA sharedSecret kdfParam
wrapped <-
first (RecipientKeyWrapFailure pka) .
aesKeyWrapRFC3394 kdfSA kek $
padToMultipleOf8 (unPKESKV3SessionMaterial material)
Right
(PKESKPayloadV3
3
eoki
pka
(MPI (os2ip ephemeralBytes) :| [MPI (os2ip wrapped)]))
recipientKeyIdentifier :: SomePKPayload -> BL.ByteString
recipientKeyIdentifier = unFingerprint . fingerprint
encodeV6EcdhEsk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString
encodeV6EcdhEsk ephemeral wrapped = do
let ephLen = B.length ephemeral
if ephLen > 255
then Left (RecipientKeyWrapFailure ECDH "ephemeral key encoding is too large")
else Right (B.singleton (fromIntegral ephLen) <> ephemeral <> wrapped)
encodeV6X25519Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString
encodeV6X25519Esk ephemeral wrapped
| B.length ephemeral /= 32 =
Left (RecipientKeyWrapFailure X25519 "X25519 ephemeral key must be exactly 32 octets")
| B.length wrapped > 255 =
Left (RecipientKeyWrapFailure X25519 "wrapped session key encoding is too large")
| otherwise =
Right (ephemeral <> B.singleton (fromIntegral (B.length wrapped)) <> wrapped)
encodeV6X448Esk :: B.ByteString -> B.ByteString -> Either PKESKEncryptError B.ByteString
encodeV6X448Esk ephemeral wrapped
| B.length ephemeral /= 56 =
Left (RecipientKeyWrapFailure X448 "X448 ephemeral key must be exactly 56 octets")
| B.length wrapped > 255 =
Left (RecipientKeyWrapFailure X448 "wrapped session key encoding is too large")
| otherwise =
Right (ephemeral <> B.singleton (fromIntegral (B.length wrapped)) <> wrapped)
extractX25519RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString
extractX25519RecipientPublic recipient =
case _pubkey recipient of
EdDSAPubKey Ed25519 point ->
normalizeX25519Public (edPointBytes point)
ECDHPubKey (EdDSAPubKey Ed25519 point) _ _ ->
normalizeX25519Public (edPointBytes point)
other ->
Left
(InvalidRecipientKeyMaterial
X25519
("expected X25519-compatible recipient key, got " ++ show other))
extractX448RecipientPublic :: SomePKPayload -> Either PKESKEncryptError B.ByteString
extractX448RecipientPublic recipient =
case _pubkey recipient of
EdDSAPubKey Ed448 point ->
normalizeX448Public (edPointBytes point)
ECDHPubKey (EdDSAPubKey Ed448 point) _ _ ->
normalizeX448Public (edPointBytes point)
other ->
Left
(InvalidRecipientKeyMaterial
X448
("expected X448-compatible recipient key, got " ++ show other))
normalizeX25519Public :: B.ByteString -> Either PKESKEncryptError B.ByteString
normalizeX25519Public =
first (InvalidRecipientKeyMaterial X25519) .
normalizeMontgomeryPublic
32
"invalid X25519 public key length/prefix: "
normalizeX448Public :: B.ByteString -> Either PKESKEncryptError B.ByteString
normalizeX448Public =
first (InvalidRecipientKeyMaterial X448) .
normalizeMontgomeryPublic
56
"invalid X448 public key length/prefix: "
edPointBytes :: EdPoint -> B.ByteString
edPointBytes (PrefixedNativeEPoint (EPoint x)) = i2osp x
edPointBytes (NativeEPoint (EPoint x)) = i2osp x
deriveX25519Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX25519Kek ephemeralPublic recipientPublic sharedSecret =
let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
prk = extract @CHAlg.SHA256 B.empty ikm
info = "OpenPGP X25519" :: B.ByteString
in expand @CHAlg.SHA256 prk info 16
deriveX448Kek :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString
deriveX448Kek ephemeralPublic recipientPublic sharedSecret =
let ikm = ephemeralPublic <> recipientPublic <> sharedSecret
prk = extract @CHAlg.SHA512 B.empty ikm
info = "OpenPGP X448" :: B.ByteString
in expand @CHAlg.SHA512 prk info 32
padToMultipleOf8 :: B.ByteString -> B.ByteString
padToMultipleOf8 bs
| padLen == 0 = bs
| otherwise = bs <> B.replicate padLen (fromIntegral padLen)
where
rem8 = B.length bs `mod` 8
padLen = if rem8 == 0 then 0 else 8 - rem8
checksum16 :: B.ByteString -> Word16
checksum16 =
fromIntegral .
B.foldl' (\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer)) 0
checksum16Bytes :: B.ByteString -> B.ByteString
checksum16Bytes bs =
B.pack
[ fromIntegral ((chk `shiftR` 8) .&. 0xff)
, fromIntegral (chk .&. 0xff)
]
where
chk = checksum16 bs
aesKeyWrapRFC3394 ::
SymmetricAlgorithm -> B.ByteString -> B.ByteString -> Either String B.ByteString
aesKeyWrapRFC3394 sa kek plain =
withAESCipher "ECDH PKESK currently supports AES KEK algorithms only" sa kek wrapWithCipher
where
wrapWithCipher :: CCT.BlockCipher cipher => cipher -> Either String B.ByteString
wrapWithCipher cipher = do
if B.length plain < 16 || B.length plain `mod` 8 /= 0
then Left "ECDH key wrap input must be at least 16 octets and a multiple of 8"
else Right ()
let rs = chunksOf8 plain
if length rs < 2
then Left "ECDH key wrap input must contain at least two 64-bit blocks"
else Right ()
(aFinal, rFinal) <- wrapRounds cipher (B.replicate 8 0xA6) rs
Right (aFinal <> B.concat rFinal)
wrapRounds :: CCT.BlockCipher cipher => cipher -> B.ByteString -> [B.ByteString] -> Either String (B.ByteString, [B.ByteString])
wrapRounds cipher aInit rsInit = goJ 0 aInit rsInit
where
n = length rsInit
goJ j a rs
| j > 5 = Right (a, rs)
| otherwise = do
(a', rs') <- goI 1 a rs
goJ (j + 1) a' rs'
where
goI i curA curRs
| i > n = Right (curA, curRs)
| otherwise = do
let t = fromIntegral (n * j + i) :: Word64
rI = curRs !! (i - 1)
block = CCT.ecbEncrypt cipher (curA <> rI)
(msb, lsb) = B.splitAt 8 block
aNext = xorBS msb (encodeWord64be t)
rsNext = (ix (i - 1) .~ lsb) curRs
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)
encryptSEIPDv2WithSKESK ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> BL.ByteString
-> B.ByteString
-> Either String [Pkt]
encryptSEIPDv2WithSKESK symalgo aead chunkSize salt s2k passphrase literalPayload = do
keyLen <- symKeySize symalgo
sessionKeyMaterial <- first renderS2KError (string2Key s2k keyLen passphrase)
(_, nonceSize) <-
aeadModeAndNonceSizeForSEIPDv2
"unsupported AEAD algorithm for SKESK v6 encrypt"
aead
when (B.length (unSalt salt) < nonceSize) $
Left "SEIPD v2 salt is too short to derive the SKESK v6 IV"
let skeskIV = B.take nonceSize (unSalt salt)
kek <- deriveSKESK6KEK symalgo aead sessionKeyMaterial
(wrappedSessionKey, skeskTag) <-
encryptSKESK6SessionKey symalgo aead kek skeskIV sessionKeyMaterial
let sessionKey = SessionKey sessionKeyMaterial
encrypted <- encryptSEIPDv2Payload symalgo aead chunkSize salt sessionKey literalPayload
return
[ SKESKPkt
(SKESKPayloadV6Packet
(SKESKPayloadV6
symalgo
aead
s2k
(BL.fromStrict skeskIV)
(BL.fromStrict wrappedSessionKey)
(BL.fromStrict skeskTag)))
, SymEncIntegrityProtectedDataPkt (SEIPD2 symalgo aead chunkSize salt (BL.fromStrict encrypted))
]
encryptSEIPDv2WithSKESKBlock ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> BL.ByteString
-> Block Pkt
-> Either String [Pkt]
encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase packetBlock =
encryptSEIPDv2WithSKESK
symalgo
aead
chunkSize
salt
s2k
passphrase
(BL.toStrict (runPut (put packetBlock)))
encryptSEIPDv2LiteralDataWithSKESK ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> BL.ByteString
-> B.ByteString
-> Either String [Pkt]
encryptSEIPDv2LiteralDataWithSKESK symalgo aead chunkSize salt s2k passphrase payload =
encryptSEIPDv2WithSKESKBlock
symalgo
aead
chunkSize
salt
s2k
passphrase
(Block [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload)])
encryptSEIPDv2Payload ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> SessionKey
-> B.ByteString
-> Either String B.ByteString
encryptSEIPDv2Payload symalgo aead chunkSize salt (SessionKey sessionKey) plaintext = do
(mode, nonceSize) <- aeadModeAndNonceSize aead
keyLen <- symKeySize symalgo
let outputLen = keyLen + nonceSize - 8
info = B.pack [0xd2, 2, fromFVal symalgo, fromFVal aead, chunkSize]
prk = extract @CHAlg.SHA256 (unSalt salt) sessionKey
okm = expand @CHAlg.SHA256 prk info outputLen :: B.ByteString
messageKey = B.take keyLen okm
noncePrefix = B.take (nonceSize - 8) (B.drop keyLen okm)
withAESCipher
"SEIPD v2 encrypt currently supports AES-128/192/256 only"
symalgo
messageKey
(encryptChunks mode info chunkSize noncePrefix plaintext)
encryptChunks ::
CCT.BlockCipher cipher
=> CCT.AEADMode
-> B.ByteString
-> Word8
-> B.ByteString
-> B.ByteString
-> cipher
-> Either String B.ByteString
encryptChunks mode info chunkSize noncePrefix plaintext cipher = go 0 plaintext [] 0
where
chunkLen = 1 `shiftL` (fromIntegral chunkSize + 6)
go idx remaining acc totalPlain
| B.null remaining = do
(finalTag, finalCipher) <-
if mode == CCT.AEAD_OCB
then
encryptWithOCBRFC7253
cipher
(noncePrefix <> encodeWord64be idx)
(info <> encodeWord64be (fromIntegral totalPlain))
B.empty
else do
aead <- initAEAD idx
let (tag, out) =
CCT.aeadSimpleEncrypt
aead
(info <> encodeWord64be (fromIntegral totalPlain))
B.empty
16
Right (tag, out)
if B.null finalCipher
then return (B.concat (reverse acc) <> authTagToBS finalTag)
else Left "expected empty ciphertext for final SEIPD v2 tag"
| otherwise = do
let (chunkPlain, rest) = B.splitAt chunkLen remaining
(tag, chunkCipher) <-
if mode == CCT.AEAD_OCB
then
encryptWithOCBRFC7253
cipher
(noncePrefix <> encodeWord64be idx)
info
chunkPlain
else do
aead <- initAEAD idx
pure (CCT.aeadSimpleEncrypt aead info chunkPlain 16)
let chunkOut = chunkCipher <> authTagToBS tag
go
(idx + 1)
rest
(chunkOut : acc)
(totalPlain + B.length chunkPlain)
initAEAD idx =
first show . CE.eitherCryptoError $
CCT.aeadInit mode cipher (noncePrefix <> encodeWord64be idx)
aeadModeAndNonceSize :: AEADAlgorithm -> Either String (CCT.AEADMode, Int)
aeadModeAndNonceSize =
aeadModeAndNonceSizeForSEIPDv2
"unsupported AEAD algorithm for SEIPD v2 encrypt"
symKeySize :: SymmetricAlgorithm -> Either String Int
symKeySize =
seipdv2SymmetricKeySize
"unsupported symmetric algorithm for SEIPD v2 encrypt"
authTagToBS :: CCT.AuthTag -> B.ByteString
authTagToBS = BA.convert . CCT.unAuthTag
encodeWord64be :: Word64 -> B.ByteString
encodeWord64be = BL.toStrict . runPut . putWord64be
-- | Compose a complete AEAD-encrypted message with optional literal data and signature.
-- Returns a packet list (SKESK, SEIPD v2, optional signature) ready for serialization.
--
-- Example: @composeMessageWithSEIPDv2 AES256 OCB 6 (Salt 32 bytes)
-- (SimpleS2K SHA256) passphrase payload Nothing@
-- returns @[SKESK v6, SEIPD v2, <ciphertext>]@
--
-- If the signature is provided, it will be included in the encrypted payload.
composeMessageWithSEIPDv2 ::
SymmetricAlgorithm
-> AEADAlgorithm
-> Word8
-> Salt
-> S2K
-> BL.ByteString
-> B.ByteString
-> Maybe [Pkt]
-> Either String [Pkt]
composeMessageWithSEIPDv2 symalgo aead chunkSize salt s2k passphrase payload mSigs = do
let packets = case mSigs of
Nothing -> [LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload)]
Just sigs -> LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) (BL.fromStrict payload) : sigs
blockPayload = Block packets
encryptSEIPDv2WithSKESKBlock symalgo aead chunkSize salt s2k passphrase blockPayload