hOpenPGP-3.1: tests/Tests/Utilities.hs
-- Utilities.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 OverloadedStrings #-}
module Tests.Utilities (utilityTests) where
import Control.Error.Util (hush)
import Control.Monad (join)
import Crypto.Number.Serialize (os2ip)
import Data.Binary (get)
import Data.Binary.Get (Get)
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.Serialization.Binary (conduitGet)
import Data.Either (lefts, rights)
import Data.List (isInfixOf, nub, sortOn)
import Data.List.NonEmpty (NonEmpty (..))
import Data.Maybe (catMaybes)
import qualified Data.Set as Set
import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit
( Assertion
, assertBool
, assertEqual
, assertFailure
, testCase
)
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev)
import Codec.Encryption.OpenPGP.KeyringParser
( parsePublicTKs
, parseSecretTKs
, parseTKs
, parseTKsEither
, parseTKsWithWireRep
, parseUnknownTKs
)
import Codec.Encryption.OpenPGP.Serialize
( PktParseError (..)
, WireRepInput (..)
, conduitParsePktsWithWireRep
, dearmorIfAsciiArmored
, dearmorIfAsciiArmoredLenient
, looksLikeAsciiArmor
, parsePkts
, parsePktsEither
, parsePktsWithWireRep
, wireRepRefFromInput
)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Keyring
( AuthSecretSubkeyRejectionReason (..)
, AuthSecretSubkeyUID (..)
, AuthSecretSubkeysAtReport (..)
, authSecretSubkeyPrimaryUID
, authSecretSubkeyRejectedReason
, authSecretSubkeyUIDs
, authSecretSubkeyValue
, authSecretSubkeysAt
, authSecretSubkeysAtReport
, conduitDropErrorsAndNothings
, conduitToAuthSecretSubkeysAt
, conduitToAuthSecretSubkeysAtReport
, conduitToSomeTKsDroppingEither
, conduitToSomeTKsEither
, conduitToTKsEither
, conduitToTKsWithWireRepEither
)
import Tests.Common
( addTimestampSeconds
, loadAndDecompressPkts
, loadUnencryptedRsaSigner
, loadV6UnencryptedSecretKeyFixtureForProperty
, readFixtureLazy
, readFixturePackets
, runGet
, setKeyTimestamp
, signCertificationAt
, signSubkeyBindingWithRSAExtrasAt
, signSubkeyRevocationWithRSAAt
, timestampToUTCTime
)
utilityTests :: TestTree
utilityTests =
testGroup
"Utility function group"
[ testCase "pubring as packets" (testParsePktsUtil "pubring.gpg")
, testCase
"pubring parsePktsEither equals parsePkts on valid input"
(testParsePktsEitherUtil "pubring.gpg")
, testCase
"parsePktsEither reports truncation errors"
(testParsePktsEitherFailureUtil "pubring.gpg")
, testCase
"parseUnknownTKs drops disallowed primary-key signature context (v4)"
testParseTKsDropsDisallowedPrimaryKeySigContextV4
, testCase
"parseUnknownTKs drops disallowed primary-key signature context (v6)"
testParseTKsDropsDisallowedPrimaryKeySigContextV6
, testCase
"parseUnknownTKs accepts allowed primary-key signature context (v6)"
testParseTKsAcceptsAllowedPrimaryKeySigContextV6
, testCase "pubring as TKs" (testParseTKsUtil "pubring.gpg")
, testCase
"pubring as typed TKs"
(testParseTKsTypedUtil "pubring.gpg")
, testCase
"pubring parseTKsEither preserves typed parse outcomes"
(testParseTKsEitherUtil "pubring.gpg")
, testCase
"typed TKUnknown conduit partitioning"
(testConduitToTKsTypedUtil "pubring.gpg")
, testCase
"typed TK conduit either reports values without silent drops on valid input"
(testConduitToSomeTKsEitherUtil "pubring.gpg")
, testCase
"typed TK dropping conduit either preserves valid typed results"
(testConduitToSomeTKsDroppingEitherUtil "pubring.gpg")
, testCase
"auth-capable secret-subkey conduit filters revoked/expired/auth flags"
testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth
, testCase
"auth-capable secret-subkey conduit tracks primary UID over time"
testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime
, testCase
"auth-capable secret-subkey report includes typed rejection reasons"
testAuthSecretSubkeysAtReportIncludesRejectionReasons
, testCase
"pkalgoAbbrev handles RFC9580-era pubkey algorithms"
testPKAlgoAbbrevRFC9580
, testCase
"EightOctetKeyId Show/Read roundtrip uses hex form"
testEightOctetKeyIdReadShowRoundtrip
, testCase
"PktWithWireRep Ord uses raw bytes for tie-breakers"
testPktWithWireRepOrdUsesRawBytes
, testCase
"pubring as packets with provenance"
(testParsePktsWithWireRepUtil "pubring.gpg")
, testCase
"pubring as TKs with provenance"
(testParseTKsWithWireRepUtil "pubring.gpg")
, testCase
"wire provenance tracks original ASCII armor"
testWireRepRefTracksArmorProvenance
, testCase
"dearmorIfAsciiArmored rejects multi-block armored inputs"
testDearmorRejectsMultipleBlocks
, testCase
"dearmorIfAsciiArmoredLenient accepts BOM-prefixed armor"
testDearmorLenientAcceptsBomPrefixedArmor
, testCase
"looksLikeAsciiArmor centralizes armor prefix detection"
testLooksLikeAsciiArmor
, testCase
"wireRepRefFromInput surfaces malformed armored decode errors"
testWireRepRefRejectsMalformedArmoredInput
, testCase
"tksFromWireRep matches any source in TKUnknown provenance list"
testTksFromWireRepMatchesAnySource
, testCase
"TKWithWireRep Semigroup preserves structured provenance"
testSemigroupTKWithWireRepPreservesStructuredRefs
, testCase
"canonicalizeTKWithWireRep matches manual wire-byte ordering"
testCanonicalizeTKWithWireRepMatchesManualWireOrdering
, testCase
"canonicalizeTKWithWireRep reports missing packet refs"
testCanonicalizeTKWithWireRepReportsMissingRef
, testCase
"KeyPkt wrappers preserve packet kind/role round-trips"
testKeyPktWrappersRoundTrip
, testCase
"TK public/secret conversion and projection round-trip"
testTKTypedRoundTripAndPublicView
, testCase
"uat.gpg embeds expected image data from uat.jpg"
testUatImageFixture
]
testPKAlgoAbbrevRFC9580 :: Assertion
testPKAlgoAbbrevRFC9580 = do
assertEqual
"X25519 abbreviation"
"x25"
(pkalgoAbbrev (toFVal 25))
assertEqual "X448 abbreviation" "x448" (pkalgoAbbrev (toFVal 26))
assertEqual
"Ed25519 abbreviation"
"e25"
(pkalgoAbbrev (toFVal 27))
assertEqual
"Ed448 abbreviation"
"e448"
(pkalgoAbbrev (toFVal 28))
testEightOctetKeyIdReadShowRoundtrip :: Assertion
testEightOctetKeyIdReadShowRoundtrip = do
let eoki =
EightOctetKeyId
(BL.pack [0x01, 0x23, 0x45, 0x67, 0x89, 0xab, 0xcd, 0xef])
assertEqual
"show prints canonical uppercase hex"
"0123456789ABCDEF"
(show eoki)
assertEqual "read . show roundtrip" eoki (read (show eoki))
testUatImageFixture :: Assertion
testUatImageFixture = do
expectedImage <- readFixtureLazy "uat.jpg"
packets <- loadAndDecompressPkts "uat.gpg"
let images =
[ imageData
| UserAttributePkt uas <- packets
, ImageAttribute _ imageData <- uas
]
assertBool
"uat.gpg should contain a user-attribute image packet"
(not (null images))
assertBool
"uat.gpg should embed the uat.jpg payload"
(expectedImage `elem` images)
testParsePktsUtil :: FilePath -> Assertion
testParsePktsUtil fn = do
cp <- readFixturePackets fn
pp <- parsePkts `fmap` readFixtureLazy fn
assertEqual
"parsePkts utility function gives same results as conduit pipeline"
cp
pp
testParsePktsEitherUtil :: FilePath -> Assertion
testParsePktsEitherUtil fn = do
lbs <- readFixtureLazy fn
assertEqual
"parsePktsEither matches parsePkts on valid input"
(Right (parsePkts lbs))
(parsePktsEither lbs)
testParsePktsEitherFailureUtil :: FilePath -> Assertion
testParsePktsEitherFailureUtil fn = do
lbs <- readFixtureLazy fn
let truncated = BL.take (BL.length lbs - 1) lbs
case parsePktsEither truncated of
Left (PktParseError off msg) -> do
assertBool
"parsePktsEither reports non-empty parse error messages"
(not (null msg))
assertBool
"parsePktsEither reports an in-range failure offset"
(off >= 0 && off <= BL.length truncated)
assertBool
"legacy parsePkts still returns a parsed prefix on malformed input"
(length (parsePkts truncated) <= length (parsePkts lbs))
Right _ ->
assertFailure
"parsePktsEither should fail when input is truncated"
testParseTKsUtil :: FilePath -> Assertion
testParseTKsUtil fn = do
lbs <- readFixtureLazy fn
cp <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitGet get
DC..| conduitToTKsEither
DC..| conduitDropErrorsAndNothings
DC..| CL.consume
let pt = parseUnknownTKs True . parsePkts $ lbs
assertEqual
"parsePkts utility function gives same results as conduit pipeline"
cp
pt
testParseTKsTypedUtil :: FilePath -> Assertion
testParseTKsTypedUtil fn = do
lbs <- readFixtureLazy fn
let packets = parsePkts lbs
plain = parseUnknownTKs True packets
typed = parseTKs True packets
typedPublic = parsePublicTKs True packets
typedSecret = parseSecretTKs True packets
assertEqual
"parseTKs round-trips to the same untyped TKUnknown semantics"
plain
(map someTKToUnknown typed)
assertEqual
"public + secret typed partitions preserve full typed parse count"
(length typed)
(length typedPublic + length typedSecret)
testParseTKsEitherUtil :: FilePath -> Assertion
testParseTKsEitherUtil fn = do
lbs <- readFixtureLazy fn
let packets = parsePkts lbs
typed = parseTKs True packets
typedEither = parseTKsEither True packets
assertEqual
"parseTKsEither right results should match parseTKs"
typed
(rights typedEither)
assertBool
"parseTKsEither should have no conversion failures for canonical pubring fixture"
(null (lefts typedEither))
testConduitToTKsTypedUtil :: FilePath -> Assertion
testConduitToTKsTypedUtil fn = do
lbs <- readFixtureLazy fn
allTyped <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitGet get
DC..| conduitToSomeTKsEither
DC..| CL.map (join . hush)
DC..| CL.catMaybes
DC..| CL.consume
publicTyped <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitGet get
DC..| conduitToSomeTKsEither
DC..| CL.map (join . hush)
DC..| CL.map (join . fmap someTKToPublicTK)
DC..| CL.catMaybes
DC..| CL.consume
secretTyped <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitGet get
DC..| conduitToSomeTKsEither
DC..| CL.map (join . hush)
DC..| CL.map (join . fmap someTKToSecretTK)
DC..| CL.catMaybes
DC..| CL.consume
assertEqual
"typed conduit round-trips to parseUnknownTKs semantics"
(parseUnknownTKs True (parsePkts lbs))
(map someTKToUnknown allTyped)
assertEqual
"typed conduit public + secret partitions preserve full count"
(length allTyped)
(length publicTyped + length secretTyped)
testConduitToSomeTKsEitherUtil :: FilePath -> Assertion
testConduitToSomeTKsEitherUtil fn = do
lbs <- readFixtureLazy fn
results <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitGet get
DC..| conduitToSomeTKsEither
DC..| CL.consume
let typedFromEither = catMaybes (rights results)
assertBool
"conduitToSomeTKsEither should not report failures for canonical pubring fixture"
(null (lefts results))
assertEqual
"conduitToSomeTKsEither right values should match conduitToTKs semantics"
(parseTKs True (parsePkts lbs))
typedFromEither
testConduitToSomeTKsDroppingEitherUtil :: FilePath -> Assertion
testConduitToSomeTKsDroppingEitherUtil fn = do
lbs <- readFixtureLazy fn
results <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitGet get
DC..| conduitToSomeTKsDroppingEither
DC..| CL.consume
let typedFromEither = catMaybes (rights results)
assertBool
"conduitToSomeTKsDroppingEither should not report failures for canonical pubring fixture"
(null (lefts results))
assertEqual
"conduitToSomeTKsDroppingEither right values should match tolerant parseTKs semantics"
(parseTKs False (parsePkts lbs))
typedFromEither
testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth
:: Assertion
testConduitToAuthSecretSubkeysAtFiltersByValidityAndAuth = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let baseTime = _timestamp signer
beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18)
afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24)
uidText = "auth-subkeys@example.org"
uid = UserId uidText
secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0
authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer
expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer
signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer
uidCertification <-
signCertificationAt
signer
signingKey
uid
(addTimestampSeconds baseTime 8)
[SigSubPacket False (PrimaryUserId True)]
authBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
authSubkey
signingKey
(addTimestampSeconds baseTime 10)
[SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))]
expiringAuthBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
expiringAuthSubkey
signingKey
(addTimestampSeconds baseTime 10)
[ SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))
, SigSubPacket False (KeyExpirationTime 20)
]
signingOnlyBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
signingOnlySubkey
signingKey
(addTimestampSeconds baseTime 10)
[SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))]
authRevocation <-
signSubkeyRevocationWithRSAAt
signer
authSubkey
signingKey
(addTimestampSeconds baseTime 22)
let tk =
TKUnknown
(signer, Just secretAddendum)
[]
[(uidText, [uidCertification])]
[]
[
( SecretSubkeyPkt authSubkey secretAddendum
, [authBinding, authRevocation]
)
,
( SecretSubkeyPkt expiringAuthSubkey secretAddendum
, [expiringAuthBinding]
)
,
( SecretSubkeyPkt signingOnlySubkey secretAddendum
, [signingOnlyBinding]
)
]
typedSecret <-
case fromUnknownToTK tk of
Right (SomeSecretTK typed) -> pure typed
Right (SomePublicTK _) ->
assertFailure
"expected secret typed TKUnknown for auth subkey test fixture"
>> fail "unreachable"
Left err ->
assertFailure
("fromUnknownToTK failed for auth subkey test fixture: " ++ err)
>> fail "unreachable"
selectedBefore <-
DC.runConduitRes $
CL.sourceList [typedSecret]
DC..| conduitToAuthSecretSubkeysAt beforeTime
DC..| CL.consume
assertEqual
"pure authSecretSubkeysAt helper and conduit output should match"
(authSecretSubkeysAt beforeTime typedSecret)
selectedBefore
assertEqual
"before revocation/expiry, conduit should keep only auth-capable secret subkeys"
2
(length selectedBefore)
let selectedBeforeFps =
Set.fromList
( map
(fingerprint . keyPktPKPayload . authSecretSubkeyValue)
selectedBefore
)
assertEqual
"selected auth-capable subkeys should match expected fingerprints"
( Set.fromList
[fingerprint authSubkey, fingerprint expiringAuthSubkey]
)
selectedBeforeFps
mapM_
( \selection -> do
assertEqual
"selected auth subkey should retain active primary UID context"
(Just uidText)
(authSecretSubkeyPrimaryUID selection)
assertEqual
"selected auth subkey should expose UID context with primary marker"
[AuthSecretSubkeyUID uidText True]
(authSecretSubkeyUIDs selection)
)
selectedBefore
selectedAfter <-
DC.runConduitRes $
CL.sourceList [typedSecret]
DC..| conduitToAuthSecretSubkeysAt afterTime
DC..| CL.consume
assertEqual
"after revocation/expiry, conduit should drop revoked/expired auth subkeys"
[]
selectedAfter
testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime
:: Assertion
testConduitToAuthSecretSubkeysAtTracksPrimaryUIDOverTime = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let baseTime = _timestamp signer
beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 15)
afterTime = timestampToUTCTime (addTimestampSeconds baseTime 25)
uidA = UserId "uid-a@example.org"
UserId uidAText = uidA
uidB = UserId "uid-b@example.org"
UserId uidBText = uidB
secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0
authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer
uidACert <-
signCertificationAt
signer
signingKey
uidA
(addTimestampSeconds baseTime 10)
[SigSubPacket False (PrimaryUserId True)]
uidBCert <-
signCertificationAt
signer
signingKey
uidB
(addTimestampSeconds baseTime 20)
[SigSubPacket False (PrimaryUserId True)]
authBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
authSubkey
signingKey
(addTimestampSeconds baseTime 11)
[SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))]
let tk =
TKUnknown
(signer, Just secretAddendum)
[]
[(uidAText, [uidACert]), (uidBText, [uidBCert])]
[]
[(SecretSubkeyPkt authSubkey secretAddendum, [authBinding])]
typedSecret <-
case fromUnknownToTK tk of
Right (SomeSecretTK typed) -> pure typed
Right (SomePublicTK _) ->
assertFailure
"expected secret typed TKUnknown for primary-uid test fixture"
>> fail "unreachable"
Left err ->
assertFailure
("fromUnknownToTK failed for primary-uid test fixture: " ++ err)
>> fail "unreachable"
beforeSelections <-
DC.runConduitRes $
CL.sourceList [typedSecret]
DC..| conduitToAuthSecretSubkeysAt beforeTime
DC..| CL.consume
beforeSelection <-
case beforeSelections of
[selection] -> pure selection
other ->
assertFailure
( "expected one auth-capable subkey selection before primary-uid rollover, got "
++ show (length other)
)
>> fail "unreachable"
assertEqual
"earlier primary UID should be selected before newer self-certification"
(Just uidAText)
(authSecretSubkeyPrimaryUID beforeSelection)
assertEqual
"UID context should include only active UIDs before uid-b certification exists"
[(uidAText, True)]
( map
( \u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u)
)
(authSecretSubkeyUIDs beforeSelection)
)
afterSelections <-
DC.runConduitRes $
CL.sourceList [typedSecret]
DC..| conduitToAuthSecretSubkeysAt afterTime
DC..| CL.consume
afterSelection <-
case afterSelections of
[selection] -> pure selection
other ->
assertFailure
( "expected one auth-capable subkey selection after primary-uid rollover, got "
++ show (length other)
)
>> fail "unreachable"
assertEqual
"newer primary UID self-certification should win after rollover"
(Just uidBText)
(authSecretSubkeyPrimaryUID afterSelection)
assertEqual
"UID context should mark uid-b as primary after rollover"
[(uidAText, False), (uidBText, True)]
( map
( \u -> (authSecretSubkeyUIDValue u, authSecretSubkeyUIDIsPrimary u)
)
(authSecretSubkeyUIDs afterSelection)
)
testAuthSecretSubkeysAtReportIncludesRejectionReasons
:: Assertion
testAuthSecretSubkeysAtReportIncludesRejectionReasons = do
(signer, signingKey) <- loadUnencryptedRsaSigner
let baseTime = _timestamp signer
beforeTime = timestampToUTCTime (addTimestampSeconds baseTime 18)
afterTime = timestampToUTCTime (addTimestampSeconds baseTime 24)
uidText = "auth-subkeys@example.org"
uid = UserId uidText
secretAddendum = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey signingKey)) 0
authSubkey = setKeyTimestamp (addTimestampSeconds baseTime 1) signer
expiringAuthSubkey = setKeyTimestamp (addTimestampSeconds baseTime 2) signer
signingOnlySubkey = setKeyTimestamp (addTimestampSeconds baseTime 3) signer
uidCertification <-
signCertificationAt
signer
signingKey
uid
(addTimestampSeconds baseTime 8)
[SigSubPacket False (PrimaryUserId True)]
authBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
authSubkey
signingKey
(addTimestampSeconds baseTime 10)
[SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))]
expiringAuthBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
expiringAuthSubkey
signingKey
(addTimestampSeconds baseTime 10)
[ SigSubPacket False (KeyFlags (Set.fromList [AuthKey]))
, SigSubPacket False (KeyExpirationTime 20)
]
signingOnlyBinding <-
signSubkeyBindingWithRSAExtrasAt
signer
signingOnlySubkey
signingKey
(addTimestampSeconds baseTime 10)
[SigSubPacket False (KeyFlags (Set.fromList [SignDataKey]))]
authRevocation <-
signSubkeyRevocationWithRSAAt
signer
authSubkey
signingKey
(addTimestampSeconds baseTime 22)
let tk =
TKUnknown
(signer, Just secretAddendum)
[]
[(uidText, [uidCertification])]
[]
[
( SecretSubkeyPkt authSubkey secretAddendum
, [authBinding, authRevocation]
)
,
( SecretSubkeyPkt expiringAuthSubkey secretAddendum
, [expiringAuthBinding]
)
,
( SecretSubkeyPkt signingOnlySubkey secretAddendum
, [signingOnlyBinding]
)
]
typedSecret <-
case fromUnknownToTK tk of
Right (SomeSecretTK typed) -> pure typed
Right (SomePublicTK _) ->
assertFailure
"expected secret typed TKUnknown for auth subkey rejection test fixture"
>> fail "unreachable"
Left err ->
assertFailure
( "fromUnknownToTK failed for auth subkey rejection test fixture: "
++ err
)
>> fail "unreachable"
let beforeReport = authSecretSubkeysAtReport beforeTime typedSecret
assertEqual
"report accepted list should match authSecretSubkeysAt before revocation/expiry"
(authSecretSubkeysAt beforeTime typedSecret)
(authSecretSubkeysAccepted beforeReport)
assertEqual
"before revocation/expiry, only signing-only subkey should be rejected"
[AuthSecretSubkeyMissingAuthCapability]
( map
authSecretSubkeyRejectedReason
(authSecretSubkeysRejected beforeReport)
)
afterReportsViaConduit <-
DC.runConduitRes $
CL.sourceList [typedSecret]
DC..| conduitToAuthSecretSubkeysAtReport afterTime
DC..| CL.consume
afterReport <-
case afterReportsViaConduit of
[singleReport] -> pure singleReport
other ->
assertFailure
( "expected one report from conduitToAuthSecretSubkeysAtReport, got "
++ show (length other)
)
>> fail "unreachable"
assertEqual
"after revocation/expiry, no accepted auth subkeys should remain"
[]
(authSecretSubkeysAccepted afterReport)
assertEqual
"after revocation/expiry, rejected reasons should report invalid-time and missing-auth cases for still-visible candidates"
[ AuthSecretSubkeySubkeyInvalidAtTime
, AuthSecretSubkeyMissingAuthCapability
]
( map
authSecretSubkeyRejectedReason
(authSecretSubkeysRejected afterReport)
)
testPktWithWireRepOrdUsesRawBytes :: Assertion
testPktWithWireRepOrdUsesRawBytes = do
let src = wireRepRef "src"
pktA =
PktWithWireRep
src
(ByteRange 0 1)
"a"
0
(OtherPacketPkt 42 "a")
pktB =
PktWithWireRep
src
(ByteRange 1 1)
"b"
1
(BrokenPacketPkt "broken" 42 "b")
assertEqual
"base packet ordering can tie on tag-only fallback"
EQ
(compare (_pktValue pktA) (_pktValue pktB))
assertEqual
"PktWithWireRep ordering should break ties using packet bytes"
LT
(compare pktA pktB)
testParsePktsWithWireRepUtil :: FilePath -> Assertion
testParsePktsWithWireRepUtil fn = do
let fpath = "tests/data/" ++ fn
lbs <- BL.readFile fpath
let WireRepInput
{ wireRepInputRef = src
, wireRepInputPayload = srcBytes
} =
either
( const
WireRepInput
{ wireRepInputRef = wireRepRef lbs
, wireRepInputPayload = lbs
}
)
id
(wireRepRefFromInput Nothing lbs)
parsed = parsePktsWithWireRep src srcBytes
chunkedInput = chunkStrict 7 (BL.toStrict lbs)
conduitParsed <-
DC.runConduitRes $
CB.sourceLbs lbs
DC..| conduitParsePktsWithWireRep Nothing
DC..| CL.consume
conduitParsedChunked <-
DC.runConduitRes $
CL.sourceList chunkedInput
DC..| conduitParsePktsWithWireRep Nothing
DC..| CL.consume
assertEqual
"provenance-aware parsePkts preserves packet semantics"
(parsePkts lbs)
(map _pktValue parsed)
assertEqual
"conduit and pure provenance-aware packet parsing agree"
parsed
conduitParsed
assertEqual
"conduit parser handles packets split across chunk boundaries"
parsed
conduitParsedChunked
assertEqual
"packetsFromWireRep returns all packets for the originating bytestream"
parsed
(packetsFromWireRep src parsed)
mapM_ (assertPktProvenance src srcBytes) parsed
where
chunkStrict n bs
| B.null bs = []
| otherwise =
let (prefix, suffix) = B.splitAt n bs
in prefix : chunkStrict n suffix
testParseTKsWithWireRepUtil :: FilePath -> Assertion
testParseTKsWithWireRepUtil fn = do
let fpath = "tests/data/" ++ fn
lbs <- BL.readFile fpath
let WireRepInput
{ wireRepInputRef = src
, wireRepInputPayload = srcBytes
} =
either
( const
WireRepInput
{ wireRepInputRef = wireRepRef lbs
, wireRepInputPayload = lbs
}
)
id
(wireRepRefFromInput Nothing lbs)
packets = parsePktsWithWireRep src srcBytes
parsed = parseTKsWithWireRep True packets
plain = parseUnknownTKs True (map _pktValue packets)
conduitParsed <-
DC.runConduitRes $
CL.sourceList packets
DC..| conduitToTKsWithWireRepEither
DC..| CL.map (join . hush)
DC..| CL.catMaybes
DC..| CL.consume
assertEqual
"provenance-aware parseUnknownTKs preserves TKUnknown semantics"
plain
(map _tkValue parsed)
assertEqual
"conduit and pure provenance-aware TKUnknown parsing agree"
parsed
conduitParsed
assertEqual
"tksFromWireRep returns all TKs for the originating bytestream"
parsed
(tksFromWireRep src parsed)
mapM_ (assertTKProvenance src parsed) parsed
assertPktProvenance
:: WireRepRef -> BL.ByteString -> PktWithWireRep -> Assertion
assertPktProvenance src srcBytes pkt = do
assertEqual
"packet raw bytes round-trip back to the same packet"
(Right (_pktValue pkt))
(runGet (get :: Get Pkt) (_pktRaw pkt))
assertEqual
"packet source reference is preserved"
src
(wireRepOfPkt pkt)
let ByteRange offset len = _pktRange pkt
assertEqual
"packet raw bytes match the source bytestream slice"
(_pktRaw pkt)
(BL.take len (BL.drop offset srcBytes))
assertTKProvenance
:: WireRepRef -> [TKWithWireRep] -> TKWithWireRep -> Assertion
assertTKProvenance src allTks tk = do
assertBool
"TKUnknown source reference list includes originating source"
(src `elem` _tkWireRepRefs tk)
assertEqual
"TKUnknown source reference is preserved"
src
(wireRepOfTK tk)
assertEqual
"TKUnknown packet references reconstruct the semantic TKUnknown packet sequence"
(flattenTK (_tkValue tk))
(map _pktValue (packetRefsOfTK tk))
assertEqual
"TKUnknown source span matches the span of its packet references"
(spanByteRanges (map _pktRange (packetRefsOfTK tk)))
(_tkWireRepRange tk)
mapM_
( \pkt ->
assertBool
"packet backlink resolves to containing TKUnknown"
(tk `elem` tksContainingPacket pkt allTks)
)
(packetRefsOfTK tk)
case toStructuredTKWithWireRep tk of
Left err ->
assertFailure ("toStructuredTKWithWireRep failed: " ++ err)
Right structured -> do
assertEqual
"structured provenance retains semantic primary key"
(_tkuKey (_tkValue tk))
(_tkStructuredPrimaryKey structured)
assertEqual
"structured provenance retains packet source reference list"
(_tkWireRepRefs tk)
(_tkStructuredWireRepRefs structured)
resolved <- resolveStructuredPacketRefs structured
assertEqual
"structured provenance resolves packet refs in TKUnknown packet order"
(map _pktValue (packetRefsOfTK tk))
(map _pktValue resolved)
assertEqual
"structured provenance keeps stable packet ref ids"
(map packetRefIdOf (packetRefsOfTK tk))
(map packetRefIdOf resolved)
resolveStructuredPacketRefs
:: TKStructuredWithWireRep -> IO [PktWithWireRep]
resolveStructuredPacketRefs structured = do
let collectSigRefs = map _signatureWithWireRefRef
uidRefs =
concatMap
( \uid ->
_uidWithWireRefsRef uid
: collectSigRefs (_uidWithWireRefsSignatures uid)
)
(_tkStructuredUIDs structured)
uatRefs =
concatMap
( \uat ->
_uatWithWireRefsRef uat
: collectSigRefs (_uatWithWireRefsSignatures uat)
)
(_tkStructuredUAts structured)
subRefs =
concatMap
( \sub ->
_subkeyWithWireRefsRef sub
: collectSigRefs (_subkeyWithWireRefsSignatures sub)
)
(_tkStructuredSubkeys structured)
refIds =
_tkStructuredPrimaryKeyRef structured
: collectSigRefs (_tkStructuredDirectSignatures structured)
++ uidRefs
++ uatRefs
++ subRefs
mapM
( \refId ->
case lookupPacketRef structured refId of
Nothing ->
assertFailure
("lookupPacketRef failed for ref id " ++ show refId)
Just pkt -> pure pkt
)
refIds
testCanonicalizeTKWithWireRepMatchesManualWireOrdering
:: Assertion
testCanonicalizeTKWithWireRepMatchesManualWireOrdering = do
lbs <- readFixtureLazy "pubring.gpg"
let src = wireRepRef lbs
parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs)
case parsed of
(tk : _) ->
case toStructuredTKWithWireRep tk of
Left err ->
assertFailure ("toStructuredTKWithWireRep failed: " ++ err)
Right structured -> do
let shuffled =
structured
{ _tkStructuredDirectSignatures =
reverse (_tkStructuredDirectSignatures structured)
, _tkStructuredUIDs =
reverse
( map
( \uid ->
uid
{ _uidWithWireRefsSignatures =
reverse (_uidWithWireRefsSignatures uid)
}
)
(_tkStructuredUIDs structured)
)
, _tkStructuredUAts =
reverse
( map
( \uat ->
uat
{ _uatWithWireRefsSignatures =
reverse (_uatWithWireRefsSignatures uat)
}
)
(_tkStructuredUAts structured)
)
, _tkStructuredSubkeys =
reverse
( map
( \sub ->
sub
{ _subkeyWithWireRefsSignatures =
reverse (_subkeyWithWireRefsSignatures sub)
}
)
(_tkStructuredSubkeys structured)
)
}
expected <-
case manualCanonicalizeStructured shuffled of
Left err ->
assertFailure ("manual canonicalization failed: " ++ err)
>> fail "manual canonicalization failed"
Right x -> pure x
got <-
case canonicalizeTKStructuredWithWireRep shuffled of
Left err ->
assertFailure
("canonicalizeTKStructuredWithWireRep failed: " ++ show err)
>> fail "canonicalizeTKStructuredWithWireRep failed"
Right x -> pure x
assertEqual
"canonicalizeTKStructuredWithWireRep matches manual wire-byte ordering"
expected
got
wrapped <-
case canonicalizeTKWithWireRep tk of
Left err ->
assertFailure ("canonicalizeTKWithWireRep failed: " ++ show err)
>> fail "canonicalizeTKWithWireRep failed"
Right x -> pure x
structuredCanonical <-
case canonicalizeTKStructuredWithWireRep structured of
Left err ->
assertFailure
("canonicalizeTKStructuredWithWireRep failed: " ++ show err)
>> fail "canonicalizeTKStructuredWithWireRep failed"
Right x -> pure x
assertEqual
"canonicalizeTKWithWireRep delegates to structured canonicalization"
structuredCanonical
wrapped
[] ->
assertFailure
"pubring.gpg should parse to at least one provenance-aware TKUnknown"
where
manualCanonicalizeStructured
:: TKStructuredWithWireRep -> Either String TKUnknown
manualCanonicalizeStructured structured = do
direct <- sortSigs (_tkStructuredDirectSignatures structured)
uids <-
sortByRef _uidWithWireRefsRef
=<< mapM
( \uid -> do
sigs <- sortSigs (_uidWithWireRefsSignatures uid)
Right (uid, sigs)
)
(_tkStructuredUIDs structured)
uats <-
sortByRef _uatWithWireRefsRef
=<< mapM
( \uat -> do
sigs <- sortSigs (_uatWithWireRefsSignatures uat)
Right (uat, sigs)
)
(_tkStructuredUAts structured)
subs <-
sortByRef _subkeyWithWireRefsRef
=<< mapM
( \sub -> do
sigs <- sortSigs (_subkeyWithWireRefsSignatures sub)
Right (sub, sigs)
)
(_tkStructuredSubkeys structured)
Right $
TKUnknown
{ _tkuKey = _tkStructuredPrimaryKey structured
, _tkuRevs = map _signatureWithWireRefValue direct
, _tkuUIDs =
map
( \(uid, sigs) ->
(_uidWithWireRefsValue uid, map _signatureWithWireRefValue sigs)
)
uids
, _tkuUAts =
map
( \(uat, sigs) ->
(_uatWithWireRefsValue uat, map _signatureWithWireRefValue sigs)
)
uats
, _tkuSubs =
map
( \(sub, sigs) ->
( _subkeyWithWireRefsValue sub
, map _signatureWithWireRefValue sigs
)
)
subs
}
where
wireBytes refId =
maybe
(Left ("lookupPacketRef failed for ref id " ++ show refId))
(Right . _pktRaw)
(lookupPacketRef structured refId)
sortSigs sigs = do
keyed <-
mapM
( \sig -> do
raw <- wireBytes (_signatureWithWireRefRef sig)
Right ((raw, _signatureWithWireRefRef sig), sig)
)
sigs
Right (map snd (sortOn fst keyed))
sortByRef refAccessor items = do
keyed <-
mapM
( \(x, sigs) -> do
raw <- wireBytes (refAccessor x)
Right ((raw, refAccessor x), (x, sigs))
)
items
Right (map snd (sortOn fst keyed))
testCanonicalizeTKWithWireRepReportsMissingRef :: Assertion
testCanonicalizeTKWithWireRepReportsMissingRef = do
lbs <- readFixtureLazy "pubring.gpg"
let src = wireRepRef lbs
parsed = parseTKsWithWireRep True (parsePktsWithWireRep src lbs)
case parsed of
(tk : _) ->
case toStructuredTKWithWireRep tk of
Left err ->
assertFailure ("toStructuredTKWithWireRep failed: " ++ err)
Right structured -> do
let badRef = PacketRefId src 999999
brokenWithBadRef =
case _tkStructuredDirectSignatures structured of
(sig : rest) ->
Just
structured
{ _tkStructuredDirectSignatures =
sig {_signatureWithWireRefRef = badRef} : rest
}
[] ->
case _tkStructuredUIDs structured of
(uid : restUIDs) ->
Just
structured
{ _tkStructuredUIDs =
uid {_uidWithWireRefsRef = badRef} : restUIDs
}
[] ->
case _tkStructuredUAts structured of
(uat : restUATs) ->
Just
structured
{ _tkStructuredUAts =
uat {_uatWithWireRefsRef = badRef} : restUATs
}
[] ->
case _tkStructuredSubkeys structured of
(sub : restSubs) ->
Just
structured
{ _tkStructuredSubkeys =
sub {_subkeyWithWireRefsRef = badRef} : restSubs
}
[] -> Nothing
case brokenWithBadRef of
Nothing ->
assertFailure
"pubring.gpg first TKUnknown unexpectedly has no direct signatures, UIDs, UATs, or subkeys"
Just broken ->
case canonicalizeTKStructuredWithWireRep broken of
Left (CanonicalizeMissingPacketRef ref) ->
assertEqual
"missing ref error should include unresolved ref id"
badRef
ref
Left err ->
assertFailure
("Expected CanonicalizeMissingPacketRef, got " ++ show err)
Right _ ->
assertFailure
"Expected canonicalization to fail on missing packet ref"
[] ->
assertFailure
"pubring.gpg should parse to at least one provenance-aware TKUnknown"
testWireRepRefTracksArmorProvenance :: Assertion
testWireRepRefTracksArmorProvenance = do
armored <- readFixtureLazy "v6-secret.pgp.aa"
case wireRepRefFromInput Nothing armored of
Left err ->
assertFailure
("wireRepRefFromInput failed on armored input: " ++ err)
Right
WireRepInput
{ wireRepInputRef = src
, wireRepInputPayload = payload
} -> do
assertBool
"wireRepRefFromInput should mark ASCII-armored input as originally armored"
(_wireRepWasOriginallyArmored src)
assertBool
"dearmored payload should parse into packets"
(not (null (parsePktsWithWireRep src payload)))
testDearmorRejectsMultipleBlocks :: Assertion
testDearmorRejectsMultipleBlocks = do
armored <- readFixtureLazy "v6-secret.pgp.aa"
case dearmorIfAsciiArmored (armored <> "\n" <> armored) of
Left err ->
assertBool
"multi-block rejection error should mention expected single block"
("expected exactly one" `isInfixOf` err)
Right _ ->
assertFailure
"dearmorIfAsciiArmored unexpectedly accepted multi-block armor input"
testDearmorLenientAcceptsBomPrefixedArmor :: Assertion
testDearmorLenientAcceptsBomPrefixedArmor = do
armored <- readFixtureLazy "v6-secret.pgp.aa"
let bomPrefixed = BL.pack [0xef, 0xbb, 0xbf] <> armored
case dearmorIfAsciiArmored bomPrefixed of
Right (False, _) -> pure ()
Right (True, _) ->
assertFailure
"strict dearmorIfAsciiArmored unexpectedly treated BOM-prefixed input as armored"
Left err ->
assertFailure
("strict dearmorIfAsciiArmored failed unexpectedly: " ++ err)
case dearmorIfAsciiArmoredLenient bomPrefixed of
Left err ->
assertFailure
("lenient dearmor should decode BOM-prefixed armor: " ++ err)
Right (wasArmored, payload) -> do
assertBool
"lenient dearmor should report armored input"
wasArmored
assertBool
"lenient dearmor payload should parse as packets"
(not (null (parsePkts payload)))
testLooksLikeAsciiArmor :: Assertion
testLooksLikeAsciiArmor = do
let armoredPrefix = "\n\t -----BEGIN PGP MESSAGE-----\nYWJj\n"
partialPrefix = "-----BEGIN PG"
binaryPrefix = BL.pack [0x99, 0x01, 0x02, 0x03]
assertBool
"looksLikeAsciiArmor accepts canonical armored headers with leading whitespace"
(looksLikeAsciiArmor armoredPrefix)
assertBool
"looksLikeAsciiArmor rejects partial armored headers"
(not (looksLikeAsciiArmor partialPrefix))
assertBool
"looksLikeAsciiArmor rejects binary packet prefixes"
(not (looksLikeAsciiArmor binaryPrefix))
testWireRepRefRejectsMalformedArmoredInput :: Assertion
testWireRepRefRejectsMalformedArmoredInput = do
let malformed =
"-----BEGIN PGP MESSAGE-----\n"
<> "not base64 and no checksum\n"
<> "-----END PGP MESSAGE-----\n"
case wireRepRefFromInput Nothing malformed of
Left _ -> pure ()
Right _ ->
assertFailure
"wireRepRefFromInput unexpectedly accepted malformed ASCII-armored input"
testTksFromWireRepMatchesAnySource :: Assertion
testTksFromWireRepMatchesAnySource = do
lbs <- readFixtureLazy "pubring.gpg"
let srcA = wireRepRef lbs
srcB = namedWireRepRef "synthetic-merge-source" lbs
parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs)
case parsed of
(tk : _) -> do
let multiSourceTk = tk {_tkWireRepRefs = srcA :| [srcB]}
assertBool
"tksFromWireRep matches TKs whose source list contains the queried source"
(multiSourceTk `elem` tksFromWireRep srcA [multiSourceTk])
assertBool
"tksFromWireRep can match secondary provenance sources"
(multiSourceTk `elem` tksFromWireRep srcB [multiSourceTk])
[] ->
assertFailure
"pubring.gpg should parse to at least one provenance-aware TKUnknown"
testSemigroupTKWithWireRepPreservesStructuredRefs :: Assertion
testSemigroupTKWithWireRepPreservesStructuredRefs = do
lbs <- readFixtureLazy "pubring.gpg"
let srcA = wireRepRef lbs
srcB = namedWireRepRef "synthetic-merge-source" lbs
parsed = parseTKsWithWireRep True (parsePktsWithWireRep srcA lbs)
case parsed of
(tk : _) -> do
let remappedPackets = map (\pkt -> pkt {_pktWireRepRef = srcB}) (packetRefsOfTK tk)
tkFromSecondSource =
TKWithWireRep
(srcB :| [])
(spanByteRanges (map _pktRange remappedPackets))
remappedPackets
(_tkValue tk)
merged = tk <> tkFromSecondSource
mergedRefIds = map packetRefIdOf (packetRefsOfTK merged)
assertEqual
"Semigroup preserves TKUnknown semantic merge behavior"
(_tkValue tk <> _tkValue tkFromSecondSource)
(_tkValue merged)
assertBool
"Semigroup merged provenance references include both sources"
( srcA `elem` wireRepsOfTK merged
&& srcB `elem` wireRepsOfTK merged
)
assertEqual
"Semigroup result packet refs match merged TKUnknown packet sequence"
(flattenTK (_tkValue merged))
(map _pktValue (packetRefsOfTK merged))
assertEqual
"Semigroup result keeps packet refs unique by source-aware PacketRefId"
(length mergedRefIds)
(length (nub mergedRefIds))
case toStructuredTKWithWireRep merged of
Left err ->
assertFailure
("toStructuredTKWithWireRep failed for Semigroup result: " ++ err)
Right structured -> do
resolved <- resolveStructuredPacketRefs structured
assertEqual
"Semigroup result structured refs resolve in packet order"
(map _pktValue (packetRefsOfTK merged))
(map _pktValue resolved)
[] ->
assertFailure
"pubring.gpg should parse to at least one provenance-aware TKUnknown"
testKeyPktWrappersRoundTrip :: Assertion
testKeyPktWrappersRoundTrip = do
fixture <- loadV6UnencryptedSecretKeyFixtureForProperty
case fixture of
Left err ->
assertFailure err
Right (pkp, ska, _) -> do
let publicPrimaryPkt = PublicKeyPkt pkp
publicSubkeyPkt = PublicSubkeyPkt pkp
secretPrimaryPkt = SecretKeyPkt pkp ska
secretSubkeyPkt = SecretSubkeyPkt pkp ska
assertEqual
"mkPrimaryKeyPkt preserves public primary packets"
publicPrimaryPkt
(someKeyPktToPkt (mkPrimaryKeyPkt pkp Nothing))
assertEqual
"mkPrimaryKeyPkt preserves secret primary packets"
secretPrimaryPkt
(someKeyPktToPkt (mkPrimaryKeyPkt pkp (Just ska)))
assertEqual
"mkSubkeyKeyPkt preserves public subkey packets"
publicSubkeyPkt
(someKeyPktToPkt (mkSubkeyKeyPkt pkp Nothing))
assertEqual
"mkSubkeyKeyPkt preserves secret subkey packets"
secretSubkeyPkt
(someKeyPktToPkt (mkSubkeyKeyPkt pkp (Just ska)))
case pktToPublicKeyPkt publicPrimaryPkt of
Nothing ->
assertFailure "pktToPublicKeyPkt should accept PublicKeyPkt"
Just keyPkt -> do
assertEqual
"public primary role is preserved"
KeyPktPrimary
(keyPktRole keyPkt)
assertEqual
"public primary TKUnknown key view is preserved"
(pkp, Nothing)
(keyPktTKKey keyPkt)
assertEqual
"public primary round-trips through KeyPkt"
publicPrimaryPkt
(keyPktToPkt keyPkt)
case pktToPublicKeyPkt publicSubkeyPkt of
Nothing ->
assertFailure "pktToPublicKeyPkt should accept PublicSubkeyPkt"
Just keyPkt ->
assertEqual
"public subkey role is preserved"
KeyPktSubkey
(keyPktRole keyPkt)
case pktToSecretKeyPkt secretPrimaryPkt of
Nothing ->
assertFailure "pktToSecretKeyPkt should accept SecretKeyPkt"
Just keyPkt -> do
assertEqual
"secret primary role is preserved"
KeyPktPrimary
(keyPktRole keyPkt)
assertEqual
"secret primary TKUnknown key view is preserved"
(pkp, Just ska)
(keyPktTKKey keyPkt)
assertEqual
"secret primary round-trips through KeyPkt"
secretPrimaryPkt
(keyPktToPkt keyPkt)
assertEqual
"secret primary public view downgrades to PublicKeyPkt"
publicPrimaryPkt
(keyPktToPkt (keyPktToPublicView keyPkt))
case pktToSecretKeyPkt secretSubkeyPkt of
Nothing ->
assertFailure "pktToSecretKeyPkt should accept SecretSubkeyPkt"
Just keyPkt -> do
assertEqual
"secret subkey role is preserved"
KeyPktSubkey
(keyPktRole keyPkt)
assertEqual
"secret subkey public view downgrades to PublicSubkeyPkt"
publicSubkeyPkt
(keyPktToPkt (keyPktToPublicView keyPkt))
case pktToSomeKeyPktEither (UserIdPkt "not a key packet") of
Left (NotAKeyPacket pkt) ->
assertEqual
"non-key coercion error reports the original packet"
(UserIdPkt "not a key packet")
pkt
other ->
assertFailure
("Expected NotAKeyPacket error, got " ++ show other)
testTKTypedRoundTripAndPublicView :: Assertion
testTKTypedRoundTripAndPublicView = do
pubringBytes <- readFixtureLazy "pubring.gpg"
let publicParsed = parseUnknownTKs True (parsePkts pubringBytes)
publicTk <-
case publicParsed of
(tk : _) -> pure tk
[] ->
assertFailure
"pubring.gpg should parse to at least one TKUnknown"
>> fail "unreachable"
publicTyped <-
case fromUnknownToTK publicTk of
Left err ->
assertFailure
("fromUnknownToTK failed for public TKUnknown: " ++ err)
>> fail "unreachable"
Right typed@(SomePublicTK _) -> pure typed
Right (SomeSecretTK _) ->
assertFailure
"fromUnknownToTK should classify pubring primary key as public"
>> fail "unreachable"
assertEqual
"public typed TKUnknown round-trips back to untyped TKUnknown"
publicTk
(someTKToUnknown publicTyped)
armored <- readFixtureLazy "v6-secret.pgp.aa"
secretTk <- do
payload <-
case dearmorIfAsciiArmored armored of
Left err ->
assertFailure ("failed to decode v6-secret fixture: " ++ err)
>> fail "unreachable"
Right (_, bs) -> pure bs
case parseUnknownTKs True (parsePkts payload) of
(tk : _) -> pure tk
[] ->
assertFailure
"v6-secret.pgp.aa should parse to at least one TKUnknown"
>> fail "unreachable"
secretTyped <-
case fromUnknownToTK secretTk of
Left err ->
assertFailure
("fromUnknownToTK failed for secret TKUnknown: " ++ err)
>> fail "unreachable"
Right (SomeSecretTK typed) -> pure typed
Right (SomePublicTK _) ->
assertFailure
"fromUnknownToTK should classify v6 secret primary key as secret"
>> fail "unreachable"
let secretRoundTrip = tkToUnknown secretTyped
assertEqual
"secret typed TKUnknown round-trips back to untyped TKUnknown"
secretTk
secretRoundTrip
let projectedPublic = tkToUnknown (publicViewTK secretTyped)
expectedPublic =
secretTk
{ _tkuKey = (\(pkp, _) -> (pkp, Nothing)) (_tkuKey secretTk)
, _tkuSubs =
map
(\(pkt, sigs) -> (publicKeyPacketOf pkt, sigs))
(_tkuSubs secretTk)
}
assertEqual
"publicViewTK drops secret material from primary/subkeys"
expectedPublic
projectedPublic
flattenTK :: TKUnknown -> [Pkt]
flattenTK tk =
[someKeyPktToPkt (mkPrimaryKeyPkt pkp mska)]
++ map SignaturePkt (_tkuRevs tk)
++ concatMap flattenUID (_tkuUIDs tk)
++ concatMap flattenUAt (_tkuUAts tk)
++ concatMap flattenSub (_tkuSubs tk)
where
(pkp, mska) = _tkuKey tk
flattenUID (uid, sigs) = UserIdPkt uid : map SignaturePkt sigs
flattenUAt (uat, sigs) = UserAttributePkt uat : map SignaturePkt sigs
flattenSub (pkt, sigs) = pkt : map SignaturePkt sigs
testParseTKsDropsDisallowedPrimaryKeySigContextV4 :: Assertion
testParseTKsDropsDisallowedPrimaryKeySigContextV4 = do
let pkp =
PKPayload
V4
(ThirtyTwoBitTimeStamp 0)
0
EdDSA
( EdDSAPubKey
EdSigningCurve25519
( PrefixedNativeEPoint
(EPoint (os2ip (B.cons 0x40 (B.replicate 32 0x01))))
)
)
invalidSig = SigV4 GenericCert RSA SHA512 [] [] 0 (MPI 0 :| [])
case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of
[tk] ->
assertEqual
"parseUnknownTKs True should drop GenericCert as a primary-key signature in v4"
[]
(_tkuRevs tk)
other ->
assertFailure
( "Expected one TKUnknown when dropping invalid v4 signature context, got "
++ show other
)
testParseTKsDropsDisallowedPrimaryKeySigContextV6 :: Assertion
testParseTKsDropsDisallowedPrimaryKeySigContextV6 = do
let pkp =
PKPayload
V6
(ThirtyTwoBitTimeStamp 0)
0
EdDSA
(EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1)))
invalidSig =
SigV6
GenericCert
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x01))
[]
[]
0
(MPI 0 :| [])
case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt invalidSig] of
[tk] ->
assertEqual
"parseUnknownTKs True should drop GenericCert as a primary-key signature in v6"
[]
(_tkuRevs tk)
other ->
assertFailure
( "Expected one TKUnknown when dropping invalid v6 signature context, got "
++ show other
)
testParseTKsAcceptsAllowedPrimaryKeySigContextV6 :: Assertion
testParseTKsAcceptsAllowedPrimaryKeySigContextV6 = do
let pkp =
PKPayload
V6
(ThirtyTwoBitTimeStamp 0)
0
EdDSA
(EdDSAPubKey EdSigningCurve25519 (NativeEPoint (EPoint 1)))
allowedSig =
SigV6
KeyRevocationSig
EdDSA
SHA512
(SignatureSalt (BL.replicate 32 0x02))
[]
[]
0
(MPI 0 :| [])
case parseUnknownTKs True [PublicKeyPkt pkp, SignaturePkt allowedSig] of
[tk] ->
assertBool
"parseUnknownTKs True should keep allowed v6 key-revocation signatures on primary keys"
(not (null (_tkuRevs tk)))
other ->
assertFailure
( "Expected one TKUnknown with a retained v6 revocation signature, got "
++ show other
)