-- 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.Lens (view, (^.))
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
                (PktWithBytes "a" (OtherPacketPkt 42 "a"))
                src
                (ByteRange 0 1)
                0
        pktB =
            PktWithWireRep
                (PktWithBytes "b" (BrokenPacketPkt "broken" 42 "b"))
                src
                (ByteRange 1 1)
                1
    assertEqual
        "base packet ordering can tie on tag-only fallback"
        EQ
        ( compare
            (pktA ^. pktWireRep . pktValue)
            (pktB ^. pktWireRep . pktValue)
        )
    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 (\p -> view (pktWireRep . pktValue) p) 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 (\p -> view (pktWireRep . pktValue) p) 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 (pkt ^. pktWireRep . pktValue))
        (runGet (get :: Get Pkt) (pkt ^. pktWireRep . pktRaw))
    assertEqual
        "packet source reference is preserved"
        src
        (wireRepOfPkt pkt)
    let ByteRange offset len = _pktRange pkt
    assertEqual
        "packet raw bytes match the source bytestream slice"
        (pkt ^. pktWireRep . pktRaw)
        (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 (\p -> view (pktWireRep . pktValue) p) (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 (\p -> view (pktWireRep . pktValue) p) (packetRefsOfTK tk))
                (map (\p -> view (pktWireRep . pktValue) p) 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 . (\p -> p ^. pktWireRep . 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
                    (\p -> view (pktWireRep . pktValue) p)
                    (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
                            (\p -> view (pktWireRep . pktValue) p)
                            (packetRefsOfTK merged)
                        )
                        (map (\p -> view (pktWireRep . pktValue) p) 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
                )
