hOpenPGP-3.1: tests/Tests/Encryption.hs
-- Encryption.hs: hOpenPGP test suite
-- Copyright © 2012-2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Tests.Encryption (encryptionAndCompressionTests) where
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor (..))
import Control.Exception.Base (SomeException, catch, try)
import Control.Monad (void)
import Control.Monad.Trans.Resource (ResourceT)
import qualified Crypto.Error as CE
import Crypto.Number.ModArithmetic (inverse)
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 Crypto.PubKey.ECC.Prim (pointBaseMul)
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.RSA as RSA
import qualified Crypto.PubKey.RSA.PKCS15 as P15
import Data.Binary (get, put)
import Data.Binary.Get
( Get
)
import Data.Binary.Put (putWord16be, runPut)
import qualified Data.ByteArray as BA
import qualified Data.ByteString as B
import qualified Data.ByteString.Base16.Lazy as B16L
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Char (toUpper)
import Data.Conduit (fuseBoth)
import qualified Data.Conduit as DC
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.List (find, isInfixOf)
import Data.List.NonEmpty (NonEmpty (..))
import qualified Data.List.NonEmpty as NE
import Data.Maybe (listToMaybe)
import qualified Data.Set as Set
import Data.Word (Word16)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit
( Assertion
, assertBool
, assertEqual
, assertFailure
, testCase
)
import Codec.Encryption.OpenPGP.BlockCipher
( keySize
, withSymmetricCipher
)
import Codec.Encryption.OpenPGP.CFB
import Codec.Encryption.OpenPGP.Compression
( CompressionError (..)
, compressPkts
, decompressPkt
)
import Codec.Encryption.OpenPGP.Encrypt
( EncryptCompatibilityProfile (..)
, PKESKEncryptError
( InvalidRecipientIdentifier
, InvalidRecipientKeyMaterial
, PayloadBuildFailure
, RecipientCapabilitySelectionFailure
, RecipientKdfFailure
, UnsupportedRecipientAlgorithm
)
, PKESKVersionPolicy (..)
, PassphraseEncryptRequest (..)
, PassphraseSKESKVersionPolicy (..)
, RecipientCapabilities (..)
, RecipientCapabilityError
( RecipientCapabilityMissingSEIPDv1Support
, RecipientCapabilityNoCommonAEADAlgorithms
, RecipientCapabilityNoCommonSymmetricAlgorithms
, RecipientCapabilityNoEncryptableKeyMaterialInTK
)
, RecipientCapabilityNegotiationMode (..)
, RecipientEncryptRequest (..)
, RecipientEncryptRequestOverrides (..)
, RecipientEncryptResult (..)
, RecipientEncryptionTarget (..)
, RecipientEncryptionTargetRejected (..)
, RecipientEncryptionTargetsReport (..)
, RecipientPKESKVersionStrategy (..)
, RecipientPayloadShape (..)
, RecipientTargetRejectionReason (..)
, RecipientTargetSelectionPolicy (..)
, buildPKESKPayloadForRecipient
, buildPKESKv3PayloadForRecipient
, canonicalizePKESKRecipientId
, defaultRecipientPayloadShape
, encryptForRecipients
, encryptForRecipientsLegacy
, encryptForRecipientsWithCapabilityNegotiation
, encryptPassphraseWithPolicy
, encryptSEIPDv2Payload
, pkeskSessionAlgorithm
, pkeskV3SessionMaterial
, recipientCapabilitiesFromSubpacketPayloads
, recipientEncryptionTarget
, recipientEncryptionTargetFromTK
, recipientEncryptionTargetFromTKAtTimestamp
, recipientEncryptionTargetFromTKAtTimestampWithPolicy
, recipientEncryptionTargetWithCapabilities
, recipientEncryptionTargetWithStrategy
, recipientEncryptionTargetsFromTK
, recipientEncryptionTargetsFromTKAtTimestamp
, recipientEncryptionTargetsReportFromTKAtTimestamp
, recipientVersionStrategyForProfile
)
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.Internal (point2MBS)
import Codec.Encryption.OpenPGP.Internal.HOBlockCipher
( HOBlockCipher (..)
)
import Codec.Encryption.OpenPGP.Message
( SessionMaterialExposure (..)
, encryptedPayloadBytes
, mkClearPayload
, mkPassphrase
)
import Codec.Encryption.OpenPGP.Policy
( OpenPGPPolicy (..)
, OpenPGPRFC (..)
, defaultDecryptPolicy
, defaultPolicy
, lenientDecryptPolicy
, policyForRFC
)
import Codec.Encryption.OpenPGP.S2K
( EncodedSessionKeyError (..)
, S2KError (..)
, decodeOpenPGPEncodedSessionKey
, renderS2KError
, skesk2SessionKey
, string2Key
)
import Codec.Encryption.OpenPGP.SecretKey
( decryptPrivateKey
, encryptPrivateKeyWithPolicyAndSaltAndIV
)
import Codec.Encryption.OpenPGP.Serialize (parsePkts)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Compression (conduitCompress)
import Data.Conduit.OpenPGP.Decrypt
( DecryptKeyResolution (..)
, DecryptOptions (..)
, DecryptOutcome (..)
, PKESKRecipientKey (..)
)
import qualified Data.Conduit.OpenPGP.Decrypt as DCD
import Data.Conduit.OpenPGP.Keyring
( conduitToSomeTKsDroppingEither
, conduitToSomeTKsEither
, conduitToTKsDroppingEither
, conduitToTKsEither
)
import Tests.Common
( aesKeyWrapRFC3394ForTest
, armorPayload
, assertX25519EskShape
, assertX448EskShape
, buildCurve25519LegacyKdfParamForTest
, buildECDHKDFParamForTest
, cgp
, collectSecretKeyInfos
, conduitDecrypt
, conduitDecryptChecked
, conduitDecryptCheckedWithDecryptPolicy
, conduitDecryptWithCandidatesCallbackAndPolicy
, conduitDecryptWithDecryptPolicy
, conduitDecryptWithPKESKContext
, deriveECDHKekForTest
, deriveX25519KekForTest
, deriveX448KekForTest
, doPkeyAndSkeyMatch
, encodeChecksum16
, encryptMessageDefault
, fixturePath
, forceVersionedRecipientIdentifier
, isPrecedingESK
, loadArmor
, loadDeterministicEd25519Signer
, loadSEIPDv2FixtureWithV4Secret
, loadUnencryptedRsaSigner
, mkPKESKSessionMaterialOrFail
, prependUnusableLatestPKESK
, readFixtureLazy
, readFixturePackets
, readFixtureStrict
, readPKIPassphrase
, reorderPrecedingPKESKs
, runGet
, selectRecipientKeyInfo
, selectRecipientKeyInfoByRawRecipientId
, setKeyTimestamp
, setKeyVersion
, signDirectKeyWithRSAExtrasAt
, signSubkeyBindingWithRSAExtrasAt
, signSubkeyRevocationWithRSAAt
, testEncodeOpenPGPSessionMaterial
, testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized
, testSEIPDv2ForV4KeyArmor
, testSEIPDv2ThreeRecipientsArmor
, testSEIPDv2TwoRecipientsArmor
)
mkLegacySymmetricCase
:: (String, Bool, FilePath, FilePath, BL.ByteString) -> TestTree
mkLegacySymmetricCase (label, expectSEIPDv1, encFile, passFile, cleartext) =
testCase
label
( testLegacySymmetricEncryption
expectSEIPDv1
encFile
passFile
cleartext
)
legacySymmetricCases
:: [(String, Bool, FilePath, FilePath, BL.ByteString)]
legacySymmetricCases =
[
( "Symmetric Encryption simple S2K SHA1 3DES, no MDC"
, False
, "encryption-sym-3des-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 3DES, no MDC"
, False
, "encryption-sym-3des.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 3DES"
, True
, "encryption-sym-3des-mdc-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 3DES"
, True
, "encryption-sym-3des-mdc.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 CAST5, no MDC"
, False
, "encryption-sym-cast5-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 CAST5, no MDC"
, False
, "encryption-sym-cast5.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 CAST5"
, True
, "encryption-sym-cast5-mdc-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 CAST5"
, True
, "encryption-sym-cast5-mdc.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 Blowfish, no MDC"
, False
, "encryption-sym-blowfish-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 Blowfish, no MDC"
, False
, "encryption-sym-blowfish.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 Blowfish"
, True
, "encryption-sym-blowfish-mdc-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 Blowfish"
, True
, "encryption-sym-blowfish-mdc.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 AES128"
, True
, "encryption-sym-aes128-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 AES128"
, True
, "encryption-sym-aes128.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 AES192"
, True
, "encryption-sym-aes192-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 AES192"
, True
, "encryption-sym-aes192.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 AES256"
, True
, "encryption-sym-aes256-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 AES256"
, True
, "encryption-sym-aes256.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA256 AES256"
, True
, "encryption-sym-aes256-sha256.pgp"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple S2K SHA1 Twofish"
, True
, "encryption-sym-twofish-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted S2K SHA1 Twofish"
, True
, "encryption-sym-twofish.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption simple Camellia128"
, True
, "encryption-sym-camellia128-s2k0.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted Camellia128"
, True
, "encryption-sym-camellia128.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted Camellia192"
, True
, "encryption-sym-camellia192.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption iterated-salted Camellia256"
, True
, "encryption-sym-camellia256.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "Symmetric Encryption pgcrypto"
, True
, "encryption-sym-pgcrypto.pgp"
, "pgcrypto-passphrase.txt"
, "{\"t\":\"plus\"}"
)
]
mkStrictSymmetricCase
:: (String, FilePath, FilePath, BL.ByteString) -> TestTree
mkStrictSymmetricCase (label, encFile, passFile, cleartext) =
testCase
label
(testSymmetricEncryption encFile passFile cleartext)
strictSymmetricCases
:: [(String, FilePath, FilePath, BL.ByteString)]
strictSymmetricCases =
[
( "strict policy AES128 iterated-salted S2K SEIPDv1"
, "encryption-sym-aes128.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "strict policy AES192 iterated-salted S2K SEIPDv1"
, "encryption-sym-aes192.gpg"
, "symmetric-password.txt"
, "test\n"
)
,
( "strict policy AES256 iterated-salted S2K SEIPDv1"
, "encryption-sym-aes256.gpg"
, "symmetric-password.txt"
, "test\n"
)
]
mkSyntheticNISTP256
:: B.ByteString -> (ECDSA.PublicKey, ECDSA.PrivateKey)
mkSyntheticNISTP256 bs =
let curve = ECCT.getCurveByName ECCT.SEC_p256r1
d = os2ip bs
q = pointBaseMul curve d
pub = ECDSA.PublicKey curve q
priv = ECDSA.PrivateKey curve d
in (pub, priv)
syntheticNISTP256Low
, syntheticNISTP256High
:: (ECDSA.PublicKey, ECDSA.PrivateKey)
syntheticNISTP256Low = mkSyntheticNISTP256 $ B.pack [1 .. 32]
syntheticNISTP256High = mkSyntheticNISTP256 $ B.pack [101 .. 132]
encryptionAndCompressionTests :: TestTree
encryptionAndCompressionTests =
testGroup
"Encryption and compression"
[ testGroup
"Compression group"
[ testCase
"compressedsig.gpg"
(testCompression "compressedsig.gpg")
, testCase
"compressedsig-zlib.gpg"
(testCompression "compressedsig-zlib.gpg")
, testCase
"compressedsig-bzip2.gpg"
(testCompression "compressedsig-bzip2.gpg")
, testCase
"decompressPkt classifies empty ZIP payload"
( assertEqual
"empty ZIP"
(Left (EmptyCompressedPayload ZIP))
(decompressPkt (CompressedDataPkt ZIP ""))
)
, testCase
"decompressPkt classifies empty Uncompressed payload"
( assertEqual
"empty Uncompressed"
(Left (EmptyCompressedPayload Uncompressed))
(decompressPkt (CompressedDataPkt Uncompressed ""))
)
, testCase
"decompressPkt classifies marker-only ZIP payload"
( let markerPkt = MarkerPkt "\x50\x47\x50"
compressed = compressPkts ZIP [markerPkt]
in assertEqual
"marker-only"
(Left (MarkerOnlyPayload ZIP))
(decompressPkt compressed)
)
, testCase
"decompressPkt passes through non-compressed packets"
( let pkt = OtherPacketPkt 255 ""
in assertEqual
"passthrough"
(Right [pkt])
(decompressPkt pkt)
)
]
, testGroup
"Conduit length group"
[ testCase
"conduitCompress (ZIP)"
( testConduitOutputLength
"pubring.gpg"
(cgp DC..| conduitCompress ZIP)
1
)
, testCase
"conduitCompress (Zlib)"
( testConduitOutputLength
"pubring.gpg"
(cgp DC..| conduitCompress ZLIB)
1
)
, testCase
"conduitCompress (BZip2)"
( testConduitOutputLength
"pubring.gpg"
(cgp DC..| conduitCompress BZip2)
1
)
, testCase
"conduitToTKsDroppingEither"
( testConduitOutputLength
"pubring.gpg"
(cgp DC..| conduitToTKsDroppingEither)
4
)
, testCase
"conduitToSomeTKsDroppingEither"
( testConduitOutputLength
"pubring.gpg"
(cgp DC..| conduitToSomeTKsDroppingEither)
4
)
, testCase
"conduitToTKsEither reports parse failures"
testConduitToTKsEitherReportsParseFailure
, testCase
"conduitToSomeTKsEither reports parse failures"
testConduitToSomeTKsEitherReportsParseFailure
, testCase
"conduitToTKsDroppingEither reports parse failures"
testConduitToTKsDroppingEitherReportsParseFailure
, testCase
"conduitToSomeTKsDroppingEither reports parse failures"
testConduitToSomeTKsDroppingEitherReportsParseFailure
]
, testGroup
"Encrypted data"
( [ testCase
"Legacy symmetric encryption fixture shape"
testLegacyEncryptionFixtureShape
, testCase
"SEIPDv1 resync nonce/MDC roundtrip"
testSEIPDv1ResyncNonceMdcRoundTrip
]
++ map mkLegacySymmetricCase legacySymmetricCases
++ map mkStrictSymmetricCase strictSymmetricCases
++ [ testCase
"strict policy rejects SED (no MDC)"
( testStrictPolicyRejectsEncryption
"encryption-sym-cast5.gpg"
"symmetric-password.txt"
"unauthenticated SED"
)
, testCase
"strict policy rejects Simple S2K"
( testStrictPolicyRejectsEncryption
"encryption-sym-aes128-s2k0.gpg"
"symmetric-password.txt"
"Simple S2K specifier"
)
, testCase
"strict policy rejects non-encrypted packet after ESK prelude"
testRejectsNonEncryptedAfterESKPrelude
, testCase
"strict policy rejects SEIPDv2 with only misaligned ESK versions"
testRejectsMisalignedESKVersionForSEIPDv2
, testCase
"strict policy discards misaligned ESK when aligned ESK is present"
testDiscardsMisalignedESKWhenAlignedCandidateExists
, testCase
"strict policy rejects trailing data after SEIPD v2"
testTrailingDataRejectedStrictSEIPDv2
, testCase
"lenient policy reports DecryptTrailingData for trailing packet after SEIPD v2"
testTrailingDataReportedLenientSEIPDv2
, testCase
"conduitDecryptChecked reports DecryptClean for well-formed SEIPD v2"
testDecryptCleanSEIPDv2
, testCase
"conduitDecrypt matches conduitDecryptChecked (default)"
testOptionsMatchesCheckedDefaultSEIPDv2
, testCase
"conduitDecrypt matches legacy conduitDecrypt output (default)"
testOptionsMatchesLegacyDefaultOutputSEIPDv2
, testCase
"conduitDecrypt matches checked lenient trailing behavior"
testOptionsMatchesCheckedLenientTrailingSEIPDv2
]
)
, testGroup
"Encrypted secret keys"
[ testCase
"SUSSHA1 CAST5 IteratedSalted SHA1 RSA"
(testSecretKeyDecryption "simple.seckey" "pki-password.txt")
, testCase
"SUS16bit CAST5 IteratedSalted SHA1 RSA"
(testSecretKeyDecryption "16bitcksum.seckey" "pki-password.txt")
, testCase
"SUSSHA1 AES256 IteratedSalted SHA512 RSA"
(testSecretKeyDecryption "aes256-sha512.seckey" "pki-password.txt")
, testCase
"SUSSHA1 AES128 IteratedSalted SHA256 ECDSA"
( testSecretKeyDecryption
"nist_p-256_secretkey.gpg"
"pki-password.txt"
)
]
, testGroup
"Encrypting secret keys"
[ testCase
"legacy secret key encryption rejects implicit SHA-1 protection"
( testLegacySecretKeyEncryptionRejected
"unencrypted.seckey"
"pki-password.txt"
)
, testCase
"SUSym secret key roundtrips"
testSUSymSecretKeyRoundTrip
, testCase
"v6 secret key encryption roundtrips with SUSAEAD"
testV6SecretKeyEncryptionRoundTrip
, testCase
"v4 AEAD OCB secret key compatibility roundtrip"
testV4SecretKeyAEADOCBRoundTripCompat
]
, testGroup
"decrypt conduit stuff"
[ testCase
"conduitDecrypt supports PKESKv6 with raw session-key callback"
testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey
, testCase
"conduitDecrypt rejects invalid PKESKv6 raw session-key length"
testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength
, testCase
"conduitDecrypt unwraps PKESK RSA session keys in-library"
testConduitDecryptSEIPDv2WithPKESKRSAUnwrap
, testCase
"conduitDecrypt probes wildcard callback fallback for PKESKv3 RSA key-id packets"
testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback
, testCase
"conduitDecrypt unwraps PKESKv3 RSA session keys via SHA1-CFB protected key loaded from file"
testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey
, testCase
"parsed RSA secret key decrypts PKCS#1 v1.5 payload"
testParsedRSASecretKeyPKCS15DecryptNotMessageNotRecognized
, testCase
"conduitDecrypt unwraps PKESK ECDH session keys in-library"
testConduitDecryptSEIPDv2WithPKESKECDHUnwrap
, testCase
"conduitDecrypt rejects ECDH ephemeral points with wrong curve length"
testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength
, testCase
"conduitDecrypt unwraps PKESKv3 X25519 session keys in-library"
testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap
, testCase
"conduitDecrypt retries wildcard PKESKv3 keys across callback order"
testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder
, testCase
"conduitDecrypt retries wildcard PKESKv3 keys across long callback order"
testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder
, testCase
"conduitDecrypt retries wildcard PKESKv3 keys across long callback order for SEIPDv1"
testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder
, testCase
"unwrap callback decrypts wildcard PKESKv3 via candidates list"
testMkCandidateResolverDecryptsWildcardPKESKv3
, testCase
"conduitDecrypt wildcard resolver receives typed previous-failure diagnostics"
testConduitDecryptWildcardResolverProvidesTypedPreviousFailures
, testCase
"conduitDecryptWithReport surfaces wildcard resolver diagnostics"
testConduitDecryptWithReportCapturesWildcardResolverDiagnostics
, testCase
"conduitDecrypt rejects PKESKv3 X25519 ephemeral values with wrong length"
testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength
, testCase
"conduitDecrypt falls back from Argon2 SKESK to PKESKv3 X25519"
testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519
, testCase
"conduitDecrypt retries earlier Argon2 SKESKs when latest is unusable"
testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK
, testCase
"conduitDecrypt rejects ECDH KDF/KEK params outside RFC9580 Table 30"
testConduitDecryptSEIPDv2RejectsECDHNonTable30Params
, testCase
"conduitDecrypt allows v4 Curve25519Legacy RFC6637 accepted parameters"
testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams
, testCase
"conduitDecrypt allows v4 Curve25519Legacy with truncated wrapped MPI"
testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI
, testCase
"conduitDecrypt keeps v6 Curve25519Legacy ECDH strict"
testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params
, testCase
"conduitDecrypt unwraps PKESK X448 session keys in-library"
testConduitDecryptSEIPDv2WithPKESKX448Unwrap
, testCase
"conduitDecrypt rejects PKESKv6 X448 ephemeral values with wrong length"
testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength
, testCase
"encrypt-side session material encoding uses OpenPGP format"
testEncodeOpenPGPSessionMaterial
, testCase
"encrypt-side PKESK builder wraps RSA recipient session key"
testBuildPKESKPayloadForRecipientRSA
, testCase
"encrypt-side PKESKv3 builder supports RSA v4 interop"
testBuildPKESKv3PayloadForRecipientRSAInterop
, testCase
"encrypt-side PKESKv3 builder supports v6 recipients"
testBuildPKESKv3PayloadForRecipientSupportsV6Key
, testCase
"encrypt-side PKESKv3 builder supports RFC6637 ECDH recipients"
testBuildPKESKv3PayloadForRecipientECDHInterop
, testCase
"PKESKv3 ECDH serializer uses RFC 6637 wire format"
testPKESKv3ECDHWireFormat
, testCase
"encrypt-side PKESKv3 builder supports RFC6637 Curve25519Legacy recipients"
testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop
, testCase
"encrypt-side PKESKv3 builder rejects non-RFC6637 Curve448Legacy recipients"
testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy
, testCase
"RFC 9580 v6 X25519 PKESK uses raw-key semantics, not v3-encoded material"
testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics
, testCase
"RFC 9580 v6 X448 PKESK uses raw-key semantics, not v3-encoded material"
testBuildPKESKv6PayloadForRecipientX448RawKeySemantics
, testCase
"encrypt-side policy builder emits PKESK3 for ForceV3Interop"
testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop
, testCase
"encrypt-side profile helper honors recipient capability hints"
testRecipientVersionStrategyForProfileHonorsHints
, testCase
"encryptForRecipients auto-detects mixed recipient PKESK strategies"
testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies
, testCase
"encryptForRecipients negotiates symmetric algorithm from recipient capabilities when enabled"
testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled
, testCase
"encryptForRecipients negotiates recipient capabilities by default"
testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault
, testCase
"encryptForRecipientsLegacy preserves capability negotiation opt-out"
testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut
, testCase
"encryptForRecipients capability negotiation fails when recipients share no symmetric algorithm"
testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm
, testCase
"recipientCapabilitiesFromSubpacketPayloads extracts preferred AEAD algorithms"
testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms
, testCase
"encryptForRecipients negotiates AEAD algorithm from recipient capabilities when enabled"
testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled
, testCase
"encryptForRecipients capability negotiation fails when recipients share no AEAD algorithm"
testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm
, testCase
"encryptForRecipients falls back to SEIPDv1 when recipients do not advertise SEIPDv2 support"
testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2
, testCase
"encryptForRecipients rejects SEIPDv1 when recipients do not advertise MDC support"
testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC
, testCase
"recipientEncryptionTargetsFromTK returns only encryption-capable candidates"
testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys
, testCase
"recipientEncryptionTargetFromTK prefers encryption-capable subkeys"
testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary
, testCase
"recipientEncryptionTargetFromTK rejects TKs without encryptable key material"
testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys
, testCase
"recipientEncryptionTargetsReportFromTKAtTimestamp reports sign-only subkey rejection reasons"
testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections
, testCase
"recipientEncryptionTargetsReportFromTKAtTimestamp reports unsupported algorithm rejections"
testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms
, testCase
"recipientEncryptionTargetsReportFromTKAtTimestamp rejects expired subkeys"
testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey
, testCase
"recipientEncryptionTargetsReportFromTKAtTimestamp rejects revoked subkeys"
testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey
, testCase
"recipientEncryptionTargetsFromTKAtTimestamp extracts effective self-signature capabilities"
testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities
, testCase
"recipientEncryptionTargetFromTKAtTimestamp filters subkey self-signatures by timestamp"
testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering
, testCase
"recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer primary key"
testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary
, testCase
"recipientEncryptionTargetFromTKAtTimestampWithPolicy can prefer newest key"
testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest
, testCase
"recipientEncryptionTargetsFromTK excludes subkeys with non-encrypt key flags"
testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags
, testCase
"recipientEncryptionTargetsFromTK includes subkeys with no key flags advertised"
testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags
, testCase
"encryptForRecipients optionally emits one-pass signature packets"
testEncryptRecipientsWithRequestEmitsOnePassSignatures
, testCase
"encryptForRecipients one-pass mode requires issuer metadata"
testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing
, testCase
"encryptForRecipients with EncryptInteropLegacy produces SEIPDv1 and PKESKv3"
testEncryptInteropLegacyProducesSEIPDv1
, testCase
"encrypt-side PKESK builder reports unsupported recipient algorithms"
testBuildPKESKPayloadUnsupportedRecipient
, testCase
"encrypt-side ECDH PKESK builder rejects SHA1 KDF policy"
testBuildPKESKPayloadRejectsECDHSHA1
, testCase
"encrypt-side canonicalize PKESK recipient id helper"
testCanonicalizePKESKRecipientIdHelper
, testCase
"conduitDecrypt decrypts seipdv2 fixture with matching v6 secret key"
testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey
, testCase
"seipdv2-for-v4-key fixture parses as PKESKv6+SEIPDv2"
testSEIPDv2ForV4KeyArmor
, testCase
"conduitDecrypt decrypts seipdv2-for-v4-key fixture with matching v4 secret key"
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey
, testCase
"conduitDecrypt tries earlier PKESKs when latest is unusable"
testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK
, testCase
"conduitDecrypt matches valid recipient-id forms without caller retries"
testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations
, testCase
"conduitDecrypt fails PKESK exhaustion without manual session-key prompt"
testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial
, testCase
"seipdv2-two-recipients fixture parses as PKESKv6*2+SEIPDv2"
testSEIPDv2TwoRecipientsArmor
, testCase
"seipdv2-three-recipients fixture parses as PKESKv6*3+SEIPDv2"
testSEIPDv2ThreeRecipientsArmor
, testCase
"conduitDecrypt decrypts seipdv2-two-recipients fixture with matching v4 secret key"
testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey
, testCase
"conduitDecrypt decrypts reordered+bogus seipdv2-two-recipients PKESKs"
testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs
, testCase
"conduitDecrypt decrypts seipdv2-three-recipients fixture with matching v4 secret key"
testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey
, testCase
"conduitDecrypt decrypts reordered+bogus seipdv2-three-recipients PKESKs"
testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs
]
, testGroup
"ESK/SKESK/ArgonS2K"
[ testCase
"encoded session key rejects too-short payloads"
testDecodeOpenPGPEncodedSessionKeyRejectsTooShort
, testCase
"encoded session key rejects algorithm/key-length mismatches"
testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch
, testCase
"encoded session key rejects checksum mismatches"
testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch
, testCase
"unknown SKESK version is rejected"
testSKESKRejectsUnknownVersion
, testCase
"v4 SKESK encrypted session keys reject Simple S2K"
testSKESK4EncryptedSessionKeyRejectsSimpleS2K
, testCase
"v4 SKESK Argon2 encrypted ESK roundtrip across AES-128/192/256"
testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES
, testCase
"v4 SKESK Argon2 encrypted ESK rejects legacy checksum trailer"
testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum
, testCase
"passphrase SKESK policy ForceV4Interop emits SKESKv4 + SEIPDv1"
testEncryptPassphraseWithPolicyForceV4Interop
, testCase
"passphrase SKESK policy PreferV6 emits SKESKv6 + SEIPDv2"
testEncryptPassphraseWithPolicyPreferV6
, testCase "Argon2 S2K derivation vector" testArgon2S2KVector
, testCase "Argon2 S2K Ord instance is total" testArgon2S2KOrdTotal
]
]
testCompression :: FilePath -> Assertion
testCompression fpr = do
bs <- BL.readFile $ "tests/data/" ++ fpr
let firstpass =
fmap (concatMap (either (const []) id . decompressPkt) . unBlock)
. runGet get
$ bs
case firstpass of
Left _ -> assertFailure $ "First pass failed on " ++ fpr
Right [] ->
assertFailure $ "First pass of " ++ fpr ++ " decoded to nothing."
Right packs -> do
let roundtrip = runPut $ put . Block $ [compressPkts ZIP packs]
let secondpass =
fmap (concatMap (either (const []) id . decompressPkt) . unBlock)
. runGet get
$ roundtrip
if secondpass == Right []
then
assertFailure $
"Second pass of " ++ fpr ++ " decoded to nothing."
else assertEqual ("for " ++ fpr) firstpass secondpass
counter :: (Monad m) => DC.ConduitT a DC.Void m Int
counter = CL.fold (const . (1 +)) 0
testConduitOutputLength
:: FilePath
-> DC.ConduitT B.ByteString b (ResourceT IO) ()
-> Int
-> Assertion
testConduitOutputLength fpr c target = do
len <-
DC.runConduitRes $
CB.sourceFile ("tests/data/" ++ fpr) DC..| c DC..| counter
assertEqual ("expected length " ++ show target) target len
testConduitToTKsEitherReportsParseFailure :: Assertion
testConduitToTKsEitherReportsParseFailure = do
results <-
DC.runConduitRes $
CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg"
DC..| conduitGet get
DC..| conduitToTKsEither
DC..| CL.consume
assertBool
"conduitToTKsEither should report parse failures for non-key packet streams"
(any (either (const True) (const False)) results)
testConduitToTKsDroppingEitherReportsParseFailure :: Assertion
testConduitToTKsDroppingEitherReportsParseFailure = do
results <-
DC.runConduitRes $
CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg"
DC..| conduitGet get
DC..| conduitToTKsDroppingEither
DC..| CL.consume
assertBool
"conduitToTKsDroppingEither should report parse failures for non-key packet streams"
(any (either (const True) (const False)) results)
testConduitToSomeTKsEitherReportsParseFailure :: Assertion
testConduitToSomeTKsEitherReportsParseFailure = do
results <-
DC.runConduitRes $
CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg"
DC..| conduitGet get
DC..| conduitToSomeTKsEither
DC..| CL.consume
assertBool
"conduitToSomeTKsEither should report parse failures for non-key packet streams"
(any (either (const True) (const False)) results)
testConduitToSomeTKsDroppingEitherReportsParseFailure
:: Assertion
testConduitToSomeTKsDroppingEitherReportsParseFailure = do
results <-
DC.runConduitRes $
CB.sourceFile "tests/data/uncompressed-ops-rsa.gpg"
DC..| conduitGet get
DC..| conduitToSomeTKsDroppingEither
DC..| CL.consume
assertBool
"conduitToSomeTKsDroppingEither should report parse failures for non-key packet streams"
(any (either (const True) (const False)) results)
-- This needs a lot of work
{- | Decrypt a symmetric-encrypted fixture using 'defaultDecryptPolicy' and
assert the packet structure is SKESK + SEIPDv1 and the cleartext matches.
Only suitable for AES-128/192/256 fixtures with iterated-salted S2K.
-}
testSymmetricEncryption
:: FilePath -> FilePath -> BL.ByteString -> Assertion
testSymmetricEncryption encfile passfile cleartext = do
passphrase <- readFixtureLazy passfile
pt <- readFixturePackets encfile
assertEqual "wrong number of packets" 2 (length pt)
skesk <-
case pt of
[] ->
assertFailure
( "expected SKESK packet in "
++ encfile
++ " but packet list was empty"
)
>> fail "empty fixture packet list"
(firstPkt : _) ->
case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of
Left err ->
assertFailure ("failed to coerce first packet to SKESK: " ++ err)
>> fail err
Right x -> pure x
assertEqual
"first packet should be SKESK"
SKESKType
(packetType skesk)
case last pt of
SymEncIntegrityProtectedDataPkt (SEIPD1 1 _) -> pure ()
other ->
assertFailure
( "second packet should be SEIPDv1 (tag 18, version 1), got: "
++ show other
)
decrypted <-
catch
( DC.runConduitRes $
CL.sourceList pt
DC..| conduitDecrypt (fakeCallback passphrase)
DC..| CL.consume
)
( \e -> do
let err = show (e :: SomeException)
assertFailure ("decryption threw exception: " ++ err)
)
payload <-
case decrypted of
[] ->
assertFailure ("decryption produced no packets for " ++ encfile)
>> fail "expected decrypted literal packet"
(firstDecrypted : _) ->
case (fromPktEither firstDecrypted :: Either String LiteralData) of
Left err ->
assertFailure
("failed to coerce decrypted packet to literal data: " ++ err)
>> fail err
Right x -> pure (_literalDataPayload x)
assertEqual ("cleartext for " ++ encfile) cleartext payload
where
fakeCallback :: BL.ByteString -> String -> IO BL.ByteString
fakeCallback = const . return
testSEIPDv1ResyncNonceMdcRoundTrip :: Assertion
testSEIPDv1ResyncNonceMdcRoundTrip = do
let sa = AES256
keyBytes = B.pack [0 .. 31]
iv = IV (B.pack [32 .. 47])
cleartext = B.pack [1 .. 80]
cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext
ciphertext <-
either
( \e ->
assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e)
>> pure mempty
)
pure
( encryptOpenPGPCfbRaw
OpenPGPCFBResyncW
sa
iv
cleartextWithMDC
keyBytes
)
(nonce, decrypted) <-
either
( \e ->
assertFailure ("decryptOpenPGPCfbWithNonce failed: " ++ show e)
>> pure (mempty, mempty)
)
pure
(decryptOpenPGPCfbWithNonce sa ciphertext keyBytes)
assertEqual
"SEIPDv1 nonce should match IV||IV[-2:]"
(seipdv1NonceFromIV iv)
nonce
assertEqual
"decrypted bytes should include payload+MDC"
cleartextWithMDC
decrypted
payloadOut <-
either
( \err ->
assertFailure ("validateSEIPD1MDC failed: " ++ err)
>> pure mempty
)
pure
(validateSEIPD1MDC nonce decrypted)
assertEqual
"MDC-verified payload should round-trip"
cleartext
payloadOut
{- | Like 'testSymmetricEncryption' but uses 'lenientDecryptPolicy' to permit
legacy RFC4880/RFC2440 message formats (SED, deprecated S2K, old ciphers).
The 'Bool' indicates whether the fixture uses SEIPDv1 (True) or SED (False).
-}
testLegacySymmetricEncryption
:: Bool -> FilePath -> FilePath -> BL.ByteString -> Assertion
testLegacySymmetricEncryption expectSEIPDv1 encfile passfile cleartext = do
passphrase <- readFixtureLazy passfile
pt <- readFixturePackets encfile
assertEqual "wrong number of packets" 2 (length pt)
skesk <-
case pt of
[] ->
assertFailure
( "expected SKESK packet in "
++ encfile
++ " but packet list was empty"
)
>> fail "empty fixture packet list"
(firstPkt : _) ->
case (fromPktEither firstPkt :: Either String (SKESK 'SKESKV4)) of
Left err ->
assertFailure ("failed to coerce first packet to SKESK: " ++ err)
>> fail err
Right x -> pure x
assertEqual
"first packet should be SKESK"
SKESKType
(packetType skesk)
case last pt of
SymEncDataPkt {}
| not expectSEIPDv1 -> pure ()
| otherwise ->
assertFailure
"expected SEIPDv1 packet (tag 18) but got SED (tag 9)"
SymEncIntegrityProtectedDataPkt (SEIPD1 1 _)
| expectSEIPDv1 -> pure ()
| otherwise ->
assertFailure
"expected SED packet (tag 9) but got SEIPDv1 (tag 18)"
other -> assertFailure ("unexpected second packet: " ++ show other)
decrypted <-
catch
( DC.runConduitRes $
CL.sourceList pt
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
(\_ -> pure Nothing)
(fakeCallback passphrase)
DC..| CL.consume
)
( \e -> do
let err = show (e :: SomeException)
assertFailure ("decryption threw exception: " ++ err)
)
payload <-
case decrypted of
[] ->
assertFailure ("decryption produced no packets for " ++ encfile)
>> fail "expected decrypted literal packet"
(firstDecrypted : _) ->
case (fromPktEither firstDecrypted :: Either String LiteralData) of
Left err ->
assertFailure
("failed to coerce decrypted packet to literal data: " ++ err)
>> fail err
Right x -> pure (_literalDataPayload x)
assertEqual ("cleartext for " ++ encfile) cleartext payload
where
fakeCallback :: BL.ByteString -> String -> IO BL.ByteString
fakeCallback = const . return
{- | Assert that decrypting with the strict 'defaultDecryptPolicy' throws an
exception whose message contains the given substring.
-}
testStrictPolicyRejectsEncryption
:: FilePath -> FilePath -> String -> Assertion
testStrictPolicyRejectsEncryption encfile passfile expectedFragment = do
passphrase <- readFixtureLazy passfile
pt <- readFixturePackets encfile
result <-
try
( DC.runConduitRes $
CL.sourceList pt
DC..| conduitDecrypt (fakeCallback passphrase)
DC..| CL.consume
)
:: IO (Either SomeException [Pkt])
case result of
Right _ ->
assertFailure $
"Expected strict policy to reject '"
++ encfile
++ "' with error containing '"
++ expectedFragment
++ "', but decryption succeeded"
Left err ->
assertBool
( "Expected error containing '"
++ expectedFragment
++ "', got: "
++ show err
)
(expectedFragment `isInfixOf` show err)
where
fakeCallback :: BL.ByteString -> String -> IO BL.ByteString
fakeCallback = const . return
-- | Decrypt a file and check the 'DecryptOutcome'.
testDecryptOutcome
:: FilePath -> FilePath -> DecryptOutcome -> Assertion
testDecryptOutcome encfile passfile expectedOutcome = do
passphrase <- readFixtureLazy passfile
pt <- readFixturePackets encfile
(outcome, _pkts) <-
catch
( DC.runConduitRes $
CL.sourceList pt
DC..| fuseBoth
(conduitDecryptChecked (fakeCallback passphrase))
CL.consume
)
( \e -> do
let err = show (e :: SomeException)
assertFailure ("decryption threw unexpected exception: " ++ err)
fail "unreachable"
)
assertEqual
("DecryptOutcome for " ++ encfile)
expectedOutcome
outcome
where
fakeCallback :: BL.ByteString -> String -> IO BL.ByteString
fakeCallback = const . return
{- | Build a synthetic packet list with an appended trailing packet, decrypt
with lenient policy, and verify 'DecryptTrailingData' is reported.
-}
testTrailingDataReportedLenient
:: FilePath -> FilePath -> Assertion
testTrailingDataReportedLenient encfile passfile = do
passphrase <- readFixtureLazy passfile
pt <- readFixturePackets encfile
let trailingPkt = OtherPacketPkt 0xFE ""
ptWithTrailing = pt ++ [trailingPkt]
(outcome, _pkts) <-
catch
( DC.runConduitRes $
CL.sourceList ptWithTrailing
DC..| fuseBoth
( conduitDecryptCheckedWithDecryptPolicy
lenientDecryptPolicy
(\_ -> pure Nothing)
(fakeCallback passphrase)
)
CL.consume
)
( \e -> do
let err = show (e :: SomeException)
assertFailure
("lenient decrypt threw unexpected exception: " ++ err)
fail "unreachable"
)
assertEqual
("DecryptTrailingData for " ++ encfile)
DecryptTrailingData
outcome
where
fakeCallback :: BL.ByteString -> String -> IO BL.ByteString
fakeCallback = const . return
{- | Same as above but with strict policy: should throw "after message
integrity boundary".
-}
testTrailingDataRejectedStrict
:: FilePath -> FilePath -> Assertion
testTrailingDataRejectedStrict encfile passfile = do
passphrase <- readFixtureLazy passfile
pt <- readFixturePackets encfile
let trailingPkt = OtherPacketPkt 0xFE ""
ptWithTrailing = pt ++ [trailingPkt]
result <-
try
( DC.runConduitRes $
CL.sourceList ptWithTrailing
DC..| fuseBoth
(conduitDecryptChecked (fakeCallback passphrase))
CL.consume
)
:: IO (Either SomeException (DecryptOutcome, [Pkt]))
case result of
Left err ->
assertFailure
( "Expected DecryptMalformedStructure but got exception: "
++ show err
)
Right (DecryptMalformedStructure malformedReason, _) ->
assertBool
( "Expected 'after message integrity boundary', got: "
++ malformedReason
)
("after message integrity boundary" `isInfixOf` malformedReason)
Right (other, _) ->
assertFailure
("Expected DecryptMalformedStructure but got: " ++ show other)
where
fakeCallback :: BL.ByteString -> String -> IO BL.ByteString
fakeCallback = const . return
encryptedSEIPDv2Packets :: IO [Pkt]
encryptedSEIPDv2Packets = do
let passphrase =
mkPassphrase
(BL.pack (map (fromIntegral . fromEnum) ("test" :: String)))
payload =
mkClearPayload
(BL.pack (map (fromIntegral . fromEnum) ("hello" :: String)))
let result =
encryptMessageDefault
DoNotExposeSessionMaterial
passphrase
payload
case result of
Left err ->
fail
( "encryptedSEIPDv2Packets: encryptMessageDefault failed: "
++ show err
)
Right (encPayload, _) ->
DC.runConduitRes $
CB.sourceLbs (encryptedPayloadBytes encPayload)
DC..| conduitGet get
DC..| CL.consume
defaultOptionsForPassphrase :: BL.ByteString -> DecryptOptions
defaultOptionsForPassphrase passphrase =
DecryptOptions
{ decryptOptionsKeyResolution = DecryptWithoutPKESK
, decryptOptionsPolicy = defaultDecryptPolicy
, decryptOptionsPassphraseCallback = const (pure passphrase)
}
testDecryptCleanSEIPDv2 :: Assertion
testDecryptCleanSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
(outcome, _) <-
catch
( DC.runConduitRes $
CL.sourceList pt
DC..| fuseBoth (conduitDecryptChecked cb) CL.consume
)
( \e ->
assertFailure
("unexpected exception: " ++ show (e :: SomeException))
>> fail "unreachable"
)
assertEqual
"clean SEIPD v2 should yield DecryptClean"
DecryptClean
outcome
testOptionsMatchesCheckedDefaultSEIPDv2 :: Assertion
testOptionsMatchesCheckedDefaultSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
opts = defaultOptionsForPassphrase passphrase
checkedResult <-
DC.runConduitRes $
CL.sourceList pt
DC..| fuseBoth (conduitDecryptChecked cb) CL.consume
optionsResult <-
DC.runConduitRes $
CL.sourceList pt
DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume
assertEqual
"options conduit should match checked conduit on clean decrypt"
checkedResult
optionsResult
testOptionsMatchesLegacyDefaultOutputSEIPDv2 :: Assertion
testOptionsMatchesLegacyDefaultOutputSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
opts = defaultOptionsForPassphrase passphrase
legacyOutput <-
DC.runConduitRes $
CL.sourceList pt DC..| conduitDecrypt cb DC..| CL.consume
(optionsOutcome, optionsOutput) <-
DC.runConduitRes $
CL.sourceList pt
DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume
assertEqual
"options conduit should report DecryptClean for clean stream"
DecryptClean
optionsOutcome
assertEqual
"legacy conduit output should match options conduit output"
legacyOutput
optionsOutput
testTrailingDataRejectedStrictSEIPDv2 :: Assertion
testTrailingDataRejectedStrictSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""]
passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
result <-
try
( DC.runConduitRes $
CL.sourceList ptWithTrailing
DC..| fuseBoth (conduitDecryptChecked cb) CL.consume
)
:: IO (Either SomeException (DecryptOutcome, [Pkt]))
case result of
Left err ->
assertFailure
( "Expected DecryptMalformedStructure but got exception: "
++ show err
)
Right (DecryptMalformedStructure reason, _) ->
assertBool
("Expected 'after message integrity boundary', got: " ++ reason)
("after message integrity boundary" `isInfixOf` reason)
Right (other, _) ->
assertFailure
( "Expected strict policy to reject trailing data but got: "
++ show other
)
testTrailingDataReportedLenientSEIPDv2 :: Assertion
testTrailingDataReportedLenientSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""]
passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
(outcome, _) <-
catch
( DC.runConduitRes $
CL.sourceList ptWithTrailing
DC..| fuseBoth
( conduitDecryptCheckedWithDecryptPolicy
lenientDecryptPolicy
(\_ -> pure Nothing)
cb
)
CL.consume
)
( \e ->
assertFailure
("unexpected exception: " ++ show (e :: SomeException))
>> fail "unreachable"
)
assertEqual
"trailing packet should yield DecryptTrailingData"
DecryptTrailingData
outcome
testOptionsMatchesCheckedLenientTrailingSEIPDv2 :: Assertion
testOptionsMatchesCheckedLenientTrailingSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let ptWithTrailing = pt ++ [OtherPacketPkt 0xFE ""]
passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
opts =
DecryptOptions
{ decryptOptionsKeyResolution = DecryptWithoutPKESK
, decryptOptionsPolicy = lenientDecryptPolicy
, decryptOptionsPassphraseCallback = cb
}
checkedResult <-
DC.runConduitRes $
CL.sourceList ptWithTrailing
DC..| fuseBoth
( conduitDecryptCheckedWithDecryptPolicy
lenientDecryptPolicy
(\_ -> pure Nothing)
cb
)
CL.consume
optionsResult <-
DC.runConduitRes $
CL.sourceList ptWithTrailing
DC..| fuseBoth (DCD.conduitDecrypt opts) CL.consume
assertEqual
"options conduit should match checked lenient conduit with trailing data"
checkedResult
optionsResult
testRejectsNonEncryptedAfterESKPrelude :: Assertion
testRejectsNonEncryptedAfterESKPrelude = do
pt <- encryptedSEIPDv2Packets
let malformed =
case pt of
[] -> []
esk : _ ->
[ esk
, LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
"not-encrypted"
]
passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
result <-
try
( DC.runConduitRes $
CL.sourceList malformed
DC..| fuseBoth (conduitDecryptChecked cb) CL.consume
)
:: IO (Either SomeException (DecryptOutcome, [Pkt]))
case result of
Left err ->
assertFailure
( "Expected DecryptMalformedStructure but got exception: "
++ show err
)
Right (DecryptMalformedStructure reason, _) ->
assertBool
("Expected ESK prelude shape failure, got: " ++ reason)
( "ESK packets must immediately precede encrypted data"
`isInfixOf` reason
)
Right (other, _) ->
assertFailure
("Expected DecryptMalformedStructure but got: " ++ show other)
testRejectsMisalignedESKVersionForSEIPDv2 :: Assertion
testRejectsMisalignedESKVersionForSEIPDv2 = do
pt <- encryptedSEIPDv2Packets
let malformed =
case pt of
( SKESKPkt (SKESKPayloadV6Packet (SKESKPayloadV6 sa _ s2k _ _ _))
: rest
) ->
SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing))
: rest
_ -> pt
passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
result <-
try
( DC.runConduitRes $
CL.sourceList malformed
DC..| fuseBoth (conduitDecryptChecked cb) CL.consume
)
:: IO (Either SomeException (DecryptOutcome, [Pkt]))
case result of
Left err ->
assertFailure
( "Expected DecryptMalformedStructure but got exception: "
++ show err
)
Right (DecryptMalformedStructure reason, _) ->
assertBool
("Expected payload/ESK alignment failure, got: " ++ reason)
("version-aligned" `isInfixOf` reason)
Right (other, _) ->
assertFailure
("Expected DecryptMalformedStructure but got: " ++ show other)
testDiscardsMisalignedESKWhenAlignedCandidateExists :: Assertion
testDiscardsMisalignedESKWhenAlignedCandidateExists = do
pt <- encryptedSEIPDv2Packets
let withMixedPrelude =
case pt of
( SKESKPkt
(SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag))
: rest
) ->
SKESKPkt (SKESKPayloadV4Packet (SKESKPayloadV4 sa s2k Nothing))
: SKESKPkt
(SKESKPayloadV6Packet (SKESKPayloadV6 sa aa s2k iv esk tag))
: rest
_ -> pt
passphrase = BL.pack (map (fromIntegral . fromEnum) ("test" :: String))
cb = const (pure passphrase)
(outcome, _) <-
catch
( DC.runConduitRes $
CL.sourceList withMixedPrelude
DC..| fuseBoth (conduitDecryptChecked cb) CL.consume
)
( \e ->
assertFailure
("unexpected exception: " ++ show (e :: SomeException))
>> fail "unreachable"
)
assertEqual
"misaligned ESKs should be discarded when an aligned ESK is present"
DecryptClean
outcome
testSecretKeyDecryption :: FilePath -> FilePath -> Assertion
testSecretKeyDecryption keyfile passfile = do
passphrase <- readFixtureLazy passfile
kr <-
DC.runConduitRes $
CB.sourceFile (fixturePath keyfile)
DC..| conduitGet get
DC..| CL.consume
SecretKey pkp ska <-
case kr of
[] ->
assertFailure
("no packets found in secret key fixture " ++ keyfile)
>> fail "empty secret key fixture"
(firstPkt : _) ->
case (fromPktEither firstPkt :: Either String SecretKey) of
Left err ->
assertFailure
("failed to coerce key packet to SecretKey: " ++ err)
>> fail err
Right x -> pure x
decrypted <-
case decryptPrivateKey (pkp, ska) passphrase of
Left err ->
assertFailure ("secret key decryption failed: " ++ err)
>> fail "secret key decryption failed"
Right x -> pure x
case decrypted of
SUUnencrypted skey _ -> doPkeyAndSkeyMatch (_pubkey pkp) skey
other ->
assertFailure
( "secret key decryption should produce an unencrypted secret key, got: "
++ show other
)
testLegacySecretKeyEncryptionRejected
:: FilePath -> FilePath -> Assertion
testLegacySecretKeyEncryptionRejected keyfile passfile = do
passphrase <- readFixtureLazy passfile
kr <-
DC.runConduitRes $
CB.sourceFile (fixturePath keyfile)
DC..| conduitGet get
DC..| CL.consume
SecretKey pkp ska <-
case kr of
[] ->
assertFailure
("no packets found in secret key fixture " ++ keyfile)
>> fail "empty secret key fixture"
(firstPkt : _) ->
case (fromPktEither firstPkt :: Either String SecretKey) of
Left err ->
assertFailure
("failed to coerce key packet to SecretKey: " ++ err)
>> fail err
Right x -> pure x
case encryptPrivateKeyWithPolicyAndSaltAndIV
defaultPolicy
pkp
(Salt "\226~\197\a\202#\"G")
(IV "\187\219\253I\236\204\t5D\196\NAK>;\202\185\t")
ska
passphrase of
Left err | "explicit legacy override required" `isInfixOf` err -> pure ()
Left err ->
assertFailure
( "legacy secret key encryption should be rejected with a policy error, got: "
++ err
)
Right _ ->
assertFailure
"legacy secret key encryption should reject implicit SHA-1 protection"
testV6SecretKeyEncryptionRoundTrip :: Assertion
testV6SecretKeyEncryptionRoundTrip = do
passphrase <- readPKIPassphrase
armors <- loadArmor "v6-secret.pgp.aa"
armor <-
case armors of
(a : _) -> pure a
[] ->
assertFailure
"v6-secret.pgp.aa should contain one armored payload"
>> fail "expected one armored payload"
let packets = parsePkts (armorPayload armor)
SecretKey pkp ska <-
case [ sk
| pkt <- packets
, Right sk <- [fromPktEither pkt :: Either String SecretKey]
] of
(sk : _) -> pure sk
[] ->
assertFailure
"v6-secret.pgp.aa should contain a secret key packet"
>> fail "expected secret key packet"
originalSKey <-
case ska of
SUUnencrypted skey _ -> pure skey
_ ->
assertFailure
"v6-secret.pgp.aa should contain unencrypted secret key material"
>> fail "expected unencrypted secret key"
changed <-
case encryptPrivateKeyWithPolicyAndSaltAndIV
defaultPolicy
pkp
(Salt "1234567890ABCDEF")
(IV "1234567890ABCDE")
ska
passphrase of
Left err ->
assertFailure ("v6 secret key encryption failed: " ++ err)
>> fail "v6 secret key encryption failed"
Right x -> pure x
case changed of
SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do
assertEqual
"v6 secret key encryption should use expected Argon2 t parameter"
1
t
assertEqual
"v6 secret key encryption should use expected Argon2 p parameter"
4
p
assertEqual
"v6 secret key encryption should use expected Argon2 encoded memory parameter"
15
em
assertBool
"v6 secret key encryption should emit encrypted payload"
(not (BL.null encryptedPayload))
_ ->
assertFailure
"v6 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K"
let serialized = runPut (put (toPkt (SecretKey pkp changed)))
reparsed = parsePkts serialized
(parsedPKP, parsedSKA) <-
case reparsed of
(SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum)
_ ->
assertFailure
"re-serialized v6 secret key should parse back as a secret key packet"
>> fail "expected serialized secret key packet"
decrypted <-
case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of
Left err ->
assertFailure
("v6 secret key roundtrip decryption failed: " ++ err)
>> fail "v6 secret key roundtrip decryption failed"
Right x -> pure x
case decrypted of
SUUnencrypted skey _ ->
assertEqual
"v6 secret key roundtrip should preserve secret key material"
originalSKey
skey
_ ->
assertFailure
"v6 secret key roundtrip should decrypt to unencrypted secret material"
testV4SecretKeyAEADOCBRoundTripCompat :: Assertion
testV4SecretKeyAEADOCBRoundTripCompat = do
(pkp, privateKey) <- loadUnencryptedRsaSigner
let skey = RSAPrivateKey (RSA_PrivateKey privateKey)
passphrase = "legacy-aead-passphrase"
compatPolicy =
(policyForRFC RFC4880)
{ policySecretKeyProtection =
policySecretKeyProtection defaultPolicy
}
salt = Salt (B.pack [0x00 .. 0x0f])
iv = IV (B.pack [0x10 .. 0x1e])
encrypted <-
case encryptPrivateKeyWithPolicyAndSaltAndIV
compatPolicy
pkp
salt
iv
(SUUnencrypted skey 0)
passphrase of
Left err ->
assertFailure ("v4 AEAD secret key encryption failed: " ++ err)
>> fail "v4 AEAD secret key encryption failed"
Right x -> pure x
case encrypted of
SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do
assertEqual
"v4 AEAD secret key encryption should use expected Argon2 t"
1
t
assertEqual
"v4 AEAD secret key encryption should use expected Argon2 p"
4
p
assertEqual
"v4 AEAD secret key encryption should use expected Argon2 encoded-memory"
15
em
assertBool
"v4 AEAD secret key encryption should emit encrypted payload"
(not (BL.null encryptedPayload))
_ ->
assertFailure
"v4 secret key encryption should emit SUSAEAD/AES256/OCB with Argon2 S2K"
let serialized = runPut (put (toPkt (SecretKey pkp encrypted)))
reparsed = parsePkts serialized
(parsedPKP, parsedSKA) <-
case reparsed of
(SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum)
_ ->
assertFailure
"re-serialized v4 AEAD secret key should parse back as a secret key packet"
>> fail "expected serialized secret key packet"
decrypted <-
case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of
Left err ->
assertFailure
("v4 AEAD secret key roundtrip decryption failed: " ++ err)
>> fail "v4 AEAD secret key roundtrip decryption failed"
Right x -> pure x
case decrypted of
SUUnencrypted skey' _ ->
assertEqual
"v4 AEAD secret key roundtrip should preserve secret key material"
skey
skey'
_ ->
assertFailure
"v4 AEAD secret key roundtrip should decrypt to unencrypted secret material"
testSUSymSecretKeyRoundTrip :: Assertion
testSUSymSecretKeyRoundTrip = do
passphrase <- readPKIPassphrase
packets <-
DC.runConduitRes $
CB.sourceFile "tests/data/unencrypted.seckey"
DC..| conduitGet get
DC..| CL.consume
(pkp, skey) <-
case packets of
(SecretKeyPkt pkpayload (SUUnencrypted sk _) : _) -> pure (pkpayload, sk)
_ ->
assertFailure
"unencrypted.seckey did not begin with an unencrypted secret key packet"
>> fail "expected unencrypted secret key packet"
let cleartext = legacyRsaSecretKeyBytes skey
cleartextLBS = BL.fromStrict cleartext
clearWithChecksum =
cleartextLBS <> runPut (putWord16be (legacyChecksum16 cleartext))
iv = IV (B.pack [0 .. 15])
sa = AES128
keyMaterial <-
case string2Key (Simple DeprecatedMD5) 16 passphrase of
Left err ->
assertFailure
("failed to derive SUSym key material: " ++ renderS2KError err)
>> fail "failed to derive SUSym key material"
Right km -> pure km
encrypted <-
case encryptNoNonce
sa
(Simple DeprecatedMD5)
iv
(BL.toStrict clearWithChecksum)
keyMaterial of
Left err ->
assertFailure
("failed to encrypt legacy SUSym secret key: " ++ show err)
>> fail "failed to encrypt legacy SUSym secret key"
Right bs -> pure bs
let legacySka = SUSym sa iv (BL.fromStrict encrypted)
serialized = runPut (put (toPkt (SecretKey pkp legacySka)))
reparsed = parsePkts serialized
(parsedPKP, parsedSKA) <-
case reparsed of
(SecretKeyPkt pkpayload skaddendum : _) -> pure (pkpayload, skaddendum)
_ ->
assertFailure
"serialized SUSym secret key should parse back as a secret key packet"
>> fail "expected serialized secret key packet"
decrypted <-
case decryptPrivateKey (parsedPKP, parsedSKA) passphrase of
Left err ->
assertFailure ("SUSym secret key decryption failed: " ++ err)
>> fail "SUSym secret key decryption failed"
Right x -> pure x
case decrypted of
SUUnencrypted parsedSKey _ ->
assertEqual
"SUSym secret key roundtrip should preserve secret key material"
skey
parsedSKey
_ ->
assertFailure
"SUSym secret key roundtrip should decrypt to unencrypted secret material"
legacyRsaSecretKeyBytes :: SKey -> B.ByteString
legacyRsaSecretKeyBytes (RSAPrivateKey (RSA_PrivateKey (RSA.PrivateKey _ d p q _ _ _))) =
BL.toStrict $
runPut $
case inverse q p of
Just u -> do
put (MPI d)
put (MPI p)
put (MPI q)
put (MPI u)
Nothing -> error "invalid RSA key in legacy secret key test"
legacyRsaSecretKeyBytes _ = error "legacyRsaSecretKeyBytes requires an RSA secret key"
legacyChecksum16 :: B.ByteString -> Word16
legacyChecksum16 =
fromIntegral
. B.foldl'
(\acc octet -> (acc + fromIntegral octet) `mod` (65536 :: Integer))
0
testLegacyEncryptionFixtureShape :: Assertion
testLegacyEncryptionFixtureShape = do
packets <-
DC.runConduitRes $
CB.sourceFile "tests/data/encryption.gpg"
DC..| conduitGet get
DC..| CL.consume
let hasKeyEncapsulation = any isKeyEncapsulation packets
hasEncryptedData = any isEncryptedData packets
assertBool
"encryption.gpg should contain PKESK or SKESK key-encapsulation"
hasKeyEncapsulation
assertBool
"encryption.gpg should contain encrypted data"
hasEncryptedData
where
isKeyEncapsulation (SKESKPkt _) = True
isKeyEncapsulation (PKESKPkt _) = True
isKeyEncapsulation _ = False
isEncryptedData SymEncDataPkt {} = True
isEncryptedData SymEncIntegrityProtectedDataPkt {} = True
isEncryptedData _ = False
testBuildPKESKPayloadForRecipientRSA :: Assertion
testBuildPKESKPayloadForRecipientRSA = do
(baseRecipient, privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V6 baseRecipient
sessionKey = SessionKey (B.replicate 32 0x2e)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk builder rsa payload"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
PKESKRecipientKey
{ pkeskRecipientPKPayload = Nothing
, pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey)
}
)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskPayloadResult <-
buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial
pkeskPayload <-
case pkeskPayloadResult of
Left err ->
assertFailure
("buildPKESKPayloadForRecipient failed: " ++ show err)
>> fail "buildPKESKPayloadForRecipient failed"
Right p -> pure p
case pkeskPayload of
PKESKPayloadV6Packet (PKESKPayloadV6 _ RSA eskBytesLazy) -> do
let eskBytes = BL.toStrict eskBytesLazy
assertBool
"PKESKv6 RSA ESK should include MPI framing"
(B.length eskBytes >= 2)
let mpiBits =
fromIntegral (B.index eskBytes 0) * 256
+ fromIntegral (B.index eskBytes 1)
mpiLen = (mpiBits + 7) `div` 8
assertEqual
"PKESKv6 RSA ESK should be exactly one RFC9580 MPI"
(2 + mpiLen)
(B.length eskBytes)
other ->
assertFailure
("Expected PKESKv6 RSA payload, got " ++ show other)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ PKESKPkt pkeskPayload
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESK builder RSA decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testBuildPKESKv3PayloadForRecipientRSAInterop :: Assertion
testBuildPKESKv3PayloadForRecipientRSAInterop = do
(baseRecipient, privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V4 baseRecipient
sessionKey = SessionKey (B.replicate 32 0x2d)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk builder rsa v3 interop payload"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyCallback _ = pure (Just (RSAPrivateKey (RSA_PrivateKey privateKey)))
keyContextCallback pkt = do
msk <- keyCallback pkt
pure $
fmap
( \sk ->
PKESKRecipientKey
{ pkeskRecipientPKPayload = Nothing
, pkeskRecipientSKey = sk
}
)
msk
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskPayloadResult <-
buildPKESKv3PayloadForRecipient
recipient
(pkeskV3SessionMaterial sessionMaterial)
pkeskPayload <-
case pkeskPayloadResult of
Left err ->
assertFailure
("buildPKESKv3PayloadForRecipient failed: " ++ show err)
>> fail "buildPKESKv3PayloadForRecipient failed"
Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure p
Right other ->
assertFailure ("Expected PKESK3 RSA payload, got " ++ show other)
>> fail "Unexpected PKESK payload variant"
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ PKESKPkt pkeskPayload
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv3 RSA interop decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testBuildPKESKv3PayloadForRecipientSupportsV6Key :: Assertion
testBuildPKESKv3PayloadForRecipientSupportsV6Key = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V6 baseRecipient
sessionKey = SessionKey (B.replicate 32 0x11)
let expectedKeyId =
EightOctetKeyId
(BL.take 8 (unFingerprint (fingerprint recipient)))
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
result <-
buildPKESKv3PayloadForRecipient
recipient
(pkeskV3SessionMaterial sessionMaterial)
case result of
Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ keyId RSA _)) ->
assertEqual
"PKESKv3 builder should derive v6 key ID from the high-order 64 bits of the fingerprint"
expectedKeyId
keyId
Right payload ->
assertFailure
( "Expected PKESK3 RSA payload for v6 recipient, got "
++ show payload
)
Left err ->
assertFailure
( "Expected PKESK3 RSA payload for v6 recipient, got error "
++ show err
)
testBuildPKESKv3PayloadForRecipientECDHInterop :: Assertion
testBuildPKESKv3PayloadForRecipientECDHInterop = do
let (recipientPub, recipientPriv) = syntheticNISTP256Low
recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey recipientPub))
SHA256
AES128
)
sessionKey = SessionKey (B.replicate 32 0x21)
salt = Salt (B.pack [0x20 .. 0x3f])
payload = "pkesk builder ecdh v3 interop payload"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv)
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipient
, pkeskRecipientSKey = recipientSKey
}
)
)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskPayloadResult <-
buildPKESKv3PayloadForRecipient
recipient
(pkeskV3SessionMaterial sessionMaterial)
pkeskPayload <-
case pkeskPayloadResult of
Left err ->
assertFailure
("buildPKESKv3PayloadForRecipient failed: " ++ show err)
>> fail "buildPKESKv3PayloadForRecipient failed"
Right p@(PKESKPayloadV3Packet (PKESKPayloadV3 _ _ ECDH _)) -> pure p
Right other ->
assertFailure
("Expected PKESK3 ECDH payload, got " ++ show other)
>> fail "Unexpected PKESK payload variant"
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ PKESKPkt pkeskPayload
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv3 ECDH interop decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testPKESKv3ECDHWireFormat :: Assertion
testPKESKv3ECDHWireFormat = do
let (recipientPub, _) = syntheticNISTP256Low
recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey recipientPub))
SHA256
AES256
)
-- Use a session key whose first byte is 0x00 so leading-zero stripping
-- is observable if i2osp truncates the wrapped key.
sessionKey = SessionKey (B.cons 0x00 (B.replicate 31 0xAB))
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskResult <-
buildPKESKv3PayloadForRecipient
recipient
(pkeskV3SessionMaterial sessionMaterial)
case pkeskResult of
Left err ->
assertFailure
("buildPKESKv3PayloadForRecipient failed: " ++ show err)
Right p -> do
-- Serialise the packet to wire bytes then parse the PKESK body manually.
let wire = BL.toStrict (runPut (put (PKESKPkt p)))
-- Skip new-format tag byte (0xC1), then parse the packet length.
-- For the test we just round-trip through parsePkts and check the body layout.
case parsePkts (BL.fromStrict wire) of
[ PKESKPkt
( PKESKPayloadV3Packet
(PKESKPayloadV3 _ _ ECDH (ephMPI NE.:| [wrappedMPI]))
)
] -> do
-- The ephemeral MPI should be non-trivially large (EC point).
assertBool "ephemeral MPI should be non-empty" (unMPI ephMPI > 0)
-- The wrapped MPI stores the raw i2osp bytes; for AES-256 the RFC 3394
-- ciphertext is 48 bytes. i2osp strips leading zeros so the stored
-- integer may represent fewer bytes, but candidateWrappedRFC3394Ciphertexts
-- handles that. What we're checking here is the WIRE format:
-- after the ephemeral MPI there must be exactly 1-byte-len + C bytes,
-- not a second MPI header.
--
-- Re-serialise and inspect the bytes after the ephemeral MPI manually.
let ephBytes = BL.toStrict (runPut (put ephMPI))
pktBody =
-- wire: 0xC1 | varlen | version(1) | keyid(8) | pka(1) | body
-- skip tag(1) + len(variable) + version(1) + keyid(8) + pka(1)
-- We just serialise the body directly via putPKESKv3SessionKeyMaterial equivalent:
BL.toStrict
( runPut
( put
( PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
ECDH
(ephMPI NE.:| [wrappedMPI])
)
)
)
)
)
-- Find the position of the body after tag+len+version+keyid+pka.
-- Tag: 1 byte; new-format len: 1 or 2 bytes; version: 1; keyid: 8; pka: 1 = 12 or 13 bytes
-- Instead of parsing the header, just verify the body doesn't start with
-- the two-byte MPI bit-count of the wrapped key.
-- After ephBytes in the body, the next byte should be the 1-byte count (24-48),
-- not the high byte of an MPI bit-count (which would be 0x01 for 383-bit keys).
-- We search for ephBytes in pktBody and check what follows.
let stripped = dropPKESKv3Header pktBody
afterEph = B.drop (B.length ephBytes) stripped
assertBool
"PKESKv3 ECDH wire body: after ephemeral MPI there must be at least 1 byte for wrapped-key length"
(not (B.null afterEph))
let wrappedLenByte = fromIntegral (B.head afterEph) :: Int
assertBool
( "PKESKv3 ECDH wire: wrapped-key length byte "
++ show wrappedLenByte
++ " should be a valid RFC 3394 wrapped-key length (24, 32, 40, or 48)"
)
(wrappedLenByte `elem` [24, 32, 40, 48])
assertEqual
"PKESKv3 ECDH wire: bytes after length field must equal length"
wrappedLenByte
(B.length (B.tail afterEph))
other ->
assertFailure
( "Expected single PKESKv3 ECDH packet after round-trip, got "
++ show other
)
where
-- Drop the new-format packet header (tag byte + variable-length field +
-- version byte + 8-byte key-id + pka byte) to reach the session-key material.
dropPKESKv3Header bs
| B.length bs < 3 = bs
| otherwise =
let lenByte = B.index bs 1
headerLen
| lenByte < 192 = 2 -- 1-byte length
| lenByte < 224 = 3 -- 2-byte length
| otherwise = 6 -- 5-byte length (rare)
in B.drop (headerLen + 1 + 8 + 1) bs
testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop
:: Assertion
testBuildPKESKv3PayloadForRecipientCurve25519LegacyInterop = do
let recipientSecretRaw = B.pack [1 .. 32]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy recipient secret key: "
++ show err
)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
( EdDSAPubKey
EdSigningCurve25519
( PrefixedNativeEPoint
(EPoint (os2ip (B.cons 0x40 recipientPublicRaw)))
)
)
SHA256
AES256
)
recipientSKey =
ECDHPrivateKey
( ECDSA_PrivateKey
( ECDSA.PrivateKey
(ECCT.getCurveByName ECCT.SEC_p256r1)
(os2ip recipientSecretRaw)
)
)
sessionKey = SessionKey (B.replicate 32 0x22)
salt = Salt (B.pack [0x40 .. 0x5f])
payload = "pkesk builder curve25519legacy v3 interop payload"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipient
, pkeskRecipientSKey = recipientSKey
}
)
)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskPayloadResult <-
buildPKESKv3PayloadForRecipient
recipient
(pkeskV3SessionMaterial sessionMaterial)
pkeskPayload <-
case pkeskPayloadResult of
Left err ->
assertFailure
("buildPKESKv3PayloadForRecipient failed: " ++ show err)
>> fail "buildPKESKv3PayloadForRecipient failed"
Right
p@( PKESKPayloadV3Packet
(PKESKPayloadV3 _ _ ECDH (ephemeralMPI NE.:| _))
) -> do
let ephemeralBytes = i2osp (unMPI ephemeralMPI)
assertEqual
"PKESKv3 Curve25519Legacy ephemeral point should be 0x40-prefixed 33-octet value"
33
(B.length ephemeralBytes)
assertEqual
"PKESKv3 Curve25519Legacy ephemeral point should use RFC6637 0x40 prefix"
0x40
(B.head ephemeralBytes)
pure p
Right other ->
assertFailure
("Expected PKESK3 ECDH payload, got " ++ show other)
>> fail "Unexpected PKESK payload variant"
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ PKESKPkt pkeskPayload
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv3 Curve25519Legacy interop decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy
:: Assertion
testBuildPKESKv3PayloadForRecipientRejectsCurve448Legacy = do
let recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(EdDSAPubKey EdSigningCurve448 (PrefixedNativeEPoint (EPoint 1)))
SHA512
AES256
)
sessionKey = SessionKey (B.replicate 32 0x23)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
result <-
buildPKESKv3PayloadForRecipient
recipient
(pkeskV3SessionMaterial sessionMaterial)
case result of
Left (InvalidRecipientKeyMaterial ECDH err)
| "RFC6637-compatible" `isInfixOf` err -> pure ()
| otherwise ->
assertFailure
("Expected RFC6637 compatibility rejection, got: " ++ err)
Left err ->
assertFailure
("Expected InvalidRecipientKeyMaterial ECDH, got " ++ show err)
Right payload ->
assertFailure
( "Expected RFC6637 compatibility rejection, got payload: "
++ show payload
)
testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics
:: Assertion
testBuildPKESKv6PayloadForRecipientX25519RawKeySemantics = do
let recipientSecretRaw = B.pack [1 .. 32]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
v4Recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipient = setKeyVersion V6 v4Recipient
sessionKey = SessionKey (B.replicate 32 0x24)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskPayloadResult <-
buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial
case pkeskPayloadResult of
Left err ->
assertFailure
( "buildPKESKPayloadForRecipient failed for v6 X25519: "
++ show err
)
Right
(PKESKPayloadV6Packet (PKESKPayloadV6 _ X25519 eskBytesLazy)) -> do
let eskBytes = BL.toStrict eskBytesLazy
assertX25519EskShape "v6 X25519 raw-key conformance" eskBytes
let wrappedLen = fromIntegral (B.index eskBytes 32) :: Int
assertEqual
"v6 X25519 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes"
40
wrappedLen
Right other ->
assertFailure
("Expected PKESKPayloadV6 with X25519, got " ++ show other)
{- | Conformance test: v6 X448 PKESK uses raw session key, not v3-encoded material.
RFC 9580 specifies that v6 X448 wraps the raw session key directly (no algorithm byte or checksum).
When the raw 32-byte key is AES-KW wrapped with RFC3394: 32 bytes + 8-byte integrity = 40 bytes.
If v3-encoded (1 byte algo + 32 bytes key + 2 bytes checksum + ~5 bytes padding = 40 bytes unwrapped),
the wrapped result would be ~48 bytes, so we verify wrapped size is 40.
-}
testBuildPKESKv6PayloadForRecipientX448RawKeySemantics
:: Assertion
testBuildPKESKv6PayloadForRecipientX448RawKeySemantics = do
let recipientSecretRaw = B.pack [1 .. 56]
recipientSecret =
case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X448 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString
v4Recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X448
( EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipient = setKeyVersion V6 v4Recipient
sessionKey = SessionKey (B.replicate 32 0x25)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
pkeskPayloadResult <-
buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial
case pkeskPayloadResult of
Left err ->
assertFailure
("buildPKESKPayloadForRecipient failed for v6 X448: " ++ show err)
Right (PKESKPayloadV6Packet (PKESKPayloadV6 _ X448 eskBytesLazy)) -> do
let eskBytes = BL.toStrict eskBytesLazy
assertX448EskShape "v6 X448 raw-key conformance" eskBytes
let wrappedLen = fromIntegral (B.index eskBytes 56) :: Int
assertEqual
"v6 X448 wrapped session key (AES-KW RFC3394 of raw 32 bytes) must be 40 bytes"
40
wrappedLen
Right other ->
assertFailure
("Expected PKESKPayloadV6 with X448, got " ++ show other)
testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop
:: Assertion
testBuildPKESKPayloadForRecipientWithPolicyForceV3Interop = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V4 baseRecipient
sessionKey = SessionKey (B.replicate 32 0x16)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
result <-
buildPKESKPayloadForRecipient
ForceV3Interop
recipient
sessionMaterial
case result of
Right (PKESKPayloadV3Packet (PKESKPayloadV3 _ _ RSA _)) -> pure ()
Right payload ->
assertFailure
("Expected PKESK3 RSA for ForceV3Interop, got " ++ show payload)
Left err ->
assertFailure
("Expected PKESK3 RSA for ForceV3Interop, got error " ++ show err)
testRecipientVersionStrategyForProfileHonorsHints :: Assertion
testRecipientVersionStrategyForProfileHonorsHints = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V6 baseRecipient
case recipientVersionStrategyForProfile
EncryptStrictDefault
( recipientEncryptionTargetWithStrategy
recipient
RecipientForceV3Interop
) of
Right RecipientForceV3Interop -> pure ()
other ->
assertFailure
("Expected explicit recipient hint to win, got " ++ show other)
case recipientVersionStrategyForProfile
EncryptInteropLegacy
(recipientEncryptionTarget recipient) of
Right RecipientForceV3Interop -> pure ()
other ->
assertFailure
( "Expected legacy profile fallback to force v3, got "
++ show other
)
let v4Recipient = setKeyVersion V4 recipient
case recipientVersionStrategyForProfile
EncryptStrictDefault
(recipientEncryptionTarget recipient) of
Right RecipientPreferV6 -> pure ()
other ->
assertFailure
( "Expected strict profile auto-detect to prefer v6 for v6 recipients, got "
++ show other
)
case recipientVersionStrategyForProfile
EncryptStrictDefault
(recipientEncryptionTarget v4Recipient) of
Right RecipientForceV3Interop -> pure ()
other ->
assertFailure
( "Expected strict profile auto-detect to force v3 for legacy recipients, got "
++ show other
)
testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies
:: Assertion
testEncryptRecipientsWithRequestAutoDetectsMixedRecipientStrategies = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTarget v6Recipient
, recipientEncryptionTarget v4Recipient
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload = "recipient autodetect"
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x77))
}
}
result <- encryptForRecipients request
case result of
Left err ->
assertFailure
( "Expected mixed-recipient request to encrypt successfully, got "
++ show err
)
Right RecipientEncryptResult {recipientEncryptPackets = packets} -> do
let pkesks = [p | PKESKPkt p <- packets]
assertBool
"strict profile auto-detect should emit PKESKv6 for v6 recipients"
(any isPKESK6 pkesks)
assertBool
"strict profile auto-detect should emit PKESKv3 for v4 recipients"
(any isPKESK3 pkesks)
where
isPKESK6 PKESKPayloadV6Packet {} = True
isPKESK6 _ = False
isPKESK3 PKESKPayloadV3Packet {} = True
isPKESK3 _ = False
testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled
:: Assertion
testEncryptRecipientsNegotiatesSymmetricAlgorithmWhenEnabled = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
v6Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V6
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms =
[AES128, AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
v4Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms = [AES128]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps
, recipientEncryptionTargetWithCapabilities v4Recipient v4Caps
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"recipient capability negotiation payload"
, recipientEncryptRequestSymmetricOverride = Nothing
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x22))
}
}
result <-
encryptForRecipientsWithCapabilityNegotiation
RecipientCapabilityNegotiationOn
request
case result of
Left err ->
assertFailure
( "Expected recipient capability negotiation to succeed, got "
++ show err
)
Right
RecipientEncryptResult
{ recipientEncryptSessionMaterial = material
} ->
assertEqual
"capability negotiation should pick common preferred symmetric algorithm"
AES128
(pkeskSessionAlgorithm material)
testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault
:: Assertion
testEncryptRecipientsNegotiatesSymmetricAlgorithmByDefault = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
v6Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V6
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms =
[AES128, AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
v4Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms = [AES128]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps
, recipientEncryptionTargetWithCapabilities v4Recipient v4Caps
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"default recipient capability negotiation payload"
, recipientEncryptRequestSymmetricOverride = Nothing
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x24))
}
}
result <- encryptForRecipients request
case result of
Left err ->
assertFailure
( "Expected default encryptForRecipients negotiation to succeed, got "
++ show err
)
Right
RecipientEncryptResult
{ recipientEncryptSessionMaterial = material
} ->
assertEqual
"encryptForRecipients should negotiate recipient capabilities by default"
AES128
(pkeskSessionAlgorithm material)
testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut
:: Assertion
testEncryptRecipientsLegacyKeepsCapabilityNegotiationOptOut = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
v6Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V6
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms =
[AES128, AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
v4Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms = [AES128]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps
, recipientEncryptionTargetWithCapabilities v4Recipient v4Caps
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"legacy recipient capability opt-out payload"
, recipientEncryptRequestSymmetricOverride = Nothing
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x25))
}
}
result <- encryptForRecipientsLegacy request
case result of
Left err ->
assertFailure
( "Expected legacy encryptForRecipients opt-out to succeed, got "
++ show err
)
Right
RecipientEncryptResult
{ recipientEncryptSessionMaterial = material
} ->
assertEqual
"encryptForRecipientsLegacy should preserve policy-default symmetric selection"
AES256
(pkeskSessionAlgorithm material)
testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm
:: Assertion
testEncryptRecipientsNegotiationFailsWithoutCommonSymmetricAlgorithm = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
v6Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V6
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms = [AES128]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
v4Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.empty
, recipientCapabilityPreferredSymmetricAlgorithms = [AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps
, recipientEncryptionTargetWithCapabilities v4Recipient v4Caps
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"recipient capability mismatch payload"
, recipientEncryptRequestSymmetricOverride = Nothing
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x23))
}
}
result <-
encryptForRecipientsWithCapabilityNegotiation
RecipientCapabilityNegotiationOn
request
case result of
Left
( RecipientCapabilitySelectionFailure
(RecipientCapabilityNoCommonSymmetricAlgorithms _)
) -> pure ()
Left other ->
assertFailure
( "Expected RecipientCapabilityNoCommonSymmetricAlgorithms, got "
++ show other
)
Right _ ->
assertFailure
"Expected recipient capability negotiation to fail without common symmetric algorithm"
testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms
:: Assertion
testRecipientCapabilitiesFromSubpacketPayloadsExtractsPreferredAEADAlgorithms = do
(recipient, _privateKey) <- loadUnencryptedRsaSigner
let caps =
recipientCapabilitiesFromSubpacketPayloads
recipient
[OtherSigSub 39 (BL.pack [9, 2, 7, 3, 9, 2])]
assertEqual
"preferred AEAD ciphersuites subpacket should extract unique AEAD preferences in declaration order"
[OCB, GCM]
(recipientCapabilityPreferredAEADAlgorithms caps)
testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled
:: Assertion
testEncryptRecipientsNegotiatesAEADAlgorithmWhenEnabled = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
v6Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V6
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures =
Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]
, recipientCapabilityPreferredSymmetricAlgorithms =
[AES128, AES256]
, recipientCapabilityPreferredAEADAlgorithms = [GCM, OCB]
}
v4Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures =
Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]
, recipientCapabilityPreferredSymmetricAlgorithms = [AES128]
, recipientCapabilityPreferredAEADAlgorithms = [GCM]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps
, recipientEncryptionTargetWithCapabilities v4Recipient v4Caps
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"recipient AEAD capability negotiation payload"
, recipientEncryptRequestSymmetricOverride = Nothing
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Nothing
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x26))
}
}
result <-
encryptForRecipientsWithCapabilityNegotiation
RecipientCapabilityNegotiationOn
request
case result of
Left err ->
assertFailure
( "Expected AEAD capability negotiation to succeed, got "
++ show err
)
Right
RecipientEncryptResult
{ recipientEncryptPackets = packets
, recipientEncryptSessionMaterial = material
} -> do
assertEqual
"AEAD capability negotiation should preserve symmetric negotiation"
AES128
(pkeskSessionAlgorithm material)
case [ aa
| SymEncIntegrityProtectedDataPkt (SEIPD2 _ aa _ _ _) <- packets
] of
[selectedAEAD] ->
assertEqual
"AEAD capability negotiation should pick common preferred AEAD algorithm"
GCM
selectedAEAD
other ->
assertFailure ("Expected one SEIPDv2 packet, got " ++ show other)
testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm
:: Assertion
testEncryptRecipientsNegotiationFailsWithoutCommonAEADAlgorithm = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
v6Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V6
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v6Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures =
Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]
, recipientCapabilityPreferredSymmetricAlgorithms = [AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
v4Caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures =
Set.fromList [FeatureSEIPDv1, FeatureSEIPDv2]
, recipientCapabilityPreferredSymmetricAlgorithms = [AES256]
, recipientCapabilityPreferredAEADAlgorithms = [GCM]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities v6Recipient v6Caps
, recipientEncryptionTargetWithCapabilities v4Recipient v4Caps
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"recipient AEAD mismatch payload"
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Nothing
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x27))
}
}
result <-
encryptForRecipientsWithCapabilityNegotiation
RecipientCapabilityNegotiationOn
request
case result of
Left
( RecipientCapabilitySelectionFailure
(RecipientCapabilityNoCommonAEADAlgorithms _)
) -> pure ()
Left other ->
assertFailure
( "Expected RecipientCapabilityNoCommonAEADAlgorithms, got "
++ show other
)
Right _ ->
assertFailure
"Expected recipient capability negotiation to fail without common AEAD algorithm"
testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2
:: Assertion
testEncryptRecipientsSEIPDv2FallsBackWhenRecipientsDoNotAdvertiseV2 = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
v6Recipient = setKeyVersion V6 baseRecipient
sharedCaps keyVersion recipient =
RecipientCapabilities
{ recipientCapabilityKeyVersion = keyVersion
, recipientCapabilityPublicKeyAlgorithm = _pkalgo recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.singleton FeatureSEIPDv1
, recipientCapabilityPreferredSymmetricAlgorithms = [AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[ recipientEncryptionTargetWithCapabilities
v6Recipient
(sharedCaps V6 v6Recipient)
, recipientEncryptionTargetWithCapabilities
v4Recipient
(sharedCaps V4 v4Recipient)
]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"recipient seipd fallback payload"
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Nothing
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x28))
}
}
result <- encryptForRecipients request
case result of
Left err ->
assertFailure
( "Expected fallback to SEIPDv1 when recipients do not advertise SEIPDv2, got "
++ show err
)
Right RecipientEncryptResult {recipientEncryptPackets = packets} -> do
let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets]
case seipdPkts of
[SEIPD1 1 _] -> pure ()
[SEIPD2 {}] ->
assertFailure
"Expected SEIPDv1 fallback when recipients do not advertise SEIPDv2 support"
other -> assertFailure ("Unexpected SEIPD packets: " ++ show other)
testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC
:: Assertion
testEncryptRecipientsRejectsSEIPDv1WhenRecipientsDoNotAdvertiseMDC = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let v4Recipient = setKeyVersion V4 baseRecipient
caps =
RecipientCapabilities
{ recipientCapabilityKeyVersion = V4
, recipientCapabilityPublicKeyAlgorithm = _pkalgo v4Recipient
, recipientCapabilityKeyFlags = Set.empty
, recipientCapabilityFeatures = Set.singleton FeatureSEIPDv2
, recipientCapabilityPreferredSymmetricAlgorithms = [AES256]
, recipientCapabilityPreferredAEADAlgorithms = [OCB]
}
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[recipientEncryptionTargetWithCapabilities v4Recipient caps]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload =
"recipient seipd v1 capability failure payload"
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv1Overrides
{ recipientEncryptRequestIVOverride = Nothing
}
}
result <- encryptForRecipients request
case result of
Left
( RecipientCapabilitySelectionFailure
(RecipientCapabilityMissingSEIPDv1Support _)
) -> pure ()
Left other ->
assertFailure
( "Expected RecipientCapabilityMissingSEIPDv1Support, got "
++ show other
)
Right _ ->
assertFailure
"Expected SEIPDv1 encryption to fail when recipients do not advertise MDC support"
testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys
:: Assertion
testRecipientEncryptionTargetsFromTKIncludesOnlyEncryptionCapableKeys = do
(signingPrimary, _signingKey) <- loadDeterministicEd25519Signer
(baseEncryptingSubkey, _privateKey) <- loadUnencryptedRsaSigner
let tkUnknown =
TKUnknown
{ _tkuKey = (signingPrimary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs =
[
( PublicSubkeyPkt
(setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey)
, []
)
]
}
tk =
case fromUnknownToTK tkUnknown of
Right (SomePublicTK publicTk) -> publicTk
Right (SomeSecretTK _) -> error "expected public TK for recipient target test"
Left err -> error err
encryptingSubkey =
setKeyTimestamp (_timestamp signingPrimary) baseEncryptingSubkey
targets = recipientEncryptionTargetsFromTK tk
assertEqual
"TKUnknown-derived targets should include only encryption-capable keys"
1
(length targets)
case targets of
[target] ->
assertEqual
"TKUnknown-derived target should preserve selected encryption key"
(fingerprint encryptingSubkey)
(fingerprint (recipientEncryptionTargetKey target))
_ ->
assertFailure "Expected exactly one encryption-capable target"
testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary
:: Assertion
testRecipientEncryptionTargetFromTKPrefersSubkeyOverPrimary = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let primary = setKeyVersion V4 baseRecipient
subkey = setKeyVersion V6 baseRecipient
tkUnknown =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [])]
}
tk =
case fromUnknownToTK tkUnknown of
Right (SomePublicTK publicTk) -> publicTk
Right (SomeSecretTK _) ->
error "expected public TK for recipient target selection test"
Left err -> error err
case recipientEncryptionTargetFromTK tk of
Right target ->
assertEqual
"TKUnknown-derived single target should prioritize encryption subkeys"
(fingerprint subkey)
(fingerprint (recipientEncryptionTargetKey target))
Left err ->
assertFailure
( "Expected TKUnknown-derived target selection to succeed, got "
++ show err
)
testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys
:: Assertion
testRecipientEncryptionTargetFromTKRejectsTKWithoutEncryptableKeys = do
(signingPrimary, _signingKey) <- loadDeterministicEd25519Signer
let tkUnknown =
TKUnknown
{ _tkuKey = (signingPrimary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = []
}
tk =
case fromUnknownToTK tkUnknown of
Right (SomePublicTK publicTk) -> publicTk
Right (SomeSecretTK _) -> error "expected public TK for recipient rejection test"
Left err -> error err
case recipientEncryptionTargetFromTK tk of
Left RecipientCapabilityNoEncryptableKeyMaterialInTK -> pure ()
Left other ->
assertFailure
( "Expected RecipientCapabilityNoEncryptableKeyMaterialInTK, got "
++ show other
)
Right _ ->
assertFailure
"Expected TKUnknown-derived target selection to reject non-encryptable TKs"
testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections
:: Assertion
testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsRejections = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
report =
recipientEncryptionTargetsReportFromTKAtTimestamp
signatureTime
tk
acceptedFps =
map
(fingerprint . recipientEncryptionTargetKey)
(recipientEncryptionTargetsAccepted report)
rejectedReasons =
map
recipientEncryptionTargetRejectedReason
(recipientEncryptionTargetsRejected report)
assertBool
"report should keep encryption-eligible primary key as accepted"
(fingerprint primary `elem` acceptedFps)
assertEqual
"report should explain sign-only subkey rejection"
[ RecipientTargetMissingEncryptionFlags
subkey
(Set.fromList [SignDataKey])
]
rejectedReasons
testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms
:: Assertion
testRecipientEncryptionTargetsReportFromTKAtTimestampExplainsUnsupportedAlgorithms = do
(signingPrimary, _signingKey) <- loadDeterministicEd25519Signer
let tk =
TKUnknown
{ _tkuKey = (signingPrimary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = []
}
report =
recipientEncryptionTargetsReportFromTKAtTimestamp
(_timestamp signingPrimary)
tk
assertEqual
"unsupported key algorithms should be surfaced in report rejections"
[RecipientTargetUnsupportedAlgorithm (_pkalgo signingPrimary)]
( map
recipientEncryptionTargetRejectedReason
(recipientEncryptionTargetsRejected report)
)
testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey
:: Assertion
testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsExpiredSubkey = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
targetTime = ThirtyTwoBitTimeStamp 1700000020
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[ SigSubPacket
False
(KeyFlags (Set.fromList [EncryptCommunicationsKey]))
, SigSubPacket False (KeyExpirationTime (ThirtyTwoBitDuration 5))
]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
report =
recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk
rejectedReasons =
map
recipientEncryptionTargetRejectedReason
(recipientEncryptionTargetsRejected report)
assertBool
"expired subkey should be rejected from recipient targets"
( RecipientTargetNotValidAtTimestamp subkey targetTime
`elem` rejectedReasons
)
testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey
:: Assertion
testRecipientEncryptionTargetsReportFromTKAtTimestampRejectsRevokedSubkey = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let bindingTime = ThirtyTwoBitTimeStamp 1700000000
revocationTime = ThirtyTwoBitTimeStamp 1700000005
targetTime = ThirtyTwoBitTimeStamp 1700000010
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
bindingTime
[ SigSubPacket
False
(KeyFlags (Set.fromList [EncryptCommunicationsKey]))
]
subkeyRevocationSig <-
signSubkeyRevocationWithRSAAt
primary
subkey
signingKey
revocationTime
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs =
[ (PublicSubkeyPkt subkey, [subkeyBindingSig, subkeyRevocationSig])
]
}
report =
recipientEncryptionTargetsReportFromTKAtTimestamp targetTime tk
rejectedReasons =
map
recipientEncryptionTargetRejectedReason
(recipientEncryptionTargetsRejected report)
assertBool
"revoked subkey should be rejected from recipient targets"
(RecipientTargetRevoked subkey `elem` rejectedReasons)
testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities
:: Assertion
testRecipientEncryptionTargetsFromTKAtTimestampExtractsSelfSigCapabilities = do
(primary, signingKey) <- loadUnencryptedRsaSigner
(subkey, _privateKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
directKeySig <-
signDirectKeyWithRSAExtrasAt
primary
signingKey
signatureTime
[ SigSubPacket False (PreferredSymmetricAlgorithms [AES128])
, SigSubPacket False (OtherSigSub 39 (BL.pack [9, 2, 7, 3]))
]
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[ SigSubPacket
False
(KeyFlags (Set.fromList [EncryptCommunicationsKey]))
]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = [directKeySig]
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk
case targets of
(target : _) ->
case recipientEncryptionTargetCapabilities target of
Nothing ->
assertFailure
"Expected TKUnknown-derived target to include extracted capabilities"
Just caps -> do
assertEqual
"self-signature capability extraction should include primary-key symmetric preferences"
[AES128]
(recipientCapabilityPreferredSymmetricAlgorithms caps)
assertEqual
"self-signature capability extraction should include primary-key preferred AEAD algorithms"
[OCB, GCM]
(recipientCapabilityPreferredAEADAlgorithms caps)
assertEqual
"self-signature capability extraction should include subkey key flags"
(Set.fromList [EncryptCommunicationsKey])
(recipientCapabilityKeyFlags caps)
[] ->
assertFailure "Expected at least one TKUnknown-derived target"
testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering
:: Assertion
testRecipientEncryptionTargetFromTKAtTimestampAppliesTimestampFiltering = do
(primary, signingKey) <- loadUnencryptedRsaSigner
(subkey, _privateKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000100
beforeSignature = ThirtyTwoBitTimeStamp 1699999999
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[ SigSubPacket
False
(KeyFlags (Set.fromList [EncryptCommunicationsKey]))
]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
case recipientEncryptionTargetFromTKAtTimestamp beforeSignature tk of
Left err ->
assertFailure
( "Expected timestamp-scoped TKUnknown target selection to succeed, got "
++ show err
)
Right target ->
case recipientEncryptionTargetCapabilities target of
Nothing ->
assertFailure
"Expected TKUnknown-derived target to include capabilities when timestamp-scoped"
Just caps ->
assertEqual
"subkey binding created after target timestamp should not contribute key flags"
Set.empty
(recipientCapabilityKeyFlags caps)
testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary
:: Assertion
testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersPrimary = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[ SigSubPacket
False
(KeyFlags (Set.fromList [EncryptCommunicationsKey]))
]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
case recipientEncryptionTargetFromTKAtTimestampWithPolicy
RecipientTargetSelectionPreferPrimary
signatureTime
tk of
Left err ->
assertFailure
( "Expected policy-based recipient selection to succeed, got "
++ show err
)
Right target ->
assertEqual
"prefer-primary policy should select primary key when both primary and subkey are valid"
(fingerprint primary)
(fingerprint (recipientEncryptionTargetKey target))
testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest
:: Assertion
testRecipientEncryptionTargetFromTKAtTimestampWithPolicyPrefersNewest = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000002) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[ SigSubPacket
False
(KeyFlags (Set.fromList [EncryptCommunicationsKey]))
]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
case recipientEncryptionTargetFromTKAtTimestampWithPolicy
RecipientTargetSelectionPreferNewestCreationTime
signatureTime
tk of
Left err ->
assertFailure
( "Expected policy-based recipient selection to succeed, got "
++ show err
)
Right target ->
assertEqual
"prefer-newest policy should select newest valid key"
(fingerprint subkey)
(fingerprint (recipientEncryptionTargetKey target))
testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags
:: Assertion
testRecipientEncryptionTargetsFromTKRejectsKeyWithNonEncryptFlags = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk
let subkeyFp = fingerprint subkey
primaryFp = fingerprint primary
targetFps = map (fingerprint . recipientEncryptionTargetKey) targets
assertBool
"subkey with sign-only key flags should be excluded from encryption targets"
(subkeyFp `notElem` targetFps)
assertBool
"primary key (no explicit flags) should still be included as encryption target"
(primaryFp `elem` targetFps)
testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags
:: Assertion
testRecipientEncryptionTargetsFromTKIncludesKeyWithNoFlags = do
(baseKey, signingKey) <- loadUnencryptedRsaSigner
let signatureTime = ThirtyTwoBitTimeStamp 1700000000
primary = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000000) baseKey
subkey = setKeyTimestamp (ThirtyTwoBitTimeStamp 1600000001) baseKey
subkeyBindingSig <-
signSubkeyBindingWithRSAExtrasAt
primary
subkey
signingKey
signatureTime
[]
let tk =
TKUnknown
{ _tkuKey = (primary, Nothing)
, _tkuRevs = []
, _tkuUIDs = []
, _tkuUAts = []
, _tkuSubs = [(PublicSubkeyPkt subkey, [subkeyBindingSig])]
}
targets = recipientEncryptionTargetsFromTKAtTimestamp signatureTime tk
let subkeyFp = fingerprint subkey
targetFps = map (fingerprint . recipientEncryptionTargetKey) targets
assertBool
"subkey with no key flags should be included as encryption target (legacy-compatible)"
(subkeyFp `elem` targetFps)
testEncryptRecipientsWithRequestEmitsOnePassSignatures
:: Assertion
testEncryptRecipientsWithRequestEmitsOnePassSignatures = do
(baseRecipient, privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V6 baseRecipient
signature =
SigV4
BinarySig
RSA
SHA256
[]
[ SigSubPacket
False
(Issuer (EightOctetKeyId (BL.pack [0x01 .. 0x08])))
]
0
(MPI 1 :| [])
payload = "recipient one-pass signature payload"
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[recipientEncryptionTarget recipient]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
{ recipientPayloadUseOnePassSignatures = True
, recipientPayloadSignatures = [signature]
}
, recipientEncryptRequestPayload = payload
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x55))
}
}
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipient
, pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey)
}
)
)
passphraseCallback _ = pure BL.empty
result <- encryptForRecipients request
packets <-
case result of
Left err ->
assertFailure
( "Expected one-pass encryption request to succeed, got "
++ show err
)
>> fail "encryptForRecipients failed"
Right
RecipientEncryptResult
{ recipientEncryptPackets = encryptedPackets
} -> pure encryptedPackets
decrypted <-
DC.runConduitRes $
CL.sourceList packets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[ OnePassSignaturePkt
(OPSPayloadV3Packet (OPSPayloadV3 3 BinarySig SHA256 RSA _ False))
, LiteralDataPkt _ _ _ gotPayload
, SignaturePkt _
] ->
assertEqual
"decrypted payload matches original plaintext"
(BL.fromStrict payload)
gotPayload
other ->
assertFailure
( "Expected decrypted [OPS3, LiteralData, Signature], got "
++ show other
)
testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing
:: Assertion
testEncryptRecipientsWithRequestRejectsOnePassWhenIssuerMetadataMissing = do
(baseRecipient, _privateKey) <- loadUnencryptedRsaSigner
let recipient = setKeyVersion V6 baseRecipient
signature = SigV4 BinarySig RSA SHA256 [] [] 0 (MPI 1 :| [])
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[recipientEncryptionTarget recipient]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
{ recipientPayloadUseOnePassSignatures = True
, recipientPayloadSignatures = [signature]
}
, recipientEncryptRequestPayload =
"recipient one-pass missing issuer metadata payload"
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv2Overrides
{ recipientEncryptRequestAEADOverride = Just OCB
, recipientEncryptRequestChunkSizeOverride = Just 6
, recipientEncryptRequestSaltOverride =
Just (Salt (B.replicate 32 0x56))
}
}
result <- encryptForRecipients request
case result of
Left (PayloadBuildFailure err) ->
assertBool
"missing issuer metadata should surface as payload build failure"
("without issuer metadata" `isInfixOf` err)
Left err ->
assertFailure
( "Expected PayloadBuildFailure for missing OPS issuer metadata, got "
++ show err
)
Right _ ->
assertFailure
"Expected one-pass request without issuer metadata to fail"
testEncryptInteropLegacyProducesSEIPDv1 :: Assertion
testEncryptInteropLegacyProducesSEIPDv1 = do
(recipient, privateKey) <- loadUnencryptedRsaSigner
let iv = IV (B.replicate 16 0xAB)
payload = "legacy interop payload"
request =
RecipientEncryptRequest
{ recipientEncryptRequestTargets =
[recipientEncryptionTarget recipient]
, recipientEncryptRequestPayloadShape =
defaultRecipientPayloadShape
, recipientEncryptRequestPayload = payload
, recipientEncryptRequestSymmetricOverride = Just AES256
, recipientEncryptRequestOverrides =
RecipientEncryptRequestSEIPDv1Overrides
{ recipientEncryptRequestIVOverride = Just iv
}
}
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipient
, pkeskRecipientSKey = RSAPrivateKey (RSA_PrivateKey privateKey)
}
)
)
passphraseCallback _ = pure BL.empty
result <- encryptForRecipients request
packets <-
case result of
Left err ->
assertFailure
( "Expected EncryptInteropLegacy request to succeed, got "
++ show err
)
>> fail "encryptForRecipients failed"
Right RecipientEncryptResult {recipientEncryptPackets = ps} -> pure ps
let seipdPkts = [p | SymEncIntegrityProtectedDataPkt p <- packets]
case seipdPkts of
[SEIPD1 1 _] -> pure ()
[SEIPD2 {}] -> assertFailure "Expected SEIPDv1 but got SEIPDv2"
other -> assertFailure ("Unexpected SEIPD packets: " ++ show other)
let pkeskPkts = [p | PKESKPkt p <- packets]
assertBool "EncryptInteropLegacy should emit PKESKv3 packets" $
all
(\p -> case p of PKESKPayloadV3Packet {} -> True; _ -> False)
pkeskPkts
decrypted <-
DC.runConduitRes $
CL.sourceList packets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"decrypted legacy interop payload matches original"
(BL.fromStrict payload)
gotPayload
other ->
assertFailure
("Expected [LiteralData] from legacy decrypt, got " ++ show other)
testCanonicalizePKESKRecipientIdHelper :: Assertion
testCanonicalizePKESKRecipientIdHelper = do
let rid = BL.pack (0x04 : replicate 20 0x11)
payload = PKESKPayloadV6Packet (PKESKPayloadV6 rid RSA "esk")
case canonicalizePKESKRecipientId payload of
Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _))
| BL.length normalized == 20 -> pure ()
| otherwise ->
assertFailure
( "Expected canonicalized recipient id length 20, got "
++ show (BL.length normalized)
)
Left err ->
assertFailure
("canonicalizePKESKRecipientId failed unexpectedly: " ++ show err)
Right other ->
assertFailure
( "Expected PKESK6 payload after canonicalization, got "
++ show other
)
case canonicalizePKESKRecipientId
( PKESKPayloadV6Packet
(PKESKPayloadV6 (BL.replicate 19 0x22) RSA "esk")
) of
Left (InvalidRecipientIdentifier _) -> pure ()
other ->
assertFailure
( "Expected InvalidRecipientIdentifier for malformed rid, got "
++ show other
)
case canonicalizePKESKRecipientId
( PKESKPayloadV6Packet
(PKESKPayloadV6 (BL.pack (0x06 : replicate 32 0x33)) RSA "esk")
) of
Right (PKESKPayloadV6Packet (PKESKPayloadV6 normalized _ _))
| BL.length normalized == 32 -> pure ()
| otherwise ->
assertFailure
( "Expected canonicalized v6 recipient id length 32, got "
++ show (BL.length normalized)
)
other ->
assertFailure
( "Expected 0x06-prefixed v6 recipient id to canonicalize, got "
++ show other
)
case canonicalizePKESKRecipientId
( PKESKPayloadV6Packet
(PKESKPayloadV6 (BL.pack (0x04 : replicate 32 0x44)) RSA "esk")
) of
Left (InvalidRecipientIdentifier _) -> pure ()
other ->
assertFailure
( "Expected InvalidRecipientIdentifier for mismatched v4-prefixed v6-length rid, got "
++ show other
)
testBuildPKESKPayloadUnsupportedRecipient :: Assertion
testBuildPKESKPayloadUnsupportedRecipient = do
let recipient =
PKPayload
V6
(ThirtyTwoBitTimeStamp 0)
0
EdDSA
(EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1)))
sessionKey = SessionKey (B.replicate 32 0x19)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
result <-
buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial
case result of
Left (UnsupportedRecipientAlgorithm EdDSA) -> pure ()
Left err ->
assertFailure
("Expected UnsupportedRecipientAlgorithm EdDSA, got " ++ show err)
Right payload ->
assertFailure
( "Expected UnsupportedRecipientAlgorithm, got payload: "
++ show payload
)
testBuildPKESKPayloadRejectsECDHSHA1 :: Assertion
testBuildPKESKPayloadRejectsECDHSHA1 = do
let (recipientPub, _) = syntheticNISTP256Low
recipient =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey recipientPub))
SHA1
AES256
)
sessionKey = SessionKey (B.replicate 32 0x19)
sessionMaterial <- mkPKESKSessionMaterialOrFail AES256 sessionKey
result <-
buildPKESKPayloadForRecipient PreferV6 recipient sessionMaterial
case result of
Left (RecipientKdfFailure ECDH err)
| "SHA1 is disallowed by policy" `isInfixOf` err -> pure ()
| otherwise ->
assertFailure
( "Expected SHA1 policy rejection in RecipientKdfFailure, got: "
++ err
)
Left err ->
assertFailure
("Expected RecipientKdfFailure ECDH for SHA1, got " ++ show err)
Right payload ->
assertFailure
("Expected SHA1 policy rejection, got payload: " ++ show payload)
testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey
:: Assertion
testConduitDecryptSEIPDv2FixtureWithMatchingV6SecretKey = do
armoredMessage <- readFixtureStrict "seipdv2.pgp.aa"
armoredEncryptedSecret <-
readFixtureStrict "v6-encrypted-secret.pgp.aa"
armoredPlainSecret <- readFixtureStrict "v6-secret.pgp.aa"
passphrase <- readPKIPassphrase
messageArmors <-
case (AA.decode armoredMessage :: Either String [Armor]) of
Left err ->
assertFailure ("failed to decode seipdv2 armor: " ++ err)
>> pure []
Right as -> pure as
encryptedSecretArmors <-
case (AA.decode armoredEncryptedSecret :: Either String [Armor]) of
Left err ->
assertFailure
("failed to decode v6 encrypted secret armor: " ++ err)
>> pure []
Right as -> pure as
plainSecretArmors <-
case (AA.decode armoredPlainSecret :: Either String [Armor]) of
Left err ->
assertFailure ("failed to decode v6 plain secret armor: " ++ err)
>> pure []
Right as -> pure as
messageBody <-
case messageArmors of
(a : _) -> pure (armorPayload a)
[] ->
assertFailure "seipdv2 armor file contained no armor blocks"
>> pure mempty
encryptedSecretBody <-
case encryptedSecretArmors of
(a : _) -> pure (armorPayload a)
[] ->
assertFailure
"v6-encrypted-secret armor file contained no armor blocks"
>> pure mempty
plainSecretBody <-
case plainSecretArmors of
(a : _) -> pure (armorPayload a)
[] ->
assertFailure "v6-secret armor file contained no armor blocks"
>> pure mempty
let messagePackets = parsePkts messageBody
encryptedSecretPackets = parsePkts encryptedSecretBody
plainSecretPackets = parsePkts plainSecretBody
passphraseCallback _ = pure BL.empty
allKeyInfos <-
collectSecretKeyInfos
(encryptedSecretPackets ++ plainSecretPackets)
passphrase
let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt allKeyInfos)
if null allKeyInfos
then
assertFailure
( "no usable secret key material found in v6-encrypted-secret fixture: "
++ show
( [ (_pkalgo pkp, ska)
| SecretKeyPkt pkp ska <- encryptedSecretPackets
]
++ [ (_pkalgo pkp, ska)
| SecretSubkeyPkt pkp ska <- encryptedSecretPackets
]
)
)
else do
decrypted <-
DC.runConduitRes $
CL.sourceList messagePackets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case [p | LiteralDataPkt _ _ _ p <- decrypted] of
(payload : _) ->
if BL.null payload
then
assertFailure "fixture decrypt produced empty literal payload"
else pure ()
[] ->
assertFailure
( "expected decrypted literal payload from seipdv2 fixture, got: "
++ show decrypted
)
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey
:: Assertion
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKey = do
(messagePackets, encryptedSecretPackets, passphrase) <-
loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa"
let
passphraseCallback _ = pure BL.empty
keyInfos <-
collectSecretKeyInfos encryptedSecretPackets passphrase
let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)
decrypted <-
DC.runConduitRes $
CL.sourceList messagePackets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case [p | LiteralDataPkt _ _ _ p <- decrypted] of
(payload : _) ->
if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload
then pure ()
else
assertFailure
( "unexpected decrypted payload for seipdv2-for-v4-key fixture: "
++ show payload
)
[] ->
assertFailure
( "expected decrypted literal payload from seipdv2-for-v4-key fixture, got: "
++ show decrypted
)
testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK
:: Assertion
testConduitDecryptSEIPDv2FixtureIgnoresUnusableLatestPKESK = do
(messagePackets, encryptedSecretPackets, passphrase) <-
loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa"
let
bogusRid = BL.pack (0x06 : replicate 32 0x99)
bogusPKESK =
PKESKPkt
(PKESKPayloadV6Packet (PKESKPayloadV6 bogusRid RSA "bogus-esk"))
(eskPrefix, encryptedSuffix) = span isPrecedingESK messagePackets
packetsWithBogusLatestPKESK = eskPrefix ++ [bogusPKESK] ++ encryptedSuffix
passphraseCallback _ = pure BL.empty
keyInfos <-
collectSecretKeyInfos encryptedSecretPackets passphrase
let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)
decrypted <-
DC.runConduitRes $
CL.sourceList packetsWithBogusLatestPKESK
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case [p | LiteralDataPkt _ _ _ p <- decrypted] of
(payload : _) ->
if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload
then pure ()
else
assertFailure
( "unexpected decrypted payload for seipdv2-for-v4-key fixture with bogus latest PKESK: "
++ show payload
)
[] ->
assertFailure
( "expected decrypted literal payload with bogus latest PKESK, got: "
++ show decrypted
)
testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations
:: Assertion
testConduitDecryptSEIPDv2FixtureAcceptsRecipientIdWithoutCallerPermutations = do
(messagePacketsRaw, encryptedSecretPackets, passphrase) <-
loadSEIPDv2FixtureWithV4Secret "seipdv2-for-v4-key.pgp.aa"
let messagePackets = map forceVersionedRecipientIdentifier messagePacketsRaw
passphraseCallback _ = pure BL.empty
keyInfos <-
collectSecretKeyInfos encryptedSecretPackets passphrase
let keyContextCallback pkt = pure (selectRecipientKeyInfoByRawRecipientId pkt keyInfos)
decrypted <-
DC.runConduitRes $
CL.sourceList messagePackets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case [p | LiteralDataPkt _ _ _ p <- decrypted] of
(payload : _) ->
if "This is a test of SEIPDv1" `isInfixOf` BLC8.unpack payload
then pure ()
else
assertFailure
( "unexpected decrypted payload for recipient-id normalization fixture: "
++ show payload
)
[] ->
assertFailure
( "expected decrypted literal payload for recipient-id normalization fixture, got: "
++ show decrypted
)
testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial
:: Assertion
testConduitDecryptPKESKFailureDoesNotRequireManualSessionMaterial = do
armors <- loadArmor "seipdv2-for-v4-key.pgp.aa"
armor <-
case armors of
(a : _) -> pure a
[] ->
assertFailure
"seipdv2-for-v4-key.pgp.aa should contain one armored payload"
>> fail "expected one armored payload"
let packets = parsePkts (armorPayload armor)
keyContextCallback _ = pure Nothing
passphraseCallback prompt =
fail ("unexpected manual PKESK session key prompt: " ++ prompt)
result <-
catch
( Right
<$> ( DC.runConduitRes $
CL.sourceList packets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err -> do
assertBool
"failure should report PKESK candidate exhaustion"
("no matching key context" `isInfixOf` err)
assertBool
"failure should not request manual PKESK session material"
( not
("unexpected manual PKESK session key prompt" `isInfixOf` err)
)
Right decrypted ->
assertFailure
( "expected decryption failure when no PKESK key context is available, got: "
++ show decrypted
)
testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey
:: Assertion
testConduitDecryptSEIPDv2TwoRecipientsFixtureWithMatchingV4SecretKey =
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform
"seipdv2-two-recipients.pgp.aa"
id
testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey
:: Assertion
testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithMatchingV4SecretKey =
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform
"seipdv2-three-recipients.pgp.aa"
id
testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs
:: Assertion
testConduitDecryptSEIPDv2TwoRecipientsFixtureWithReorderedAndUnusablePKESKs =
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform
"seipdv2-two-recipients.pgp.aa"
(prependUnusableLatestPKESK . reorderPrecedingPKESKs)
testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs
:: Assertion
testConduitDecryptSEIPDv2ThreeRecipientsFixtureWithReorderedAndUnusablePKESKs =
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform
"seipdv2-three-recipients.pgp.aa"
(prependUnusableLatestPKESK . reorderPrecedingPKESKs)
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile
:: FilePath -> Assertion
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFile fixture =
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform
fixture
id
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform
:: FilePath
-> ([Pkt] -> [Pkt])
-> Assertion
testConduitDecryptSEIPDv2FixtureWithMatchingV4SecretKeyFromFileWithTransform fixture transformPackets = do
(messagePacketsRaw, encryptedSecretPackets, passphrase) <-
loadSEIPDv2FixtureWithV4Secret fixture
let messagePackets = transformPackets messagePacketsRaw
passphraseCallback _ = pure BL.empty
keyInfos <-
collectSecretKeyInfos encryptedSecretPackets passphrase
let keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)
decrypted <-
DC.runConduitRes $
CL.sourceList messagePackets
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case [p | LiteralDataPkt _ _ _ p <- decrypted] of
(payload : _) ->
if BL.null payload
then
assertFailure
(fixture ++ " decrypt produced empty literal payload")
else pure ()
[] ->
assertFailure
( "expected decrypted literal payload from "
++ fixture
++ ", got: "
++ show decrypted
)
testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey :: Assertion
testConduitDecryptSEIPDv2WithPKESKv6RawSessionKey = do
let sessionKey = B.replicate 32 0x2a
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "v6 pkesk session key decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
packets ct =
[ PKESKPkt
( PKESKPayloadV6Packet
( PKESKPayloadV6
"\x01\x02\x03\x04\x05\x06\x07\x08"
RSA
"\x99\x88\x77"
)
)
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct))
]
callback _ = pure (BL.fromStrict sessionKey)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList (packets ciphertext)
DC..| conduitDecrypt callback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv6 raw session-key decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength
:: Assertion
testConduitDecryptSEIPDv2RejectsWrongPKESKv6RawSessionKeyLength = do
let sessionKey = B.replicate 32 0x2a
badSessionKey = B.replicate 31 0x2a
salt = Salt (B.pack [0x00 .. 0x1f])
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
"payload"
]
packets ct =
[ PKESKPkt
( PKESKPayloadV6Packet
( PKESKPayloadV6
"\x10\x11\x12\x13\x14\x15\x16\x17"
RSA
"\x01\x02\x03"
)
)
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ct))
]
callback _ = pure (BL.fromStrict badSessionKey)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
result <-
catch
( Right
<$> ( DC.runConduitRes $
CL.sourceList (packets ciphertext)
DC..| conduitDecrypt callback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err ->
if "PKESK raw session key length does not match payload algorithm"
`isInfixOf` err
then return ()
else
assertFailure
( "Expected PKESKv6 raw session-key length validation failure, got: "
++ err
)
Right got ->
assertFailure
( "Expected PKESKv6 raw session-key length failure, got packets: "
++ show got
)
testConduitDecryptSEIPDv2WithPKESKRSAUnwrap :: Assertion
testConduitDecryptSEIPDv2WithPKESKRSAUnwrap = do
(baseRecipient, privateKey) <- loadUnencryptedRsaSigner
publicKey <-
case _pubkey baseRecipient of
RSAPubKey (RSA_PublicKey pub) -> pure pub
other ->
assertFailure
( "unencrypted.seckey did not contain an RSA recipient, got "
++ show other
)
>> fail "expected RSA recipient"
let sessionKey = B.replicate 32 0x2b
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk rsa unwrap decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ = do
let msk = Just (RSAPrivateKey (RSA_PrivateKey privateKey))
pure $
fmap
( \sk ->
PKESKRecipientKey
{ pkeskRecipientPKPayload = Nothing
, pkeskRecipientSKey = sk
}
)
msk
encryptedResult <-
( P15.encrypt publicKey sessionKey
:: IO (Either RSA.Error B.ByteString)
)
encryptedSessionMaterial <-
case encryptedResult of
Left err ->
assertFailure ("RSA PKESK encryption failed: " ++ show err)
>> pure mempty
Right ct -> pure ct
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
let pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88")
RSA
(MPI (os2ip encryptedSessionMaterial) :| [])
)
)
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual "PKESK RSA unwrap decrypt payload" payload gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback
:: Assertion
testConduitDecryptSEIPDv2WithPKESKRSAUnwrapViaWildcardCallbackFallback = do
(baseRecipient, privateKey) <- loadUnencryptedRsaSigner
publicKey <-
case _pubkey baseRecipient of
RSAPubKey (RSA_PublicKey pub) -> pure pub
other ->
assertFailure
( "unencrypted.seckey did not contain an RSA recipient, got "
++ show other
)
>> fail "expected RSA recipient"
let sessionKey = B.replicate 32 0x2e
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk rsa unwrap decrypt path via wildcard callback fallback"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback pkt =
case pkt of
PKESKPkt
(PKESKPayloadV3Packet (PKESKPayloadV3 _ (EightOctetKeyId rid) _ _))
| BL.length rid == 8 && BL.all (== 0) rid ->
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Nothing
, pkeskRecipientSKey =
RSAPrivateKey (RSA_PrivateKey privateKey)
}
)
)
_ -> pure Nothing
encryptedResult <-
( P15.encrypt publicKey sessionKey
:: IO (Either RSA.Error B.ByteString)
)
encryptedSessionMaterial <-
case encryptedResult of
Left err ->
assertFailure ("RSA PKESK encryption failed: " ++ show err)
>> pure mempty
Right ct -> pure ct
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
let pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\xaa\xbb\xcc\xdd\xee\xff\x00\x11")
RSA
(MPI (os2ip encryptedSessionMaterial) :| [])
)
)
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESK RSA unwrap via wildcard callback fallback payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey
:: Assertion
testConduitDecryptSEIPDv2WithPKESKRSAUnwrapFromProtectedKey = do
passphrase <- readPKIPassphrase
secretPackets <-
DC.runConduitRes $
CB.sourceFile "tests/data/aes256-sha512.seckey"
DC..| conduitGet get
DC..| CL.consume
keyInfos <- collectSecretKeyInfos secretPackets passphrase
keyInfo <-
case keyInfos of
(ki : _) -> pure ki
[] ->
assertFailure
"aes256-sha512.seckey should yield at least one RSA key context"
>> fail "expected key info"
publicKey <-
case pkeskRecipientPKPayload keyInfo of
Nothing ->
assertFailure
"key info from file should include a public key payload"
>> fail "expected public key payload"
Just pkp ->
case _pubkey pkp of
RSAPubKey (RSA_PublicKey pub) -> pure pub
other ->
assertFailure
( "expected RSA public key from aes256-sha512.seckey, got "
++ show other
)
>> fail "expected RSA public key"
let sessionKey = B.replicate 32 0x42
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk rsa unwrap via sha1-cfb protected key loaded from file"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback pkt = pure (selectRecipientKeyInfo pkt keyInfos)
encryptedResult <-
( P15.encrypt publicKey sessionKey
:: IO (Either RSA.Error B.ByteString)
)
encryptedSessionMaterial <-
case encryptedResult of
Left err ->
assertFailure ("RSA PKESK encryption failed: " ++ show err)
>> pure mempty
Right ct -> pure ct
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
let pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x11\x22\x33\x44\x55\x66\x77\x88")
RSA
(MPI (os2ip encryptedSessionMaterial) :| [])
)
)
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESK RSA unwrap with SHA1-CFB protected key from file"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2WithPKESKECDHUnwrap :: Assertion
testConduitDecryptSEIPDv2WithPKESKECDHUnwrap = do
let (recipientPub, recipientPriv) = syntheticNISTP256Low
(ephPub, ephPriv) = syntheticNISTP256High
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey recipientPub))
SHA256
AES128
)
recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv)
sessionKey = B.replicate 32 0x2c
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
sharedSecret =
BA.convert
( ECCDH.getShared
(ECDSA.public_curve recipientPub)
(ECDSA.private_d ephPriv)
(ECDSA.public_q recipientPub)
)
:: B.ByteString
kdfParam =
buildECDHKDFParamForTest
recipientPKP
ECDH
(ECDSA.public_curve recipientPub)
SHA256
AES128
kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession
ephPointBytes =
maybe
(error "failed to encode ephemeral point")
id
(point2MBS (ECDSA.public_q ephPub))
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22")
ECDH
(MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk ecdh unwrap decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESK ECDH unwrap decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength
:: Assertion
testConduitDecryptSEIPDv2RejectsECDHWrongEphemeralPointLength = do
let (recipientPub, recipientPriv) = syntheticNISTP256Low
(ephPub, ephPriv) = syntheticNISTP256High
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey recipientPub))
SHA256
AES128
)
recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv)
sessionKey = B.replicate 32 0x2c
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
sharedSecret =
BA.convert
( ECCDH.getShared
(ECDSA.public_curve recipientPub)
(ECDSA.private_d ephPriv)
(ECDSA.public_q recipientPub)
)
:: B.ByteString
kdfParam =
buildECDHKDFParamForTest
recipientPKP
ECDH
(ECDSA.public_curve recipientPub)
SHA256
AES128
kek = deriveECDHKekForTest SHA256 AES128 sharedSecret kdfParam
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek encodedSession
ephPointBytes =
maybe
(error "failed to encode ephemeral point")
id
(point2MBS (ECDSA.public_q ephPub))
truncatedEphemeral = B.take (B.length ephPointBytes - 1) ephPointBytes
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22")
ECDH
(MPI (os2ip truncatedEphemeral) :| [MPI (os2ip wrappedSession)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk ecdh wrong ephemeral point length"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
result <-
catch
( Right
<$> DC.runConduitRes
( CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err ->
assertBool
"ECDH unwrap should reject wrong uncompressed point length for recipient curve"
("invalid length for recipient curve" `isInfixOf` err)
Right packets ->
assertFailure
( "Expected ECDH point-length validation failure, got: "
++ show packets
)
testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap :: Assertion
testConduitDecryptSEIPDv2WithPKESKX25519V3Unwrap = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6a)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef")
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk x25519 v3 unwrap decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESK X25519 v3 unwrap decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder
:: Assertion
testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossRecipientKeyOrder = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
wrongRecipientSecretRaw = B.pack [0x61 .. 0x80]
wrongRecipientSecret =
case CE.eitherCryptoError (C25519.secretKey wrongRecipientSecretRaw) of
Left err ->
error
( "failed to initialize wrong X25519 recipient secret key: "
++ show err
)
Right sk -> sk
wrongRecipientPublicRaw =
BA.convert (C25519.toPublic wrongRecipientSecret) :: B.ByteString
wrongRecipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip wrongRecipientPublicRaw)))
)
wrongRecipientSKey = X25519PrivateKey wrongRecipientSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6b)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk x25519 v3 wildcard key-id retry path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
wrongKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just wrongRecipientPKP
, pkeskRecipientSKey = wrongRecipientSKey
}
correctKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
keyContextCallback _rid _pka = pure [wrongKeyInfo, correctKeyInfo]
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithCandidatesCallbackAndPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv3 wildcard-keyid retries across recipient key order"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder
:: Assertion
testConduitDecryptSEIPDv2RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6c)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk x25519 v3 wildcard key-id long retry path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
mkSecretBytes offset =
B.pack
[fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]]
mkX25519RecipientKeyInfo label secretRaw =
let sk =
case CE.eitherCryptoError (C25519.secretKey secretRaw) of
Left err ->
error
( "failed to initialize "
++ label
++ " X25519 secret key: "
++ show err
)
Right secretKey -> secretKey
publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString
in PKESKRecipientKey
{ pkeskRecipientPKPayload =
Just
( PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip publicRaw)))
)
)
, pkeskRecipientSKey = X25519PrivateKey secretRaw
}
wrongKeyInfos =
[ mkX25519RecipientKeyInfo
("wrong-" ++ show n)
(mkSecretBytes (96 + n * 7))
| n <- [1 .. 20 :: Int]
]
correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw
keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo])
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithCandidatesCallbackAndPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv3 wildcard-keyid retries long recipient key order"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder
:: Assertion
testConduitDecryptSEIPDv1RetriesWildcardPKESKv3AcrossLongRecipientKeyOrder = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6d)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
payload =
"pkesk x25519 v3 wildcard key-id long retry legacy seipd1 path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
cleartext = BL.toStrict (runPut (put literalBlock))
iv = IV (B.pack [0x33 .. 0x42])
cleartextWithMDC = cleartext <> mdcTrailerForSEIPDv1 iv cleartext
passphraseCallback _ = pure BL.empty
mkSecretBytes offset =
B.pack
[fromIntegral ((offset + i) `mod` 256) | i <- [0 .. 31 :: Int]]
mkX25519RecipientKeyInfo label secretRaw =
let sk =
case CE.eitherCryptoError (C25519.secretKey secretRaw) of
Left err ->
error
( "failed to initialize "
++ label
++ " X25519 secret key: "
++ show err
)
Right secretKey -> secretKey
publicRaw = BA.convert (C25519.toPublic sk) :: B.ByteString
in PKESKRecipientKey
{ pkeskRecipientPKPayload =
Just
( PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip publicRaw)))
)
)
, pkeskRecipientSKey = X25519PrivateKey secretRaw
}
wrongKeyInfos =
[ mkX25519RecipientKeyInfo
("wrong-" ++ show n)
(mkSecretBytes (96 + n * 7))
| n <- [1 .. 20 :: Int]
]
correctKeyInfo = mkX25519RecipientKeyInfo "correct" recipientSecretRaw
keyContextCallback _rid _pka = pure (wrongKeyInfos ++ [correctKeyInfo])
ciphertext <-
either
( \e ->
assertFailure ("encryptOpenPGPCfbRaw failed: " ++ show e)
>> pure mempty
)
pure
( encryptOpenPGPCfbRaw
OpenPGPCFBNoResyncW
AES256
iv
cleartextWithMDC
(unSessionKey sessionKey)
)
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD1 1 (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithCandidatesCallbackAndPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESKv3 wildcard-keyid retries long recipient key order for SEIPDv1"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testMkCandidateResolverDecryptsWildcardPKESKv3 :: Assertion
testMkCandidateResolverDecryptsWildcardPKESKv3 = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
wrongSecretRaw = B.pack [0x61 .. 0x80]
wrongSecret =
case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of
Left err ->
error
("failed to initialize wrong X25519 secret key: " ++ show err)
Right sk -> sk
wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString
wrongPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip wrongPublicRaw)))
)
wrongSKey = X25519PrivateKey wrongSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6d)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "unwrap callback wildcard path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
wrongKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just wrongPKP
, pkeskRecipientSKey = wrongSKey
}
correctKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo]
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| ( void $
DCD.conduitDecrypt
DCD.DecryptOptions
{ DCD.decryptOptionsKeyResolution =
DCD.DecryptWithUnwrapCandidatesCallback resolver
, DCD.decryptOptionsPolicy = lenientDecryptPolicy
, DCD.decryptOptionsPassphraseCallback = passphraseCallback
}
)
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"unwrap callback should decrypt wildcard PKESK via candidate list"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptWildcardResolverProvidesTypedPreviousFailures
:: Assertion
testConduitDecryptWildcardResolverProvidesTypedPreviousFailures = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
wrongSecretRaw = B.pack [0x61 .. 0x80]
wrongSecret =
case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of
Left err ->
error
("failed to initialize wrong X25519 secret key: " ++ show err)
Right sk -> sk
wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString
wrongPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip wrongPublicRaw)))
)
wrongSKey = X25519PrivateKey wrongSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6e)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "typed previous failures for wildcard retries"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
wrongKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just wrongPKP
, pkeskRecipientSKey = wrongSKey
}
correctKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo]
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| ( void $
DCD.conduitDecrypt
DCD.DecryptOptions
{ DCD.decryptOptionsKeyResolution =
DCD.DecryptWithUnwrapCandidatesCallback resolver
, DCD.decryptOptionsPolicy = lenientDecryptPolicy
, DCD.decryptOptionsPassphraseCallback = passphraseCallback
}
)
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"wildcard retries with typed previous failures should still decrypt"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
pure ()
testConduitDecryptWithReportCapturesWildcardResolverDiagnostics
:: Assertion
testConduitDecryptWithReportCapturesWildcardResolverDiagnostics = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
wrongSecretRaw = B.pack [0x61 .. 0x80]
wrongSecret =
case CE.eitherCryptoError (C25519.secretKey wrongSecretRaw) of
Left err ->
error
("failed to initialize wrong X25519 secret key: " ++ show err)
Right sk -> sk
wrongPublicRaw = BA.convert (C25519.toPublic wrongSecret) :: B.ByteString
wrongPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip wrongPublicRaw)))
)
wrongSKey = X25519PrivateKey wrongSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6f)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId (BL.replicate 8 0))
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "conduitDecryptWithReport wildcard diagnostics"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
wrongKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just wrongPKP
, pkeskRecipientSKey = wrongSKey
}
correctKeyInfo =
PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
let resolver _rid _pka = pure [wrongKeyInfo, correctKeyInfo]
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
(report, decrypted) <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| DC.fuseBoth
( DCD.conduitDecryptWithReport
DCD.DecryptOptions
{ DCD.decryptOptionsKeyResolution =
DCD.DecryptWithUnwrapCandidatesCallback resolver
, DCD.decryptOptionsPolicy = lenientDecryptPolicy
, DCD.decryptOptionsPassphraseCallback = passphraseCallback
}
)
CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"wildcard retries with report diagnostics should decrypt"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
assertEqual
"decrypt report should preserve outcome"
DCD.DecryptClean
(DCD.decryptReportOutcome report)
case DCD.decryptReportSessionKeyResolutions report of
[resolution] -> do
assertEqual
"resolution path should be PKESK for wildcard key retries"
DCD.DecryptResolvedViaPKESK
(DCD.decryptSessionResolutionPath resolution)
let attempts = DCD.decryptSessionResolutionResolverAttempts resolution
assertBool
"report should contain wildcard resolver attempts"
(length attempts >= 2)
assertBool
"report should record typed previous failures in resolver attempt context"
( any
( \attempt ->
any
( \failure ->
DCD.pkeskAttemptFailureKind failure
== DCD.PKESKAttemptUnwrapFailed
&& DCD.pkeskAttemptFailureKeyContext failure == Just (V4, X25519)
)
(DCD.pkeskResolverAttemptPreviousFailures attempt)
)
attempts
)
assertBool
"report should capture ResolveWith key context for X25519"
( any
( \attempt ->
DCD.pkeskResolverAttemptAction attempt
== DCD.ResolverAttemptResolveWith (Just (V4, X25519))
)
attempts
)
other ->
assertFailure
( "Expected exactly one session-key resolution report, got "
++ show (length other)
)
testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength
:: Assertion
testConduitDecryptSEIPDv2RejectsPKESKX25519V3WrongEphemeralLength = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKey = SessionKey (B.replicate 32 0x6a)
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek (unSessionKey sessionKey)
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
overlongEphemeral = ephPublicRaw <> "\x00\x01"
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef")
X25519
(MPI (os2ip overlongEphemeral) :| [MPI (os2ip eskWithAlgo)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk x25519 v3 wrong ephemeral length"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
result <-
catch
( Right
<$> DC.runConduitRes
( CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err ->
assertBool
"PKESKv3 X25519 unwrap should reject non-32-byte ephemeral values"
( "invalid X25519 ephemeral public key length/prefix"
`isInfixOf` err
)
Right packets ->
assertFailure
( "Expected X25519 ephemeral-length validation failure, got: "
++ show packets
)
testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519
:: Assertion
testConduitDecryptSEIPDv2FallsBackFromArgon2SKESKToPKESKv3X25519 = do
let recipientSecretRaw = B.pack [0x21 .. 0x40]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X25519 recipient secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientSKey = X25519PrivateKey recipientSecretRaw
ephSecretRaw = B.pack [0x41 .. 0x60]
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X25519 ephemeral secret key: " ++ show err)
Right sk -> sk
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPub =
case CE.eitherCryptoError (C25519.publicKey recipientPublicRaw) of
Left err ->
error
("failed to initialize X25519 recipient public key: " ++ show err)
Right pk -> pk
sharedSecret = BA.convert (C25519.dh recipientPub ephSecret) :: B.ByteString
kek =
deriveX25519KekForTest
ephPublicRaw
recipientPublicRaw
sharedSecret
sessionKeyBytes = B.replicate 32 0x6a
sessionKey = SessionKey sessionKeyBytes
wrappedSession = aesKeyWrapRFC3394ForTest AES128 kek sessionKeyBytes
eskWithAlgo = B.singleton (fromFVal AES256) <> wrappedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x12\x34\x56\x78\x90\xab\xcd\xef")
X25519
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip eskWithAlgo)])
)
)
skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
skeskPassphrase = "correct horse battery staple"
wrongPassphrase = "wrong passphrase"
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "skesk->pkesk fallback decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
passphraseCallback _ = pure wrongPassphrase
keyLen <-
case keySize AES256 of
Left err ->
assertFailure ("keySize failed for AES256: " ++ show err)
>> fail "keySize failed"
Right n -> pure n
skeskKek <-
case string2Key skeskS2K keyLen skeskPassphrase of
Left err ->
assertFailure
("string2Key failed for Argon2 SKESK: " ++ renderS2KError err)
>> fail "string2Key failed"
Right x -> pure x
skeskEncryptedEsk <-
case withSymmetricCipher AES256 skeskKek $ \cipher ->
paddedCfbEncrypt
cipher
(B.replicate (blockSize cipher) 0)
(B.singleton (fromFVal AES256) <> sessionKeyBytes) of
Left err ->
assertFailure
("encrypting Argon2 SKESK ESK failed: " ++ show err)
>> fail "encrypting SKESK ESK failed"
Right x -> pure x
let skesk =
SKESKPkt
( SKESKPayloadV4Packet
( SKESKPayloadV4
AES256
skeskS2K
(Just (BL.fromStrict skeskEncryptedEsk))
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ skesk
, pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"conduitDecrypt should fall back from failing Argon2 SKESK to PKESKv3 X25519"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK
:: Assertion
testConduitDecryptSEIPDv2FallsBackToEarlierArgon2SKESK = do
let skeskS2K = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
passphrase = "password"
sessionKeyBytes = B.replicate 32 0x7b
sessionKey = SessionKey sessionKeyBytes
badLatestEsk = BL.fromStrict (B.pack [0x00])
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "earlier argon2 skesk fallback decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure passphrase
keyLen <-
case keySize AES256 of
Left err ->
assertFailure ("keySize failed for AES256: " ++ show err)
>> fail "keySize failed"
Right n -> pure n
skeskKek <-
case string2Key skeskS2K keyLen passphrase of
Left err ->
assertFailure
("string2Key failed for Argon2 SKESK: " ++ renderS2KError err)
>> fail "string2Key failed"
Right x -> pure x
validEsk <-
case withSymmetricCipher AES256 skeskKek $ \cipher ->
paddedCfbEncrypt
cipher
(B.replicate (blockSize cipher) 0)
(B.singleton (fromFVal AES256) <> sessionKeyBytes) of
Left err ->
assertFailure
("encrypting Argon2 SKESK ESK failed: " ++ show err)
>> fail "encrypting SKESK ESK failed"
Right x -> pure x
let earlierValidSKESK =
SKESKPkt
( SKESKPayloadV4Packet
(SKESKPayloadV4 AES256 skeskS2K (Just (BL.fromStrict validEsk)))
)
latestUnusableSKESK =
SKESKPkt
( SKESKPayloadV4Packet
(SKESKPayloadV4 AES256 skeskS2K (Just badLatestEsk))
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ earlierValidSKESK
, latestUnusableSKESK
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
(\_ -> pure Nothing)
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"conduitDecrypt should retry earlier Argon2 SKESK when latest SKESK is unusable"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RejectsECDHNonTable30Params :: Assertion
testConduitDecryptSEIPDv2RejectsECDHNonTable30Params = do
let (recipientPub, recipientPriv) = syntheticNISTP256Low
(ephPub, ephPriv) = syntheticNISTP256High
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey recipientPub))
SHA256
AES256
)
recipientSKey = ECDHPrivateKey (ECDSA_PrivateKey recipientPriv)
sessionKey = B.replicate 32 0x2c
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
sharedSecret =
BA.convert
( ECCDH.getShared
(ECDSA.public_curve recipientPub)
(ECDSA.private_d ephPriv)
(ECDSA.public_q recipientPub)
)
:: B.ByteString
kdfParam =
buildECDHKDFParamForTest
recipientPKP
ECDH
(ECDSA.public_curve recipientPub)
SHA256
AES256
kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam
wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession
ephPointBytes =
maybe
(error "failed to encode ephemeral point")
id
(point2MBS (ECDSA.public_q ephPub))
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22")
ECDH
(MPI (os2ip ephPointBytes) :| [MPI (os2ip wrappedSession)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk ecdh unwrap policy failure path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
result <-
catch
( Right
<$> DC.runConduitRes
( CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err ->
assertBool
"ECDH unwrap should reject non-Table-30 parameters"
("Table 30 policy violation" `isInfixOf` err)
Right packets ->
assertFailure
( "Expected Table 30 policy failure, got decrypted packets: "
++ show packets
)
testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams
:: Assertion
testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyRFC6637AcceptedParams = do
let recipientSecretRaw = B.pack [1 .. 32]
ephSecretRaw = B.pack [101 .. 132]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy recipient secret key: "
++ show err
)
Right sk -> sk
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy ephemeral secret key: "
++ show err
)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
( EdDSAPubKey
EdSigningCurve25519
( PrefixedNativeEPoint
(EPoint (os2ip (B.cons 0x40 recipientPublicRaw)))
)
)
SHA256
AES256
)
recipientSKey =
ECDHPrivateKey
( ECDSA_PrivateKey
( ECDSA.PrivateKey
(ECCT.getCurveByName ECCT.SEC_p256r1)
(os2ip recipientSecretRaw)
)
)
sessionKey = B.replicate 32 0x3d
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
sharedSecret =
BA.convert
(C25519.dh (C25519.toPublic ephSecret) recipientSecret)
:: B.ByteString
kdfParam =
buildCurve25519LegacyKdfParamForTest
recipientPKP
ECDH
SHA256
AES256
kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam
wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22")
ECDH
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk ecdh v4 curve25519legacy accepted-combo path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"v4 Curve25519Legacy ECDH should allow RFC6637-accepted parameters"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI
:: Assertion
testConduitDecryptSEIPDv2AllowsV4Curve25519LegacyWithTruncatedWrappedMPI = do
let recipientSecretRaw = B.pack [1 .. 32]
ephSecretRaw = B.pack [101 .. 132]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy recipient secret key: "
++ show err
)
Right sk -> sk
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy ephemeral secret key: "
++ show err
)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPKP =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
( EdDSAPubKey
EdSigningCurve25519
( PrefixedNativeEPoint
(EPoint (os2ip (B.cons 0x40 recipientPublicRaw)))
)
)
SHA256
AES256
)
recipientSKey =
ECDHPrivateKey
( ECDSA_PrivateKey
( ECDSA.PrivateKey
(ECCT.getCurveByName ECCT.SEC_p256r1)
(os2ip recipientSecretRaw)
)
)
sharedSecret =
BA.convert
(C25519.dh (C25519.toPublic ephSecret) recipientSecret)
:: B.ByteString
kdfParam =
buildCurve25519LegacyKdfParamForTest
recipientPKP
ECDH
SHA256
AES256
kek = deriveECDHKekForTest SHA256 AES256 sharedSecret kdfParam
candidate =
find
( \(_, wrappedSession) -> not (B.null wrappedSession) && B.head wrappedSession == 0x00
)
[ let sessionKeyBytes =
B.pack
[ fromIntegral ((seed + offset) `mod` 256)
| offset <- [0 .. 31]
]
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKeyBytes
<> encodeChecksum16 sessionKeyBytes
<> B.replicate 5 0
wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession
in (SessionKey sessionKeyBytes, wrappedSession)
| seed <- [0 .. 4095 :: Int]
]
case candidate of
Nothing ->
assertFailure
"failed to find deterministic Curve25519Legacy wrapped session key with leading zero"
Just (sessionKey, wrappedSession) -> do
let pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22")
ECDH
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk ecdh v4 curve25519legacy truncated wrapped-mpi path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
sessionKey
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"v4 Curve25519Legacy ECDH should unwrap after wrapped-MPI leading-zero truncation"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params
:: Assertion
testConduitDecryptSEIPDv2RejectsV6Curve25519LegacyNonTable30Params = do
let recipientSecretRaw = B.pack [1 .. 32]
ephSecretRaw = B.pack [101 .. 132]
recipientSecret =
case CE.eitherCryptoError (C25519.secretKey recipientSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy recipient secret key: "
++ show err
)
Right sk -> sk
ephSecret =
case CE.eitherCryptoError (C25519.secretKey ephSecretRaw) of
Left err ->
error
( "failed to initialize Curve25519Legacy ephemeral secret key: "
++ show err
)
Right sk -> sk
recipientPublicRaw = BA.convert (C25519.toPublic recipientSecret) :: B.ByteString
ephPublicRaw = BA.convert (C25519.toPublic ephSecret) :: B.ByteString
recipientPKP =
PKPayload
V6
(ThirtyTwoBitTimeStamp 0)
0
ECDH
( ECDHPubKey
( EdDSAPubKey
EdSigningCurve25519
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
SHA512
AES256
)
recipientSKey =
ECDHPrivateKey
( ECDSA_PrivateKey
( ECDSA.PrivateKey
(ECCT.getCurveByName ECCT.SEC_p256r1)
(os2ip recipientSecretRaw)
)
)
sessionKey = B.replicate 32 0x3d
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
sharedSecret =
BA.convert
(C25519.dh (C25519.toPublic ephSecret) recipientSecret)
:: B.ByteString
kdfParam =
buildCurve25519LegacyKdfParamForTest
recipientPKP
ECDH
SHA512
AES256
kek = deriveECDHKekForTest SHA512 AES256 sharedSecret kdfParam
wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession
pkesk =
PKESKPkt
( PKESKPayloadV3Packet
( PKESKPayloadV3
3
(EightOctetKeyId "\x99\x88\x77\x66\x55\x44\x33\x22")
ECDH
(MPI (os2ip ephPublicRaw) :| [MPI (os2ip wrappedSession)])
)
)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk ecdh v6 curve25519legacy strict path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = recipientSKey
}
)
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
result <-
catch
( Right
<$> DC.runConduitRes
( CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithDecryptPolicy
lenientDecryptPolicy
keyContextCallback
passphraseCallback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err ->
assertBool
"v6 Curve25519Legacy ECDH should remain strict"
("Table 30 policy violation" `isInfixOf` err)
Right packets ->
assertFailure
( "Expected Table 30 policy failure, got decrypted packets: "
++ show packets
)
testConduitDecryptSEIPDv2WithPKESKX448Unwrap :: Assertion
testConduitDecryptSEIPDv2WithPKESKX448Unwrap = do
let recipientSecretRaw = B.pack [1 .. 56]
ephSecretRaw = B.pack [57 .. 112]
sessionKey = B.replicate 32 0x4d
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
recipientSecret =
case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X448 recipient secret key: " ++ show err)
Right sk -> sk
ephSecret =
case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X448 ephemeral secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString
ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString
sharedSecret =
BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret)
:: B.ByteString
kek =
deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret
wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession
esk =
ephPublicRaw
<> B.singleton (fromIntegral (B.length wrappedSession))
<> wrappedSession
recipientPKP =
PKPayload
V6
(ThirtyTwoBitTimeStamp 0)
0
X448
( EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientRid = unFingerprint (fingerprint recipientPKP)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk x448 unwrap decrypt path"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = X448PrivateKey recipientSecretRaw
}
)
)
pkesk =
PKESKPkt
( PKESKPayloadV6Packet
(PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
decrypted <-
DC.runConduitRes $
CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
case decrypted of
[LiteralDataPkt _ _ _ gotPayload] ->
assertEqual
"PKESK X448 unwrap decrypt payload"
payload
gotPayload
other ->
assertFailure
("Expected one decrypted literal packet, got " ++ show other)
testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength
:: Assertion
testConduitDecryptSEIPDv2RejectsPKESKX448WrongEphemeralLength = do
let recipientSecretRaw = B.pack [1 .. 56]
ephSecretRaw = B.pack [57 .. 112]
sessionKey = B.replicate 32 0x4d
encodedSession =
B.singleton (fromFVal AES256)
<> sessionKey
<> encodeChecksum16 sessionKey
<> B.replicate 5 0
recipientSecret =
case CE.eitherCryptoError (C448.secretKey recipientSecretRaw) of
Left err ->
error
("failed to initialize X448 recipient secret key: " ++ show err)
Right sk -> sk
ephSecret =
case CE.eitherCryptoError (C448.secretKey ephSecretRaw) of
Left err ->
error
("failed to initialize X448 ephemeral secret key: " ++ show err)
Right sk -> sk
recipientPublicRaw = BA.convert (C448.toPublic recipientSecret) :: B.ByteString
ephPublicRaw = BA.convert (C448.toPublic ephSecret) :: B.ByteString
shortEphemeral = B.tail ephPublicRaw
sharedSecret =
BA.convert (C448.dh (C448.toPublic recipientSecret) ephSecret)
:: B.ByteString
kek =
deriveX448KekForTest ephPublicRaw recipientPublicRaw sharedSecret
wrappedSession = aesKeyWrapRFC3394ForTest AES256 kek encodedSession
esk =
shortEphemeral
<> B.singleton (fromIntegral (B.length wrappedSession))
<> wrappedSession
recipientPKP =
PKPayload
V6
(ThirtyTwoBitTimeStamp 0)
0
X448
( EdDSAPubKey
EdSigningCurve448
(NativeEPoint (EPoint (os2ip recipientPublicRaw)))
)
recipientRid = unFingerprint (fingerprint recipientPKP)
salt = Salt (B.pack [0x00 .. 0x1f])
payload = "pkesk x448 wrong ephemeral length"
literalBlock =
Block
[ LiteralDataPkt
BinaryData
BL.empty
(ThirtyTwoBitTimeStamp 0)
payload
]
passphraseCallback _ = pure BL.empty
keyContextCallback _ =
pure
( Just
( PKESKRecipientKey
{ pkeskRecipientPKPayload = Just recipientPKP
, pkeskRecipientSKey = X448PrivateKey recipientSecretRaw
}
)
)
pkesk =
PKESKPkt
( PKESKPayloadV6Packet
(PKESKPayloadV6 recipientRid X448 (BL.fromStrict esk))
)
ciphertext <-
case encryptSEIPDv2Payload
AES256
OCB
6
salt
(SessionKey sessionKey)
(BL.toStrict (runPut (put literalBlock))) of
Left err ->
assertFailure ("encryptSEIPDv2Payload failed: " ++ err)
>> pure mempty
Right ct -> pure ct
result <-
catch
( Right
<$> DC.runConduitRes
( CL.sourceList
[ pkesk
, SymEncIntegrityProtectedDataPkt
(SEIPD2 AES256 OCB 6 salt (BL.fromStrict ciphertext))
]
DC..| conduitDecryptWithPKESKContext
keyContextCallback
passphraseCallback
DC..| CL.consume
)
)
(\e -> pure (Left (show (e :: SomeException))))
case result of
Left err ->
assertBool
"PKESKv6 X448 unwrap should reject non-56-byte ephemeral values"
("expected 56-octet ephemeral value" `isInfixOf` err)
Right packets ->
assertFailure
( "Expected X448 ephemeral-length validation failure, got: "
++ show packets
)
testDecodeOpenPGPEncodedSessionKeyRejectsTooShort :: Assertion
testDecodeOpenPGPEncodedSessionKeyRejectsTooShort =
assertEqual
"encoded session key should reject too-short payloads"
(Left EncodedSessionKeyTooShort)
(decodeOpenPGPEncodedSessionKey (B.pack [0x09, 0x01]))
testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch
:: Assertion
testDecodeOpenPGPEncodedSessionKeyRejectsLengthMismatch =
assertEqual
"encoded session key should reject algorithm/key-length mismatches"
(Left (EncodedSessionKeyLengthMismatch AES128 16 3))
( decodeOpenPGPEncodedSessionKey
(B.pack [fromFVal AES128, 0x01, 0x02, 0x03])
)
testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch
:: Assertion
testDecodeOpenPGPEncodedSessionKeyRejectsChecksumMismatch =
assertEqual
"encoded session key should reject checksum mismatches"
(Left EncodedSessionKeyChecksumMismatch)
( decodeOpenPGPEncodedSessionKey
(B.pack ([fromFVal AES128] <> replicate 16 0x00 <> [0x00, 0x01]))
)
testSKESKRejectsUnknownVersion :: Assertion
testSKESKRejectsUnknownVersion = do
let s2k = Simple SHA256
pkt =
SKESKPkt
(SKESKPayloadV4Packet (SKESKPayloadV4 AES128 s2k Nothing))
encoded = BL.toStrict (runPut (put pkt))
malformed =
BL.fromStrict
(B.take 2 encoded <> B.singleton 5 <> B.drop 3 encoded)
case runGet (get :: Get Pkt) malformed of
Right (BrokenPacketPkt errReason 3 _) ->
assertBool
("expected unsupported SKESK version error, got: " ++ errReason)
("unsupported SKESK packet version" `isInfixOf` errReason)
Right other ->
assertFailure
( "unknown SKESK version should not parse successfully: "
++ show other
)
Left err ->
assertFailure
( "unknown SKESK version should be reported as a broken packet: "
++ err
)
testSKESK4EncryptedSessionKeyRejectsSimpleS2K :: Assertion
testSKESK4EncryptedSessionKeyRejectsSimpleS2K = do
let pkt =
SKESKPkt
( SKESKPayloadV4Packet
( SKESKPayloadV4
AES128
(Simple SHA256)
(Just (BL.pack [0x01, 0x02, 0x03]))
)
)
encoded = runPut (put pkt)
case runGet (get :: Get Pkt) encoded of
Right (BrokenPacketPkt errReason 3 _) ->
assertBool
("expected Simple S2K rejection, got: " ++ errReason)
("must not use Simple S2K" `isInfixOf` errReason)
Right other ->
assertFailure
( "Simple-S2K v4 SKESK with encrypted session key should not parse successfully: "
++ show other
)
Left err ->
assertFailure
( "Simple-S2K v4 SKESK with encrypted session key should be reported as a broken packet: "
++ err
)
testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES
:: Assertion
testSKESK4Argon2EncryptedSessionKeyRoundTripAcrossAES =
mapM_ assertRoundTrip [AES128, AES192, AES256]
where
passphrase = "password"
s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
assertRoundTrip sa = do
keyLen <-
case keySize sa of
Left err ->
assertFailure
("keySize failed for " ++ show sa ++ ": " ++ show err)
>> fail "keySize failed"
Right n -> pure n
kek <-
case string2Key s2k keyLen passphrase of
Left err ->
assertFailure
("string2Key failed for " ++ show sa ++ ": " ++ renderS2KError err)
>> fail "string2Key failed"
Right x -> pure x
let sessionKey = B.pack (take keyLen (cycle [0x11, 0x22, 0x33, 0x44]))
encodedSessionKey = B.singleton (fromFVal sa) <> sessionKey
encryptedEsk <-
case withSymmetricCipher sa kek $ \cipher ->
paddedCfbEncrypt
cipher
(B.replicate (blockSize cipher) 0)
encodedSessionKey of
Left err ->
assertFailure
( "encrypting SKESK v4 ESK failed for "
++ show sa
++ ": "
++ show err
)
>> fail "encrypting SKESK v4 ESK failed"
Right x -> pure x
let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk))
case skesk2SessionKey skesk passphrase of
Right (decodedAlgo, decodedSessionKey) -> do
assertEqual
("decoded SKESK v4 encrypted ESK algorithm for " ++ show sa)
sa
decodedAlgo
assertEqual
("decoded SKESK v4 encrypted ESK session key for " ++ show sa)
sessionKey
decodedSessionKey
Left err ->
assertFailure
( "decoding SKESK v4 encrypted ESK failed for "
++ show sa
++ ": "
++ renderS2KError err
)
testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum
:: Assertion
testSKESK4Argon2EncryptedSessionKeyRejectsTrailingChecksum = do
let sa = AES128
passphrase = "password"
s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
sessionKey = B.pack (take 16 (cycle [0xaa, 0xbb, 0xcc, 0xdd]))
keyLen <-
case keySize sa of
Left err ->
assertFailure ("keySize failed: " ++ show err)
>> fail "keySize failed"
Right n -> pure n
kek <-
case string2Key s2k keyLen passphrase of
Left err ->
assertFailure ("string2Key failed: " ++ renderS2KError err)
>> fail "string2Key failed"
Right x -> pure x
let encodedWithChecksum =
B.singleton (fromFVal sa)
<> sessionKey
<> encodeChecksum16 sessionKey
encryptedEsk <-
case withSymmetricCipher sa kek $ \cipher ->
paddedCfbEncrypt
cipher
(B.replicate (blockSize cipher) 0)
encodedWithChecksum of
Left err ->
assertFailure
("encrypting malformed SKESK v4 ESK failed: " ++ show err)
>> fail "encrypting malformed SKESK v4 ESK failed"
Right x -> pure x
let skesk = SKESK4Packet sa s2k (Just (BL.fromStrict encryptedEsk))
case skesk2SessionKey skesk passphrase of
Left
( S2KEncryptedSessionKeyDecodeError
(EncodedSessionKeyLengthMismatch AES128 16 18)
) -> pure ()
Left err ->
assertFailure
( "expected SKESK v4 trailing-checksum rejection, got: "
++ renderS2KError err
)
Right _ ->
assertFailure
"expected SKESK v4 trailing-checksum rejection, but decode succeeded"
testEncryptPassphraseWithPolicyForceV4Interop :: Assertion
testEncryptPassphraseWithPolicyForceV4Interop = do
let request =
PassphraseEncryptRequest
{ passphraseEncryptVersionPolicy = PassphraseSKESKForceV4Interop
, passphraseEncryptSymmetricAlgorithm = AES128
, passphraseEncryptS2K = Simple SHA256
, passphraseEncryptPassphrase = "password"
, passphraseEncryptPayload = "hello"
, passphraseEncryptSEIPDv1IVOverride =
Just (IV (B.replicate 16 0x22))
, passphraseEncryptSEIPDv2AEADOverride = Nothing
, passphraseEncryptSEIPDv2ChunkSizeOverride = Nothing
, passphraseEncryptSEIPDv2SaltOverride = Nothing
}
result <- encryptPassphraseWithPolicy request
case result of
Left err ->
assertFailure
( "Expected passphrase SKESK force-v4 encryption to succeed, got: "
++ err
)
Right
( SKESKPkt (SKESKPayloadV4Packet _)
: SymEncIntegrityProtectedDataPkt (SEIPD1 _ _)
: _
) ->
pure ()
Right packets ->
assertFailure
( "Expected SKESKv4 + SEIPDv1 packet sequence, got: "
++ show packets
)
testEncryptPassphraseWithPolicyPreferV6 :: Assertion
testEncryptPassphraseWithPolicyPreferV6 = do
let request =
PassphraseEncryptRequest
{ passphraseEncryptVersionPolicy = PassphraseSKESKPreferV6
, passphraseEncryptSymmetricAlgorithm = AES128
, passphraseEncryptS2K = Simple SHA256
, passphraseEncryptPassphrase = "password"
, passphraseEncryptPayload = "hello"
, passphraseEncryptSEIPDv1IVOverride = Nothing
, passphraseEncryptSEIPDv2AEADOverride = Just OCB
, passphraseEncryptSEIPDv2ChunkSizeOverride = Just 6
, passphraseEncryptSEIPDv2SaltOverride =
Just (Salt (B.replicate 32 0x44))
}
result <- encryptPassphraseWithPolicy request
case result of
Left err ->
assertFailure
( "Expected passphrase SKESK prefer-v6 encryption to succeed, got: "
++ err
)
Right
( SKESKPkt (SKESKPayloadV6Packet _)
: SymEncIntegrityProtectedDataPkt (SEIPD2 _ _ _ _ _)
: _
) ->
pure ()
Right packets ->
assertFailure
( "Expected SKESKv6 + SEIPDv2 packet sequence, got: "
++ show packets
)
testArgon2S2KVector :: Assertion
testArgon2S2KVector = do
let s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
pass = BLC8.pack "password"
derivedKeyResult = string2Key s2k 16 pass
derivedKey <-
case derivedKeyResult of
Left err ->
assertFailure
("Argon2 S2K key derivation failed: " ++ renderS2KError err)
>> fail "Argon2 key derivation failed"
Right x -> pure x
let
hex =
map toUpper . BLC8.unpack . B16L.encode . BL.fromStrict $
derivedKey
assertEqual
"Argon2 S2K key derivation vector"
"A3BDFE3814D790F1F366ABA6954EB386"
hex
testArgon2S2KOrdTotal :: Assertion
testArgon2S2KOrdTotal = do
let argon2A = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
argon2B = Argon2 (Salt16 (B.pack [0x01 .. 0x10])) 1 4 15
assertEqual
"Argon2 S2K compares after simple S2K"
GT
(compare argon2A (Simple SHA256))
assertEqual
"Argon2 S2K compares before unknown S2K types"
LT
(compare argon2A (OtherS2K 101 BL.empty))
assertEqual
"Argon2 S2K constructor compares lexicographically by fields"
LT
(compare argon2A argon2B)