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 qualified Data.List.NonEmpty as NE
import Data.Maybe (catMaybes, mapMaybe)
import Data.Text (Text)
import Text.ParserCombinators.Incremental.LeftBiasedLocal
    ( Parser
    , concatMany
    , failure
    , feed
    , feedEof
    , inspect
    , satisfy
    )

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 ()

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