KeyringParser.hs

-- KeyringParser.hs: OpenPGP (RFC9580) transferable keys parsing
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}

module Codec.Encryption.OpenPGP.KeyringParser
  (
 -- * Parsers
    parseAChunk
  , parseAChunkEither
  , finalizeParsing
  , finalizeParsingEither
  , KeyringChunkParseError(..)
  , anyTK
  , anyTKWithWireRep
  , UidOrUat(..)
  , splitUs
  , publicTK
  , publicTKWithWireRep
  , secretTK
  , secretTKWithWireRep
  , brokenTK
  , brokenTKWithWireRep
  , pkPayload
  , pkPayloadWithWireRep
  , signature
  , signatureWithWireRep
  , signedUID
  , signedUIDWithWireRep
  , signedUAt
  , signedUAtWithWireRep
  , signedOrRevokedPubSubkey
  , signedOrRevokedPubSubkeyWithWireRep
  , brokenPubSubkey
  , brokenPubSubkeyWithWireRep
  , rawOrSignedOrRevokedSecSubkey
  , rawOrSignedOrRevokedSecSubkeyWithWireRep
  , brokenSecSubkey
  , brokenSecSubkeyWithWireRep
  , skPayload
  , skPayloadWithWireRep
  , broken
  , brokenWithWireRep
 -- * Utilities
  , parseUnknownTKs
 , parseTKsEither
 , parseTKs
 , parsePublicTKs
 , parseSecretTKs
 , parseTKsWithWireRep
 ) where

import Control.Applicative ((<|>), many)
import Data.Either (rights)
import Data.List (foldl')
import Data.Maybe (catMaybes, mapMaybe)
import qualified Data.List.NonEmpty as NE

import Data.Text (Text)

import Codec.Encryption.OpenPGP.Ontology (isTrustPkt)
import Codec.Encryption.OpenPGP.Policy
  ( isAllowedPrimaryKeySigType
  , isAllowedSubkeySigType
  , isAllowedUIDSigType
  )
import Codec.Encryption.OpenPGP.SignatureQualities (sigType)
import Codec.Encryption.OpenPGP.Types
import Data.Conduit.OpenPGP.Keyring.Instances ()
import Text.ParserCombinators.Incremental.LeftBiasedLocal
  ( Parser
  , concatMany
  , failure
  , feed
  , feedEof
  , inspect
  , satisfy
  )

data KeyringChunkParseError
  = ChunkFailureBeforeInput String
  | ChunkUnexpectedFinalizationFailure
  | ChunkParserFailure String
  deriving (Eq, Show)

renderChunkParseError :: KeyringChunkParseError -> String
renderChunkParseError (ChunkFailureBeforeInput msg) = msg
renderChunkParseError ChunkUnexpectedFinalizationFailure =
  "Unexpected finalization failure"
renderChunkParseError (ChunkParserFailure msg) = msg

collapseCompleted ::
     Monoid s
  => [(r, s)]
  -> ([r], s)
collapseCompleted rs =
  let (resultsRev, remainder) =
        foldl'
          (\(accResults, accRemainder) (result, rest) ->
             (result : accResults, accRemainder <> rest))
          ([], mempty)
          rs
   in (reverse resultsRev, remainder)

parseAChunk ::
     (Monoid s, Show s)
  => Parser s r
  -> s
  -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
  -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
parseAChunk op a st =
  either (error . renderChunkParseError) id (parseAChunkEither op a st)

parseAChunkEither ::
     (Monoid s, Show s)
   => Parser s r
   -> s
   -> ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
   -> Either
       KeyringChunkParseError
       (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
parseAChunkEither _ a ([], Nothing) =
  Left (ChunkFailureBeforeInput ("Failure before " ++ show a))
parseAChunkEither op a (cr, Nothing) =
  let (completed, remainder) = collapseCompleted cr
   in
  (\x -> (x, completed)) <$>
  either (Left . ChunkParserFailure) Right (inspect (feed (remainder <> a) op))
parseAChunkEither _ a (_, Just (_, p)) =
  (\x -> (x, [])) <$> either (Left . ChunkParserFailure) Right (inspect (feed a p))

finalizeParsing ::
     Monoid s
  => ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
  -> (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
finalizeParsing st =
  either (error . renderChunkParseError) id (finalizeParsingEither st)

finalizeParsingEither ::
     Monoid s
   => ([(r, s)], Maybe (Maybe (r -> r), Parser s r))
   -> Either
       KeyringChunkParseError
       (([(r, s)], Maybe (Maybe (r -> r), Parser s r)), [r])
finalizeParsingEither ([], Nothing) = Left ChunkUnexpectedFinalizationFailure
finalizeParsingEither (cr, Nothing) =
  let (completed, _) = collapseCompleted cr
   in Right (([], Nothing), completed)
finalizeParsingEither (_, Just (_, p)) =
  either (Left . ChunkParserFailure) finalizeParsingEither (inspect (feedEof p))

anyTK :: Bool -> Parser [Pkt] (Maybe TKUnknown)
anyTK True = publicTK True <|> secretTK True
anyTK False = publicTK False <|> secretTK False <|> brokenTK 6 <|> brokenTK 5

data UidOrUat
  = I Text
  | A [UserAttrSubPacket]
  deriving (Show)

splitUs ::
     [(UidOrUat, [SignaturePayload])]
  -> ([(Text, [SignaturePayload])], [([UserAttrSubPacket], [SignaturePayload])])
splitUs us = (is, as)
  where
    is = map unI (filter isI us)
    as = map unA (filter isA us)
    isI (I _, _) = True
    isI _ = False
    isA (A _, _) = True
    isA _ = False
    unI (I x, y) = (x, y)
    unI x = error $ "unI should never be called on " ++ show x
    unA (A x, y) = (x, y)
    unA x = error $ "unA should never be called on " ++ show x

publicTK, secretTK :: Bool -> Parser [Pkt] (Maybe TKUnknown)
publicTK intolerant = do
  pkp <- pkPayload
  pkpsigs <-
    concatMany
      (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)
  (uids, uats) <-
    fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant))
  subs <- concatMany (pubsub intolerant)
  return $ Just (TKUnknown pkp pkpsigs uids uats subs)
  where
    pubsub True = signedOrRevokedPubSubkey True
    pubsub False = signedOrRevokedPubSubkey False <|> brokenPubSubkey

secretTK intolerant = do
  skp <- skPayload
  skpsigs <-
    concatMany
      (signatureWithPredicate intolerant isAllowedPrimaryKeySigType)
  (uids, uats) <-
    fmap splitUs (many (signedUID intolerant <|> signedUAt intolerant))
  subs <- concatMany (secsub intolerant)
  return $ Just (TKUnknown skp skpsigs uids uats subs)
  where
    secsub True = rawOrSignedOrRevokedSecSubkey True
    secsub False = rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey

brokenTK :: Int -> Parser [Pkt] (Maybe TKUnknown)
brokenTK 6 = do
  _ <- broken 6
  _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])
  _ <- many (signedUID False <|> signedUAt False)
  _ <- concatMany (signedOrRevokedPubSubkey False <|> brokenPubSubkey)
  return Nothing
brokenTK 5 = do
  _ <- broken 5
  _ <- many (signature False [KeyRevocationSig, SignatureDirectlyOnAKey])
  _ <- many (signedUID False <|> signedUAt False)
  _ <- concatMany (rawOrSignedOrRevokedSecSubkey False <|> brokenSecSubkey)
  return Nothing
brokenTK _ = fail "Unexpected broken packet type"

pkPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum)
pkPayload = do
  pkpkts <- satisfy isPKP
  case pkpkts of
    [pkt] ->
      case pktToPublicKeyPkt pkt of
        Just keyPkt | keyPktRole keyPkt == KeyPktPrimary ->
          return (keyPktTKKey keyPkt)
        _ -> failure
    _ -> failure
  where
    isPKP [pkt] =
      case pktToPublicKeyPkt pkt of
        Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary
        Nothing -> False
    isPKP _ = False

signature :: Bool -> [SigType] -> Parser [Pkt] [SignaturePayload]
signature intolerant rts = signatureWithPredicate intolerant (\st -> st `elem` rts)

-- | RFC9580-aware signature parser that validates context using a predicate
-- The predicate operates on SigType to determine if the signature is allowed
-- in this context (e.g., isAllowedPrimaryKeySigType for primary keys).
signatureWithPredicate :: Bool -> (SigType -> Bool) -> Parser [Pkt] [SignaturePayload]
signatureWithPredicate intolerant predicate =
  if intolerant
    then signature'
    else signature' <|> brokensig'
  where
    signature' = do
      spks <- satisfy (isSP intolerant)
      case spks of
        [SignaturePkt sp] ->
          return $!
          (if intolerant
             then id
             else filter isSP')
            [sp]
        _ -> failure
    brokensig' = const [] <$> broken 2
    isSP True [SignaturePkt sp] = isSP' sp
    isSP False [SignaturePkt _] = True
    isSP _ _ = False
    isSP' sigPayload = maybe False predicate (sigType sigPayload)

signedUID :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])
signedUID intolerant = do
  upkts <- satisfy isUID
  case upkts of
    [UserIdPkt u] -> do
      sigs <-
        concatMany
          (signatureWithPredicate intolerant isAllowedUIDSigType)
      return (I u, sigs)
    _ -> failure
  where
    isUID [UserIdPkt _] = True
    isUID _ = False

signedUAt :: Bool -> Parser [Pkt] (UidOrUat, [SignaturePayload])
signedUAt intolerant = do
  uapkts <- satisfy isUAt
  case uapkts of
    [UserAttributePkt us] -> do
      sigs <-
        concatMany
          (signatureWithPredicate intolerant isAllowedUIDSigType)
      return (A us, sigs)
    _ -> failure
  where
    isUAt [UserAttributePkt _] = True
    isUAt _ = False

signedOrRevokedPubSubkey :: Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
signedOrRevokedPubSubkey intolerant = do
  pskpkts <- satisfy isPSKP
  case pskpkts of
    [p] -> do
      sigs <-
        concatMany
          (signatureWithPredicate intolerant isAllowedSubkeySigType)
      return [(p, sigs)]
    _ -> failure
  where
    isPSKP [pkt] =
      case pktToPublicKeyPkt pkt of
        Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey
        Nothing -> False
    isPSKP _ = False

brokenPubSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]
brokenPubSubkey = do
  _ <- broken 14
  _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType)
  return []

rawOrSignedOrRevokedSecSubkey ::
     Bool -> Parser [Pkt] [(Pkt, [SignaturePayload])]
rawOrSignedOrRevokedSecSubkey intolerant = do
  sskpkts <- satisfy isSSKP
  case sskpkts of
    [p] -> do
      sigs <-
        concatMany
          (signatureWithPredicate intolerant isAllowedSubkeySigType)
      return [(p, sigs)]
    _ -> failure
  where
    isSSKP [pkt] =
      case pktToSecretKeyPkt pkt of
        Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey
        Nothing -> False
    isSSKP _ = False

brokenSecSubkey :: Parser [Pkt] [(Pkt, [SignaturePayload])]
brokenSecSubkey = do
  _ <- broken 7
  _ <- concatMany (signatureWithPredicate False isAllowedSubkeySigType)
  return []

skPayload :: Parser [Pkt] (SomePKPayload, Maybe SKAddendum)
skPayload = do
  spkts <- satisfy isSKP
  case spkts of
    [pkt] ->
      case pktToSecretKeyPkt pkt of
        Just keyPkt | keyPktRole keyPkt == KeyPktPrimary ->
          return (keyPktTKKey keyPkt)
        _ -> failure
    _ -> failure
  where
    isSKP [pkt] =
      case pktToSecretKeyPkt pkt of
        Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary
        Nothing -> False
    isSKP _ = False

broken :: Int -> Parser [Pkt] Pkt
broken t = do
  bpkts <- satisfy isBroken
  case bpkts of
    [bp] -> return bp
    _ -> failure
  where
    isBroken [BrokenPacketPkt _ a _] = t == fromIntegral a
    isBroken _ = False

-- | parse TKs from packets
parseUnknownTKs :: Bool -> [Pkt] -> [TKUnknown]
parseUnknownTKs intolerant ps =
  catMaybes $
  runIncrementalParser
    (anyTK intolerant)
    (map (: []) (filter notTrustPacket ps))
  where
    notTrustPacket = not . isTrustPkt

parseTKsEither :: Bool -> [Pkt] -> [Either TKConversionError SomeTK]
parseTKsEither intolerant =
  map fromUnknownToTKEither . parseUnknownTKs intolerant

parseTKs :: Bool -> [Pkt] -> [SomeTK]
parseTKs intolerant packets = rights (parseTKsEither intolerant packets)

parsePublicTKs :: Bool -> [Pkt] -> [TK 'PublicTK]
parsePublicTKs intolerant packets =
  mapMaybe someTKToPublicTK (parseTKs intolerant packets)

parseSecretTKs :: Bool -> [Pkt] -> [TK 'SecretTK]
parseSecretTKs intolerant packets =
  mapMaybe someTKToSecretTK (parseTKs intolerant packets)

anyTKWithWireRep :: Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep)
anyTKWithWireRep True = publicTKWithWireRep True <|> secretTKWithWireRep True
anyTKWithWireRep False =
  publicTKWithWireRep False <|> secretTKWithWireRep False <|>
  brokenTKWithWireRep 6 <|> brokenTKWithWireRep 5

publicTKWithWireRep, secretTKWithWireRep ::
     Bool -> Parser [PktWithWireRep] (Maybe TKWithWireRep)
publicTKWithWireRep intolerant = do
  (pkp, pkps) <- pkPayloadWithWireRep
  (pkpsigs, pkpsigrefs) <-
    concatMany
      (signatureWithWireRepPredicate intolerant isAllowedPrimaryKeySigType)
  uidResults <- many (signedUIDWithWireRep intolerant <|> signedUAtWithWireRep intolerant)
  subResults <- concatMany (pubsub intolerant)
  let semanticUs = fmap fst uidResults
      (uids, uats) = splitUs semanticUs
      uidrefs = concatMap snd uidResults
      subs = fmap fst subResults
      subrefs = concatMap snd subResults
      tk = TKUnknown pkp pkpsigs uids uats subs
      refs = pkps ++ pkpsigrefs ++ uidrefs ++ subrefs
  return $ Just (mkTKWithWireRep tk refs)
  where
    pubsub True = signedOrRevokedPubSubkeyWithWireRep True
    pubsub False =
      signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep

secretTKWithWireRep intolerant = do
  (skp, skps) <- skPayloadWithWireRep
  (skpsigs, skpsigrefs) <-
    concatMany
      (signatureWithWireRepPredicate intolerant isAllowedPrimaryKeySigType)
  uidResults <- many (signedUIDWithWireRep intolerant <|> signedUAtWithWireRep intolerant)
  subResults <- concatMany (secsub intolerant)
  let semanticUs = fmap fst uidResults
      (uids, uats) = splitUs semanticUs
      uidrefs = concatMap snd uidResults
      subs = fmap fst subResults
      subrefs = concatMap snd subResults
      tk = TKUnknown skp skpsigs uids uats subs
      refs = skps ++ skpsigrefs ++ uidrefs ++ subrefs
  return $ Just (mkTKWithWireRep tk refs)
  where
    secsub True = rawOrSignedOrRevokedSecSubkeyWithWireRep True
    secsub False =
      rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep

brokenTKWithWireRep :: Int -> Parser [PktWithWireRep] (Maybe TKWithWireRep)
brokenTKWithWireRep 6 = do
  _ <- brokenWithWireRep 6
  _ <- many (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType)
  _ <- many (signedUIDWithWireRep False <|> signedUAtWithWireRep False)
  _ <-
    concatMany
      (signedOrRevokedPubSubkeyWithWireRep False <|> brokenPubSubkeyWithWireRep)
  return Nothing
brokenTKWithWireRep 5 = do
  _ <- brokenWithWireRep 5
  _ <- many (signatureWithWireRepPredicate False isAllowedPrimaryKeySigType)
  _ <- many (signedUIDWithWireRep False <|> signedUAtWithWireRep False)
  _ <-
    concatMany
      (rawOrSignedOrRevokedSecSubkeyWithWireRep False <|> brokenSecSubkeyWithWireRep)
  return Nothing
brokenTKWithWireRep _ = fail "Unexpected broken packet type"

pkPayloadWithWireRep ::
     Parser [PktWithWireRep] ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep])
pkPayloadWithWireRep = do
  pkpkts <- satisfy isPKPWS
  case pkpkts of
    [pktWithSource] ->
      case pktToPublicKeyPkt (_pktValue pktWithSource) of
        Just keyPkt | keyPktRole keyPkt == KeyPktPrimary ->
          return (keyPktTKKey keyPkt, [pktWithSource])
        _ -> failure
    _ -> failure
  where
    isPKPWS [pktWithSource] =
      case pktToPublicKeyPkt (_pktValue pktWithSource) of
        Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary
        _ -> False
    isPKPWS _ = False

signatureWithWireRep ::
     Bool
  -> [SigType]
  -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep])
signatureWithWireRep intolerant rts =
  signatureWithWireRepPredicate intolerant (\st -> st `elem` rts)

-- | RFC9580-aware signature parser with wire representation support
signatureWithWireRepPredicate ::
     Bool
  -> (SigType -> Bool)
  -> Parser [PktWithWireRep] ([SignaturePayload], [PktWithWireRep])
signatureWithWireRepPredicate intolerant predicate =
  if intolerant
    then signature'
    else signature' <|> brokensig'
  where
    signature' = do
      spks <- satisfy (isSPWS intolerant)
      case spks of
        [pktWithSource] ->
          case _pktValue pktWithSource of
            SignaturePkt sp ->
              let sigs =
                    (if intolerant
                       then id
                       else filter isSP')
                      [sp]
               in return (sigs, if null sigs then [] else [pktWithSource])
            _ -> failure
        _ -> failure
    brokensig' = const ([], []) <$> brokenWithWireRep 2
    isSPWS True [pktWithSource] =
      case _pktValue pktWithSource of
        SignaturePkt sp -> isSP' sp
        _ -> False
    isSPWS False [pktWithSource] =
      case _pktValue pktWithSource of
        SignaturePkt _ -> True
        _ -> False
    isSPWS _ _ = False
    isSP' sigPayload = maybe False predicate (sigType sigPayload)

signedUIDWithWireRep ::
     Bool
  -> Parser [PktWithWireRep] ((UidOrUat, [SignaturePayload]), [PktWithWireRep])
signedUIDWithWireRep intolerant = do
  upkts <- satisfy isUIDWS
  case upkts of
    [pktWithSource] ->
      case _pktValue pktWithSource of
        UserIdPkt u -> do
          (sigs, sigrefs) <-
            concatMany
              (signatureWithWireRepPredicate intolerant isAllowedUIDSigType)
          return ((I u, sigs), pktWithSource : sigrefs)
        _ -> failure
    _ -> failure
  where
    isUIDWS [pktWithSource] =
      case _pktValue pktWithSource of
        UserIdPkt _ -> True
        _ -> False
    isUIDWS _ = False

signedUAtWithWireRep ::
     Bool
  -> Parser [PktWithWireRep] ((UidOrUat, [SignaturePayload]), [PktWithWireRep])
signedUAtWithWireRep intolerant = do
  uapkts <- satisfy isUAtWS
  case uapkts of
    [pktWithSource] ->
      case _pktValue pktWithSource of
        UserAttributePkt us -> do
          (sigs, sigrefs) <-
            concatMany
              (signatureWithWireRepPredicate intolerant isAllowedUIDSigType)
          return ((A us, sigs), pktWithSource : sigrefs)
        _ -> failure
    _ -> failure
  where
    isUAtWS [pktWithSource] =
      case _pktValue pktWithSource of
        UserAttributePkt _ -> True
        _ -> False
    isUAtWS _ = False

signedOrRevokedPubSubkeyWithWireRep ::
     Bool -> Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])]
signedOrRevokedPubSubkeyWithWireRep intolerant = do
  pskpkts <- satisfy isPSKPWS
  case pskpkts of
    [pktWithSource] -> do
      (sigs, sigrefs) <-
        concatMany
          (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)
      return [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)]
    _ -> failure
  where
    isPSKPWS [pktWithSource] =
      case pktToPublicKeyPkt (_pktValue pktWithSource) of
        Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey
        _ -> False
    isPSKPWS _ = False

brokenPubSubkeyWithWireRep ::
     Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])]
brokenPubSubkeyWithWireRep = do
  _ <- brokenWithWireRep 14
  _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType)
  return []

rawOrSignedOrRevokedSecSubkeyWithWireRep ::
     Bool -> Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])]
rawOrSignedOrRevokedSecSubkeyWithWireRep intolerant = do
  sskpkts <- satisfy isSSKPWS
  case sskpkts of
    [pktWithSource] -> do
      (sigs, sigrefs) <-
        concatMany
          (signatureWithWireRepPredicate intolerant isAllowedSubkeySigType)
      return [((_pktValue pktWithSource, sigs), pktWithSource : sigrefs)]
    _ -> failure
  where
    isSSKPWS [pktWithSource] =
      case pktToSecretKeyPkt (_pktValue pktWithSource) of
        Just keyPkt -> keyPktRole keyPkt == KeyPktSubkey
        _ -> False
    isSSKPWS _ = False

brokenSecSubkeyWithWireRep ::
     Parser [PktWithWireRep] [((Pkt, [SignaturePayload]), [PktWithWireRep])]
brokenSecSubkeyWithWireRep = do
  _ <- brokenWithWireRep 7
  _ <- concatMany (signatureWithWireRepPredicate False isAllowedSubkeySigType)
  return []

skPayloadWithWireRep ::
     Parser [PktWithWireRep] ((SomePKPayload, Maybe SKAddendum), [PktWithWireRep])
skPayloadWithWireRep = do
  spkts <- satisfy isSKPWS
  case spkts of
    [pktWithSource] ->
      case pktToSecretKeyPkt (_pktValue pktWithSource) of
        Just keyPkt | keyPktRole keyPkt == KeyPktPrimary ->
          return (keyPktTKKey keyPkt, [pktWithSource])
        _ -> failure
    _ -> failure
  where
    isSKPWS [pktWithSource] =
      case pktToSecretKeyPkt (_pktValue pktWithSource) of
        Just keyPkt -> keyPktRole keyPkt == KeyPktPrimary
        _ -> False
    isSKPWS _ = False

brokenWithWireRep :: Int -> Parser [PktWithWireRep] PktWithWireRep
brokenWithWireRep t = do
  bpkts <- satisfy isBrokenWS
  case bpkts of
    [bp] -> return bp
    _ -> failure
  where
    isBrokenWS [pktWithSource] =
      case _pktValue pktWithSource of
        BrokenPacketPkt _ a _ -> t == fromIntegral a
        _ -> False
    isBrokenWS _ = False

parseTKsWithWireRep :: Bool -> [PktWithWireRep] -> [TKWithWireRep]
parseTKsWithWireRep intolerant ps =
  catMaybes $
  runIncrementalParser
    (anyTKWithWireRep intolerant)
    (map (: []) (filter notTrustPacketWithWireRep ps))
  where
    notTrustPacketWithWireRep = not . isTrustPkt . _pktValue

runIncrementalParser ::
     (Monoid s, Show s)
  => Parser s r
  -> [s]
  -> [r]
runIncrementalParser parser chunks = go ([], Just (Nothing, parser)) chunks
  where
    go st [] = snd (finalizeParsing st)
    go st (chunk:rest) =
      let (st', out) = parseAChunk parser chunk st
       in out <> go st' rest

mkTKWithWireRep :: TKUnknown -> [PktWithWireRep] -> TKWithWireRep
mkTKWithWireRep tk refs =
  case refs of
    [] -> error "mkTKWithWireRep requires at least one packet reference"
    (pktWithSource:_) ->
      TKWithWireRep
        (NE.singleton (wireRepOfPkt pktWithSource))
        (spanByteRanges (map _pktRange refs))
        refs
        tk