hOpenPGP-3.1: tests/Tests/MessageAndArmor.hs
-- MessageAndArmor.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 #-}
{-# LANGUAGE TypeApplications #-}
module Tests.MessageAndArmor (messageAndArmorTests) where
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( Armor (..)
, ArmorType (..)
)
import qualified Crypto.PubKey.Ed25519 as Ed25519
import qualified Crypto.PubKey.RSA as RSA
import Data.Binary (get, put)
import Data.Binary.Get (Get, runGetOrFail)
import Data.Binary.Put
( putByteString
, putWord16be
, putWord32be
, putWord8
, runPut
)
import Data.Bits (xor)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import Data.Either (isLeft, isRight)
import Data.List (isInfixOf)
import qualified Data.List.NonEmpty as NE
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit
( Assertion
, assertBool
, assertEqual
, assertFailure
, testCase
)
import Codec.Encryption.OpenPGP.BlockCipher (keySize)
import Codec.Encryption.OpenPGP.CFB
( decryptPreservingNonce
, validateSEIPD1MDC
)
import Codec.Encryption.OpenPGP.Encrypt
( encryptSEIPDv2WithSKESKBlock
)
import Codec.Encryption.OpenPGP.Fingerprint
( eightOctetKeyID
, fingerprint
)
import Codec.Encryption.OpenPGP.Internal (emptyPSC, lastLD)
import Codec.Encryption.OpenPGP.KeyringParser (parseUnknownTKs)
import Codec.Encryption.OpenPGP.Message
import Codec.Encryption.OpenPGP.Policy
( defaultVerificationPolicy
, signatureV6SaltSizeForHashAlgorithm
)
import Codec.Encryption.OpenPGP.S2K (renderS2KError, string2Key)
import Codec.Encryption.OpenPGP.Serialize
( armorPayloadsOfType
, parsePkts
, parsePktsEither
, recommendedArmorType
, singleArmorPayloadOfType
, singleClearSignedBlock
)
import Codec.Encryption.OpenPGP.SerializeForSigs
( payloadForSig
, payloadForSigWith
)
import Codec.Encryption.OpenPGP.Signatures
( SignError (..)
, VerificationError (..)
, renderSignError
, renderVerificationError
, signCertRevocationWithRSA
, signCertificationWithRSA
, signDataWithEd25519
, signDataWithEd25519Builder
, signDataWithEd25519V6
, signDataWithEd25519V6Builder
, signDataWithEd448
, signDataWithEd448V6
, signDataWithRSA
, signDataWithRSABuilder
, signDirectKeyWithRSA
, signKeyRevocationWithRSA
, signSubkeyRevocationWithRSA
, verifyAgainstKeyring
, verifyAgainstKeys
, verifySigWith
)
import Codec.Encryption.OpenPGP.Subpackets
( TextNormalizationMode (..)
, addHashedSubs
, addUnhashedSubs
, listToHashedSubs
, listToUnhashedSubs
, sbTextNormMode
, sigBuilderInit
)
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Data.Conduit.OpenPGP.Message
( verifyMessage
, verifyMessagePackets
)
import Data.Conduit.OpenPGP.Verify (VerificationMode (..))
import Tests.Common
( addTimestampSeconds
, assertSingleFailureContainsTimeline
, assertSingleSignerFingerprint
, encryptMessageDefault
, expectV4PKPayload
, expectV6PKPayload
, extractV4SignatureAlgorithmFields
, fp
, loadAndDecompressPkts
, loadArmor
, loadDeterministicEd25519Signer
, loadDeterministicEd25519SignerV6
, loadDeterministicEd448Signer
, loadDeterministicEd448SignerV6
, loadKeyring
, loadUnencryptedRsaSigner
, loadUnencryptedRsaSignerV6
, messageIssuerSubpacketsAt
, mkTestKeyring
, readFixtureLazy
, setPKAlgorithm
, signBinaryMessageWithEd25519At
, signBinaryMessageWithRSAAt
, signKeyRevocationWithReasonAndExtrasAt
, signKeyRevocationWithReasonAt
, signSubkeyBindingWithRSAAt
, signSubkeyRevocationWithRSAAt
, verifyTimelinePackets
)
messageAndArmorTests :: TestTree
messageAndArmorTests =
testGroup
"Message API and armor fixtures"
[ testGroup
"Message API group"
[ testCase
"default encrypt/decrypt message"
testDefaultedEncryptDecrypt
, testCase
"specific encrypt/decrypt message"
testExplicitEncryptDecrypt
, testCase
"specific encrypt can expose effective session material"
testExplicitEncryptExposesEffectiveSessionMaterial
, testCase
"default encrypt does not expose session material"
testDefaultEncryptDoesNotExposeSessionMaterial
, testCase
"AES-128 EAX encrypt/decrypt message"
testExplicitAES128EAXEncryptDecrypt
, testCase
"AES-128 GCM encrypt/decrypt message"
testExplicitAES128GCMEncryptDecrypt
, testCase
"specific encrypt rejects deprecated S2K hash in modern mode"
testExplicitEncryptRejectsDeprecatedS2KHash
, testCase
"legacy fallback encrypt/decrypt message"
testLegacyFallbackEncryptDecrypt
, testCase
"RFC4880 encryptMessage SEIPDv1 cleartext parses without trailing junk"
testRFC4880EncryptMessageSEIPDv1ParsesCleanly
, testCase
"decryptMessage returns typed parse failures"
testDecryptMessageTypedParseFailure
, testCase
"decryptMessage rejects unknown critical packets"
testDecryptMessageRejectsUnknownCriticalPacket
, testCase
"decryptMessage returns typed decrypt failures"
testDecryptMessageTypedDecryptFailure
, testCase
"decryptMessage rejects SEIPDv1 MDC tampering"
testDecryptMessageSEIPDv1MDCTampering
, testCase "sign message shape" testSignMessageShape
, testCase "sign message shape (RSA SigV6)" testSignMessageRSAV6
, testCase "sign message shape (Ed25519)" testSignMessageEd25519
, testCase
"sign message shape (Ed25519 SigV6)"
testSignMessageEd25519V6
, testCase "sign message shape (Ed448)" testSignMessageEd448
, testCase
"sign message shape (Ed448 SigV6)"
testSignMessageEd448V6
, testCase
"v4 Ed25519/Ed448 signatures use native fixed-width encoding"
testV4EdSignaturesUseNativeFixedWidthEncoding
, testCase
"v4 Ed25519Legacy key parsing rejects missing 0x40 prefix"
testV4Ed25519LegacyKeyRejectsMissingPrefix
, testCase
"detached v4 Ed25519 verification tolerates missing issuer hints"
testVerifyDetachedEd25519WithoutIssuerHints
, testCase
"detached v4 Ed25519 verification tolerates fake issuer hints"
testVerifyDetachedEd25519WithFakeIssuerHint
, testCase
"detached v4 Ed25519 verifyAgainstKeys tolerates missing issuer hints"
testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys
, testCase
"detached v4 Ed25519 verifyAgainstKeys tolerates fake issuer hints"
testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys
, testCase
"v4 EdDSA signatures verify with Ed25519 key algorithm identifier"
testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm
, testCase
"sign message convenience API"
testSignMessageConvenience
, testCase
"typed verify surface matches legacy results"
testTypedVerifySurfaceMatchesLegacy
, testCase
"strict typed verify rejects tamper"
testVerifyMessageStrictRejectsTamper
, testCase
"verifySignedMessage convenience API"
testVerifySignedMessageConvenience
, testCase
"signature generation primitives"
testSignaturePrimitives
, testCase
"typed signature payload coercions"
testSignatureDataKindsCoercions
, testCase
"typed armor payload helpers centralize block selection"
testTypedArmorPayloadHelpers
, testCase
"recommendedArmorType infers canonical armor labels from packets"
testRecommendedArmorType
, testCase
"singleClearSignedBlock validates cleartext signature envelopes"
testSingleClearSignedBlock
, testCase
"canonical text signature payload normalization"
testCanonicalTextSigPayloadNormalization
, testCase
"canonical text signatures normalize during signing"
testCanonicalTextSignatureSigningPaths
, testCase
"text normalization modes (RFC9580Strict vs CleartextCompat)"
testTextNormalizationModes
]
, testGroup
"ASCII armor fixture group"
[ testCase
"v4-encrypted-secret.pgp.aa decodes as an encrypted v4 secret key"
testV4EncryptedSecretArmor
, testCase
"v4-encrypted.rev.aa decodes as a v4 revocation certificate"
testV4EncryptedRevocationArmor
, testCase
"v4-encrypted.rev.aa SigV4 key-revocation semantics"
testV4RevocationSignatureSemantics
, testCase
"v4-encrypted.rev.aa parses as single revocation TKUnknown"
( testRevocationArmorParsesAsSingleTransferableKey
"v4-encrypted.rev.aa"
True
)
, testCase
"v6.rev.aa decodes as a v6 revocation certificate"
(testV6RevocationArmor "v6.rev.aa")
, testCase
"v6.rev.aa SigV6 salt semantics"
(testV6RevocationSignatureSaltSemantics "v6.rev.aa")
, testCase
"v6.rev.aa forbids legacy Issuer key-id subpackets"
(testV6RevocationSignatureRejectsLegacyIssuerKeyID "v6.rev.aa")
, testCase
"v6.rev.aa parses as single revocation TKUnknown"
(testRevocationArmorParsesAsSingleTransferableKey "v6.rev.aa" True)
, testCase
"v6-encrypted.rev.aa decodes as a v6 revocation certificate"
(testV6RevocationArmor "v6-encrypted.rev.aa")
, testCase
"v6-encrypted.rev.aa SigV6 salt semantics"
(testV6RevocationSignatureSaltSemantics "v6-encrypted.rev.aa")
, testCase
"v6-encrypted.rev.aa forbids legacy Issuer key-id subpackets"
( testV6RevocationSignatureRejectsLegacyIssuerKeyID
"v6-encrypted.rev.aa"
)
, testCase
"v6-encrypted.rev.aa parses as single revocation TKUnknown"
( testRevocationArmorParsesAsSingleTransferableKey
"v6-encrypted.rev.aa"
True
)
, testCase
"msg1.asc decodes as a parseable armored message"
testMsg1ArmorFixture
]
, testGroup
"timeline-aware group"
[ testCase
"timeline-aware primary soft revocation keeps pre-revocation signatures"
testSignerTimelineSoftPrimaryRevocation
, testCase
"timeline-aware primary hard revocation rejects historical signatures"
testSignerTimelineHardPrimaryRevocation
, testCase
"timeline-aware no-reason primary revocation rejects historical signatures"
testSignerTimelineNoReasonPrimaryRevocation
, testCase
"timeline-aware unknown-reason primary revocation rejects historical signatures"
testSignerTimelineUnknownReasonPrimaryRevocation
, testCase
"timeline-aware non-compromise primary revocation stays historical until effective"
testSignerTimelineNonCompromisePrimaryRevocationIsHistorical
, testCase
"timeline-aware temporary primary revocation expires and restores validity"
testSignerTimelineTemporaryPrimaryRevocationExpires
, testCase
"timeline-aware subkey revocation distinguishes pre/post signatures"
testSignerTimelineSubkeyRevocation
]
]
testV4EncryptedSecretArmor :: Assertion
testV4EncryptedSecretArmor = do
armors <- loadArmor "v4-encrypted-secret.pgp.aa"
armor <-
case armors of
[a] -> pure a
_ ->
assertFailure
"v4 encrypted secret fixture should contain one armored payload"
>> fail "expected one armored payload"
(headers, payload) <-
case armor of
Armor ArmorPrivateKeyBlock hs p -> pure (hs, p)
Armor atype _ _ ->
assertFailure
( "v4 encrypted secret fixture should decode as a private key block, got "
++ show atype
)
>> fail "expected private key block"
_ ->
assertFailure
"v4 encrypted secret fixture should decode as an armored payload"
>> fail "expected armored payload"
assertEqual
"v4 encrypted secret fixture should keep identifying comments"
[ ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1")
, ("Comment", "<v4test@example.org>")
, ("Comment", "v4 Test User")
]
headers
let packets = parsePkts payload
userIds = [u | UserIdPkt u <- packets]
primarySecretKeys = [(pkp, ska) | SecretKeyPkt pkp ska <- packets]
secretSubkeys = [(pkp, ska) | SecretSubkeyPkt pkp ska <- packets]
assertEqual
"v4 encrypted secret fixture should include expected user IDs"
["<v4test@example.org>", "v4 Test User"]
userIds
assertEqual
"v4 encrypted secret fixture should contain one primary secret key packet"
1
(length primarySecretKeys)
assertEqual
"v4 encrypted secret fixture should contain three encrypted secret subkeys"
3
(length secretSubkeys)
case packets of
(SecretKeyPkt pkp ska : _) -> do
assertEqual
"v4 encrypted secret fixture should contain a v4 primary key"
V4
(_keyVersion pkp)
assertEqual
"v4 encrypted secret fixture should have the expected primary-key fingerprint"
(fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1")
(fingerprint pkp)
assertEqual
"v4 encrypted secret fixture should use EdDSA for its primary key"
EdDSA
(_pkalgo pkp)
assertEncryptedS2K "primary key" ska
mapM_ (assertEncryptedS2K "subkey" . snd) secretSubkeys
assertEqual
"v4 encrypted secret fixture should contain two EdDSA subkeys and one ECDH subkey"
[EdDSA, EdDSA, ECDH]
(map (_pkalgo . fst) secretSubkeys)
_ ->
assertFailure
"v4 encrypted secret fixture should start with a secret key packet"
where
assertEncryptedS2K :: String -> SKAddendum -> Assertion
assertEncryptedS2K testLabel ska =
case ska of
SUSSHA1 AES256 (IteratedSalted SHA256 _ iter) _ encryptedPayload -> do
assertEqual
(testLabel ++ " should use expected S2K iteration count")
(IterationCount 65011712)
iter
if BL.null encryptedPayload
then
assertFailure
(testLabel ++ " should have non-empty encrypted key material")
else pure ()
SUUnencrypted _ _ ->
assertFailure
( testLabel
++ " should be encrypted, got unencrypted secret material"
)
_ ->
assertFailure
( testLabel
++ " should be encrypted with SUSSHA1/AES256/IteratedSalted SHA256"
)
testV4EncryptedRevocationArmor :: Assertion
testV4EncryptedRevocationArmor = do
armors <- loadArmor "v4-encrypted.rev.aa"
armor <-
case armors of
[a] -> pure a
_ ->
assertFailure
"v4 encrypted revocation fixture should contain one armored payload"
>> fail "expected one armored payload"
(headers, payload) <-
case armor of
Armor ArmorPublicKeyBlock hs p -> pure (hs, p)
Armor atype _ _ ->
assertFailure
( "v4 encrypted revocation fixture should decode as a public key block, got "
++ show atype
)
>> fail "expected public key block"
_ ->
assertFailure
"v4 encrypted revocation fixture should decode as an armored payload"
>> fail "expected armored payload"
assertEqual
"v4 encrypted revocation fixture should keep identifying comments"
[ ("Comment", "Revocation certificate for")
, ("Comment", "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1")
, ("Comment", "<v4test@example.org>")
, ("Comment", "v4 Test User")
]
headers
let packets = parsePkts payload
case packets of
[PublicKeyPkt pkp, SignaturePkt _] -> do
assertEqual
"v4 encrypted revocation fixture should contain a v4 public key"
V4
(_keyVersion pkp)
assertEqual
"v4 encrypted revocation fixture should contain the expected public key fingerprint"
(fp "D2E0 81E9 3FDC A2E7 8B5F C433 811D 9243 394B 79C1")
(fingerprint pkp)
assertEqual
"v4 encrypted revocation fixture should use EdDSA for its public key"
EdDSA
(_pkalgo pkp)
_ ->
assertFailure
( "v4 encrypted revocation fixture should contain [PublicKeyPkt, SignaturePkt], got: "
++ show packets
)
testV6RevocationArmor :: FilePath -> Assertion
testV6RevocationArmor fixture = do
armors <- loadArmor fixture
armor <-
case armors of
[a] -> pure a
_ ->
assertFailure
(fixture ++ " fixture should contain one armored payload")
>> fail "expected one armored payload"
payload <-
case armor of
Armor ArmorPublicKeyBlock _ p -> pure p
Armor atype _ _ ->
assertFailure
( fixture
++ " fixture should decode as a public key block, got "
++ show atype
)
>> fail "expected public key block"
_ ->
assertFailure
(fixture ++ " fixture should decode as an armored payload")
>> fail "expected armored payload"
let packets = parsePkts payload
case packets of
[PublicKeyPkt pkp, SignaturePkt sig] -> do
assertEqual
(fixture ++ " should contain a v6 public key")
V6
(_keyVersion pkp)
case sig of
SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _ -> do
let issuerFps =
[ ifp
| SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <-
hashed ++ unhashed
]
if fingerprint pkp `elem` issuerFps
then pure ()
else
assertFailure
( fixture
++ " should include an IssuerFingerprint v6 matching the public key"
)
_ ->
assertFailure
(fixture ++ " should contain a SigV6 key-revocation signature")
_ ->
assertFailure
( fixture
++ " should contain [PublicKeyPkt, SignaturePkt], got: "
++ show packets
)
testV6RevocationSignatureSaltSemantics :: FilePath -> Assertion
testV6RevocationSignatureSaltSemantics fixture = do
armors <- loadArmor fixture
payload <-
case armors of
[Armor ArmorPublicKeyBlock _ p] -> pure p
_ ->
assertFailure
(fixture ++ " should contain one armored public-key payload")
>> fail "expected one armored payload"
let packets = parsePkts payload
(pkp, sig) <-
case packets of
[PublicKeyPkt pk, SignaturePkt sigV6@(SigV6 _ _ _ _ _ _ _ _)] -> pure (pk, sigV6)
_ ->
assertFailure
( fixture
++ " should parse as [PublicKeyPkt, SignaturePkt SigV6], got "
++ show packets
)
>> fail "unexpected revocation fixture packet shape"
case sig of
SigV6 _ _ ha salt _ _ _ _ ->
case expectedV6SaltSizeForTest ha of
Nothing ->
assertFailure
( fixture
++ " uses unsupported v6 signature salt hash algorithm: "
++ show ha
)
Just expected ->
assertEqual
(fixture ++ " SigV6 salt size should match hash algorithm")
expected
(fromIntegral (BL.length (unSignatureSalt salt)))
other ->
assertFailure
( fixture
++ " expected SigV6 revocation signature payload, got: "
++ show other
)
assertBool
( fixture
++ " should include IssuerFingerprint v6 for the revoked key"
)
(signatureHasIssuerFingerprintV6 (fingerprint pkp) sig)
testV4RevocationSignatureSemantics :: Assertion
testV4RevocationSignatureSemantics = do
armors <- loadArmor "v4-encrypted.rev.aa"
payload <-
case armors of
[Armor ArmorPublicKeyBlock _ p] -> pure p
_ ->
assertFailure
"v4-encrypted.rev.aa should contain one armored public-key payload"
>> fail "expected one armored payload"
let packets = parsePkts payload
case packets of
[ PublicKeyPkt _
, SignaturePkt (SigV4 KeyRevocationSig _ _ hashed unhashed _ _)
] -> do
assertBool
"v4-encrypted.rev.aa key-revocation signature should include an Issuer key-id subpacket"
(any isIssuerSubpacket (hashed ++ unhashed))
_ ->
assertFailure
( "v4-encrypted.rev.aa should parse as [PublicKeyPkt, SignaturePkt SigV4 KeyRevocationSig], got "
++ show packets
)
where
isIssuerSubpacket (SigSubPacket _ Issuer {}) = True
isIssuerSubpacket _ = False
testV6RevocationSignatureRejectsLegacyIssuerKeyID
:: FilePath -> Assertion
testV6RevocationSignatureRejectsLegacyIssuerKeyID fixture = do
armors <- loadArmor fixture
payload <-
case armors of
[Armor ArmorPublicKeyBlock _ p] -> pure p
_ ->
assertFailure
(fixture ++ " should contain one armored public-key payload")
>> fail "expected one armored payload"
let packets = parsePkts payload
case packets of
[ PublicKeyPkt _
, SignaturePkt (SigV6 KeyRevocationSig _ _ _ hashed unhashed _ _)
] ->
assertBool
( fixture
++ " SigV6 key-revocation signature must not include Issuer key-id subpackets"
)
(all (not . isIssuerSubpacket) (hashed ++ unhashed))
_ ->
assertFailure
( fixture
++ " should parse as [PublicKeyPkt, SignaturePkt SigV6 KeyRevocationSig]"
)
where
isIssuerSubpacket (SigSubPacket _ Issuer {}) = True
isIssuerSubpacket _ = False
testRevocationArmorParsesAsSingleTransferableKey
:: FilePath -> Bool -> Assertion
testRevocationArmorParsesAsSingleTransferableKey fixture expectDirectRevs = do
armors <- loadArmor fixture
payload <-
case armors of
[Armor ArmorPublicKeyBlock _ p] -> pure p
_ ->
assertFailure
(fixture ++ " should contain one armored public-key payload")
>> fail "expected one armored payload"
let tks = parseUnknownTKs True (parsePkts payload)
case tks of
[tk] -> do
if expectDirectRevs
then
assertBool
( fixture
++ " transferable key should contain at least one direct-key revocation signature"
)
(not (null (_tkuRevs tk)))
else pure ()
assertEqual
(fixture ++ " revocation certificate should not carry user IDs")
[]
(_tkuUIDs tk)
assertEqual
( fixture
++ " revocation certificate should not carry user attributes"
)
[]
(_tkuUAts tk)
assertEqual
(fixture ++ " revocation certificate should not carry subkeys")
[]
(_tkuSubs tk)
_ ->
assertFailure
(fixture ++ " should parse into exactly one transferable key")
testMsg1ArmorFixture :: Assertion
testMsg1ArmorFixture = do
armors <- loadArmor "msg1.asc"
assertBool
"msg1.asc should decode to at least one armor block"
(not (null armors))
let packetBlocks =
[ parsePkts payload
| Armor _ _ payload <- armors
]
assertBool
"msg1.asc should contain at least one parseable packet block"
(any (not . null) packetBlocks)
expectedV6SaltSizeForTest :: HashAlgorithm -> Maybe Int
expectedV6SaltSizeForTest =
fmap fromIntegral . signatureV6SaltSizeForHashAlgorithm
signatureHasIssuerFingerprintV6
:: Fingerprint -> SignaturePayload -> Bool
signatureHasIssuerFingerprintV6 expectedFp (SigV6 _ _ _ _ hashed unhashed _ _) =
expectedFp
`elem` [ ifp
| SigSubPacket _ (IssuerFingerprint IssuerFingerprintV6 ifp) <-
hashed ++ unhashed
]
signatureHasIssuerFingerprintV6 _ _ = False
testDefaultedEncryptDecrypt :: Assertion
testDefaultedEncryptDecrypt = do
let passphrase = mkPassphrase "roundtrip1"
payload = mkClearPayload "hello from a balloon farm on Mars"
encryptedResult =
encryptMessageDefault
DoNotExposeSessionMaterial
passphrase
payload
encrypted <-
case encryptedResult of
Left err ->
assertFailure ("encryptMessageDefault failed: " ++ show err)
>> fail "encryptMessageDefault failed"
Right (bs, _) -> pure bs
case parsePkts (encryptedPayloadBytes encrypted) of
[ SKESKPkt
(SKESKPayloadV6Packet (SKESKPayloadV6 AES256 OCB _ iv esk tag))
, SymEncIntegrityProtectedDataPkt (SEIPD2 AES256 OCB 6 _ _)
] -> do
assertBool
"default SKESK v6 IV should be present"
(not (BL.null iv))
assertBool
"default SKESK v6 wrapped session key should be present"
(not (BL.null esk))
assertEqual "default SKESK v6 tag length" 16 (BL.length tag)
other ->
assertFailure
( "default encryption should emit SKESK v6 + SEIPD v2 packets, got "
++ show other
)
decrypted <-
case decryptMessage passphrase encrypted of
Left err ->
assertFailure ("decryptMessage failed: " ++ show err)
>> fail "decryptMessage failed"
Right bs -> pure bs
assertEqual
"default encrypt/decrypt payload roundtrip"
payload
decrypted
testExplicitEncryptDecrypt :: Assertion
testExplicitEncryptDecrypt = do
let passphrase = mkPassphrase "roundtrip2"
payload = mkClearPayload "hello from nonsenseville"
s2k = Argon2 (Salt16 (B.pack [0x00 .. 0x0f])) 1 4 15
iv = IV "1234567890ABCDEF"
encrypted <-
case encryptMessage
( RFC9580EncryptMessageOptions
{ rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial
, rfc9580EncryptMessageSymmetricAlgorithm = AES128
, rfc9580EncryptMessageS2K = s2k
, rfc9580EncryptMessageIV = iv
}
)
passphrase
payload of
Left err ->
assertFailure ("micro-managed encryption failed: " ++ show err)
>> fail "encryptMessage failed"
Right (bs, _) -> pure bs
case parsePkts (encryptedPayloadBytes encrypted) of
[ SKESKPkt
( SKESKPayloadV6Packet
(SKESKPayloadV6 AES128 OCB _ packetIv esk tag)
)
, SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 OCB 6 _ _)
] -> do
assertBool
"explicit SKESK v6 IV should be present"
(not (BL.null packetIv))
assertBool
"explicit SKESK v6 wrapped session key should be present"
(not (BL.null esk))
assertEqual "explicit SKESK v6 tag length" 16 (BL.length tag)
other ->
assertFailure
( "explicit AES encryption should default to SKESK v6 + SEIPD v2 packets, got "
++ show other
)
decrypted <-
case decryptMessage passphrase encrypted of
Left err ->
assertFailure ("decryption failed: " ++ show err)
>> fail "decryptMessage failed"
Right bs -> pure bs
assertEqual
"specific encrypt/decrypt payload roundtrip"
payload
decrypted
testExplicitEncryptExposesEffectiveSessionMaterial :: Assertion
testExplicitEncryptExposesEffectiveSessionMaterial = do
let passphraseBytes = "roundtrip2-session-material"
passphrase = mkPassphrase passphraseBytes
payload = mkClearPayload "hello from session material town"
sa = AES128
s2k = Argon2 (Salt16 (B.pack [0x40 .. 0x4f])) 1 4 15
iv = IV "ABCDEF1234567890"
(encrypted, recovered) <-
case encryptMessage
( RFC9580EncryptMessageOptions
{ rfc9580EncryptMessageExposure = ExposeSessionMaterial
, rfc9580EncryptMessageSymmetricAlgorithm = sa
, rfc9580EncryptMessageS2K = s2k
, rfc9580EncryptMessageIV = iv
}
)
passphrase
payload of
Left err ->
assertFailure
("explicit encryption with session material failed: " ++ show err)
>> fail "encryptMessage failed"
Right x -> pure x
expectedSessionKey <-
case keySize sa of
Left err ->
assertFailure
("failed to derive expected key size: " ++ show err)
>> fail "keySize failed"
Right keyLen ->
case string2Key s2k keyLen passphraseBytes of
Left err ->
assertFailure
("failed to derive expected session key: " ++ renderS2KError err)
>> fail "string2Key failed"
Right bs -> pure bs
case recovered of
Just recoveredSessionMaterial -> do
assertEqual
"recovered session material algorithm"
sa
(recoveredSessionAlgorithm recoveredSessionMaterial)
assertEqual
"recovered session material key"
(SessionKey expectedSessionKey)
(recoveredSessionKey recoveredSessionMaterial)
Nothing ->
assertFailure "expected exposed session material"
decrypted <-
case decryptMessage passphrase encrypted of
Left err ->
assertFailure ("decryption failed: " ++ show err)
>> fail "decryptMessage failed"
Right bs -> pure bs
assertEqual
"session-material exposing encrypt/decrypt payload roundtrip"
payload
decrypted
testDefaultEncryptDoesNotExposeSessionMaterial :: Assertion
testDefaultEncryptDoesNotExposeSessionMaterial = do
let passphrase = mkPassphrase "roundtrip-default-no-session-material"
payload = mkClearPayload "hello from hidden-session-material town"
(_, recovered) <-
do
let encryptedResult =
encryptMessageDefault
DoNotExposeSessionMaterial
passphrase
payload
case encryptedResult of
Left err ->
assertFailure
("default encryption with exposure mode failed: " ++ show err)
>> fail "encryptMessageDefault failed"
Right x -> pure x
case recovered of
Nothing -> pure ()
Just _ ->
assertFailure
"default exposure mode should not return session material"
testExplicitAES128AEADEncryptDecrypt
:: AEADAlgorithm -> Int -> String -> Assertion
testExplicitAES128AEADEncryptDecrypt aead expectedIvLen label = do
let passphraseBytes =
"roundtrip-"
<> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label))
passphrase = mkPassphrase passphraseBytes
payload =
mkClearPayload
( "hello from "
<> BL.fromStrict (B.pack (map (fromIntegral . fromEnum) label))
)
s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15
salt = Salt (B.pack [0x20 .. 0x3f])
block =
Block
[ LiteralDataPkt BinaryData BL.empty 0 (clearPayloadBytes payload)
]
packets <-
case encryptSEIPDv2WithSKESKBlock
AES128
aead
6
salt
s2k
passphraseBytes
block of
Left err ->
assertFailure
("AES-128 " ++ label ++ " encryption failed: " ++ err)
>> fail "encryptSEIPDv2WithSKESKBlock failed"
Right ps -> pure ps
let encrypted = mkEncryptedPayload (runPut (put (Block packets)))
case parsePkts (encryptedPayloadBytes encrypted) of
[ SKESKPkt
( SKESKPayloadV6Packet
(SKESKPayloadV6 AES128 parsedAead _ iv esk tag)
)
, SymEncIntegrityProtectedDataPkt (SEIPD2 AES128 payloadAead 6 _ _)
] -> do
assertEqual
("AES-128 " ++ label ++ " SKESK AEAD")
aead
parsedAead
assertEqual
("AES-128 " ++ label ++ " payload AEAD")
aead
payloadAead
assertEqual
("AES-128 " ++ label ++ " SKESK v6 IV length")
(fromIntegral expectedIvLen)
(BL.length iv)
assertBool
("AES-128 " ++ label ++ " wrapped session key should be present")
(not (BL.null esk))
assertEqual
("AES-128 " ++ label ++ " SKESK tag length")
16
(BL.length tag)
other ->
assertFailure
( "AES-128 "
++ label
++ " encryption should emit matching SKESK v6 + SEIPD v2 packets, got "
++ show other
)
decrypted <-
case decryptMessage passphrase encrypted of
Left err ->
assertFailure
("AES-128 " ++ label ++ " decryption failed: " ++ show err)
>> fail "decryptMessage failed"
Right bs -> pure bs
assertEqual
("AES-128 " ++ label ++ " payload roundtrip")
payload
decrypted
testExplicitAES128EAXEncryptDecrypt :: Assertion
testExplicitAES128EAXEncryptDecrypt = do
let passphraseBytes = "roundtrip-EAX"
s2k = Argon2 (Salt16 (B.pack [0x10 .. 0x1f])) 1 4 15
salt = Salt (B.pack [0x20 .. 0x3f])
block = Block [LiteralDataPkt BinaryData BL.empty 0 "hello from EAX"]
case encryptSEIPDv2WithSKESKBlock
AES128
EAX
6
salt
s2k
passphraseBytes
block of
Left err
| "EAX is currently unsupported by the crypton AEAD backend"
`isInfixOf` err ->
pure ()
| otherwise ->
assertFailure
("expected explicit EAX backend limitation, got: " ++ err)
Right packets ->
assertFailure
( "expected AES-128 EAX encryption to fail explicitly, got packets: "
++ show packets
)
testExplicitAES128GCMEncryptDecrypt :: Assertion
testExplicitAES128GCMEncryptDecrypt =
testExplicitAES128AEADEncryptDecrypt GCM 12 "GCM"
testExplicitEncryptRejectsDeprecatedS2KHash :: Assertion
testExplicitEncryptRejectsDeprecatedS2KHash = do
let passphrase = mkPassphrase "roundtrip2b"
payload = mkClearPayload "modern-path deprecated s2k hash rejection"
s2k = Salted SHA1 (Salt8 "12345678")
iv = IV "1234567890ABCDEF"
case encryptMessage
( RFC9580EncryptMessageOptions
{ rfc9580EncryptMessageExposure = DoNotExposeSessionMaterial
, rfc9580EncryptMessageSymmetricAlgorithm = AES128
, rfc9580EncryptMessageS2K = s2k
, rfc9580EncryptMessageIV = iv
}
)
passphrase
payload of
Left (MessageEncryptError err)
| "deprecated hash algorithm disallowed for modern message generation"
`isInfixOf` err ->
pure ()
| otherwise ->
assertFailure
("Expected deprecated modern S2K hash rejection, got: " ++ err)
Left err ->
assertFailure
( "Expected MessageEncryptError for deprecated modern S2K hash, got "
++ show err
)
Right _ ->
assertFailure
"Expected encryptMessage AES128 to reject deprecated SHA1 S2K"
testLegacyFallbackEncryptDecrypt :: Assertion
testLegacyFallbackEncryptDecrypt = do
let passphrase = mkPassphrase "roundtrip3"
payload = mkClearPayload "hello from legacy town"
s2k = Salted SHA1 (Salt8 "12345678")
iv = IV mempty
encrypted <-
case encryptMessage
( RFC4880EncryptMessageOptions
{ rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial
, rfc4880EncryptMessageSymmetricAlgorithm = Plaintext
, rfc4880EncryptMessageS2K = s2k
, rfc4880EncryptMessageIV = iv
}
)
passphrase
payload of
Left err ->
assertFailure ("legacy fallback encryption failed: " ++ show err)
>> fail "encryptMessage fallback failed"
Right (bs, _) -> pure bs
case parsePkts (encryptedPayloadBytes encrypted) of
[ SKESKPkt
(SKESKPayloadV4Packet (SKESKPayloadV4 Plaintext _ Nothing))
, SymEncIntegrityProtectedDataPkt (SEIPD1 1 _)
] -> pure ()
other ->
assertFailure
( "non-AES explicit encryption should use RFC4880 SKESKv4 + SEIPDv1 packets, got "
++ show other
)
decrypted <-
case decryptMessage passphrase encrypted of
Left err ->
assertFailure ("legacy fallback decryption failed: " ++ show err)
>> fail "decryptMessage fallback failed"
Right bs -> pure bs
assertEqual
"legacy fallback encrypt/decrypt payload roundtrip"
payload
decrypted
testRFC4880EncryptMessageSEIPDv1ParsesCleanly :: Assertion
testRFC4880EncryptMessageSEIPDv1ParsesCleanly = do
let passphraseBytes = "legacy-clean-parse" :: BL.ByteString
passphrase = mkPassphrase passphraseBytes
payload = mkClearPayload "hello from clean legacy town"
s2k =
IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536)
iv = IV "1234567890ABCDEF"
encrypted <-
case encryptMessage
( RFC4880EncryptMessageOptions
{ rfc4880EncryptMessageExposure = DoNotExposeSessionMaterial
, rfc4880EncryptMessageSymmetricAlgorithm = AES128
, rfc4880EncryptMessageS2K = s2k
, rfc4880EncryptMessageIV = iv
}
)
passphrase
payload of
Left err ->
assertFailure ("RFC4880 encryption failed: " ++ show err)
>> fail "encryptMessage failed"
Right (bs, _) -> pure bs
packets <-
case parsePktsEither (encryptedPayloadBytes encrypted) of
Left err ->
assertFailure ("encrypted packet parse failed: " ++ show err)
>> fail "parsePktsEither failed"
Right ps -> pure ps
ciphertext <-
case packets of
[ SKESKPkt
(SKESKPayloadV4Packet (SKESKPayloadV4 parsedSA parsedS2K Nothing))
, SymEncIntegrityProtectedDataPkt (SEIPD1 1 payloadBytes)
] -> do
assertEqual "RFC4880 encrypted SKESK algorithm" AES128 parsedSA
assertEqual "RFC4880 encrypted S2K" s2k parsedS2K
pure (BL.toStrict payloadBytes)
other ->
assertFailure
( "RFC4880 encryption should emit SKESKv4 + SEIPDv1 packets, got "
++ show other
)
>> fail "unexpected encrypted packet layout"
keyLen <-
case keySize AES128 of
Left err ->
assertFailure ("keySize failed for AES128: " ++ show err)
>> fail "keySize failed"
Right n -> pure n
sessionKey <-
case string2Key s2k keyLen passphraseBytes of
Left err ->
assertFailure ("string2Key failed: " ++ renderS2KError err)
>> fail "string2Key failed"
Right keyBytes -> pure keyBytes
(nonce, decrypted) <-
case decryptPreservingNonce AES128 ciphertext sessionKey of
Left err ->
assertFailure ("decryptPreservingNonce failed: " ++ show err)
>> fail "decryptPreservingNonce failed"
Right out -> pure out
cleartext <-
case validateSEIPD1MDC nonce decrypted of
Left err ->
assertFailure ("validateSEIPD1MDC failed: " ++ err)
>> fail "validateSEIPD1MDC failed"
Right out -> pure out
case parsePktsEither (BL.fromStrict cleartext) of
Right [LiteralDataPkt BinaryData filename timestamp clearPayload] -> do
assertEqual
"RFC4880 decrypted literal filename"
BL.empty
filename
assertEqual "RFC4880 decrypted literal timestamp" 0 timestamp
assertEqual
"RFC4880 decrypted literal payload"
(clearPayloadBytes payload)
clearPayload
Right other ->
assertFailure
( "RFC4880 decrypted cleartext should contain exactly one literal packet, got "
++ show other
)
Left err ->
assertFailure
( "RFC4880 decrypted cleartext should parse without trailing junk, got "
++ show err
)
testDecryptMessageTypedParseFailure :: Assertion
testDecryptMessageTypedParseFailure = do
let passphrase = mkPassphrase "unused"
encrypted = mkEncryptedPayload BL.empty
case decryptMessage passphrase encrypted of
Left (MessageParseFailureError MissingEncryptedMessage) -> pure ()
Left err ->
assertFailure
( "Expected MissingEncryptedMessage parse failure, got "
++ show err
)
Right clear ->
assertFailure
("Expected parse failure, got payload " ++ show clear)
testDecryptMessageRejectsUnknownCriticalPacket :: Assertion
testDecryptMessageRejectsUnknownCriticalPacket = do
let passphrase = mkPassphrase "unused"
encrypted =
mkEncryptedPayload . runPut . put $
Block [OtherPacketPkt 39 "unknown-critical"]
case decryptMessage passphrase encrypted of
Left (MessageParseFailureError (UnknownCriticalPacketType 39)) -> pure ()
Left err ->
assertFailure
( "Expected UnknownCriticalPacketType 39 parse failure, got "
++ show err
)
Right clear ->
assertFailure
( "Expected unknown critical packet rejection, got payload "
++ show clear
)
testDecryptMessageTypedDecryptFailure :: Assertion
testDecryptMessageTypedDecryptFailure = do
let correctPassphrase = mkPassphrase "correct passphrase"
wrongPassphrase = mkPassphrase "wrong passphrase"
payload = mkClearPayload "typed decrypt failure payload"
encryptedResult =
encryptMessageDefault
DoNotExposeSessionMaterial
correctPassphrase
payload
encrypted <-
case encryptedResult of
Left err ->
assertFailure ("encryptMessageDefault failed: " ++ show err)
>> fail "encryptMessageDefault failed"
Right (bs, _) -> pure bs
case decryptMessage wrongPassphrase encrypted of
Left (MessageDecryptFailureError (PayloadDecryptFailed _)) -> pure ()
Left
(MessageDecryptFailureError (SessionMaterialDerivationFailed _)) -> pure ()
Left err ->
assertFailure
("Expected typed decrypt failure, got " ++ show err)
Right clear ->
assertFailure
("Expected decrypt failure, got payload " ++ show clear)
testDecryptMessageSEIPDv1MDCTampering :: Assertion
testDecryptMessageSEIPDv1MDCTampering = do
let passphrase = mkPassphrase "mdc-tamper-test"
payload = mkClearPayload "payload for MDC tampering test"
s2k =
IteratedSalted SHA256 (Salt8 "saltxyz!") (IterationCount 65536)
iv = IV "1234567890ABCDEF"
encrypted <-
case encryptMessage
( RFC4880EncryptMessageOptions
{ rfc4880EncryptMessageExposure =
DoNotExposeSessionMaterial
, rfc4880EncryptMessageSymmetricAlgorithm = AES128
, rfc4880EncryptMessageS2K = s2k
, rfc4880EncryptMessageIV = iv
}
)
passphrase
payload of
Left err ->
assertFailure ("SEIPDv1 encryption failed: " ++ show err)
>> fail "encryptMessage failed"
Right (bs, _) -> pure bs
let raw = encryptedPayloadBytes encrypted
midpoint = BL.length raw `div` 2
tampered =
BL.take midpoint raw
<> BL.cons
(BL.head (BL.drop midpoint raw) `xor` 0xFF)
(BL.drop (midpoint + 1) raw)
case decryptMessage passphrase (mkEncryptedPayload tampered) of
Left (MessageDecryptFailureError (PayloadDecryptFailed msg))
| "MDC" `isInfixOf` msg -> pure ()
| otherwise ->
assertFailure
("Expected MDC-related PayloadDecryptFailed, got: " ++ msg)
Left err ->
assertFailure
("Expected PayloadDecryptFailed with MDC error, got: " ++ show err)
Right _ ->
assertFailure
"Expected MDC tampering rejection, but decryption succeeded"
testSignMessageShape :: Assertion
testSignMessageShape = do
(signer, signingKey) <- loadUnencryptedRsaSigner
signerV4 <- expectV4PKPayload "RSA v4 signer" signer
signedResult <-
signMessageWith
(mkRSASignerV4 signerV4 signingKey)
(mkClearPayload "message-api signing payload")
signedMessage <-
case signedResult of
Left err ->
assertFailure ("message signing failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
case parsePkts signedMessage of
[LiteralDataPkt {}, SignaturePkt _] -> pure ()
_ ->
assertFailure
"signing output should contain literal data and one signature packet"
testSignMessageRSAV6 :: Assertion
testSignMessageRSAV6 = do
(signer, signingKey) <- loadUnencryptedRsaSignerV6
signerV6 <- expectV6PKPayload "RSA v6 signer" signer
let payload = "message-api signing payload with RSA SigV6"
signedResult <-
signMessageWith
(mkRSASignerV6 signerV6 signingKey)
(mkClearPayload payload)
signedMessage <-
case signedResult of
Left err ->
assertFailure ("RSA SigV6 message signing failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
signaturePkt <-
case parsePkts signedMessage of
[ LiteralDataPkt {}
, sig@(SignaturePkt (SigV6 BinarySig RSA SHA512 salt _ _ _ _))
] -> do
assertEqual
"SigV6 RSA salt must be 32 bytes for SHA512"
32
(BL.length (unSignatureSalt salt))
pure sig
other ->
assertFailure
( "RSA SigV6 signing output should contain [LiteralDataPkt, RSA SigV6], got "
++ show other
)
>> fail "unexpected RSA SigV6 signMessage output shape"
let state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring = [TKUnknown (signer, Nothing) [] [] [] []]
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeys keyring)
signaturePkt
state
Nothing of
Left err ->
assertFailure
( "RSA SigV6 signed message verification failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testSignMessageEd25519 :: Assertion
testSignMessageEd25519 = do
(signer, signingKey) <- loadDeterministicEd25519Signer
signerV4 <- expectV4PKPayload "Ed25519 v4 signer" signer
let payload = "message-api signing payload with Ed25519"
signedResult <-
signMessageWith
(mkEd25519SignerV4 signerV4 signingKey)
(mkClearPayload payload)
signedMessage <-
case signedResult of
Left err ->
assertFailure ("Ed25519 message signing failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
signaturePkt <-
case parsePkts signedMessage of
[ LiteralDataPkt {}
, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _))
] ->
pure sig
other ->
assertFailure
( "Ed25519 signing output should contain [LiteralDataPkt, Ed25519 SigV4], got "
++ show other
)
>> fail "unexpected Ed25519 signMessage output shape"
let state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring = [TKUnknown (signer, Nothing) [] [] [] []]
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeys keyring)
signaturePkt
state
Nothing of
Left err ->
assertFailure
( "Ed25519 signed message verification failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testSignMessageEd25519V6 :: Assertion
testSignMessageEd25519V6 = do
(signer, signingKey) <- loadDeterministicEd25519SignerV6
signerV6 <- expectV6PKPayload "Ed25519 v6 signer" signer
let payload = "message-api signing payload with Ed25519 SigV6"
signedResult <-
signMessageWith
(mkEd25519SignerV6 signerV6 signingKey)
(mkClearPayload payload)
signedMessage <-
case signedResult of
Left err ->
assertFailure
("Ed25519 SigV6 message signing failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
signaturePkt <-
case parsePkts signedMessage of
[ LiteralDataPkt {}
, sig@(SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _))
] -> do
assertEqual
"SigV6 Ed25519 salt must be 32 bytes for SHA512"
32
(BL.length (unSignatureSalt salt))
pure sig
other ->
assertFailure
( "Ed25519 SigV6 signing output should contain [LiteralDataPkt, Ed25519 SigV6], got "
++ show other
)
>> fail "unexpected Ed25519 SigV6 signMessage output shape"
case signaturePkt of
SignaturePkt (SigV6 BinarySig PKA.Ed25519 SHA512 _ _ _ _ _) -> do
let state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring = [TKUnknown (signer, Nothing) [] [] [] []]
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeys keyring)
signaturePkt
state
Nothing of
Left err ->
assertFailure
( "Ed25519 SigV6 signed message verification failed: "
++ renderVerificationError err
)
Right _ -> pure ()
_ -> assertFailure "expected an Ed25519 SigV6 signature packet"
testV4Ed25519LegacyKeyRejectsMissingPrefix :: Assertion
testV4Ed25519LegacyKeyRejectsMissingPrefix = do
let legacyEd25519Oid = B.pack [0x2B, 0x06, 0x01, 0x04, 0x01, 0xDA, 0x47, 0x0F, 0x01]
rawEd25519Public = B.replicate 32 0x01
encoded =
runPut $ do
putWord8 4
putWord32be 0
putWord8 (fromFVal EdDSA)
putWord8 (fromIntegral (B.length legacyEd25519Oid))
putByteString legacyEd25519Oid
putWord16be 256
putByteString rawEd25519Public
case runGetOrFail (get :: Get SomePKPayload) encoded of
Left (_, _, err) ->
assertBool
("expected invalid-legacy-point parse failure, got: " ++ err)
("invalid Ed25519Legacy public key" `isInfixOf` err)
Right _ ->
assertFailure
"legacy Ed25519 key without 0x40 prefix should be rejected"
testSignMessageEd448 :: Assertion
testSignMessageEd448 = do
(signer, signingKey) <- loadDeterministicEd448Signer
signerV4 <- expectV4PKPayload "Ed448 v4 signer" signer
let payload = "message-api signing payload with Ed448"
signedResult <-
signMessageWith
(mkEd448SignerV4 signerV4 signingKey)
(mkClearPayload payload)
signedMessage <-
case signedResult of
Left err ->
assertFailure ("Ed448 message signing failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
signaturePkt <-
case parsePkts signedMessage of
[ LiteralDataPkt {}
, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _))
] ->
pure sig
other ->
assertFailure
( "Ed448 signing output should contain [LiteralDataPkt, Ed448 SigV4], got "
++ show other
)
>> fail "unexpected Ed448 signMessage output shape"
let state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring = [TKUnknown (signer, Nothing) [] [] [] []]
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeys keyring)
signaturePkt
state
Nothing of
Left err ->
assertFailure
( "Ed448 signed message verification failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testSignMessageEd448V6 :: Assertion
testSignMessageEd448V6 = do
(signer, signingKey) <- loadDeterministicEd448SignerV6
signerV6 <- expectV6PKPayload "Ed448 v6 signer" signer
let payload = "message-api signing payload with Ed448 SigV6"
signedResult <-
signMessageWith
(mkEd448SignerV6 signerV6 signingKey)
(mkClearPayload payload)
signedMessage <-
case signedResult of
Left err ->
assertFailure
("Ed448 SigV6 message signing failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
signaturePkt <-
case parsePkts signedMessage of
[ LiteralDataPkt {}
, sig@(SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _))
] -> do
assertEqual
"SigV6 Ed448 salt must be 32 bytes for SHA512"
32
(BL.length (unSignatureSalt salt))
pure sig
other ->
assertFailure
( "Ed448 SigV6 signing output should contain [LiteralDataPkt, Ed448 SigV6], got "
++ show other
)
>> fail "unexpected Ed448 SigV6 signMessage output shape"
case signaturePkt of
SignaturePkt (SigV6 BinarySig PKA.Ed448 SHA512 _ _ _ _ _) -> pure ()
_ -> assertFailure "expected an Ed448 SigV6 signature packet"
testV4EdSignaturesUseNativeFixedWidthEncoding :: Assertion
testV4EdSignaturesUseNativeFixedWidthEncoding = do
(_, ed25519SigningKey) <- loadDeterministicEd25519Signer
ed25519Sig <-
case signDataWithEd25519
BinarySig
ed25519SigningKey
[]
[]
"v4 ed25519 encoding" of
Left err ->
assertFailure
("Ed25519 v4 signing failed: " ++ renderSignError err)
>> fail "expected Ed25519 signature"
Right sig -> pure sig
case extractV4SignatureAlgorithmFields (runPut (put ed25519Sig)) of
Left err ->
assertFailure
( "failed to decode serialized Ed25519 v4 signature payload: "
++ err
)
Right (pka, algorithmFields) -> do
assertEqual
"Ed25519 v4 signature packet algorithm id"
PKA.Ed25519
pka
assertEqual
"Ed25519 v4 algorithm field width"
64
(B.length algorithmFields)
(_, ed448SigningKey) <- loadDeterministicEd448Signer
ed448Sig <-
case signDataWithEd448
BinarySig
ed448SigningKey
[]
[]
"v4 ed448 encoding" of
Left err ->
assertFailure
("Ed448 v4 signing failed: " ++ renderSignError err)
>> fail "expected Ed448 signature"
Right sig -> pure sig
case extractV4SignatureAlgorithmFields (runPut (put ed448Sig)) of
Left err ->
assertFailure
("failed to decode serialized Ed448 v4 signature payload: " ++ err)
Right (pka, algorithmFields) -> do
assertEqual
"Ed448 v4 signature packet algorithm id"
PKA.Ed448
pka
assertEqual
"Ed448 v4 algorithm field width"
114
(B.length algorithmFields)
testVerifyDetachedEd25519WithoutIssuerHints :: Assertion
testVerifyDetachedEd25519WithoutIssuerHints = do
(signer, signingKey) <- loadDeterministicEd25519Signer
let payload = "detached v4 eddsa payload without issuer hints"
state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []]
sigPayload <-
case signDataWithEd25519 BinarySig signingKey [] [] payload of
Left err ->
assertFailure
("Ed25519 detached signing failed: " ++ renderSignError err)
>> fail (renderSignError err)
Right sig -> pure sig
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeyring keyring)
(SignaturePkt sigPayload)
state
Nothing of
Left err ->
assertFailure
( "Ed25519 detached verification without issuer hints failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testVerifyDetachedEd25519WithFakeIssuerHint :: Assertion
testVerifyDetachedEd25519WithFakeIssuerHint = do
(signer, signingKey) <- loadDeterministicEd25519Signer
let payload = "detached v4 eddsa payload with fake issuer hint"
state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []]
fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef"
unhashed = [SigSubPacket False (Issuer fakeIssuer)]
sigPayload <-
case signDataWithEd25519 BinarySig signingKey [] unhashed payload of
Left err ->
assertFailure
("Ed25519 detached signing failed: " ++ renderSignError err)
>> fail (renderSignError err)
Right sig -> pure sig
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeyring keyring)
(SignaturePkt sigPayload)
state
Nothing of
Left err ->
assertFailure
( "Ed25519 detached verification with fake issuer hint failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys
:: Assertion
testVerifyDetachedEd25519WithoutIssuerHintsAgainstKeys = do
(signer, signingKey) <- loadDeterministicEd25519Signer
let payload =
"detached v4 eddsa payload without issuer hints (verifyAgainstKeys)"
state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keys = [TKUnknown (signer, Nothing) [] [] [] []]
sigPayload <-
case signDataWithEd25519 BinarySig signingKey [] [] payload of
Left err ->
assertFailure
("Ed25519 detached signing failed: " ++ renderSignError err)
>> fail (renderSignError err)
Right sig -> pure sig
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeys keys)
(SignaturePkt sigPayload)
state
Nothing of
Left err ->
assertFailure
( "Ed25519 detached verification against keys without issuer hints failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys
:: Assertion
testVerifyDetachedEd25519WithFakeIssuerHintAgainstKeys = do
(signer, signingKey) <- loadDeterministicEd25519Signer
let payload =
"detached v4 eddsa payload with fake issuer hint (verifyAgainstKeys)"
state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keys = [TKUnknown (signer, Nothing) [] [] [] []]
fakeIssuer = EightOctetKeyId "\x01\x23\x45\x67\x89\xab\xcd\xef"
unhashed = [SigSubPacket False (Issuer fakeIssuer)]
sigPayload <-
case signDataWithEd25519 BinarySig signingKey [] unhashed payload of
Left err ->
assertFailure
("Ed25519 detached signing failed: " ++ renderSignError err)
>> fail (renderSignError err)
Right sig -> pure sig
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeys keys)
(SignaturePkt sigPayload)
state
Nothing of
Left err ->
assertFailure
( "Ed25519 detached verification against keys with fake issuer hint failed: "
++ renderVerificationError err
)
Right _ -> pure ()
testCanonicalTextSigPayloadNormalization :: Assertion
testCanonicalTextSigPayloadNormalization = do
let state =
emptyPSC
{ lastLD =
LiteralDataPkt
TextData
BL.empty
(ThirtyTwoBitTimeStamp 0)
"line1 \t\nline2\t \rline3\t \r\nline4 \t"
}
assertEqual
"Binary signatures preserve original line endings"
"line1 \t\nline2\t \rline3\t \r\nline4 \t"
(payloadForSig BinarySig state)
assertEqual
"Canonical text signatures normalize line endings and trim trailing whitespace"
"line1\r\nline2\r\nline3\r\nline4"
(payloadForSig CanonicalTextSig state)
testTextNormalizationModes :: Assertion
testTextNormalizationModes = do
let state =
emptyPSC
{ lastLD =
LiteralDataPkt
TextData
BL.empty
(ThirtyTwoBitTimeStamp 0)
"line1 \t\nline2\t \r\nline3"
}
let cleartextResult = payloadForSigWith CleartextCompat CanonicalTextSig state
strictResult = payloadForSigWith RFC9580Strict CanonicalTextSig state
assertEqual
"CleartextCompat mode strips trailing whitespace per line"
"line1\r\nline2\r\nline3"
cleartextResult
assertEqual
"RFC9580Strict mode preserves trailing whitespace (CRLF-only normalization)"
"line1 \t\r\nline2\t \r\nline3"
strictResult
(signer, signingKey) <- loadUnencryptedRsaSigner
issuerKeyId <-
case eightOctetKeyID signer of
Left err ->
assertFailure ("failed to derive issuer key id: " ++ err)
>> fail "expected issuer key id"
Right i -> pure i
let payload = "line with trailing space \nno trailing space\n"
hashed =
[ SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))
]
unhashed = [SigSubPacket False (Issuer issuerKeyId)]
builderCompat = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512
builderStrict =
(sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512)
{ sbTextNormMode = RFC9580Strict
}
withSubs b =
addUnhashedSubs
(listToUnhashedSubs unhashed)
(addHashedSubs (listToHashedSubs hashed) b)
bc = withSubs builderCompat
bs = withSubs builderStrict
sigCompat <- case signDataWithRSABuilder bc signingKey payload of
Left err ->
assertFailure
("CleartextCompat sign failed: " ++ renderSignError err)
>> fail ""
Right s -> pure s
sigStrict <- case signDataWithRSABuilder bs signingKey payload of
Left err ->
assertFailure
("RFC9580Strict sign failed: " ++ renderSignError err)
>> fail ""
Right s -> pure s
assertBool
"CleartextCompat and RFC9580Strict produce different signatures for payloads with trailing whitespace"
(sigCompat /= sigStrict)
testCanonicalTextSignatureSigningPaths :: Assertion
testCanonicalTextSignatureSigningPaths = do
(signer, signingKey) <- loadUnencryptedRsaSigner
issuerKeyId <-
case eightOctetKeyID signer of
Left err ->
assertFailure ("failed to derive issuer key id: " ++ err)
>> fail "expected issuer key id"
Right i -> pure i
let mixedPayload = "line1 \t\nline2\t \rline3\t \r\nline4 \t"
normalizedPayload = "line1\r\nline2\r\nline3\r\nline4"
hashed =
[ SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint signer))
]
unhashed = [SigSubPacket False (Issuer issuerKeyId)]
primitiveMixed <-
case signDataWithRSA
CanonicalTextSig
signingKey
hashed
unhashed
mixedPayload of
Left err ->
assertFailure
( "canonical text primitive signing failed: "
++ renderSignError err
)
>> fail (renderSignError err)
Right sig -> pure sig
primitiveNormalized <-
case signDataWithRSA
CanonicalTextSig
signingKey
hashed
unhashed
normalizedPayload of
Left err ->
assertFailure
( "canonical text primitive signing (normalized payload) failed: "
++ renderSignError err
)
>> fail (renderSignError err)
Right sig -> pure sig
assertEqual
"primitive canonical text signing should normalize mixed line endings"
primitiveNormalized
primitiveMixed
let builder = sigBuilderInit @'PKA.RSA CanonicalTextSig SHA512
withHashed = addHashedSubs (listToHashedSubs hashed) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs unhashed) withHashed
builderMixed <-
case signDataWithRSABuilder withUnhashed signingKey mixedPayload of
Left err ->
assertFailure
("canonical text builder signing failed: " ++ renderSignError err)
>> fail (renderSignError err)
Right sig -> pure sig
builderNormalized <-
case signDataWithRSABuilder withUnhashed signingKey normalizedPayload of
Left err ->
assertFailure
( "canonical text builder signing (normalized payload) failed: "
++ renderSignError err
)
>> fail (renderSignError err)
Right sig -> pure sig
assertEqual
"builder canonical text signing should normalize mixed line endings"
builderNormalized
builderMixed
testSignaturePrimitives :: Assertion
testSignaturePrimitives = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let userId = UserId "primitive-api@example.org"
assertSigType
:: String
-> SigType
-> Either SignError SignaturePayload
-> Assertion
assertSigType testLabel expected result =
case result of
Left err ->
assertFailure (testLabel ++ " failed: " ++ renderSignError err)
Right (SigV4 sigType _ _ _ _ _ _) ->
assertEqual
(testLabel ++ " uses expected signature type")
expected
sigType
Right _ ->
assertFailure
(testLabel ++ " should generate a V4 signature payload")
assertSigType
"certification signature"
GenericCert
( signCertificationWithRSA
GenericCert
signer
userId
[]
[]
signingKey
)
assertSigType
"key revocation signature"
KeyRevocationSig
(signKeyRevocationWithRSA signer [] [] signingKey)
assertSigType
"subkey revocation signature"
SubkeyRevocationSig
(signSubkeyRevocationWithRSA signer signer [] [] signingKey)
assertSigType
"certification revocation signature"
CertRevocationSig
(signCertRevocationWithRSA signer userId [] [] signingKey)
let left16Payload = "left16 primitive payload"
left16Keyring = mkTestKeyring [TKUnknown (signer, Nothing) [] [] [] []]
left16Sig <-
case signDataWithRSA BinarySig signingKey [] [] left16Payload of
Left err ->
assertFailure
( "RSA primitive signing for left16 failed: "
++ renderSignError err
)
>> fail "expected RSA signature payload"
Right sigPayload -> pure sigPayload
case verifyAgainstKeyring
left16Keyring
(SignaturePkt left16Sig)
Nothing
left16Payload of
Right _ -> pure ()
Left err ->
assertFailure
( "fresh RSA signature should verify with matching left16, got: "
++ renderVerificationError err
)
let tamperedLeft16Sig =
case left16Sig of
SigV4 st pka ha hs us l16 mpis -> SigV4 st pka ha hs us (l16 + 1) mpis
other -> other
case verifyAgainstKeyring
left16Keyring
(SignaturePkt tamperedLeft16Sig)
Nothing
left16Payload of
Left _ -> pure ()
Right _ ->
assertFailure
"verification unexpectedly succeeded with tampered left16"
if isRight
( signCertificationWithRSA
KeyRevocationSig
signer
userId
[]
[]
signingKey
)
then
assertFailure
"certification primitive should reject non-certification signature types"
else pure ()
(edSigner, edSigningKey) <- loadDeterministicEd25519Signer
edIssuerKeyId <-
case eightOctetKeyID edSigner of
Left err ->
assertFailure ("failed to derive Ed25519 issuer key id: " ++ err)
>> fail "expected Ed25519 issuer key id"
Right i -> pure i
let edPayload = "primitive Ed25519 payload"
edHashed =
[ SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint edSigner))
]
edUnhashed = [SigSubPacket False (Issuer edIssuerKeyId)]
case signDataWithEd25519
BinarySig
edSigningKey
edHashed
edUnhashed
edPayload of
Left err ->
assertFailure
("Ed25519 primitive signing failed: " ++ renderSignError err)
Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure ()
Right other ->
assertFailure
( "Ed25519 primitive should generate an Ed25519 SigV4 payload, got "
++ show other
)
let v6Salt = SignatureSalt (BL.replicate 32 0x42)
case signDataWithEd25519V6
BinarySig
v6Salt
edSigningKey
edHashed
edUnhashed
edPayload of
Left err ->
assertFailure
("Ed25519 SigV6 primitive signing failed: " ++ renderSignError err)
Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) ->
assertEqual
"Ed25519 SigV6 primitive should preserve 32-byte salt"
32
(BL.length (unSignatureSalt salt))
Right other ->
assertFailure
( "Ed25519 SigV6 primitive should generate an Ed25519 SigV6 payload, got "
++ show other
)
(ed448Signer, ed448SigningKey) <- loadDeterministicEd448Signer
ed448IssuerKeyId <-
case eightOctetKeyID ed448Signer of
Left err ->
assertFailure ("failed to derive Ed448 issuer key id: " ++ err)
>> fail "expected Ed448 issuer key id"
Right i -> pure i
let ed448Payload = "primitive Ed448 payload"
ed448Hashed =
[ SigSubPacket
False
(IssuerFingerprint IssuerFingerprintV4 (fingerprint ed448Signer))
]
ed448Unhashed = [SigSubPacket False (Issuer ed448IssuerKeyId)]
case signDataWithEd448
BinarySig
ed448SigningKey
ed448Hashed
ed448Unhashed
ed448Payload of
Left err ->
assertFailure
("Ed448 primitive signing failed: " ++ renderSignError err)
Right (SigV4 BinarySig PKA.Ed448 SHA512 _ _ _ _) -> pure ()
Right other ->
assertFailure
( "Ed448 primitive should generate an Ed448 SigV4 payload, got "
++ show other
)
case signDataWithEd448V6
BinarySig
v6Salt
ed448SigningKey
ed448Hashed
ed448Unhashed
ed448Payload of
Left err ->
assertFailure
("Ed448 SigV6 primitive signing failed: " ++ renderSignError err)
Right (SigV6 BinarySig PKA.Ed448 SHA512 salt _ _ _ _) ->
assertEqual
"Ed448 SigV6 primitive should preserve 32-byte salt"
32
(BL.length (unSignatureSalt salt))
Right other ->
assertFailure
( "Ed448 SigV6 primitive should generate an Ed448 SigV6 payload, got "
++ show other
)
testSignatureDataKindsCoercions :: Assertion
testSignatureDataKindsCoercions = do
let sigV3 =
SigV3
BinarySig
(ThirtyTwoBitTimeStamp 1)
(EightOctetKeyId "\x01\x02\x03\x04\x05\x06\x07\x08")
RSA
SHA256
0
(NE.fromList [MPI 1])
sigV4 =
SigV4
BinarySig
RSA
SHA256
[]
[]
0
(NE.fromList [MPI 2])
sigV6 =
SigV6
BinarySig
PKA.Ed25519
SHA512
(SignatureSalt (BL.replicate 32 0x01))
[]
[]
0
(NE.fromList [MPI 3, MPI 4])
sigOther = SigVOther 77 "opaque-signature-body"
assertPacketRoundTrip label expected pkt =
case fromPktEitherSomeSignatureV pkt of
Left err -> assertFailure (label ++ " packet coercion failed: " ++ err)
Right (SomeSignatureV typedSig) ->
assertEqual
(label ++ " packet coercion preserves payload")
expected
(signaturePayloadFromSignatureV typedSig)
assertBool
"toSomeSignaturePayload should preserve SigV3 witness"
(isRight (asSignaturePayloadV3 sigV3))
assertBool
"toSomeSignaturePayload should preserve SigV4 witness"
(isRight (asSignaturePayloadV4 sigV4))
assertBool
"toSomeSignaturePayload should preserve SigV6 witness"
(isRight (asSignaturePayloadV6 sigV6))
assertBool
"toSomeSignaturePayload should preserve SigVOther witness"
(isRight (asSignaturePayloadOther sigOther))
case asSignaturePayloadV3 sigV3 of
Left err ->
assertFailure
("asSignaturePayloadV3 should accept SigV3: " ++ err)
Right typed ->
assertEqual
"asSignaturePayloadV3 round-trips SigV3"
sigV3
(toSignaturePayload typed)
case asSignaturePayloadV4 sigV4 of
Left err ->
assertFailure
("asSignaturePayloadV4 should accept SigV4: " ++ err)
Right typed ->
assertEqual
"asSignaturePayloadV4 round-trips SigV4"
sigV4
(toSignaturePayload typed)
case asSignaturePayloadV6 sigV6 of
Left err ->
assertFailure
("asSignaturePayloadV6 should accept SigV6: " ++ err)
Right typed ->
assertEqual
"asSignaturePayloadV6 round-trips SigV6"
sigV6
(toSignaturePayload typed)
case asSignaturePayloadOther sigOther of
Left err ->
assertFailure
("asSignaturePayloadOther should accept SigVOther: " ++ err)
Right typed ->
assertEqual
"asSignaturePayloadOther round-trips SigVOther"
sigOther
(toSignaturePayload typed)
assertBool
"asSignaturePayloadV6 rejects SigV4"
(not (isRight (asSignaturePayloadV6 sigV4)))
assertBool
"asSignaturePayloadV4 rejects SigVOther"
(not (isRight (asSignaturePayloadV4 sigOther)))
assertPacketRoundTrip "SigV3" sigV3 (SignaturePkt sigV3)
assertPacketRoundTrip "SigV4" sigV4 (SignaturePkt sigV4)
assertPacketRoundTrip "SigV6" sigV6 (SignaturePkt sigV6)
assertPacketRoundTrip
"SigVOther"
sigOther
(SignaturePkt sigOther)
assertBool
"fromPktEitherSomeSignatureV rejects non-signature packets"
( not
( isRight
(fromPktEitherSomeSignatureV (LiteralDataPkt BinaryData "" 0 ""))
)
)
testTypedArmorPayloadHelpers :: Assertion
testTypedArmorPayloadHelpers = do
let armors =
[ Armor ArmorPublicKeyBlock [] "public-one"
, Armor ArmorMessage [] "message-one"
, Armor ArmorPublicKeyBlock [] "public-two"
]
publicPayloads =
map BL.toStrict (armorPayloadsOfType ArmorPublicKeyBlock armors)
assertEqual
"armorPayloadsOfType returns all matching typed blocks in order"
["public-one", "public-two"]
publicPayloads
assertEqual
"singleArmorPayloadOfType returns the sole matching message payload"
(Right "message-one")
(fmap BL.toStrict (singleArmorPayloadOfType ArmorMessage armors))
assertBool
"singleArmorPayloadOfType fails when no typed blocks exist"
(isLeft (singleArmorPayloadOfType ArmorPrivateKeyBlock armors))
assertBool
"singleArmorPayloadOfType fails when multiple typed blocks exist"
(isLeft (singleArmorPayloadOfType ArmorPublicKeyBlock armors))
testRecommendedArmorType :: Assertion
testRecommendedArmorType = do
secretArmors <- loadArmor "v4-encrypted-secret.pgp.aa"
publicArmors <- loadArmor "v4-encrypted.rev.aa"
secretPayload <-
case singleArmorPayloadOfType ArmorPrivateKeyBlock secretArmors of
Left err -> assertFailure err >> fail err
Right payload -> pure payload
publicPayload <-
case singleArmorPayloadOfType ArmorPublicKeyBlock publicArmors of
Left err -> assertFailure err >> fail err
Right payload -> pure payload
let secretPkts = parsePkts secretPayload
publicPkts = parsePkts publicPayload
firstPkt label pkts =
case pkts of
[] ->
assertFailure (label ++ " should contain at least one packet")
>> fail "missing packet"
pkt : _ -> pure pkt
firstSecret <- firstPkt "secret armor fixture" secretPkts
firstPublic <- firstPkt "public armor fixture" publicPkts
let sig =
SignaturePkt
(SigV4 BinarySig RSA SHA256 [] [] 0 (NE.fromList [MPI 1]))
assertEqual
"recommendedArmorType rejects empty packet streams"
Nothing
(recommendedArmorType [])
assertEqual
"recommendedArmorType maps secret-key packets to private key armor"
(Just ArmorPrivateKeyBlock)
(recommendedArmorType [firstSecret])
assertEqual
"recommendedArmorType maps public-key packets to public key armor"
(Just ArmorPublicKeyBlock)
(recommendedArmorType [firstPublic])
assertEqual
"recommendedArmorType maps signature packets to signature armor"
(Just ArmorSignature)
(recommendedArmorType [sig])
assertEqual
"recommendedArmorType defaults non-key/signature packets to message armor"
(Just ArmorMessage)
(recommendedArmorType [LiteralDataPkt BinaryData "" 0 "payload"])
testSingleClearSignedBlock :: Assertion
testSingleClearSignedBlock = do
let clearSigned =
ClearSigned
[("Hash", "SHA256")]
"signed cleartext payload\n"
( Armor
ArmorSignature
[("Version", "test-suite")]
"detached-signature"
)
assertEqual
"singleClearSignedBlock extracts cleartext and signature payloads"
( Right
( [("Hash", "SHA256")]
, "signed cleartext payload\n"
, "detached-signature"
)
)
(singleClearSignedBlock [clearSigned])
assertBool
"singleClearSignedBlock rejects absent clear-signed blocks"
(isLeft (singleClearSignedBlock [Armor ArmorMessage [] "payload"]))
assertBool
"singleClearSignedBlock rejects multiple clear-signed blocks"
(isLeft (singleClearSignedBlock [clearSigned, clearSigned]))
assertBool
"singleClearSignedBlock rejects non-signature inner armor blocks"
( isLeft
( singleClearSignedBlock
[ ClearSigned [] "payload" (Armor ArmorMessage [] "not-signature")
]
)
)
testSignerTimelineSoftPrimaryRevocation :: Assertion
testSignerTimelineSoftPrimaryRevocation = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let payload = "soft primary revocation timeline payload"
keyCreated = _timestamp signer
sigBeforeTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
sigAfterTime = addTimestampSeconds keyCreated 30
sigBefore <-
signBinaryMessageWithRSAAt
signer
signingKey
sigBeforeTime
payload
revocation <-
signKeyRevocationWithReasonAt
signer
signingKey
revocationTime
KeySuperseded
sigAfter <-
signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload
let keyring =
mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]
assertSingleSignerFingerprint
"soft primary revocation should preserve pre-revocation signatures"
(fingerprint signer)
(verifyTimelinePackets keyring payload sigBefore)
assertSingleFailureContainsTimeline
"soft primary revocation should reject post-revocation signatures"
"signing key is revoked"
(verifyTimelinePackets keyring payload sigAfter)
testSignerTimelineHardPrimaryRevocation :: Assertion
testSignerTimelineHardPrimaryRevocation = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let payload = "hard primary revocation timeline payload"
keyCreated = _timestamp signer
sigBeforeTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
sigBefore <-
signBinaryMessageWithRSAAt
signer
signingKey
sigBeforeTime
payload
revocation <-
signKeyRevocationWithReasonAt
signer
signingKey
revocationTime
KeyMaterialCompromised
let keyring =
mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]
assertSingleFailureContainsTimeline
"hard primary revocation should reject even pre-revocation signatures"
"signing key is revoked"
(verifyTimelinePackets keyring payload sigBefore)
testSignerTimelineNoReasonPrimaryRevocation :: Assertion
testSignerTimelineNoReasonPrimaryRevocation = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let payload = "no-reason primary revocation timeline payload"
keyCreated = _timestamp signer
sigBeforeTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
sigBefore <-
signBinaryMessageWithRSAAt
signer
signingKey
sigBeforeTime
payload
revocation <-
signKeyRevocationWithReasonAt
signer
signingKey
revocationTime
NoReason
let keyring =
mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]
assertSingleFailureContainsTimeline
"no-reason primary revocation should reject even pre-revocation signatures"
"signing key is revoked"
(verifyTimelinePackets keyring payload sigBefore)
testSignerTimelineUnknownReasonPrimaryRevocation :: Assertion
testSignerTimelineUnknownReasonPrimaryRevocation = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let payload = "unknown-reason primary revocation timeline payload"
keyCreated = _timestamp signer
sigBeforeTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
sigBefore <-
signBinaryMessageWithRSAAt
signer
signingKey
sigBeforeTime
payload
revocation <-
signKeyRevocationWithReasonAt
signer
signingKey
revocationTime
(RCoOther 100)
let keyring =
mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]
assertSingleFailureContainsTimeline
"unknown-reason primary revocation should reject even pre-revocation signatures"
"signing key is revoked"
(verifyTimelinePackets keyring payload sigBefore)
testSignerTimelineNonCompromisePrimaryRevocationIsHistorical
:: Assertion
testSignerTimelineNonCompromisePrimaryRevocationIsHistorical = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let payload = "non-compromise primary revocation timeline payload"
keyCreated = _timestamp signer
sigBeforeTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
sigAfterTime = addTimestampSeconds keyCreated 30
sigBefore <-
signBinaryMessageWithRSAAt
signer
signingKey
sigBeforeTime
payload
revocation <-
signKeyRevocationWithReasonAt
signer
signingKey
revocationTime
UserIdInfoNoLongerValid
sigAfter <-
signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload
let keyring =
mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]
assertSingleSignerFingerprint
"non-compromise primary revocation should preserve pre-revocation signatures"
(fingerprint signer)
(verifyTimelinePackets keyring payload sigBefore)
assertSingleFailureContainsTimeline
"non-compromise primary revocation should reject post-revocation signatures"
"signing key is revoked"
(verifyTimelinePackets keyring payload sigAfter)
testSignerTimelineTemporaryPrimaryRevocationExpires :: Assertion
testSignerTimelineTemporaryPrimaryRevocationExpires = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let payload = "temporary primary revocation expiry timeline payload"
keyCreated = _timestamp signer
sigBeforeTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
sigDuringTime = addTimestampSeconds keyCreated 25
sigAfterTime = addTimestampSeconds keyCreated 35
sigBefore <-
signBinaryMessageWithRSAAt
signer
signingKey
sigBeforeTime
payload
revocation <-
signKeyRevocationWithReasonAndExtrasAt
signer
signingKey
revocationTime
KeySuperseded
[SigSubPacket False (SigExpirationTime 10)]
sigDuring <-
signBinaryMessageWithRSAAt
signer
signingKey
sigDuringTime
payload
sigAfter <-
signBinaryMessageWithRSAAt signer signingKey sigAfterTime payload
let keyring =
mkTestKeyring [TKUnknown (signer, Nothing) [revocation] [] [] []]
assertSingleSignerFingerprint
"temporary primary revocation should preserve pre-revocation signatures"
(fingerprint signer)
(verifyTimelinePackets keyring payload sigBefore)
assertSingleFailureContainsTimeline
"temporary primary revocation should reject signatures while revocation is effective"
"signing key is revoked"
(verifyTimelinePackets keyring payload sigDuring)
assertSingleSignerFingerprint
"temporary primary revocation should allow signatures after revocation expiration"
(fingerprint signer)
(verifyTimelinePackets keyring payload sigAfter)
testSignerTimelineSubkeyRevocation :: Assertion
testSignerTimelineSubkeyRevocation = do
(primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner
(subkeySigner, subkeySigningKey) <-
loadDeterministicEd25519Signer
let payload = "subkey revocation timeline payload"
keyCreated = _timestamp primarySigner
bindingTime = addTimestampSeconds keyCreated 10
sigBeforeTime = addTimestampSeconds keyCreated 20
revocationTime = addTimestampSeconds keyCreated 30
sigAfterTime = addTimestampSeconds keyCreated 40
subkeyPacket = PublicSubkeyPkt subkeySigner
bindingSig <-
signSubkeyBindingWithRSAAt
primarySigner
subkeySigner
primarySigningKey
bindingTime
sigBefore <-
signBinaryMessageWithEd25519At
subkeySigner
subkeySigningKey
sigBeforeTime
payload
revocationSig <-
signSubkeyRevocationWithRSAAt
primarySigner
subkeySigner
primarySigningKey
revocationTime
sigAfter <-
signBinaryMessageWithEd25519At
subkeySigner
subkeySigningKey
sigAfterTime
payload
let keyring =
mkTestKeyring
[ TKUnknown
(primarySigner, Nothing)
[]
[]
[]
[(subkeyPacket, [bindingSig, revocationSig])]
]
assertSingleSignerFingerprint
"subkey revocation should preserve pre-revocation signatures"
(fingerprint subkeySigner)
(verifyTimelinePackets keyring payload sigBefore)
assertSingleFailureContainsTimeline
"subkey revocation should reject post-revocation signatures"
"signing key was not valid at the signature creation time"
(verifyTimelinePackets keyring payload sigAfter)
testSignMessageConvenience :: Assertion
testSignMessageConvenience = do
(signer, signingKey) <- loadUnencryptedRsaSigner
signerV4 <- expectV4PKPayload "RSA v4 convenience signer" signer
signedResult <-
signMessage
(mkRSASignerV4 signerV4 signingKey)
"message-api convenience signing payload"
signedMessage <-
case signedResult of
Left err ->
assertFailure
("message signing convenience API failed: " ++ show err)
>> pure mempty
Right bs -> pure bs
case parsePkts signedMessage of
[LiteralDataPkt {}, SignaturePkt _] -> pure ()
_ ->
assertFailure
"convenience signing output should contain literal data and one signature packet"
testTypedVerifySurfaceMatchesLegacy :: Assertion
testTypedVerifySurfaceMatchesLegacy = do
kr <- loadKeyring "pubring.gpg"
signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg"
let typedResults =
verifyMessage
defaultVerificationOptions
{ verificationPolicy = VerifyInformational
, verificationMode = VerificationStreaming
}
kr
signedMessage
strictResults =
verifyMessage
defaultVerificationOptions
{ verificationPolicy = VerifyStrict
, verificationMode = VerificationStreaming
}
kr
signedMessage
normalizeTyped
:: Either VerificationError Verification -> Either Bool Fingerprint
normalizeTyped (Left _) = Left False
normalizeTyped (Right v) = Right (fingerprint (_verificationSigner v))
assertEqual
"strict verification should collapse informational failures"
( map
normalizeTyped
(either (pure . Left) (Right <$>) (sequence typedResults))
)
(map normalizeTyped strictResults)
assertBool
"informational verification should emit at least one result for known-good fixture"
(not (null (map normalizeTyped typedResults)))
testVerifyMessageStrictRejectsTamper :: Assertion
testVerifyMessageStrictRejectsTamper = do
kr <- loadKeyring "pubring.gpg"
packets <- loadAndDecompressPkts "uncompressed-ops-rsa.gpg"
let tamperedPackets = map tamperLiteral packets
strictOptions =
defaultVerificationOptions
{ verificationPolicy = VerifyStrict
, verificationMode = VerificationStreaming
}
case verifyMessagePackets strictOptions kr tamperedPackets of
[Left _] -> pure ()
_ ->
assertFailure
"strict typed verification should fail on tampered payload"
where
tamperLiteral (LiteralDataPkt dt fn ts payload) =
LiteralDataPkt dt fn ts (BL.snoc payload 0)
tamperLiteral pkt = pkt
testVerifySignedMessageConvenience :: Assertion
testVerifySignedMessageConvenience = do
kr <- loadKeyring "pubring.gpg"
signedMessage <- readFixtureLazy "uncompressed-ops-rsa.gpg"
strictResult <-
pure
( verifySignedMessage
defaultVerificationOptions
{ verificationPolicy = VerifyStrict
, verificationMode = VerificationStreaming
}
kr
signedMessage
)
case strictResult of
[Left _] ->
assertFailure
"verifySignedMessage should succeed for known-good fixture"
verifications ->
assertBool
"verifySignedMessage should emit at least one verification"
(not (null verifications))
testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm :: Assertion
testVerifyV4EdDSASignatureWithEd25519KeyAlgorithm = do
(signer, signingKey) <- loadDeterministicEd25519Signer
let signerWithEd25519Pka = setPKAlgorithm PKA.Ed25519 signer
signerV4 <-
expectV4PKPayload
"Ed25519 v4 signer with Ed25519 key algorithm"
signerWithEd25519Pka
let payload = "v4 eddsa signature with Ed25519 key algorithm"
state =
emptyPSC {lastLD = LiteralDataPkt BinaryData BL.empty 0 payload}
keyring =
mkTestKeyring
[TKUnknown (signerWithEd25519Pka, Nothing) [] [] [] []]
signedResult <-
signMessageWith
(mkEd25519SignerV4 signerV4 signingKey)
(mkClearPayload payload)
signaturePkt <-
case signedResult of
Left err ->
assertFailure ("Ed25519 message signing failed: " ++ show err)
>> fail "expected signed Ed25519 payload"
Right signedMessage ->
case parsePkts signedMessage of
[ LiteralDataPkt {}
, sig@(SignaturePkt (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _))
] ->
pure sig
other ->
assertFailure
( "Expected [LiteralDataPkt, Ed25519 SigV4] for Ed25519-key-algorithm verification test, got "
++ show other
)
>> fail "unexpected Ed25519-key-algorithm signature shape"
case verifySigWith
defaultVerificationPolicy
(verifyAgainstKeyring keyring)
signaturePkt
state
Nothing of
Left err ->
assertFailure
( "Ed25519 SigV4 verification with Ed25519 key algorithm failed: "
++ renderVerificationError err
)
Right _ -> pure ()