-- 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 Codec.Encryption.OpenPGP.Fingerprint (fingerprint)
import Codec.Encryption.OpenPGP.KeyInfo (pkalgoAbbrev)
import Codec.Encryption.OpenPGP.KeyringParser
  ( parsePublicTKs
  , parseSecretTKs
  , parseTKsEither
  , parseTKs
  , parseTKsWithWireRep
  , parseUnknownTKs
  )
import Codec.Encryption.OpenPGP.Serialize
  ( PktParseError(..)
  , WireRepInput(..)
  , conduitParsePktsWithWireRep
  , dearmorIfAsciiArmored
  , dearmorIfAsciiArmoredLenient
  , looksLikeAsciiArmor
  , parsePkts
  , parsePktsEither
  , parsePktsWithWireRep
  , wireRepRefFromInput
  )
import Codec.Encryption.OpenPGP.Types
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.OpenPGP.Keyring
  ( AuthSecretSubkeyRejectionReason(..)
  , AuthSecretSubkeyUID(..)
  , AuthSecretSubkeysAtReport(..)
  , authSecretSubkeysAt
  , authSecretSubkeysAtReport
  , authSecretSubkeyPrimaryUID
  , authSecretSubkeyRejectedReason
  , authSecretSubkeyUIDs
  , authSecretSubkeyValue
  , conduitToSomeTKsDroppingEither
  , conduitToAuthSecretSubkeysAt
  , conduitToAuthSecretSubkeysAtReport
  , conduitToSomeTKsEither
  , conduitToPublicTKs
  , conduitToSecretTKs
  , conduitToTKs
  , conduitToTKsWithWireRep
  , conduitToUnknownTKs
  )
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 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..| conduitToUnknownTKs 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..| conduitToTKs DC..| CL.consume
  publicTyped <-
    DC.runConduitRes $
    CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToPublicTKs DC..| CL.consume
  secretTyped <-
    DC.runConduitRes $
    CB.sourceLbs lbs DC..| conduitGet get DC..| conduitToSecretTKs 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..| conduitToTKsWithWireRep 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 Ed25519 (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 Ed25519 (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 Ed25519 (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)
