hOpenPGP-3.0.0: tests/Tests/Keys.hs
-- Keys.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.Keys (keyAndVerificationTests) where
import Codec.Encryption.OpenPGP.Expirations
( effectiveKeyPreferencesAtTimestamp
, effectiveUIDPreferencesAtTimestamp
, isTKTimeValid
)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.Internal
( emptyPSC
, lastPrimaryKey
, lastSubkey
)
import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev, pubkeySize)
import Codec.Encryption.OpenPGP.Message
( asV6PKPayload
, mkEd25519SignerV6
, mkRSASignerV6
)
import Codec.Encryption.OpenPGP.Policy
( OpenPGPRFC(..)
, isAllowedPrimaryKeySig
, isAllowedSubkeySig
, isAllowedUIDSig
)
import Codec.Encryption.OpenPGP.SecretKey
( changePrivateKeyPassphrase
, decryptPrivateKey
)
import Codec.Encryption.OpenPGP.Serialize
( getSecretKey
, parsePkts
)
import Codec.Encryption.OpenPGP.SerializeForSigs (payloadForSig)
import Codec.Encryption.OpenPGP.Signatures
import Codec.Encryption.OpenPGP.Subpackets
( sigBuilderInit
, sigBuilderInitRuntime
, sigBuilderInitV6
, sigBuilderInitV6Runtime
, addHashedSubs
, addUnhashedSubs
, LegalSubpacket(..)
, listToHashedSubs
, listToUnhashedSubs
, listToLegalSubs
)
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as PKA
import Control.Error.Util (isRight)
import Crypto.Number.Serialize (os2ip)
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import Data.Bifunctor (first)
import Data.Binary (get, put)
import Data.Binary.Get (Get, runGetOrFail)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Conduit as DC
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Compression (conduitDecompress)
import Data.Conduit.OpenPGP.Keyring (conduitToUnknownTKs)
import Data.Conduit.OpenPGP.Verify (conduitVerify)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.IxSet.Typed ((@=), getOne, size)
import Data.List (find, isInfixOf)
import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (isJust)
import qualified Data.Set as Set
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Prettyprinter (pretty)
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, assertBool, assertEqual, assertFailure, testCase)
import Tests.Common
( assertSingleFailureContainsTimeline
, assertSingleSignerFingerprint
, loadAndDecompressPkts
, messageIssuerSubpacketsAt
, addTimestampSeconds
, armorPayload
, assertFalse
, assertTrue
, certificateVerificationFixtures
, fixturePath
, loadArmor
, loadDeterministicEd25519Signer
, loadKeyring
, loadUnencryptedRsaSigner
, messageVerificationFixtures
, mkTestKeyring
, readFixturePayload
, readPKIPassphrase
, runGet
, setKeyVersion
, signBinaryMessageWithRSAAt
, signCertificationAt
, signCertificationRevocationAt
, signCertificationRevocationWithEd25519At
, signCertificationWithEd25519At
, signSubkeyBindingWithRSAExtrasAt
, timestampToUTCTime
, verificationFixtureGroup
, verifyMessageFromBytestring
, verifyMessageFromBytestringBatch
, verifyMessageFromPackets
, verifyMessageFromPacketsBatch
, verifyTimelinePackets
)
keyAndVerificationTests :: TestTree
keyAndVerificationTests =
testGroup
"Keys and verification"
[ testGroup
"PKA/Size/KeyID/fingerprint group"
[ testCase
"v3 key"
(testPKAandSizeAndKeyIDandFingerprint
"v3.key"
"rsa/1024:6DC580F5C7261095/CBD9 F412 6807 E405 CC2D 2712 1DF5 E86E")
, testCase
"v4 key"
(testPKAandSizeAndKeyIDandFingerprint
"000001-006.public_key"
"rsa/1248:D4D54EA16F87040E/421F 28FE AAD2 22F8 56C8 FFD5 D4D5 4EA1 6F87 040E")
, testCase
"ECDSA key"
(testPKAandSizeAndKeyIDandFingerprint
"nist_p-256_key.gpg"
"ecd/256:F7708BADD6063224/174C CF12 C571 6D0E 527F B50E F770 8BAD D606 3224")
, testCase
"EdDSA key"
(testPKAandSizeAndKeyIDandFingerprint
"sample-eddsa.pubkey"
"edd/256:8CFDE12197965A9A/C959 BDBA FA32 A2F8 9A15 3B67 8CFD E121 9796 5A9A")
, testCase
"EdDSA secret key (projected to public key packet)"
(testPKAandSizeAndKeyIDandFingerprint
"ed25519.secretkey"
"edd/256:B05F9287601D5914/B6FE 0C23 12EB D832 0238 C252 B05F 9287 601D 5914")
, testCase
"v6 secret key (projected to public key packet)"
(testPKAandSizeAndKeyIDandFingerprint
"v6-secret.pgp.aa"
"e25/256:7106CB6DB27E4FC9/7106 CB6D B27E 4FC9 B050 B02B B316 4DBD 4BBD 7263 D4D2 9E78 A3BB 3BDB B022 2D19")
]
, testGroup
"Keyring group"
[ testCase
"pubring 7732CF988A63EA86"
(testKeyringLookup "pubring.gpg" "7732CF988A63EA86" True)
, testCase
"pubring 123456789ABCDEF0"
(testKeyringLookup "pubring.gpg" "123456789ABCDEF0" False)
, testCase
"pubsub AD992E9C24399832"
(testKeyringLookup "pubring.gpg" "AD992E9C24399832" True)
, testCase
"secring 7732CF988A63EA86"
(testKeyringLookup "secring.gpg" "7732CF988A63EA86" True)
, testCase
"secring 123456789ABCDEF0"
(testKeyringLookup "secring.gpg" "123456789ABCDEF0" False)
, testCase
"secsub AD992E9C24399832"
(testKeyringLookup "secring.gpg" "AD992E9C24399832" True)
, testCase "pubring.gpg has 4 keys" (testKeyringSize "pubring.gpg" 4)
, testCase "secring.gpg has 4 keys" (testKeyringSize "secring.gpg" 4)
]
, verificationFixtureGroup
"Message verification group (packet-based)"
verifyMessageFromPackets
messageVerificationFixtures
, verificationFixtureGroup
"Message verification group (packet-based, batch)"
verifyMessageFromPacketsBatch
messageVerificationFixtures
, verificationFixtureGroup
"Message verification group (bytestring-based)"
verifyMessageFromBytestring
messageVerificationFixtures
, verificationFixtureGroup
"Message verification group (bytestring-based, batch)"
verifyMessageFromBytestringBatch
messageVerificationFixtures
, verificationFixtureGroup
"Certificate verification group (packet-based)"
verifyMessageFromPackets
certificateVerificationFixtures
, verificationFixtureGroup
"Certificate verification group (packet-based, batch)"
verifyMessageFromPacketsBatch
certificateVerificationFixtures
, verificationFixtureGroup
"Certificate verification group (bytestring-based)"
verifyMessageFromBytestring
certificateVerificationFixtures
, verificationFixtureGroup
"Certificate verification group (bytestring-based, batch)"
verifyMessageFromBytestringBatch
certificateVerificationFixtures
, testGroup
"Key verification group"
[ testCase
"6F87040E pubkey"
(testKeysSelfVerification True "6F87040E.pubkey")
, testCase
"revoked pubkey"
(testKeysSelfVerification False "revoked.pubkey")
, testCase
"expired pubkey"
(testKeysSelfVerification True "expired.pubkey")
, testCase
"nist_p-256 pubkey"
(testKeysSelfVerification True "nist_p-256_key.gpg")
, testCase
"ed25519 pubkey"
(testKeysSelfVerification True "ed25519.pubkey")
]
, testGroup
"Verification error messaging group"
[ testCase
"missing signing key in keyring"
(testMissingSigningKeyMessage
"ecdsa-key-without-ecdh.pubkey"
"uncompressed-ops-rsa.gpg")
, testCase
"tampered message signature mismatch"
(testTamperedSignatureMessage "pubring.gpg" "uncompressed-ops-rsa.gpg")
, testCase
"revoked certificate reports revocation"
(testRevokedCertificateMessage "revoked.pubkey")
]
, testGroup
"Key expiration group"
[ testCase "6F87040E pubkey" (testKeysExpiration True "6F87040E.pubkey")
, testCase "expired pubkey" (testKeysExpiration False "expired.pubkey")
, testCase
"nist_p-256 pubkey"
(testKeysExpiration True "nist_p-256_key.gpg")
, testCase
"ed25519-without-curve25519.pubkey"
(testKeysExpiration True "ed25519-without-curve25519.pubkey")
, testCase "ed25519.pubkey" (testKeysExpiration True "ed25519.pubkey")
]
, testGroup
"misc group"
[ testCase "conduitVerify processes SigV6 packets" testConduitVerifyProcessesSigV6
, testCase "signature builder API (Phase 2)" testSignatureBuilders
, testCase "typed legal subpacket builder API (P2.1)" testLegalSubpacketBuilders
, testCase
"legacy secret key passphrase changes preserve protection"
testChangePrivateKeyPassphraseLegacy
, testCase "change private key passphrase" testChangePrivateKeyPassphraseV6
, testCase
"getSecretKey parses v4 X25519 ECDH key material"
testGetSecretKeyHandlesV4X25519ECDHPubkey
, testCase
"v4 Ed25519 secret-key roundtrip preserves leading zero byte"
testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte
, testCase
"v4 Ed448 secret-key roundtrip preserves leading zero byte"
testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte
, testCase "policy signature context validation (RFC9580)" testPolicySignatureContextValidation
, testCase
"temporary validity uses latest effective self-signature window"
testTemporaryKeyValidityRespectsLatestSelfSignature
, testCase
"temporary validity rejects gaps with no effective self-signature"
testTemporaryKeyValidityRejectsSelfSignatureGaps
, testCase
"temporary validity rejects the gap before the first self-signature"
testTemporaryKeyValidityRejectsPreCertificationGap
, testCase
"temporary validity follows temporary self-revocations"
testTemporaryKeyValidityFollowsTemporarySelfRevocation
, testCase
"temporary validity does not revive older self-signatures after newer expiry"
testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures
, testCase
"uid-retired revocation is historical until effective"
testUidRetiredRevocationIsHistorical
, testCase
"third-party certifications do not affect primary key validity windows"
testThirdPartyCertificationDoesNotAffectKeyValidityWindow
, testCase
"certification revocations only remove matching signer certifications"
testCertificationRevocationOnlyRemovesMatchingSigner
, testCase
"preference resolution tracks active self-certification timeline"
testPreferencesAtTimestamp
, testCase
"verifySigWith rejects v6 revocation Issuer key-id subpackets"
testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID
, testCase
"verifySigWith rejects v6 revocation unhashed Issuer key-id subpackets"
testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed
, testCase
"verifySigWith accepts matching v6 revocation IssuerFingerprint"
testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint
, testCase "v6 signer constructor rejects v4 key" testV6SignerConstructorRejectsV4Key
, testCase
"primary key binding rejects unsupported critical hashed subpackets"
testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket
, testCase
"subkey binding missing back-signature is surfaced as a warning"
testSubkeyBindingMissingBackSignatureProducesWarning
, testCase
"subkey binding rejects unsupported critical hashed subpackets"
testSubkeyBindingRejectsUnsupportedCriticalSubpacket
]
]
testPKAandSizeAndKeyIDandFingerprint :: FilePath -> String -> Assertion
testPKAandSizeAndKeyIDandFingerprint fpr kf = do
bs <- readFixturePayload fpr
case runGet (get :: Get Pkt) bs of
Left _ -> assertFailure $ "Decoding of " ++ fpr ++ " broke."
Right pkt ->
case publicKeyPacketOf pkt of
PublicKeyPkt pkp -> do
let pref =
concat
[ pkalgoAbbrev (_pkalgo pkp)
, "/"
, either (const "unknown") show (pubkeySize (_pubkey pkp))
, ":"
, either (const "unknown") (show . pretty) (eightOctetKeyID pkp)
, "/"
]
assertEqual
("for " ++ fpr ++ " (spaceless)")
(spaceless kf)
(pref ++ show (pretty (fingerprint pkp)))
assertEqual
("for " ++ fpr ++ " (spaced)")
kf
(pref ++ show (pretty (SpacedFingerprint (fingerprint pkp))))
_ -> assertFailure "Expected (possibly secret) key packet, got something else."
where
spaceless = filter (/= ' ')
testKeyringLookup :: FilePath -> String -> Bool -> Assertion
testKeyringLookup fpr eok expected = do
kr <- loadKeyring fpr
let foundKey = getOne (kr @= (read eok :: EightOctetKeyId))
assertEqual (eok ++ " in " ++ fpr) expected (isJust foundKey)
testKeyringSize :: FilePath -> Int -> Assertion
testKeyringSize fpr expected = do
kr <- loadKeyring fpr
assertEqual ("key count in " ++ fpr) expected (size kr)
assertLeftContains :: String -> Either VerificationError a -> Assertion
assertLeftContains needle result =
case result of
Left err ->
let rendered = renderVerificationError err
in
if needle `isInfixOf` rendered
then pure ()
else
assertFailure
("Expected error containing '" ++ needle ++ "', got '" ++ rendered ++ "'.")
Right _ -> assertFailure ("Expected Left containing '" ++ needle ++ "', got Right.")
testMissingSigningKeyMessage :: FilePath -> FilePath -> Assertion
testMissingSigningKeyMessage keyring message = do
kr <- loadKeyring keyring
verification <-
DC.runConduitRes $
CB.sourceFile (fixturePath message) DC..| conduitGet get DC..| conduitDecompress DC..|
conduitVerify kr Nothing DC..|
CL.consume
case verification of
[] -> assertFailure "Expected at least one verification result."
(firstResult:_) ->
assertLeftContains "signing key not found in keyring" firstResult
testTamperedSignatureMessage :: FilePath -> FilePath -> Assertion
testTamperedSignatureMessage keyring message = do
kr <- loadKeyring keyring
packets <- loadAndDecompressPkts message
let tamperedPackets = map tamperLiteral packets
verification <-
DC.runConduitRes $
CL.sourceList tamperedPackets DC..| conduitVerify kr Nothing DC..| CL.consume
case verification of
[] -> assertFailure "Expected at least one verification result."
(firstResult:_) ->
assertLeftContains "signature mismatch" firstResult
where
tamperLiteral (LiteralDataPkt dt fn ts payload) =
LiteralDataPkt dt fn ts (BL.snoc payload 0)
tamperLiteral pkt = pkt
testRevokedCertificateMessage :: FilePath -> Assertion
testRevokedCertificateMessage keyfile = do
ks <-
DC.runConduitRes $
CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..| conduitToUnknownTKs DC..|
CL.consume
assertLeftContains
"signing key is revoked"
(mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks)
testKeysSelfVerification :: Bool -> FilePath -> Assertion
testKeysSelfVerification expectsuccess keyfile = do
ks <-
DC.runConduitRes $
CB.sourceFile ("tests/data/" ++ keyfile) DC..| conduitGet get DC..|
conduitToUnknownTKs DC..|
CL.consume
let verifieds =
mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks
assertEqual
(keyfile ++ " self-verification")
expectsuccess
(isRight verifieds)
testKeysExpiration :: Bool -> FilePath -> Assertion
testKeysExpiration expectsuccess keyfile = do
ks <-
DC.runConduitRes $
CB.sourceFile (fixturePath keyfile) DC..| conduitGet get DC..|
conduitToUnknownTKs DC..|
CL.consume
case mapM (verifyUnknownTKWith (verifySigWith (verifyAgainstKeys ks)) Nothing) ks of
Left err ->
assertFailure
(keyfile ++ " key self-verification failed before expiration check: " ++
renderVerificationError err)
Right verifieds -> do
let tvalid =
all
(isTKTimeValid
(posixSecondsToUTCTime (realToFrac (1400000000 :: Integer))))
verifieds
assertEqual (keyfile ++ " key expiration") expectsuccess tvalid
testConduitVerifyProcessesSigV6 :: Assertion
testConduitVerifyProcessesSigV6 = do
kr <- loadKeyring "pubring.gpg"
let sigPayload =
SigV6
BinarySig
RSA
SHA256
(SignatureSalt (BL.replicate 16 0))
[]
[]
0
(MPI 0 :| [])
packets =
[ LiteralDataPkt BinaryData BL.empty (ThirtyTwoBitTimeStamp 0) "payload"
, SignaturePkt sigPayload
]
verification <-
DC.runConduitRes $
CL.sourceList packets DC..| conduitVerify kr Nothing DC..| CL.consume
case verification of
[Left _] -> return ()
other ->
assertFailure
("Expected one v6 verification result (failure is fine), got " ++
show (length other) ++ " results")
testSubkeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion
testSubkeyBindingRejectsUnsupportedCriticalSubpacket = do
(primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner
(subkeySigner, _) <- loadDeterministicEd25519Signer
let creationTime = addTimestampSeconds (_timestamp primarySigner) 10
(hashed, unhashed) <- messageIssuerSubpacketsAt primarySigner creationTime
let bindingPayload =
payloadForSig
SubkeyBindingSig
emptyPSC
{ lastPrimaryKey = PublicKeyPkt primarySigner
, lastSubkey = PublicSubkeyPkt subkeySigner
}
hashedWithUnsupportedCritical =
SigSubPacket True (OtherSigSub 111 "unsupported-critical") : hashed
keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []]
state =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt primarySigner
, lastSubkey = PublicSubkeyPkt subkeySigner
}
sigPayload <-
case signDataWithRSA
SubkeyBindingSig
primarySigningKey
hashedWithUnsupportedCritical
unhashed
bindingPayload of
Left err ->
assertFailure ("failed to sign subkey binding with unsupported critical subpacket: " ++ renderSignError err) >>
fail "expected subkey binding signature"
Right sig -> pure sig
case verifySigWith (verifyAgainstKeys keyring) (SignaturePkt sigPayload) state Nothing of
Left (UnsupportedCriticalSubpacket SubkeyBindingSig) -> pure ()
Left err ->
assertFailure
("Expected unsupported critical subpacket rejection for subkey binding signature, got: " ++
renderVerificationError err)
Right _ ->
assertFailure
"Expected unsupported critical subpacket rejection for subkey binding signature, but verification succeeded"
testSubkeyBindingMissingBackSignatureProducesWarning :: Assertion
testSubkeyBindingMissingBackSignatureProducesWarning = do
(primarySigner, primarySigningKey) <- loadUnencryptedRsaSigner
(subkeySignerRaw, _) <- loadDeterministicEd25519Signer
let subkeySigner = setKeyVersion V6 subkeySignerRaw
creationTime = addTimestampSeconds (_timestamp primarySigner) 10
keyring = [TKUnknown (primarySigner, Nothing) [] [] [] []]
state =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt primarySigner
, lastSubkey = PublicSubkeyPkt subkeySigner
}
sigPayload <-
signSubkeyBindingWithRSAExtrasAt
primarySigner
subkeySigner
primarySigningKey
creationTime
[SigSubPacket False (KeyFlags (Set.singleton SignDataKey))]
case verifySigWith (verifyAgainstKeys keyring) (SignaturePkt sigPayload) state Nothing of
Left err ->
assertFailure
("Expected successful verification with warning for missing back-signature, got: " ++
renderVerificationError err)
Right verification ->
assertBool
"v6 signing-capable subkey binding without embedded back-signature should emit warning"
(MissingSubkeyBackSignatureWarning `elem` _verificationWarnings verification)
testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket :: Assertion
testPrimaryKeyBindingRejectsUnsupportedCriticalSubpacket = do
(signer, _) <- loadUnencryptedRsaSigner
let sigPayload =
SigV4
PrimaryKeyBindingSig
RSA
SHA256
[SigSubPacket True (OtherSigSub 111 "unsupported-critical")]
[]
0
(MPI 0 :| [])
verifyFn _ _ _ = Right (Verification signer sigPayload [])
state =
emptyPSC
{ lastPrimaryKey = PublicKeyPkt signer
, lastSubkey = PublicSubkeyPkt signer
}
case verifySigWith verifyFn (SignaturePkt sigPayload) state Nothing of
Left (UnsupportedCriticalSubpacket PrimaryKeyBindingSig) -> pure ()
Left err ->
assertFailure
("Expected unsupported critical subpacket rejection for primary key binding signature, got: " ++
renderVerificationError err)
Right _ ->
assertFailure
"Expected unsupported critical subpacket rejection for primary key binding signature, but verification succeeded"
testSignatureBuilders :: Assertion
testSignatureBuilders = do
(_, signingKey) <- loadUnencryptedRsaSigner
-- Test RSA builder API with empty subpackets
let builderRsa = sigBuilderInit @'PKA.RSA BinarySig SHA512
let builderRsaWithHashed = addHashedSubs (listToHashedSubs []) builderRsa
let builderRsaFinal = addUnhashedSubs (listToUnhashedSubs []) builderRsaWithHashed
case signDataWithRSABuilder builderRsaFinal signingKey "test payload" of
Left err -> assertFailure ("RSA builder API failed: " ++ renderSignError err)
Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure ()
Right other ->
assertFailure ("RSA builder API should generate BinarySig RSA SHA512, got " ++ show other)
-- Test RSA builder API with non-default hash algorithm
let builderRsaSha256 = sigBuilderInit @'PKA.RSA BinarySig SHA256
builderRsaSha256WithHashed =
addHashedSubs (listToHashedSubs []) builderRsaSha256
builderRsaSha256Final =
addUnhashedSubs (listToUnhashedSubs []) builderRsaSha256WithHashed
case signDataWithRSABuilder builderRsaSha256Final signingKey "test payload" of
Left err ->
assertFailure ("RSA SHA256 builder API failed: " ++ renderSignError err)
Right (SigV4 BinarySig RSA SHA256 _ _ _ _) ->
pure ()
Right other ->
assertFailure ("RSA builder API should generate BinarySig RSA SHA256, got " ++ show other)
-- Unsupported hash algorithms should be rejected by RSA PKCS#1 v1.5 backend
let builderRsaUnsupported = sigBuilderInit @'PKA.RSA BinarySig (OtherHA 99)
builderRsaUnsupportedWithHashed =
addHashedSubs (listToHashedSubs []) builderRsaUnsupported
builderRsaUnsupportedFinal =
addUnhashedSubs (listToUnhashedSubs []) builderRsaUnsupportedWithHashed
case signDataWithRSABuilder builderRsaUnsupportedFinal signingKey "test payload" of
Left (SignBackendError _) -> pure ()
Left err ->
assertFailure
("RSA builder API should reject unsupported hash with backend error, got " ++
renderSignError err)
Right sig ->
assertFailure
("RSA builder API should reject unsupported hash algorithm, got " ++ show sig)
-- Runtime hash witness promotion should build RFC9580-compatible builders.
let runtimeRsa =
case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA512 of
Left err -> Left err
Right builder ->
let withHashed = addHashedSubs (listToHashedSubs []) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed
in first renderSignError (signDataWithRSABuilder withUnhashed signingKey "test payload")
case runtimeRsa of
Left err ->
assertFailure
("runtime RFC9580 SHA512 builder initialization should succeed, got " ++ err)
Right (SigV4 BinarySig RSA SHA512 _ _ _ _) -> pure ()
Right other ->
assertFailure
("runtime RFC9580 SHA512 builder should produce BinarySig RSA SHA512, got " ++
show other)
case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig SHA1 of
Left _ -> pure ()
Right _ ->
assertFailure
"runtime RFC9580 builder initialization should reject deprecated SHA1"
case sigBuilderInitRuntime @'PKA.RSA RFC9580 BinarySig (OtherHA 99) of
Left _ -> pure ()
Right _ ->
assertFailure
"runtime builder initialization should reject non-witness-backed hash algorithms"
-- Test Ed25519 builder API with empty subpackets
(_, edSigningKey) <- loadDeterministicEd25519Signer
let builderEd25519 = sigBuilderInit @'PKA.Ed25519 BinarySig SHA512
let builderEd25519WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519
let builderEd25519Final = addUnhashedSubs (listToUnhashedSubs []) builderEd25519WithHashed
case signDataWithEd25519Builder builderEd25519Final edSigningKey "test payload" of
Left err -> assertFailure ("Ed25519 builder API failed: " ++ renderSignError err)
Right (SigV4 BinarySig PKA.Ed25519 SHA512 _ _ _ _) -> pure ()
Right other ->
assertFailure ("Ed25519 builder API should generate BinarySig Ed25519 SHA512, got " ++ show other)
-- Test Ed25519 v6 builder API
let v6Salt = SignatureSalt (BL.replicate 32 0x42)
let builderEd25519V6 = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt
let builderEd25519V6WithHashed = addHashedSubs (listToHashedSubs []) builderEd25519V6
let builderEd25519V6Final = addUnhashedSubs (listToUnhashedSubs []) builderEd25519V6WithHashed
case signDataWithEd25519V6Builder builderEd25519V6Final edSigningKey "test payload" of
Left err -> assertFailure ("Ed25519 v6 builder API failed: " ++ renderSignError err)
Right (SigV6 BinarySig PKA.Ed25519 SHA512 salt _ _ _ _) ->
assertEqual "Ed25519 v6 builder API should preserve 32-byte salt" 32 (BL.length (unSignatureSalt salt))
Right other ->
assertFailure ("Ed25519 v6 builder API should generate BinarySig Ed25519 SHA512 SigV6, got " ++ show other)
-- Runtime v6 builder initialization should support SHA3 witness-backed hashes.
let v6Sha3Salt = SignatureSalt (BL.replicate 16 0x33)
runtimeEd25519V6Sha3 =
case sigBuilderInitV6Runtime @'PKA.Ed25519 RFC9580 BinarySig SHA3_256 v6Sha3Salt of
Left err -> Left err
Right builder ->
let withHashed = addHashedSubs (listToHashedSubs []) builder
withUnhashed = addUnhashedSubs (listToUnhashedSubs []) withHashed
in first
renderSignError
(signDataWithEd25519V6Builder withUnhashed edSigningKey "test payload")
case runtimeEd25519V6Sha3 of
Left err ->
assertFailure
("runtime RFC9580 SHA3-256 v6 builder should succeed, got " ++ err)
Right (SigV6 BinarySig PKA.Ed25519 SHA3_256 salt _ _ _ _) ->
assertEqual
"runtime RFC9580 SHA3-256 v6 builder should preserve 16-byte salt"
16
(BL.length (unSignatureSalt salt))
Right other ->
assertFailure
("runtime RFC9580 SHA3-256 v6 builder should produce Ed25519 SigV6 SHA3_256, got " ++
show other)
testLegalSubpacketBuilders :: Assertion
testLegalSubpacketBuilders = do
(signer, signingKey) <- loadUnencryptedRsaSigner
issuerKeyId <-
case eightOctetKeyID signer of
Left err ->
assertFailure ("failed to derive issuer key id for legal-subpacket builder test: " ++ err) >>
fail "expected issuer key id"
Right i -> pure i
let signerFp = fingerprint signer
creation = ThirtyTwoBitTimeStamp 1
v4Builder = sigBuilderInit @'PKA.RSA BinarySig SHA512
v4WithHashed =
addHashedSubs
(listToLegalSubs [LegalSigCreationTime creation, LegalIssuerFingerprintV4 signerFp])
v4Builder
v4Final = addUnhashedSubs (listToLegalSubs [LegalIssuerV4 issuerKeyId]) v4WithHashed
case signDataWithRSABuilder v4Final signingKey "typed legal subpacket payload" of
Left err ->
assertFailure ("v4 legal-subpacket builder failed: " ++ renderSignError err)
Right (SigV4 _ _ _ hashed unhashed _ _) -> do
assertBool
"v4 legal-subpacket builder should include creation time in hashed subpackets"
(SigSubPacket False (SigCreationTime creation) `elem` hashed)
assertBool
"v4 legal-subpacket builder should include v4 issuer fingerprint in hashed subpackets"
(SigSubPacket False (IssuerFingerprint IssuerFingerprintV4 signerFp) `elem` hashed)
assertBool
"v4 legal-subpacket builder should include issuer key ID only in unhashed subpackets"
(SigSubPacket False (Issuer issuerKeyId) `elem` unhashed)
Right other ->
assertFailure ("v4 legal-subpacket builder should generate SigV4, got " ++ show other)
(_, edSigningKey) <- loadDeterministicEd25519Signer
let v6Salt = SignatureSalt (BL.replicate 32 0x17)
v6Builder = sigBuilderInitV6 @'PKA.Ed25519 BinarySig SHA512 v6Salt
v6WithHashed =
addHashedSubs
(listToLegalSubs [LegalSigCreationTime creation, LegalIssuerFingerprintV6 signerFp])
v6Builder
v6Final = addUnhashedSubs (listToLegalSubs []) v6WithHashed
case signDataWithEd25519V6Builder v6Final edSigningKey "typed legal subpacket payload" of
Left err ->
assertFailure ("v6 legal-subpacket builder failed: " ++ renderSignError err)
Right (SigV6 _ _ _ _ hashed unhashed _ _) -> do
assertBool
"v6 legal-subpacket builder should include creation time in hashed subpackets"
(SigSubPacket False (SigCreationTime creation) `elem` hashed)
assertBool
"v6 legal-subpacket builder should include v6 issuer fingerprint in hashed subpackets"
(SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 signerFp) `elem` hashed)
assertEqual
"v6 legal-subpacket builder should keep unhashed set empty for typed legal set used here"
[]
unhashed
Right other ->
assertFailure ("v6 legal-subpacket builder should generate SigV6, got " ++ show other)
testTemporaryKeyValidityRespectsLatestSelfSignature :: Assertion
testTemporaryKeyValidityRespectsLatestSelfSignature = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uidText = "temporary-validity@example.org"
uid = UserId uidText
keyCreated = _timestamp signer
longValidityCertTime = addTimestampSeconds keyCreated 10
temporaryValidityCertTime = addTimestampSeconds keyCreated 20
validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25)
expiredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200)
preExpirySignatureTime = addTimestampSeconds keyCreated 25
postExpirySignatureTime = addTimestampSeconds keyCreated 40
payload = "temporary validity signer timeline payload"
longValidityCert <-
signCertificationAt
signer
signingKey
uid
longValidityCertTime
[SigSubPacket False (KeyExpirationTime 1000)]
temporaryValidityCert <-
signCertificationAt
signer
signingKey
uid
temporaryValidityCertTime
[SigSubPacket False (KeyExpirationTime 30)]
preExpirySignature <-
signBinaryMessageWithRSAAt signer signingKey preExpirySignatureTime payload
postExpirySignature <-
signBinaryMessageWithRSAAt signer signingKey postExpirySignatureTime payload
let tk = TKUnknown (signer, Nothing) [] [(uidText, [longValidityCert, temporaryValidityCert])] [] []
keyring = mkTestKeyring [tk]
assertBool
"latest effective self-signature should keep key valid before temporary expiration"
(isTKTimeValid validCheckTime tk)
assertBool
"latest effective self-signature should expire key at the temporary validity boundary"
(not (isTKTimeValid expiredCheckTime tk))
assertSingleSignerFingerprint
"pre-expiry signatures should still verify"
(fingerprint signer)
(verifyTimelinePackets keyring payload preExpirySignature)
assertSingleFailureContainsTimeline
"post-expiry signatures should be rejected"
"signing key was not valid at the signature creation time"
(verifyTimelinePackets keyring payload postExpirySignature)
testTemporaryKeyValidityRejectsSelfSignatureGaps :: Assertion
testTemporaryKeyValidityRejectsSelfSignatureGaps = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uidText = "temporary-validity-gap@example.org"
uid = UserId uidText
keyCreated = _timestamp signer
firstCertTime = addTimestampSeconds keyCreated 10
secondCertTime = addTimestampSeconds keyCreated 30
gapCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25)
renewedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35)
gapSignatureTime = addTimestampSeconds keyCreated 25
renewedSignatureTime = addTimestampSeconds keyCreated 35
payload = "temporary validity gap signer timeline payload"
firstCertification <-
signCertificationAt
signer
signingKey
uid
firstCertTime
[ SigSubPacket False (KeyExpirationTime 1000)
, SigSubPacket False (SigExpirationTime 10)
]
secondCertification <-
signCertificationAt
signer
signingKey
uid
secondCertTime
[SigSubPacket False (KeyExpirationTime 1000)]
gapSignature <-
signBinaryMessageWithRSAAt signer signingKey gapSignatureTime payload
renewedSignature <-
signBinaryMessageWithRSAAt signer signingKey renewedSignatureTime payload
let tk = TKUnknown (signer, Nothing) [] [(uidText, [firstCertification, secondCertification])] [] []
keyring = mkTestKeyring [tk]
assertBool
"a gap with no effective self-signature should make the key temporarily invalid"
(not (isTKTimeValid gapCheckTime tk))
assertBool
"a later self-signature should restore validity once it becomes effective"
(isTKTimeValid renewedCheckTime tk)
assertSingleFailureContainsTimeline
"signatures made during a self-signature gap should be rejected"
"signing key was not valid at the signature creation time"
(verifyTimelinePackets keyring payload gapSignature)
assertSingleSignerFingerprint
"signatures made after a later self-signature becomes effective should verify"
(fingerprint signer)
(verifyTimelinePackets keyring payload renewedSignature)
testTemporaryKeyValidityRejectsPreCertificationGap :: Assertion
testTemporaryKeyValidityRejectsPreCertificationGap = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uidText = "temporary-validity-pre-cert-gap@example.org"
uid = UserId uidText
keyCreated = _timestamp signer
certificationTime = addTimestampSeconds keyCreated 20
invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 10)
validCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25)
invalidSignatureTime = addTimestampSeconds keyCreated 10
validSignatureTime = addTimestampSeconds keyCreated 25
payload = "temporary validity pre-certification gap signer timeline payload"
certification <-
signCertificationAt
signer
signingKey
uid
certificationTime
[SigSubPacket False (KeyExpirationTime 1000)]
invalidSignature <-
signBinaryMessageWithRSAAt signer signingKey invalidSignatureTime payload
validSignature <-
signBinaryMessageWithRSAAt signer signingKey validSignatureTime payload
let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification])] [] []
keyring = mkTestKeyring [tk]
assertBool
"a key should be invalid before its first self-signature becomes effective"
(not (isTKTimeValid invalidCheckTime tk))
assertBool
"a key should become valid once its first self-signature becomes effective"
(isTKTimeValid validCheckTime tk)
assertSingleFailureContainsTimeline
"signatures made before the first self-signature should be rejected"
"signing key was not valid at the signature creation time"
(verifyTimelinePackets keyring payload invalidSignature)
assertSingleSignerFingerprint
"signatures made after the first self-signature becomes effective should verify"
(fingerprint signer)
(verifyTimelinePackets keyring payload validSignature)
testTemporaryKeyValidityFollowsTemporarySelfRevocation :: Assertion
testTemporaryKeyValidityFollowsTemporarySelfRevocation = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uidText = "temporary-validity-self-revocation@example.org"
uid = UserId uidText
keyCreated = _timestamp signer
certificationTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
revokedCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 25)
restoredCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 35)
revokedSignatureTime = addTimestampSeconds keyCreated 25
restoredSignatureTime = addTimestampSeconds keyCreated 35
payload = "temporary validity self-revocation signer timeline payload"
certification <-
signCertificationAt
signer
signingKey
uid
certificationTime
[SigSubPacket False (KeyExpirationTime 1000)]
temporaryRevocation <-
signCertificationRevocationAt
signer
signingKey
uid
revocationTime
[SigSubPacket False (SigExpirationTime 10)]
revokedSignature <-
signBinaryMessageWithRSAAt signer signingKey revokedSignatureTime payload
restoredSignature <-
signBinaryMessageWithRSAAt signer signingKey restoredSignatureTime payload
let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification, temporaryRevocation])] [] []
keyring = mkTestKeyring [tk]
assertBool
"a temporary self-revocation should disable signing while it is effective"
(not (isTKTimeValid revokedCheckTime tk))
assertBool
"a self-certification should become valid again once its temporary revocation expires"
(isTKTimeValid restoredCheckTime tk)
assertSingleFailureContainsTimeline
"signatures made during a temporary self-revocation should be rejected"
"signing key was not valid at the signature creation time"
(verifyTimelinePackets keyring payload revokedSignature)
assertSingleSignerFingerprint
"signatures made after a temporary self-revocation expires should verify"
(fingerprint signer)
(verifyTimelinePackets keyring payload restoredSignature)
testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures :: Assertion
testTemporaryKeyValidityDoesNotReviveOlderSelfSignatures = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uidText = "temporary-validity-no-revival@example.org"
uid = UserId uidText
keyCreated = _timestamp signer
firstCertTime = addTimestampSeconds keyCreated 10
secondCertTime = addTimestampSeconds keyCreated 20
invalidCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 30)
invalidSignatureTime = addTimestampSeconds keyCreated 30
payload = "temporary validity no revival signer timeline payload"
firstCertification <-
signCertificationAt
signer
signingKey
uid
firstCertTime
[SigSubPacket False (KeyExpirationTime 1000)]
secondCertification <-
signCertificationAt
signer
signingKey
uid
secondCertTime
[ SigSubPacket False (KeyExpirationTime 1000)
, SigSubPacket False (SigExpirationTime 5)
]
invalidSignature <-
signBinaryMessageWithRSAAt signer signingKey invalidSignatureTime payload
let tk = TKUnknown (signer, Nothing) [] [(uidText, [firstCertification, secondCertification])] [] []
keyring = mkTestKeyring [tk]
assertBool
"an expired newer self-signature should not revive an older certification"
(not (isTKTimeValid invalidCheckTime tk))
assertSingleFailureContainsTimeline
"signatures after a newer self-signature expires should be rejected until re-certified"
"signing key was not valid at the signature creation time"
(verifyTimelinePackets keyring payload invalidSignature)
testUidRetiredRevocationIsHistorical :: Assertion
testUidRetiredRevocationIsHistorical = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uidText = "retired-uid@example.org"
uid = UserId uidText
keyCreated = _timestamp signer
certificationTime = addTimestampSeconds keyCreated 10
revocationTime = addTimestampSeconds keyCreated 20
certification <-
signCertificationAt signer signingKey uid certificationTime []
retirementRevocation <-
signCertificationRevocationAt
signer
signingKey
uid
revocationTime
[SigSubPacket False (ReasonForRevocation UserIdInfoNoLongerValid "")]
let tk = TKUnknown (signer, Nothing) [] [(uidText, [certification, retirementRevocation])] [] []
verifyAt ts =
verifyUnknownTKWith
(verifySigWith (verifyAgainstKeys [tk]))
(Just (timestampToUTCTime ts))
tk
beforeRetirement <-
case verifyAt (addTimestampSeconds keyCreated 15) of
Left err ->
assertFailure
("uid-retired pre-revocation verification failed: " ++ renderVerificationError err) >>
fail "expected verified transferable key before uid retirement"
Right verifiedTK -> pure verifiedTK
afterRetirement <-
case verifyAt (addTimestampSeconds keyCreated 25) of
Left err ->
assertFailure
("uid-retired post-revocation verification failed: " ++ renderVerificationError err) >>
fail "expected verified transferable key after uid retirement"
Right verifiedTK -> pure verifiedTK
assertEqual
"uid-retired revocation should preserve the UID before it becomes effective"
1
(length (_tkuUIDs beforeRetirement))
assertEqual
"uid-retired revocation should retire the UID once effective"
0
(length (_tkuUIDs afterRetirement))
testThirdPartyCertificationDoesNotAffectKeyValidityWindow :: Assertion
testThirdPartyCertificationDoesNotAffectKeyValidityWindow = do
(targetSigner, _) <- loadUnencryptedRsaSigner
(thirdPartySigner, thirdPartySigningKey) <- loadDeterministicEd25519Signer
let uidText = "third-party-validity@example.org"
uid = UserId uidText
keyCreated = _timestamp targetSigner
certificationTime = addTimestampSeconds keyCreated 10
validityCheckTime = timestampToUTCTime (addTimestampSeconds keyCreated 200)
thirdPartyCertification <-
signCertificationWithEd25519At
targetSigner
thirdPartySigner
thirdPartySigningKey
uid
certificationTime
[SigSubPacket False (KeyExpirationTime 30)]
let targetTK = TKUnknown (targetSigner, Nothing) [] [(uidText, [thirdPartyCertification])] [] []
certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] []
verifyAt =
verifyUnknownTKWith
(verifySigWith (verifyAgainstKeys [targetTK, certifierTK]))
(Just validityCheckTime)
targetTK
verifiedTK <-
case verifyAt of
Left err ->
assertFailure
("third-party certification verification failed: " ++ renderVerificationError err) >>
fail "expected verified transferable key"
Right tk -> pure tk
assertBool
"third-party certifications must not define the primary key validity window"
(isTKTimeValid validityCheckTime verifiedTK)
testCertificationRevocationOnlyRemovesMatchingSigner :: Assertion
testCertificationRevocationOnlyRemovesMatchingSigner = do
(targetSigner, targetSigningKey) <- loadUnencryptedRsaSigner
(thirdPartySigner, thirdPartySigningKey) <- loadDeterministicEd25519Signer
let uidText = "cert-revocation-scope@example.org"
uid = UserId uidText
keyCreated = _timestamp targetSigner
selfCertificationTime = addTimestampSeconds keyCreated 10
thirdPartyCertificationTime = addTimestampSeconds keyCreated 12
thirdPartyRevocationTime = addTimestampSeconds keyCreated 20
beforeRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 15)
afterRevocationTime = timestampToUTCTime (addTimestampSeconds keyCreated 25)
selfCertification <-
signCertificationAt targetSigner targetSigningKey uid selfCertificationTime []
thirdPartyCertification <-
signCertificationWithEd25519At
targetSigner
thirdPartySigner
thirdPartySigningKey
uid
thirdPartyCertificationTime
[]
thirdPartyRevocation <-
signCertificationRevocationWithEd25519At
targetSigner
thirdPartySigner
thirdPartySigningKey
uid
thirdPartyRevocationTime
[]
let targetTK =
TKUnknown
(targetSigner, Nothing)
[]
[(uidText, [selfCertification, thirdPartyCertification, thirdPartyRevocation])]
[]
[]
certifierTK = TKUnknown (thirdPartySigner, Nothing) [] [] [] []
verifyAt ts =
verifyUnknownTKWith
(verifySigWith (verifyAgainstKeys [targetTK, certifierTK]))
(Just ts)
targetTK
beforeRevocation <-
case verifyAt beforeRevocationTime of
Left err ->
assertFailure
("pre-revocation certification verification failed: " ++ renderVerificationError err) >>
fail "expected verified transferable key before certification revocation"
Right tk -> pure tk
afterRevocation <-
case verifyAt afterRevocationTime of
Left err ->
assertFailure
("post-revocation certification verification failed: " ++ renderVerificationError err) >>
fail "expected verified transferable key after certification revocation"
Right tk -> pure tk
let beforeSigs = maybe [] snd (find ((== uidText) . fst) (_tkuUIDs beforeRevocation))
afterSigs = maybe [] snd (find ((== uidText) . fst) (_tkuUIDs afterRevocation))
assertEqual
"certification revocations should not apply before they become effective"
[selfCertification, thirdPartyCertification]
beforeSigs
assertEqual
"a certification revocation should remove only certifications from the same signer"
[selfCertification]
afterSigs
testPreferencesAtTimestamp :: Assertion
testPreferencesAtTimestamp = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let uid = UserId "prefs@example.org"
UserId uidText = uid
t1 = addTimestampSeconds (_timestamp signer) 1
t2 = addTimestampSeconds t1 100
t3 = addTimestampSeconds t2 100
queryDuring = addTimestampSeconds t2 1
queryAfterRevocation = addTimestampSeconds t3 1
initialCertification <-
signCertificationAt
signer
signingKey
uid
t1
[SigSubPacket False (PreferredHashAlgorithms [SHA256])]
updatedCertification <-
signCertificationAt
signer
signingKey
uid
t2
[SigSubPacket False (PreferredHashAlgorithms [SHA512])]
certificationRevocation <-
signCertificationRevocationAt signer signingKey uid t3 []
let tk =
TKUnknown
(signer, Nothing)
[]
[(uidText, [initialCertification, updatedCertification, certificationRevocation])]
[]
[]
assertEqual
"key preferences at timestamp should use the latest active self-certification"
(Just [PreferredHashAlgorithms [SHA512]])
(effectiveKeyPreferencesAtTimestamp queryDuring tk)
assertEqual
"UID preferences at timestamp should use the latest active self-certification"
(Just [PreferredHashAlgorithms [SHA512]])
(effectiveUIDPreferencesAtTimestamp queryDuring uidText tk)
assertEqual
"revoked UID certifications should not provide effective UID preferences"
Nothing
(effectiveUIDPreferencesAtTimestamp queryAfterRevocation uidText tk)
assertEqual
"key preferences should become unavailable when no active self-certification remains"
Nothing
(effectiveKeyPreferencesAtTimestamp queryAfterRevocation tk)
testChangePrivateKeyPassphraseLegacy :: Assertion
testChangePrivateKeyPassphraseLegacy = do
passphrase <- readPKIPassphrase
packets <-
DC.runConduitRes $
CB.sourceFile "tests/data/aes256-sha512.seckey" DC..| conduitGet get DC..|
CL.consume
(pkp, ska) <-
case packets of
(SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum)
_ ->
assertFailure "aes256-sha512.seckey did not begin with a secret key packet" >>
fail "expected secret key packet"
originalDecrypted <-
case decryptPrivateKey (pkp, ska) passphrase of
Left err ->
assertFailure ("decrypting original legacy key failed: " ++ err) >>
fail "decrypting original legacy key failed"
Right x -> pure x
originalSKey <-
case originalDecrypted of
SUUnencrypted skey _ -> pure skey
_ ->
assertFailure "original legacy key should decrypt to unencrypted secret material" >>
fail "expected unencrypted secret key"
changed <-
case
changePrivateKeyPassphrase
(pkp, ska)
passphrase
(Salt "12345678")
(IV "1234567890ABCDEF")
"changed-pki-password" of
Left err ->
assertFailure
("legacy passphrase change should preserve the existing protection envelope, got: " ++
err) >>
fail "legacy passphrase change failed"
Right skaddendum -> pure skaddendum
originalIterCount <-
case ska of
SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ _ -> pure iter
_ ->
assertFailure
"legacy key fixture should use SUSSHA1/AES256/IteratedSalted SHA512" >>
fail "expected legacy key fixture"
case changed of
SUSSHA1 AES256 (IteratedSalted SHA512 _ iter) _ encryptedPayload -> do
assertEqual
"legacy passphrase change should preserve the S2K iteration count"
originalIterCount
iter
assertBool
"legacy passphrase change should emit encrypted payload"
(not (BL.null encryptedPayload))
_ ->
assertFailure
"legacy passphrase change should preserve the SUSSHA1/AES256 envelope"
decrypted <-
case decryptPrivateKey (pkp, changed) "changed-pki-password" of
Left err ->
assertFailure ("re-decrypting changed legacy key failed: " ++ err) >>
fail "re-decrypting changed legacy key failed"
Right x -> pure x
case decrypted of
SUUnencrypted skey _ ->
assertEqual
"legacy passphrase change should preserve secret key material"
originalSKey
skey
_ ->
assertFailure
"legacy passphrase change should decrypt back to unencrypted secret material"
testChangePrivateKeyPassphraseV6 :: Assertion
testChangePrivateKeyPassphraseV6 = do
oldPassphrase <- readPKIPassphrase
armors <- loadArmor "v6-encrypted-secret.pgp.aa"
armor <-
case armors of
(a:_) -> pure a
[] ->
assertFailure "v6-encrypted-secret.pgp.aa should contain one armored payload" >>
fail "expected one armored payload"
let packets = parsePkts (armorPayload armor)
(pkp, ska) <-
case packets of
(SecretKeyPkt pkpayload skaddendum:_) -> pure (pkpayload, skaddendum)
_ ->
assertFailure "v6-encrypted-secret.pgp.aa did not begin with a secret key packet" >>
fail "expected secret key packet"
let newPassphrase = "changed-pki-password"
originalDecrypted <-
case decryptPrivateKey (pkp, ska) oldPassphrase of
Left err ->
assertFailure ("decrypting original v6 key failed: " ++ err) >>
fail "decrypting original v6 key failed"
Right x -> pure x
originalSKey <-
case originalDecrypted of
SUUnencrypted skey _ -> pure skey
_ ->
assertFailure "original v6 key should decrypt to unencrypted secret material" >>
fail "expected unencrypted secret key"
let changedResult =
changePrivateKeyPassphrase
(pkp, ska)
oldPassphrase
(Salt "1234567890ABCDEF")
(IV "1234567890ABCDE")
newPassphrase
changed <-
case changedResult of
Left err ->
assertFailure ("changing v6 key passphrase failed: " ++ err) >> pure ska
Right skaddendum -> pure skaddendum
case changed of
SUSAEAD AES256 OCB (Argon2 _ t p em) _ encryptedPayload -> do
assertEqual
"changed v6 key addendum should use expected Argon2 t parameter"
1
t
assertEqual
"changed v6 key addendum should use expected Argon2 p parameter"
4
p
assertEqual
"changed v6 key addendum should use expected Argon2 encoded memory parameter"
15
em
assertBool
"changed v6 key addendum should contain encrypted key material"
(not (BL.null encryptedPayload))
_ -> assertFailure "changed v6 key addendum should be encrypted with SUSAEAD"
let decryptedResult = decryptPrivateKey (pkp, changed) newPassphrase
decrypted <-
case decryptedResult of
Left err ->
assertFailure ("decryption with changed v6 passphrase failed: " ++ err) >>
fail "decryption with changed v6 passphrase failed"
Right x -> pure x
case decrypted of
SUUnencrypted skey _ ->
assertEqual
"changing a v6 key passphrase should preserve secret key material"
originalSKey
skey
_ -> assertFailure "changed v6 key should decrypt with the new passphrase"
testPolicySignatureContextValidation :: Assertion
testPolicySignatureContextValidation = do
let pkSigV4PK = SigV4 KeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| [])
pkSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| [])
pkSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| [])
pkSigV6PK =
SigV6
KeyRevocationSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x11))
[]
[]
0
(MPI 0 :| [])
pkSigV6Direct =
SigV6
SignatureDirectlyOnAKey
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x12))
[]
[]
0
(MPI 0 :| [])
pkSigV6Binding =
SigV6
SubkeyBindingSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x13))
[]
[]
0
(MPI 0 :| [])
skSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| [])
skSigV4Revocation = SigV4 SubkeyRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| [])
skSigV4Direct = SigV4 SignatureDirectlyOnAKey RSA SHA512 [] [] 0 (MPI 0 :| [])
skSigV6Binding =
SigV6
SubkeyBindingSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x14))
[]
[]
0
(MPI 0 :| [])
skSigV6Revocation =
SigV6
SubkeyRevocationSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x15))
[]
[]
0
(MPI 0 :| [])
skSigV6Direct =
SigV6
SignatureDirectlyOnAKey
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x16))
[]
[]
0
(MPI 0 :| [])
uidSigV4Generic = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| [])
uidSigV4Persona = SigV4 PersonaCert RSA SHA512 [] [] 0 (MPI 0 :| [])
uidSigV4Casual = SigV4 CasualCert RSA SHA512 [] [] 0 (MPI 0 :| [])
uidSigV4Positive = SigV4 PositiveCert RSA SHA512 [] [] 0 (MPI 0 :| [])
uidSigV4CertRev = SigV4 CertRevocationSig RSA SHA512 [] [] 0 (MPI 0 :| [])
uidSigV4Binding = SigV4 SubkeyBindingSig RSA SHA512 [] [] 0 (MPI 0 :| [])
uidSigV6Generic =
SigV6
GenericCert
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x17))
[]
[]
0
(MPI 0 :| [])
uidSigV6Persona =
SigV6
PersonaCert
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x18))
[]
[]
0
(MPI 0 :| [])
uidSigV6Casual =
SigV6
CasualCert
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x19))
[]
[]
0
(MPI 0 :| [])
uidSigV6Positive =
SigV6
PositiveCert
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x1a))
[]
[]
0
(MPI 0 :| [])
uidSigV6CertRev =
SigV6
CertRevocationSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x1b))
[]
[]
0
(MPI 0 :| [])
uidSigV6Binding =
SigV6
SubkeyBindingSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x1c))
[]
[]
0
(MPI 0 :| [])
assertTrue "KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV4PK)
assertTrue "SignatureDirectlyOnAKey allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Direct)
assertFalse "SubkeyBindingSig not allowed on primary key" (isAllowedPrimaryKeySig pkSigV4Binding)
assertTrue "v6 KeyRevocationSig allowed on primary key" (isAllowedPrimaryKeySig pkSigV6PK)
assertTrue "v6 SignatureDirectlyOnAKey allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Direct)
assertFalse "v6 SubkeyBindingSig not allowed on primary key" (isAllowedPrimaryKeySig pkSigV6Binding)
assertTrue "SubkeyBindingSig allowed on subkey" (isAllowedSubkeySig skSigV4Binding)
assertTrue "SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV4Revocation)
assertFalse "SignatureDirectlyOnAKey not allowed on subkey" (isAllowedSubkeySig skSigV4Direct)
assertTrue "v6 SubkeyBindingSig allowed on subkey" (isAllowedSubkeySig skSigV6Binding)
assertTrue "v6 SubkeyRevocationSig allowed on subkey" (isAllowedSubkeySig skSigV6Revocation)
assertFalse "v6 SignatureDirectlyOnAKey not allowed on subkey" (isAllowedSubkeySig skSigV6Direct)
assertTrue "GenericCert allowed on UID" (isAllowedUIDSig uidSigV4Generic)
assertTrue "PersonaCert allowed on UID" (isAllowedUIDSig uidSigV4Persona)
assertTrue "CasualCert allowed on UID" (isAllowedUIDSig uidSigV4Casual)
assertTrue "PositiveCert allowed on UID" (isAllowedUIDSig uidSigV4Positive)
assertTrue "CertRevocationSig allowed on UID" (isAllowedUIDSig uidSigV4CertRev)
assertFalse "SubkeyBindingSig not allowed on UID" (isAllowedUIDSig uidSigV4Binding)
assertTrue "v6 GenericCert allowed on UID" (isAllowedUIDSig uidSigV6Generic)
assertTrue "v6 PersonaCert allowed on UID" (isAllowedUIDSig uidSigV6Persona)
assertTrue "v6 CasualCert allowed on UID" (isAllowedUIDSig uidSigV6Casual)
assertTrue "v6 PositiveCert allowed on UID" (isAllowedUIDSig uidSigV6Positive)
assertTrue "v6 CertRevocationSig allowed on UID" (isAllowedUIDSig uidSigV6CertRev)
assertFalse "v6 SubkeyBindingSig not allowed on UID" (isAllowedUIDSig uidSigV6Binding)
testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID :: Assertion
testVerifySigWithV6RevocationRejectsLegacyIssuerKeyID = do
(signer, _) <- loadUnencryptedRsaSigner
issuerKeyId <-
case eightOctetKeyID signer of
Left err ->
assertFailure ("failed to derive RSA issuer key id: " ++ err) >>
fail "expected issuer key id"
Right i -> pure i
let sigPayload =
SigV6
KeyRevocationSig
RSA
SHA256
(SignatureSalt (BL.replicate 16 0))
[SigSubPacket False (Issuer issuerKeyId)]
[]
0
(MPI 0 :| [])
verifyFn _ _ _ = Right (Verification signer sigPayload [])
result =
verifySigWith
verifyFn
(SignaturePkt sigPayload)
emptyPSC {lastPrimaryKey = PublicKeyPkt signer}
Nothing
case result of
Left err ->
assertBool
"v6 revocation verification should reject legacy Issuer key-id subpackets"
("Issuer Key ID subpacket is prohibited in v6 signatures" `isInfixOf`
renderVerificationError err)
Right _ ->
assertFailure
"Expected v6 revocation verification to reject legacy Issuer key-id subpacket"
testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed :: Assertion
testVerifySigWithV6RevocationRejectsLegacyIssuerKeyIDInUnhashed = do
(signer, _) <- loadUnencryptedRsaSigner
issuerKeyId <-
case eightOctetKeyID signer of
Left err ->
assertFailure ("failed to derive RSA issuer key id: " ++ err) >>
fail "expected issuer key id"
Right i -> pure i
let sigPayload =
SigV6
KeyRevocationSig
RSA
SHA256
(SignatureSalt (BL.replicate 16 0))
[]
[SigSubPacket False (Issuer issuerKeyId)]
0
(MPI 0 :| [])
verifyFn _ _ _ = Right (Verification signer sigPayload [])
result =
verifySigWith
verifyFn
(SignaturePkt sigPayload)
emptyPSC {lastPrimaryKey = PublicKeyPkt signer}
Nothing
case result of
Left err ->
assertBool
"v6 revocation verification should reject legacy Issuer key-id subpackets in unhashed area"
("Issuer Key ID subpacket is prohibited in v6 signatures" `isInfixOf`
renderVerificationError err)
Right _ ->
assertFailure
"Expected v6 revocation verification to reject legacy Issuer key-id subpacket in unhashed area"
testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint :: Assertion
testVerifySigWithV6RevocationAcceptsMatchingIssuerFingerprint = do
(signer, _) <- loadUnencryptedRsaSigner
let sigPayload =
SigV6
KeyRevocationSig
RSA
SHA256
(SignatureSalt (BL.replicate 16 0))
[SigSubPacket False (IssuerFingerprint IssuerFingerprintV6 (fingerprint signer))]
[]
0
(MPI 0 :| [])
verifyFn _ _ _ = Right (Verification signer sigPayload [])
result =
verifySigWith
verifyFn
(SignaturePkt sigPayload)
emptyPSC {lastPrimaryKey = PublicKeyPkt signer}
Nothing
case result of
Left err ->
assertFailure
("Expected matching IssuerFingerprint to verify for v6 revocation signature, got: " ++
renderVerificationError err)
Right _ -> pure ()
testV6SignerConstructorRejectsV4Key :: Assertion
testV6SignerConstructorRejectsV4Key = do
(signer, signingKey) <- loadDeterministicEd25519Signer
case asV6PKPayload signer of
Left _ -> pure ()
Right signerV6 ->
seq (mkEd25519SignerV6 signerV6 signingKey) $
assertFailure "asV6PKPayload should reject v4 Ed25519 key payloads"
(rsaSigner, rsaSigningKey) <- loadUnencryptedRsaSigner
case asV6PKPayload rsaSigner of
Left _ -> pure ()
Right signerV6 ->
seq (mkRSASignerV6 signerV6 rsaSigningKey) $
assertFailure "asV6PKPayload should reject v4 RSA key payloads"
testGetSecretKeyHandlesV4X25519ECDHPubkey :: Assertion
testGetSecretKeyHandlesV4X25519ECDHPubkey = do
let pkp =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
X25519
(ECDHPubKey
(EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01))))))
SHA256
AES128)
encodedSecret = runPut (put (MPI 42))
case runGetOrFail (getSecretKey pkp) encodedSecret of
Left (_, _, err) ->
assertFailure ("getSecretKey should parse v4 X25519 secret key material: " ++ err)
Right (_, _, ECDHPrivateKey (ECDSA_PrivateKey prv)) ->
assertEqual
"getSecretKey should preserve X25519 private scalar"
42
(ECDSA.private_d prv)
Right (_, _, other) ->
assertFailure ("unexpected parsed secret key type: " ++ show other)
testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte :: Assertion
testV4Ed25519SecretKeyRoundTripPreservesLeadingZeroByte = do
let secretBytes = B.pack (0 : replicate 31 1)
pkt =
SecretKeyPkt
(PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
EdDSA
(EdDSAPubKey Ed25519 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01)))))))
(SUUnencrypted (EdDSAPrivateKey Ed25519 secretBytes) 0)
case runGetOrFail (get :: Get Pkt) (runPut (put pkt)) of
Left (_, _, err) ->
assertFailure ("v4 Ed25519 secret key should round-trip: " ++ err)
Right (_, _, parsedPkt) ->
case parsedPkt of
SecretKeyPkt _ (SUUnencrypted (EdDSAPrivateKey Ed25519 parsedBytes) _) ->
assertEqual
"v4 Ed25519 secret-key round-trip should preserve MPI-encoded bytes"
secretBytes
parsedBytes
_ ->
assertFailure ("unexpected parsed packet shape: " ++ show parsedPkt)
testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte :: Assertion
testV4Ed448SecretKeyRoundTripPreservesLeadingZeroByte = do
let secretBytes = B.pack (0 : replicate 56 2)
pkp =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
EdDSA
(EdDSAPubKey Ed448 (PrefixedNativeEPoint (EPoint (os2ip (B.cons 0x40 (B.replicate 57 0x02))))))
encodedSecret = runPut (put (MPI (os2ip secretBytes)))
case runGetOrFail (getSecretKey pkp) encodedSecret of
Left (_, _, err) ->
assertFailure ("v4 Ed448 secret key should parse with preserved padding: " ++ err)
Right (_, _, parsedSecret) ->
assertEqual
"v4 Ed448 secret-key parsing should restore the curve-width byte string"
(EdDSAPrivateKey Ed448 secretBytes)
parsedSecret