-- Serialize.hs: OpenPGP (RFC9580) serialization (using binary)
-- Copyright © 2012-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}

module Codec.Encryption.OpenPGP.Serialize
    ( -- * Serialization functions
      putPkt
    , putPktEither
    , putSKAddendum
    , getSecretKey
    , putSKeyForPKPayload

      -- * Utilities
    , dearmorIfAsciiArmored
    , dearmorIfAsciiArmoredLenient
    , looksLikeAsciiArmor
    , armorPayloadsOfType
    , singleArmorPayloadOfType
    , singleClearSignedBlock
    , recommendedArmorType
    , WireRepInput (..)
    , wireRepRefFromInput
    , PktParseError (..)
    , parsePkts
    , parsePktsEither
    , parsePktsWithWireRep
    , conduitParsePktsWithWireRep
    ) where

import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
    ( Armor (..)
    , ArmorType (..)
    )
import Control.Applicative (many, some)
import Control.Arrow ((***))
import Control.Lens ((^.), _1)
import Control.Monad (guard, replicateM, replicateM_, when)
import Control.Monad.Loops (iterateUntilM)
import Crypto.Number.Basic (numBits)
import Crypto.Number.ModArithmetic (inverse)
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.DSA as D
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.RSA as R
import Data.Bifunctor (bimap)
import Data.Binary (Binary, get, put)
import Data.Binary.Get
    ( ByteOffset
    , Get
    , bytesRead
    , getByteString
    , getLazyByteString
    , getRemainingLazyByteString
    , getWord16be
    , getWord16le
    , getWord32be
    , getWord8
    , lookAhead
    , runGetOrFail
    )
import Data.Binary.Put
    ( Put
    , putByteString
    , putLazyByteString
    , putWord16be
    , putWord16le
    , putWord32be
    , putWord8
    , runPut
    )
import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.))
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Conduit (ConduitT, await, yield)
import qualified Data.Foldable as F
import Data.Int (Int64)
import Data.List (mapAccumL)
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as M
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8With, encodeUtf8)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Word (Word16, Word32, Word8)
import Network.URI (nullURI, parseURI, uriToString)

import Codec.Encryption.OpenPGP.Internal
    ( curve2Curve
    , curveFromCurve
    , curveToCurveoidBS
    , curveoidBSToCurve
    , curveoidBSToEdSigningCurve
    , edSigningCurveToCurveoidBS
    , leftPadTo
    , pubkeyToMPIs
    )
import Codec.Encryption.OpenPGP.Policy
    ( signatureV6SaltSizeForHashAlgorithm
    )
import Codec.Encryption.OpenPGP.Types
import qualified Codec.Encryption.OpenPGP.Types.Internal.Base as BTypes
import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P

instance Binary SigSubPacket where
    get = getSigSubPacket
    put = putSigSubPacket

-- instance Binary (Set NotationFlag) where
--     put = putNotationFlagSet
instance Binary CompressionAlgorithm where
    get = toFVal <$> getWord8
    put = putWord8 . fromFVal

instance Binary PubKeyAlgorithm where
    get = toFVal <$> getWord8
    put = putWord8 . fromFVal

instance Binary HashAlgorithm where
    get = toFVal <$> getWord8
    put = putWord8 . fromFVal

instance Binary SymmetricAlgorithm where
    get = toFVal <$> getWord8
    put = putWord8 . fromFVal

instance Binary AEADAlgorithm where
    get = toFVal <$> getWord8
    put = putWord8 . fromFVal

instance Binary MPI where
    get = getMPI
    put = putMPI

instance Binary SigType where
    get = toFVal <$> getWord8
    put = putWord8 . fromFVal

instance Binary UserAttrSubPacket where
    get = getUserAttrSubPacket
    put = putUserAttrSubPacket

instance Binary S2K where
    get = getS2K
    put = putS2K

instance Binary (PKESK 'PKESKV3) where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary (PKESK 'PKESKV6) where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary Signature where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary (SKESK 'SKESKV4) where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary (SKESK 'SKESKV6) where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary (OnePassSignature 'OPSV3) where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary (OnePassSignature 'OPSV6) where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary SecretKey where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary PublicKey where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary SecretSubkey where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary CompressedData where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary SymEncData where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary Marker where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary LiteralData where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary Trust where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary UserId where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary PublicSubkey where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary UserAttribute where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary SymEncIntegrityProtectedData where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary ModificationDetectionCode where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary Padding where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary OtherPacket where
    get = getPkt >>= either fail pure . fromPktEither
    put = putPkt . toPkt

instance Binary Pkt where
    get = getPkt
    put = putPkt

instance (Binary a) => Binary (Block a) where
    get = Block `fmap` many get
    put = mapM_ put . unBlock

instance Binary SomePKPayload where
    get = getPKPayload
    put = putPKPayload

instance Binary SignaturePayload where
    get = getSignaturePayload
    put = putSignaturePayload

instance Binary TKUnknown where
    get = fail "Binary TKUnknown decode is not implemented"
    put = putTK

instance Binary (TK k) where
    get = fail "Binary TK decode is not implemented"
    put = putTK . tkToUnknown

instance Binary SomeTK where
    get = fail "Binary SomeTK decode is not implemented"
    put = putTK . someTKToUnknown

getSigSubPacket :: Get SigSubPacket
getSigSubPacket = do
    l <- fmap fromIntegral getSubPacketLength
    (crit, pt) <- getSigSubPacketType
    getSigSubPacket' pt crit l
  where
    getSigSubPacket' pt crit l
        | pt > 99 && pt < 111 = getUserDefinedSigSub pt crit l
        | otherwise =
            case M.lookup pt sigSubPacketParsers of
                Just parser -> parser pt crit l
                Nothing -> getOtherSigSub pt crit l

    getOtherSigSub pt crit l = do
        payload <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (OtherSigSub pt payload)

type SigSubPacketParser =
    Word8 -> Bool -> ByteOffset -> Get SigSubPacket

sigSubPacketParsers :: M.Map Word8 SigSubPacketParser
sigSubPacketParsers =
    M.fromList
        [ (2, getSigCreationTime)
        , (3, getSigExpirationTime)
        , (4, getExportableCertification)
        , (5, getTrustSignature)
        , (6, getRegularExpression)
        , (7, getRevocable)
        , (9, getKeyExpirationTime)
        , (11, getPreferredSymmetricAlgorithms)
        , (12, getRevocationKey)
        , (16, getIssuer)
        , (20, getNotationData)
        , (21, getPreferredHashAlgorithms)
        , (22, getPreferredCompressionAlgorithms)
        , (23, getKeyServerPreferences)
        , (24, getPreferredKeyServer)
        , (25, getPrimaryUserId)
        , (26, getPolicyURL)
        , (27, getKeyFlags)
        , (28, getSignersUserId)
        , (29, getReasonForRevocation)
        , (30, getFeatures)
        , (31, getSignatureTarget)
        , (32, getEmbeddedSignature)
        , (33, getIssuerFingerprint)
        , (35, getIntendedRecipient)
        , (39, getPreferredAEADCiphersuites)
        ]

getSigCreationTime :: SigSubPacketParser
getSigCreationTime _pt crit _l =
    SigSubPacket crit . SigCreationTime
        <$> fmap ThirtyTwoBitTimeStamp getWord32be

getSigExpirationTime :: SigSubPacketParser
getSigExpirationTime _pt crit _l =
    SigSubPacket crit . SigExpirationTime
        <$> fmap ThirtyTwoBitDuration getWord32be

getExportableCertification :: SigSubPacketParser
getExportableCertification _pt crit _l = SigSubPacket crit . ExportableCertification <$> get

getTrustSignature :: SigSubPacketParser
getTrustSignature _pt crit _l = do
    tl <- getWord8
    ta <- getWord8
    return $ SigSubPacket crit (TrustSignature tl ta)

getRegularExpression :: SigSubPacketParser
getRegularExpression _pt crit l = do
    apdre <- getLazyByteString (l - 2)
    nul <- getWord8
    guard (nul == 0)
    return $ SigSubPacket crit (RegularExpression (BL.copy apdre))

getRevocable :: SigSubPacketParser
getRevocable _pt crit _l = SigSubPacket crit . Revocable <$> get

getKeyExpirationTime :: SigSubPacketParser
getKeyExpirationTime _pt crit _l =
    SigSubPacket crit . KeyExpirationTime
        <$> fmap ThirtyTwoBitDuration getWord32be

getPreferredSymmetricAlgorithms :: SigSubPacketParser
getPreferredSymmetricAlgorithms _pt crit l = do
    sa <- replicateM (fromIntegral (l - 1)) get
    return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)

getRevocationKey :: SigSubPacketParser
getRevocationKey _pt crit l = do
    rclass <- getWord8
    guard (testBit rclass 7)
    algid <- get
    fp <- getLazyByteString (fromIntegral l - 3)
    return $
        SigSubPacket
            crit
            ( RevocationKey
                (bsToFFSet . BL.singleton $ rclass .&. 0x7f)
                algid
                (Fingerprint fp)
            )

getIssuer :: SigSubPacketParser
getIssuer _pt crit l = do
    keyid <- getLazyByteString (l - 1)
    return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))

getNotationData :: SigSubPacketParser
getNotationData _pt crit l = do
    flags <- getLazyByteString 4
    nl <- getWord16be
    vl <- getWord16be
    nn <- getLazyByteString (fromIntegral nl)
    nv <- getLazyByteString (fromIntegral vl)
    return $
        SigSubPacket
            crit
            ( NotationData
                (bsToFFSet flags)
                (NotationName nn)
                (NotationValue nv)
            )

getPreferredHashAlgorithms :: SigSubPacketParser
getPreferredHashAlgorithms _pt crit l = do
    ha <- replicateM (fromIntegral (l - 1)) get
    return $ SigSubPacket crit (PreferredHashAlgorithms ha)

getPreferredCompressionAlgorithms :: SigSubPacketParser
getPreferredCompressionAlgorithms _pt crit l = do
    ca <- replicateM (fromIntegral (l - 1)) get
    return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)

getKeyServerPreferences :: SigSubPacketParser
getKeyServerPreferences _pt crit l = do
    ksps <- getLazyByteString (l - 1)
    return $
        SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))

getPreferredKeyServer :: SigSubPacketParser
getPreferredKeyServer _pt crit l = do
    pks <- getLazyByteString (l - 1)
    return $ SigSubPacket crit (PreferredKeyServer pks)

getPrimaryUserId :: SigSubPacketParser
getPrimaryUserId _pt crit _l = do
    primacy <- get
    return $ SigSubPacket crit (PrimaryUserId primacy)

getPolicyURL :: SigSubPacketParser
getPolicyURL _pt crit l = do
    url <-
        fmap
            ( URL
                . fromMaybe nullURI
                . parseURI
                . T.unpack
                . decodeUtf8With lenientDecode
            )
            (getByteString (fromIntegral (l - 1)))
    return $ SigSubPacket crit (PolicyURL url)

getKeyFlags :: SigSubPacketParser
getKeyFlags _pt crit l = do
    kfs <- getLazyByteString (l - 1)
    return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))

getSignersUserId :: SigSubPacketParser
getSignersUserId _pt crit l = do
    uid <- getByteString (fromIntegral (l - 1))
    return $
        SigSubPacket
            crit
            (SignersUserId (decodeUtf8With lenientDecode uid))

getReasonForRevocation :: SigSubPacketParser
getReasonForRevocation _pt crit l = do
    rcode <- getWord8
    rreason <-
        fmap
            (decodeUtf8With lenientDecode)
            (getByteString (fromIntegral (l - 2)))
    return $
        SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)

getFeatures :: SigSubPacketParser
getFeatures _pt crit l = do
    fbs <- getLazyByteString (l - 1)
    return $ SigSubPacket crit (Features (bsToFFSet fbs))

getSignatureTarget :: SigSubPacketParser
getSignatureTarget _pt crit l = do
    pka <- get
    ha <- get
    hash <- getLazyByteString (l - 3)
    return $ SigSubPacket crit (SignatureTarget pka ha hash)

getEmbeddedSignature :: SigSubPacketParser
getEmbeddedSignature _pt crit l = do
    spbs <- getLazyByteString (l - 1)
    case runGetOrFail get spbs of
        Left (_, _, e) -> fail ("embedded signature subpacket " ++ e)
        Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp)

getIssuerFingerprint :: SigSubPacketParser
getIssuerFingerprint _pt crit l = do
    when (l /= 22 && l /= 34) $
        fail ("invalid issuer fingerprint subpacket length: " ++ show l)
    kv <- getWord8
    let fpLen = l - 2
    when (fpLen /= 20 && fpLen /= 32) $
        fail ("invalid issuer fingerprint length: " ++ show fpLen)
    case BTypes.packetVersionToIssuerFingerprintVersion kv of
        Nothing ->
            fail ("invalid issuer fingerprint version marker: " ++ show kv)
        Just ifVersion -> do
            fp <-
                case kv of
                    4 -> getLazyByteString (fromIntegral fpLen)
                    6 -> getLazyByteString (fromIntegral fpLen)
                    _ ->
                        fail ("invalid issuer fingerprint version marker: " ++ show kv)
            return $
                SigSubPacket crit (IssuerFingerprint ifVersion (Fingerprint fp))

getIntendedRecipient :: SigSubPacketParser
getIntendedRecipient _pt crit l = do
    kv <- getWord8
    fp <- getLazyByteString (l - 2)
    when (BL.length fp /= 20 && BL.length fp /= 32) $
        fail
            ( "invalid intended recipient fingerprint length: "
                ++ show (BL.length fp)
            )
    case BTypes.packetVersionToIssuerFingerprintVersion kv of
        Nothing ->
            fail
                ( "invalid intended recipient fingerprint version marker: "
                    ++ show kv
                )
        Just ifVersion ->
            return $
                SigSubPacket crit (IntendedRecipient ifVersion (Fingerprint fp))

getPreferredAEADCiphersuites :: SigSubPacketParser
getPreferredAEADCiphersuites _pt crit l = do
    let payloadLen = fromIntegral (l - 1)
    when (payloadLen `mod` 2 /= 0) $
        fail "preferred AEAD ciphersuites subpacket length must be even"
    pairs <- replicateM (payloadLen `div` 2) $ do
        sa <- get
        aead <- get
        return (sa, aead)
    return $ SigSubPacket crit (PreferredAEADCiphersuites pairs)

getUserDefinedSigSub :: SigSubPacketParser
getUserDefinedSigSub pt crit l = do
    payload <- getLazyByteString (l - 1)
    return $ SigSubPacket crit (UserDefinedSigSub pt payload)

putSigSubPacket :: SigSubPacket -> Put
putSigSubPacket (SigSubPacket crit payload) = case payload of
    SigCreationTime et -> putSigCreationTime crit et
    SigExpirationTime et -> putSigExpirationTime crit et
    ExportableCertification e -> putExportableCertification crit e
    TrustSignature tl ta -> putTrustSignature crit tl ta
    RegularExpression apdre -> putRegularExpression crit apdre
    Revocable r -> putRevocable crit r
    KeyExpirationTime et -> putKeyExpirationTime crit et
    PreferredSymmetricAlgorithms ess -> putPreferredSymmetricAlgorithms crit ess
    RevocationKey rclass algid fp -> putRevocationKey crit rclass algid fp
    Issuer keyid -> putIssuer crit keyid
    NotationData nfs nn nv -> putNotationData crit nfs nn nv
    PreferredHashAlgorithms ehs -> putPreferredHashAlgorithms crit ehs
    PreferredCompressionAlgorithms ecs -> putPreferredCompressionAlgorithms crit ecs
    KeyServerPreferences ksps -> putKeyServerPreferences crit ksps
    PreferredKeyServer ks -> putPreferredKeyServer crit ks
    PrimaryUserId primacy -> putPrimaryUserId crit primacy
    PolicyURL url -> putPolicyURL crit url
    KeyFlags kfs -> putKeyFlags crit kfs
    SignersUserId userid -> putSignersUserId crit userid
    ReasonForRevocation rcode rreason -> putReasonForRevocation crit rcode rreason
    Features fs -> putFeatures crit fs
    SignatureTarget pka ha hash -> putSignatureTarget crit pka ha hash
    EmbeddedSignature sp -> putEmbeddedSignature crit sp
    IssuerFingerprint kv fp -> putIssuerFingerprint crit kv fp
    IntendedRecipient kv irf -> putIntendedRecipient crit kv irf
    PreferredAEADCiphersuites ps -> putPreferredAEADCiphersuites crit ps
    UserDefinedSigSub ptype payload -> putOtherSigSub crit ptype payload
    OtherSigSub ptype payload -> putOtherSigSub crit ptype payload

putSigCreationTime :: Bool -> ThirtyTwoBitTimeStamp -> Put
putSigCreationTime crit et = do
    putSubPacketLength 5
    putSigSubPacketType crit 2
    putWord32be . unThirtyTwoBitTimeStamp $ et

putSigExpirationTime :: Bool -> ThirtyTwoBitDuration -> Put
putSigExpirationTime crit et = do
    putSubPacketLength 5
    putSigSubPacketType crit 3
    putWord32be . unThirtyTwoBitDuration $ et

putExportableCertification :: Bool -> Bool -> Put
putExportableCertification crit e = do
    putSubPacketLength 2
    putSigSubPacketType crit 4
    put e

putTrustSignature :: Bool -> Word8 -> Word8 -> Put
putTrustSignature crit tl ta = do
    putSubPacketLength 3
    putSigSubPacketType crit 5
    put tl
    put ta

putRegularExpression :: Bool -> BL.ByteString -> Put
putRegularExpression crit apdre = do
    putSubPacketLength . fromIntegral $ (2 + BL.length apdre)
    putSigSubPacketType crit 6
    putLazyByteString apdre
    putWord8 0

putRevocable :: Bool -> Bool -> Put
putRevocable crit r = do
    putSubPacketLength 2
    putSigSubPacketType crit 7
    put r

putKeyExpirationTime :: Bool -> ThirtyTwoBitDuration -> Put
putKeyExpirationTime crit et = do
    putSubPacketLength 5
    putSigSubPacketType crit 9
    putWord32be . unThirtyTwoBitDuration $ et

putPreferredSymmetricAlgorithms
    :: Bool -> [SymmetricAlgorithm] -> Put
putPreferredSymmetricAlgorithms crit ess = do
    putSubPacketLength . fromIntegral $ (1 + length ess)
    putSigSubPacketType crit 11
    mapM_ put ess

putRevocationKey
    :: Bool
    -> Set RevocationClass
    -> PubKeyAlgorithm
    -> Fingerprint
    -> Put
putRevocationKey crit rclass algid fp = do
    let fpLen = BL.length (unFingerprint fp)
    putSubPacketLength (fromIntegral (3 + fpLen))
    putSigSubPacketType crit 12
    putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $
        Set.insert (RClOther 0) rclass
    put algid
    putLazyByteString (unFingerprint fp)

putIssuer :: Bool -> EightOctetKeyId -> Put
putIssuer crit keyid = do
    putSubPacketLength 9
    putSigSubPacketType crit 16
    putLazyByteString (unEOKI keyid)

putNotationData
    :: Bool
    -> Set NotationFlag
    -> NotationName
    -> NotationValue
    -> Put
putNotationData crit nfs (NotationName nn) (NotationValue nv) = do
    putSubPacketLength . fromIntegral $
        (9 + BL.length nn + BL.length nv)
    putSigSubPacketType crit 20
    putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs
    putWord16be . fromIntegral . BL.length $ nn
    putWord16be . fromIntegral . BL.length $ nv
    putLazyByteString nn
    putLazyByteString nv

putPreferredHashAlgorithms :: Bool -> [HashAlgorithm] -> Put
putPreferredHashAlgorithms crit ehs = do
    putSubPacketLength . fromIntegral $ (1 + length ehs)
    putSigSubPacketType crit 21
    mapM_ put ehs

putPreferredCompressionAlgorithms
    :: Bool -> [CompressionAlgorithm] -> Put
putPreferredCompressionAlgorithms crit ecs = do
    putSubPacketLength . fromIntegral $ (1 + length ecs)
    putSigSubPacketType crit 22
    mapM_ put ecs

putKeyServerPreferences :: Bool -> Set KSPFlag -> Put
putKeyServerPreferences crit ksps = do
    let kbs = ffSetToBS ksps
    putSubPacketLength . fromIntegral $ (1 + BL.length kbs)
    putSigSubPacketType crit 23
    putLazyByteString kbs

putPreferredKeyServer :: Bool -> BL.ByteString -> Put
putPreferredKeyServer crit ks = do
    putSubPacketLength . fromIntegral $ (1 + BL.length ks)
    putSigSubPacketType crit 24
    putLazyByteString ks

putPrimaryUserId :: Bool -> Bool -> Put
putPrimaryUserId crit primacy = do
    putSubPacketLength 2
    putSigSubPacketType crit 25
    put primacy

putPolicyURL :: Bool -> URL -> Put
putPolicyURL crit (URL uri) = do
    let bs = encodeUtf8 (T.pack (uriToString id uri ""))
    putSubPacketLength . fromIntegral $ (1 + B.length bs)
    putSigSubPacketType crit 26
    putByteString bs

putKeyFlags :: Bool -> Set KeyFlag -> Put
putKeyFlags crit kfs = do
    let kbs = ffSetToBS kfs
    putSubPacketLength . fromIntegral $ (1 + BL.length kbs)
    putSigSubPacketType crit 27
    putLazyByteString kbs

putSignersUserId :: Bool -> Text -> Put
putSignersUserId crit userid = do
    let bs = encodeUtf8 userid
    putSubPacketLength . fromIntegral $ (1 + B.length bs)
    putSigSubPacketType crit 28
    putByteString bs

putReasonForRevocation
    :: Bool -> RevocationCode -> RevocationReason -> Put
putReasonForRevocation crit rcode rreason = do
    let reasonbs = encodeUtf8 rreason
    putSubPacketLength . fromIntegral $ (2 + B.length reasonbs)
    putSigSubPacketType crit 29
    putWord8 . fromFVal $ rcode
    putByteString reasonbs

putFeatures :: Bool -> Set FeatureFlag -> Put
putFeatures crit fs = do
    let fbs = ffSetToBS fs
    putSubPacketLength . fromIntegral $ (1 + BL.length fbs)
    putSigSubPacketType crit 30
    putLazyByteString fbs

putSignatureTarget
    :: Bool -> PubKeyAlgorithm -> HashAlgorithm -> BL.ByteString -> Put
putSignatureTarget crit pka ha hash = do
    putSubPacketLength . fromIntegral $ (3 + BL.length hash)
    putSigSubPacketType crit 31
    put pka
    put ha
    putLazyByteString hash

putEmbeddedSignature :: Bool -> SignaturePayload -> Put
putEmbeddedSignature crit sp = do
    let spb = runPut (put sp)
    putSubPacketLength . fromIntegral $ (1 + BL.length spb)
    putSigSubPacketType crit 32
    putLazyByteString spb

putIssuerFingerprint
    :: Bool -> IssuerFingerprintVersion -> Fingerprint -> Put
putIssuerFingerprint crit kv fp = do
    let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv
    let fpb = unFingerprint fp
    when (BL.length fpb /= 20 && BL.length fpb /= 32) $
        error
            ("invalid issuer fingerprint length: " ++ show (BL.length fpb))
    putSubPacketLength . fromIntegral $ (2 + BL.length fpb)
    putSigSubPacketType crit 33
    putWord8 kv'
    putLazyByteString fpb

putIntendedRecipient
    :: Bool -> IssuerFingerprintVersion -> Fingerprint -> Put
putIntendedRecipient crit kv irf = do
    let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv
    let fpb = unFingerprint irf
    when (BL.length fpb /= 20 && BL.length fpb /= 32) $
        error
            ( "invalid intended-recipient fingerprint length: "
                ++ show (BL.length fpb)
            )
    putSubPacketLength . fromIntegral $ (2 + BL.length fpb)
    putSigSubPacketType crit 35
    putWord8 kv'
    putLazyByteString fpb

putPreferredAEADCiphersuites
    :: Bool -> [(SymmetricAlgorithm, AEADAlgorithm)] -> Put
putPreferredAEADCiphersuites crit ps = do
    putSubPacketLength . fromIntegral $ (1 + 2 * length ps)
    putSigSubPacketType crit 39
    mapM_ (\(sa, aead) -> put sa >> put aead) ps

putOtherSigSub :: Bool -> Word8 -> BL.ByteString -> Put
putOtherSigSub crit ptype payload = do
    putSubPacketLength . fromIntegral $ (1 + BL.length payload)
    putSigSubPacketType crit ptype
    putLazyByteString payload

getSubPacketLength :: Get Word32
getSubPacketLength = getSubPacketLength' =<< getWord8
  where
    getSubPacketLength' :: (Integral a) => Word8 -> Get a
    getSubPacketLength' f
        | f < 192 = return . fromIntegral $ f
        | f < 224 = do
            secondOctet <- getWord8
            return . fromIntegral $
                shiftL (fromIntegral (f - 192) :: Int) 8
                    + (fromIntegral secondOctet :: Int)
                    + 192
        | f == 255 = do
            len <- getWord32be
            return . fromIntegral $ len
        | otherwise = fail "Partial body length invalid."

putSubPacketLength :: Word32 -> Put
putSubPacketLength l
    | l < 192 = putWord8 (fromIntegral l)
    | l < 8384 =
        putWord8
            (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))
            >> putWord8 (fromIntegral (l - 192) .&. 0xff)
    | l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l)
    | otherwise = error ("too big (" ++ show l ++ ")")

getSigSubPacketType :: Get (Bool, Word8)
getSigSubPacketType = do
    x <- getWord8
    return
        ( if x .&. 128 == 128
            then (True, x .&. 127)
            else (False, x)
        )

putSigSubPacketType :: Bool -> Word8 -> Put
putSigSubPacketType False sst = putWord8 sst
putSigSubPacketType True sst = putWord8 (sst .|. 0x80)

bsToFFSet :: (FutureFlag a) => ByteString -> Set a
bsToFFSet bs =
    Set.fromAscList . concat . snd $
        mapAccumL
            (\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7]))
            0
            (BL.unpack bs)
  where
    shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x]

ffSetToFixedLengthBS
    :: (FutureFlag b, Integral a) => a -> Set b -> ByteString
ffSetToFixedLengthBS len ffs =
    BL.take
        (fromIntegral len)
        (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))

ffSetToBS :: (FutureFlag a) => Set a -> ByteString
ffSetToBS = BL.pack . ffSetToBS'
  where
    ffSetToBS' :: (FutureFlag a) => Set a -> [Word8]
    ffSetToBS' ks
        -- Emit a single zero octet for an empty flag set so encoded flag
        -- subpackets always carry an explicit flags byte.
        | Set.null ks = [0]
        | otherwise =
            map
                ( ( foldl (.|.) 0
                        . map (shiftR 128 . flip mod 8 . fromFFlag)
                        . Set.toAscList
                  )
                    . (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)
                )
                [0 .. fromFFlag (Set.findMax ks) `div` 8]

fromS2K :: S2K -> ByteString
fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo]
fromS2K (Salted hashalgo salt) =
    BL.pack [1, fromIntegral . fromFVal $ hashalgo]
        `BL.append` (BL.fromStrict . unSalt8) salt
fromS2K (IteratedSalted hashalgo salt count) =
    BL.pack [3, fromIntegral . fromFVal $ hashalgo]
        `BL.append` (BL.fromStrict . unSalt8) salt
        `BL.snoc` encodeIterationCount count
fromS2K (Argon2 salt t p encodedM) =
    BL.pack [4]
        `BL.append` (BL.fromStrict . unSalt16) salt
        `BL.append` BL.pack [t, p, encodedM]
fromS2K (OtherS2K _ bs) = bs

getPacketLength :: Get Integer
getPacketLength = do
    firstOctet <- getWord8
    lenOrPartial <- lengthOctetToLength firstOctet
    case lenOrPartial of
        Left _ ->
            fail "Partial body length is invalid in this context"
        Right len -> return len
  where
    lengthOctetToLength :: Word8 -> Get (Either Integer Integer)
    lengthOctetToLength f
        | f < 192 = return . Right . fromIntegral $ f
        | f < 224 = do
            secondOctet <- getWord8
            return . Right . fromIntegral $
                shiftL (fromIntegral (f - 192) :: Int) 8
                    + (fromIntegral secondOctet :: Int)
                    + 192
        | f < 255 =
            return . Left . fromIntegral $
                (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)
        | otherwise = do
            len <- getWord32be
            return . Right . fromIntegral $ len

putPacketLength :: Integer -> Put
putPacketLength l
    | l < 192 = putWord8 (fromIntegral l)
    | l < 8384 =
        putWord8
            (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))
            >> putWord8 (fromIntegral (l - 192) .&. 0xff)
    | l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)
    | otherwise =
        error "packet length exceeds 32-bit definite length encoding"

putPartialLength :: Word8 -> Put
putPartialLength n = putWord8 (224 + n)

getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64)
getPacketLengthFromOctet f
    | f < 192 = return . Right . fromIntegral $ f
    | f < 224 = do
        secondOctet <- getWord8
        return . Right . fromIntegral $
            shiftL (fromIntegral (f - 192) :: Int) 8
                + (fromIntegral secondOctet :: Int)
                + 192
    | f < 255 =
        return . Left . fromIntegral $
            (1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)
    | otherwise = do
        len <- getWord32be
        return . Right . fromIntegral $ len

getS2K :: Get S2K
getS2K = getS2K' =<< getWord8
  where
    getS2K' :: Word8 -> Get S2K
    getS2K' t
        | t == 0 = do
            ha <- getWord8
            return $ Simple (toFVal ha)
        | t == 1 = do
            ha <- getWord8
            salt <- getByteString 8
            return $ Salted (toFVal ha) (Salt8 salt)
        | t == 3 = do
            ha <- getWord8
            salt <- getByteString 8
            count <- getWord8
            return $
                IteratedSalted
                    (toFVal ha)
                    (Salt8 salt)
                    (decodeIterationCount count)
        | t == 4 = do
            salt <- getByteString 16
            passes <- getWord8
            parallelism <- getWord8
            encodedM <- getWord8
            return $ Argon2 (Salt16 salt) passes parallelism encodedM
        | otherwise = do
            bs <- getRemainingLazyByteString
            return $ OtherS2K t bs

putS2K :: S2K -> Put
putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo)
putS2K (Salted hashalgo salt) =
    error
        ("confused by salted" ++ show hashalgo ++ " by " ++ show salt)
putS2K (IteratedSalted ha salt count) = do
    putWord8 3
    put ha
    putByteString (unSalt8 salt)
    putWord8 $ encodeIterationCount count
putS2K (Argon2 salt t p encodedM) = do
    putWord8 4
    putByteString (unSalt16 salt)
    putWord8 t
    putWord8 p
    putWord8 encodedM
putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs

v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8
v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm

getPacketTypeAndPayload :: Get (Word8, ByteString)
getPacketTypeAndPayload = do
    tag <- getWord8
    guard (testBit tag 7)
    case tag .&. 0x40 of
        0x00 -> do
            let t = shiftR (tag .&. 0x3c) 2
            case tag .&. 0x03 of
                0 -> do
                    len <- getWord8
                    bs <- getLazyByteString (fromIntegral len)
                    return (t, bs)
                1 -> do
                    len <- getWord16be
                    bs <- getLazyByteString (fromIntegral len)
                    return (t, bs)
                2 -> do
                    len <- getWord32be
                    bs <- getLazyByteString (fromIntegral len)
                    return (t, bs)
                3 -> do
                    bs <- getRemainingLazyByteString
                    return (t, bs)
                _ ->
                    error "This should never happen (getPacketTypeAndPayload/0x00)."
        0x40 -> do
            firstLenOctet <- getWord8
            bs <- getPacketPayloadFromLengthOctet firstLenOctet
            return (tag .&. 0x3f, bs)
        _ ->
            error "This should never happen (getPacketTypeAndPayload/???)."
  where
    getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString
    getPacketPayloadFromLengthOctet lenOctet = do
        lenOrPartial <- getPacketLengthFromOctet lenOctet
        case lenOrPartial of
            Right len -> getLazyByteString len
            Left partialLen -> do
                chunk <- getLazyByteString partialLen
                rest <- getRemainingPartialPayload
                return (chunk <> rest)
    getRemainingPartialPayload :: Get ByteString
    getRemainingPartialPayload = do
        lenOctet <- getWord8
        lenOrPartial <- getPacketLengthFromOctet lenOctet
        case lenOrPartial of
            Right len -> getLazyByteString len
            Left partialLen -> do
                chunk <- getLazyByteString partialLen
                (chunk <>) <$> getRemainingPartialPayload

getPkt :: Get Pkt
getPkt = do
    (t, pl) <- getPacketTypeAndPayload
    case runGetOrFail (getPkt' t (BL.length pl)) pl of
        Left (_, _, e) -> return $! BrokenPacketPkt e t pl
        Right (_, _, p) -> return p
  where
    parseLegacyPKESK
        :: PacketVersion -> BL.ByteString -> Either String Pkt
    parseLegacyPKESK pv body = do
        (_, _, (eokeyid, pkaRaw, mpib)) <-
            bimap (\(_, _, e) -> e) id $
                runGetOrFail
                    ( do
                        eokeyid <- getLazyByteString 8
                        pka <- getWord8
                        mpib <- getRemainingLazyByteString
                        pure (eokeyid, pka, mpib)
                    )
                    body
        let pka = toFVal pkaRaw
        sk <- parseLegacyPKESKMPIs pka mpib
        pure $
            PKESKPkt
                ( PKESKPayloadV3Packet
                    (PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk)
                )

    parseLegacyPKESKMPIs
        :: PubKeyAlgorithm
        -> BL.ByteString
        -> Either String (NE.NonEmpty MPI)
    parseLegacyPKESKMPIs pka mpib = do
        case parseLegacyPKESKMPIsStrict pka mpib of
            Right sk -> pure sk
            Left strictErr
                | pka == X25519 ->
                    case parseLegacyPKESKX25519V3Octets mpib of
                        Right sk -> Right sk
                        Left octetErr ->
                            Left
                                ( strictErr
                                    ++ "; also failed to parse RFC9580 X25519 v3 octet layout: "
                                    ++ octetErr
                                )
                | pka == ECDH ->
                    case parseLegacyPKESKECDHOctets mpib of
                        Right sk -> Right sk
                        Left octetErr ->
                            Left
                                ( strictErr
                                    ++ "; also failed to parse RFC6637 ECDH v3 octet layout: "
                                    ++ octetErr
                                )
                | otherwise -> Left strictErr

    parseLegacyPKESKMPIsStrict
        :: PubKeyAlgorithm
        -> BL.ByteString
        -> Either String (NE.NonEmpty MPI)
    parseLegacyPKESKMPIsStrict pka mpib = do
        (rest, _, sk) <-
            bimap (\(_, _, e) -> e) id $
                runGetOrFail (parserForLegacyPKESKMPIs pka) mpib
        if BL.null rest
            then pure (NE.fromList sk)
            else
                Left
                    ("unexpected trailing PKESK MPI data for algorithm " ++ show pka)

    parseLegacyPKESKX25519V3Octets
        :: BL.ByteString -> Either String (NE.NonEmpty MPI)
    parseLegacyPKESKX25519V3Octets mpib = do
        if BL.length mpib < 33
            then Left "X25519 v3 PKESK octet layout is too short"
            else Right ()
        let ephemeral = BL.toStrict (BL.take 32 mpib)
            eskLen = fromIntegral (BL.index mpib 32) :: Int
            eskWithAlgo = BL.toStrict (BL.drop 33 mpib)
        if eskLen /= B.length eskWithAlgo
            then
                Left "X25519 v3 PKESK octet layout has inconsistent ESK length"
            else Right ()
        if B.null eskWithAlgo
            then
                Left
                    "X25519 v3 PKESK octet layout must include a symmetric algorithm octet"
            else Right ()
        let symAlgo = B.head eskWithAlgo
        if symAlgo
            `elem` [ fromIntegral (fromFVal AES128)
                   , fromIntegral (fromFVal AES192)
                   , fromIntegral (fromFVal AES256)
                   ]
            then
                pure
                    (NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)])
            else
                Left
                    ( "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "
                        ++ show symAlgo
                    )

    -- \| Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C.
    -- This is the interoperable wire format produced by GnuPG and other RFC-compliant
    -- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback
    -- allows reading RFC-compliant packets when the strict two-MPI path fails.
    parseLegacyPKESKECDHOctets
        :: BL.ByteString -> Either String (NE.NonEmpty MPI)
    parseLegacyPKESKECDHOctets mpib = do
        (rest, _, ephMPI) <-
            bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib
        let restBS = BL.toStrict rest
        when (B.null restBS) $
            Left
                "ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI"
        let wrappedLen = fromIntegral (B.head restBS) :: Int
            wrapped = B.tail restBS
        when (wrappedLen /= B.length wrapped) $
            Left
                ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field "
                    ++ show wrappedLen
                    ++ " does not match body length "
                    ++ show (B.length wrapped)
                )
        when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $
            Left
                ( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length "
                    ++ show wrappedLen
                    ++ " is not a valid RFC 3394 wrapped key size"
                )
        pure (ephMPI NE.:| [MPI (os2ip wrapped)])

    parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI]
    parserForLegacyPKESKMPIs pka =
        case expectedLegacyPKESKMPIArity pka of
            Just mpiCount -> replicateM mpiCount getMPI
            Nothing -> some getMPI

    expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int
    expectedLegacyPKESKMPIArity pka
        | pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1
        | pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] =
            Just 2
        | otherwise = Nothing

    validateV4SKESKEncryptedSessionKeyS2K
        :: S2K -> Maybe BL.ByteString -> Get ()
    validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure ()
    validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) =
        fail
            "v4 SKESK packets with encrypted session keys must not use Simple S2K"
    validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure ()

    parseV6PKESK :: BL.ByteString -> Either String Pkt
    parseV6PKESK body = do
        (_, _, (recipientKeyIdentifier, pka, esk)) <-
            bimap (\(_, _, e) -> e) id $
                runGetOrFail
                    ( do
                        keyIdentifierLen <- getWord8
                        recipientKeyIdentifier <-
                            getLazyByteString (fromIntegral keyIdentifierLen)
                        pka <- getWord8
                        esk <- getRemainingLazyByteString
                        pure (recipientKeyIdentifier, pka, esk)
                    )
                    body
        validateV6PKESKRecipientIdentifier recipientKeyIdentifier
        pure $
            PKESKPkt
                ( PKESKPayloadV6Packet
                    (PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk)
                )
      where
        validateV6PKESKRecipientIdentifier
            :: BL.ByteString -> Either String ()
        validateV6PKESKRecipientIdentifier rid =
            case BL.length rid of
                0 -> Right ()
                20 -> Right ()
                32 -> Right ()
                21 -> validateVersionedFingerprint rid
                33 -> validateVersionedFingerprint rid
                ridLen ->
                    Left
                        ( "invalid PKESK v6 recipient identifier length: "
                            ++ show ridLen
                            ++ " (expected 0, 20, 21, 32, or 33)"
                        )

        validateVersionedFingerprint :: BL.ByteString -> Either String ()
        validateVersionedFingerprint rid =
            let keyVersion = BL.head rid
                fingerprintLen = BL.length (BL.tail rid)
             in case keyVersion of
                    4 ->
                        if fingerprintLen == 20
                            then Right ()
                            else
                                Left
                                    ( "PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got "
                                        ++ show fingerprintLen
                                    )
                    6 ->
                        if fingerprintLen == 32
                            then Right ()
                            else
                                Left
                                    ( "PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got "
                                        ++ show fingerprintLen
                                    )
                    _ ->
                        Left
                            ( "invalid PKESK v6 recipient key version: "
                                ++ show keyVersion
                                ++ " (expected 4 or 6)"
                            )

    getPkt' :: Word8 -> ByteOffset -> Get Pkt
    getPkt' t len = case t of
        1 -> getPKESK
        2 -> SignaturePkt <$> get
        3 -> getSKESK
        4 -> getOPS
        5 -> getSecretKey len
        6 -> PublicKeyPkt <$> getPKPayload
        7 -> getSecretSubkey len
        8 -> getCompressedData len
        9 -> SymEncDataPkt <$> getLazyByteString len
        10 -> MarkerPkt <$> getLazyByteString len
        11 -> getLiteralData len
        12 -> TrustPkt <$> getLazyByteString len
        13 ->
            UserIdPkt . decodeUtf8With lenientDecode
                <$> getByteString (fromIntegral len)
        14 -> getPublicSubkey len
        17 -> getPublicAttribute len
        18 -> getSEIPD len
        19 -> ModificationDetectionCodePkt <$> getLazyByteString 20
        21 -> PaddingPkt <$> getLazyByteString len
        _ -> OtherPacketPkt t <$> getLazyByteString len

    getPKESK :: Get Pkt
    getPKESK = do
        pv <- getWord8
        body <- getRemainingLazyByteString
        if pv == 6
            then case parseV6PKESK body of
                Right pkt -> return pkt
                Left err -> fail err
            else case parseLegacyPKESK pv body of
                Right pkt -> return pkt
                Left err -> fail err

    getSKESK :: Get Pkt
    getSKESK = do
        pv <- getWord8
        if pv == 6
            then getSKESKV6
            else
                if pv == 4
                    then getSKESKV4
                    else fail ("unsupported SKESK packet version " ++ show pv)
      where
        getSKESKV6 = do
            let getV6SKESKParams = do
                    symalgoWord <- getWord8
                    aeadWord <- getWord8
                    s2kLen <- getWord8
                    s2kBytes <- getLazyByteString (fromIntegral s2kLen)
                    s2k <-
                        case runGetOrFail getS2K s2kBytes of
                            Left (_, _, err) -> fail err
                            Right (rest, _, parsed)
                                | not (BL.null rest) ->
                                    fail "unexpected trailing bytes in v6 SKESK S2K specifier"
                                | otherwise -> pure parsed
                    let symalgo = toFVal symalgoWord
                        aead = toFVal aeadWord
                        ivLen = fromIntegral (aeadNonceSize aead)
                    iv <- getLazyByteString ivLen
                    pure (symalgo, aead, s2k, iv)
            paramsLen <- getWord8
            params <- getLazyByteString (fromIntegral paramsLen)
            (symalgo, aead, s2k, iv) <-
                case runGetOrFail getV6SKESKParams params of
                    Left (_, _, err) -> fail err
                    Right (rest, _, parsed)
                        | not (BL.null rest) ->
                            fail "unexpected trailing v6 SKESK parameters"
                        | otherwise -> pure parsed
            payload <- getRemainingLazyByteString
            when (BL.length payload < 16) $
                fail
                    "v6 SKESK payload must include encrypted session key and authentication tag"
            let (esk, tag) = BL.splitAt (BL.length payload - 16) payload
            return $
                SKESKPkt
                    ( SKESKPayloadV6Packet
                        ( SKESKPayloadV6
                            symalgo
                            aead
                            s2k
                            iv
                            esk
                            tag
                        )
                    )
        getSKESKV4 = do
            symalgo <- getWord8
            s2k <- getS2K
            esk <- getRemainingLazyByteString
            let mesk = if BL.null esk then Nothing else Just esk
            validateV4SKESKEncryptedSessionKeyS2K s2k mesk
            return $
                SKESKPkt
                    ( SKESKPayloadV4Packet
                        ( SKESKPayloadV4
                            (toFVal symalgo)
                            s2k
                            mesk
                        )
                    )

    getOPS :: Get Pkt
    getOPS = do
        pv <- getWord8
        sigtype <- toFVal <$> getWord8
        ha <- toFVal <$> getWord8
        pka <- toFVal <$> getWord8
        case pv of
            3 -> getOPSV3 pv sigtype ha pka
            6 -> getOPSV6 pv sigtype ha pka
            _ -> fail ("Unsupported OPS version: " ++ show pv)
      where
        getOPSV3
            :: PacketVersion
            -> SigType
            -> HashAlgorithm
            -> PubKeyAlgorithm
            -> Get Pkt
        getOPSV3 pv sigtype ha pka = do
            skeyid <- getLazyByteString 8
            nested <- getWord8 >>= parseOPSNestedFlag
            return $
                OnePassSignaturePkt
                    ( OPSPayloadV3Packet
                        ( OPSPayloadV3
                            pv
                            sigtype
                            ha
                            pka
                            (EightOctetKeyId skeyid)
                            nested
                        )
                    )
        getOPSV6
            :: PacketVersion
            -> SigType
            -> HashAlgorithm
            -> PubKeyAlgorithm
            -> Get Pkt
        getOPSV6 pv sigtype ha pka = do
            saltSize <- getWord8
            expectedSaltSize <-
                maybe
                    ( fail
                        ( "signature hash algorithm does not define a V6 salt size: "
                            ++ show ha
                        )
                    )
                    pure
                    (v6SaltSizeForHashAlgorithm ha)
            when (saltSize /= expectedSaltSize) $
                fail
                    ( "OPS v6 salt size mismatch for "
                        ++ show ha
                        ++ ": expected "
                        ++ show expectedSaltSize
                        ++ ", got "
                        ++ show saltSize
                    )
            salt <-
                SignatureSalt <$> getLazyByteString (fromIntegral saltSize)
            signerFingerprint <- getLazyByteString 32
            nested <- getWord8 >>= parseOPSNestedFlag
            return $
                OnePassSignaturePkt
                    ( OPSPayloadV6Packet
                        ( OPSPayloadV6
                            sigtype
                            ha
                            pka
                            salt
                            signerFingerprint
                            nested
                        )
                    )

    getSecretKey :: ByteOffset -> Get Pkt
    getSecretKey len = do
        bs <- getLazyByteString len
        case runGetOrFail getSecretKeyParser bs of
            Left (_, _, err) -> fail ("secret key " ++ err)
            Right (_, _, pkt) -> return pkt
      where
        getSecretKeyParser = do
            pkp <- getPKPayload
            ska <- getSKAddendum pkp
            return $ SecretKeyPkt pkp ska

    getSecretSubkey :: ByteOffset -> Get Pkt
    getSecretSubkey len = do
        bs <- getLazyByteString len
        case runGetOrFail getSecretSubkeyParser bs of
            Left (_, _, err) -> fail ("secret subkey " ++ err)
            Right (_, _, pkt) -> return pkt
      where
        getSecretSubkeyParser = do
            pkp <- getPKPayload
            ska <- getSKAddendum pkp
            return $ SecretSubkeyPkt pkp ska

    getCompressedData :: ByteOffset -> Get Pkt
    getCompressedData len = do
        ca <- getWord8
        cdata <- getLazyByteString (len - 1)
        return $ CompressedDataPkt (toFVal ca) cdata

    getLiteralData :: ByteOffset -> Get Pkt
    getLiteralData len = do
        dt <- getWord8
        flen <- getWord8
        fn <- getLazyByteString (fromIntegral flen)
        ts <- fmap ThirtyTwoBitTimeStamp getWord32be
        ldata <- getLazyByteString (len - (6 + fromIntegral flen))
        return $ LiteralDataPkt (toFVal dt) fn ts ldata

    getPublicSubkey :: ByteOffset -> Get Pkt
    getPublicSubkey len = do
        bs <- getLazyByteString len
        case runGetOrFail getPublicSubkeyParser bs of
            Left (_, _, err) -> fail ("public subkey " ++ err)
            Right (_, _, pkt) -> return pkt
      where
        getPublicSubkeyParser = do
            pkp <- getPKPayload
            return $ PublicSubkeyPkt pkp

    getPublicAttribute :: ByteOffset -> Get Pkt
    getPublicAttribute len = do
        bs <- getLazyByteString len
        case runGetOrFail (many getUserAttrSubPacket) bs of
            Left (_, _, err) -> fail ("user attribute " ++ err)
            Right (_, _, uas) -> return $ UserAttributePkt uas

    getSEIPD :: ByteOffset -> Get Pkt
    getSEIPD len = do
        pv <- getWord8
        case pv of
            1 -> do
                b <- getLazyByteString (len - 1)
                return $ SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)
            2 -> do
                when (len < 36) $
                    fail "SEIPD v2 packet too short"
                symalgo <- toFVal <$> getWord8
                aeadalgo <- toFVal <$> getWord8
                chunkSize <- getWord8
                salt <- Salt <$> getByteString 32
                encrypted <- getLazyByteString (len - 36)
                validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted
                return $
                    SymEncIntegrityProtectedDataPkt
                        ( SEIPD2
                            symalgo
                            aeadalgo
                            chunkSize
                            salt
                            encrypted
                        )
            _ -> fail ("Unsupported SEIPD version: " ++ show pv)

getUserAttrSubPacket :: Get UserAttrSubPacket
getUserAttrSubPacket = do
    l <- fmap fromIntegral getSubPacketLength
    t <- getWord8
    getUserAttrSubPacket' t l
  where
    getUserAttrSubPacket'
        :: Word8 -> ByteOffset -> Get UserAttrSubPacket
    getUserAttrSubPacket' t l
        | t == 1 = do
            _ <- getWord16le -- ihlen
            hver <- getWord8 -- should be 1
            iformat <- getWord8
            nuls <- getLazyByteString 12 -- should be NULs
            bs <- getLazyByteString (l - 17)
            if hver /= 1 || nuls /= BL.pack (replicate 12 0)
                then fail "Corrupt UAt subpacket"
                else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs
        | otherwise = do
            bs <- getLazyByteString (l - 1)
            return $ OtherUASub t bs

putUserAttrSubPacket :: UserAttrSubPacket -> Put
putUserAttrSubPacket ua = do
    let sp = runPut $ putUserAttrSubPacket' ua
    putSubPacketLength . fromIntegral . BL.length $ sp
    putLazyByteString sp
  where
    putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do
        putWord8 1
        putWord16le 16
        putWord8 1
        putWord8 (fromFVal iformat)
        replicateM_ 12 $ putWord8 0
        putLazyByteString idata
    putUserAttrSubPacket' (OtherUASub t bs) = do
        putWord8 t
        putLazyByteString bs

{- | Serialize PKESKv3 session-key material.
For ECDH and X25519 the RFC 6637 §8 / RFC 9580 §5.1.6 wire format is used:
MPI(ephemeral_key) || 1-octet-count || wrapped_session_key_bytes.
All other algorithms use the standard MPI sequence.
-}
putPKESKv3SessionKeyMaterial
    :: PubKeyAlgorithm -> NE.NonEmpty MPI -> Put
putPKESKv3SessionKeyMaterial pka mpis
    | pka `elem` [ECDH, X25519]
    , (ephMPI NE.:| [wrappedMPI]) <- mpis = do
        put ephMPI
        let rawWrapped = i2osp (unMPI wrappedMPI)
            -- Left-pad to the nearest valid RFC 3394 wrapped-key length so that
            -- leading-zero bytes stripped by i2osp are restored.
            targetLen =
                headDef
                    (B.length rawWrapped)
                    (filter (>= B.length rawWrapped) [32, 40, 48])
            paddedWrapped = leftPadTo targetLen rawWrapped
        putWord8 (fromIntegral (B.length paddedWrapped))
        putByteString paddedWrapped
    | otherwise = F.mapM_ put mpis
  where
    headDef d [] = d
    headDef _ (x : _) = x

putPkt :: Pkt -> Put
putPkt pkt = case pkt of
    PKESKPkt (PKESKPayloadV3Packet payload) -> putPKESKV3 payload
    PKESKPkt (PKESKPayloadV6Packet payload) -> putPKESKV6 payload
    SignaturePkt sp -> putSignature sp
    SKESKPkt (SKESKPayloadV4Packet payload) -> putSKESKV4 payload
    SKESKPkt (SKESKPayloadV6Packet payload) -> putSKESKV6 payload
    OnePassSignaturePkt (OPSPayloadV3Packet payload) -> putOPSV3 payload
    OnePassSignaturePkt (OPSPayloadV6Packet payload) -> putOPSV6 payload
    SecretKeyPkt pkp ska -> putSecretKey pkp ska
    PublicKeyPkt pkp -> putPublicKey pkp
    SecretSubkeyPkt pkp ska -> putSecretSubkey pkp ska
    CompressedDataPkt ca cdata -> putCompressedData ca cdata
    SymEncDataPkt b -> putSymEncData b
    MarkerPkt b -> putMarker b
    LiteralDataPkt dt fn ts b -> putLiteralData dt fn ts b
    TrustPkt b -> putTrust b
    UserIdPkt u -> putUserId u
    PublicSubkeyPkt pkp -> putPublicSubkey pkp
    UserAttributePkt us -> putUserAttribute us
    SymEncIntegrityProtectedDataPkt (SEIPD1 pv b) -> putSEIPDV1 pv b
    SymEncIntegrityProtectedDataPkt
        (SEIPD2 symalgo aeadalgo chunkSize salt b) -> putSEIPDV2 symalgo aeadalgo chunkSize salt b
    ModificationDetectionCodePkt hash -> putModificationDetectionCode hash
    PaddingPkt padding -> putPadding padding
    OtherPacketPkt t payload -> putOtherPacket t payload
    BrokenPacketPkt _ t payload -> putOtherPacket t payload

putPKESKV3 :: PKESKPayloadV3 -> Put
putPKESKV3 (PKESKPayloadV3 _pv eokeyid pka mpis) = do
    putWord8 (0xc0 .|. 1)
    let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis
    putPacketLength . fromIntegral $ 10 + BL.length bsk
    putWord8 3
    putLazyByteString (unEOKI eokeyid)
    putWord8 $ fromIntegral . fromFVal $ pka
    putLazyByteString bsk

putPKESKV6 :: PKESKPayloadV6 -> Put
putPKESKV6 (PKESKPayloadV6 recipientKeyIdentifier pka esk) = do
    putWord8 (0xc0 .|. 1)
    let keyIdentifierLen = BL.length recipientKeyIdentifier
    when (keyIdentifierLen > 255) $
        error "PKESK v6 recipient key identifier must fit in one octet"
    putPacketLength . fromIntegral $
        3 + keyIdentifierLen + BL.length esk
    putWord8 6
    putWord8 (fromIntegral keyIdentifierLen)
    putLazyByteString recipientKeyIdentifier
    putWord8 $ fromIntegral . fromFVal $ pka
    putLazyByteString esk

putSignature :: SignaturePayload -> Put
putSignature sp = do
    putWord8 (0xc0 .|. 2)
    let bs = runPut $ put sp
    putLengthThenPayload bs

putSKESKV4 :: SKESKPayloadV4 -> Put
putSKESKV4 (SKESKPayloadV4 symalgo s2k mesk) = do
    putWord8 (0xc0 .|. 3)
    let bs2k = fromS2K s2k
    let bsk = fromMaybe BL.empty mesk
    putPacketLength . fromIntegral $
        2 + BL.length bs2k + BL.length bsk
    putWord8 4
    putWord8 $ fromIntegral . fromFVal $ symalgo
    putLazyByteString bs2k
    putLazyByteString bsk

putSKESKV6 :: SKESKPayloadV6 -> Put
putSKESKV6 (SKESKPayloadV6 symalgo aead s2k iv esk tag) = do
    putWord8 (0xc0 .|. 3)
    let bs2k = fromS2K s2k
    let params =
            BL.pack
                [ fromIntegral (fromFVal symalgo)
                , fromIntegral (fromFVal aead)
                , fromIntegral (BL.length bs2k)
                ]
                <> bs2k
                <> iv
    putPacketLength . fromIntegral $
        2 + BL.length params + BL.length esk + BL.length tag
    putWord8 6
    putWord8 (fromIntegral (BL.length params))
    putLazyByteString params
    putLazyByteString esk
    putLazyByteString tag

putOPSV3 :: OPSPayloadV3 -> Put
putOPSV3 (OPSPayloadV3 pv sigtype ha pka skeyid nested) = do
    putWord8 (0xc0 .|. 4)
    let bs =
            runPut $ do
                putWord8 pv
                putWord8 $ fromIntegral . fromFVal $ sigtype
                putWord8 $ fromIntegral . fromFVal $ ha
                putWord8 $ fromIntegral . fromFVal $ pka
                putLazyByteString (unEOKI skeyid)
                putWord8 . fromIntegral . fromEnum $ not nested
    putLengthThenPayload bs

putOPSV6 :: OPSPayloadV6 -> Put
putOPSV6 (OPSPayloadV6 sigtype ha pka salt signerFingerprint nested) = do
    putWord8 (0xc0 .|. 4)
    let saltBytes = unSignatureSalt salt
        saltSize = BL.length saltBytes
        expectedSaltSize =
            maybe
                ( error
                    ( "signature hash algorithm does not define a V6 salt size: "
                        ++ show ha
                    )
                )
                id
                (v6SaltSizeForHashAlgorithm ha)
    when (fromIntegral saltSize /= expectedSaltSize) $
        error
            ( "OPS v6 salt size mismatch for "
                ++ show ha
                ++ ": expected "
                ++ show expectedSaltSize
                ++ ", got "
                ++ show saltSize
            )
    when (BL.length signerFingerprint /= 32) $
        error "OPS v6 signer fingerprint must be exactly 32 octets"
    let bs =
            runPut $ do
                putWord8 6
                putWord8 $ fromIntegral . fromFVal $ sigtype
                putWord8 $ fromIntegral . fromFVal $ ha
                putWord8 $ fromIntegral . fromFVal $ pka
                putWord8 (fromIntegral saltSize)
                putLazyByteString saltBytes
                putLazyByteString signerFingerprint
                putWord8 . fromIntegral . fromEnum $ not nested
    putLengthThenPayload bs

putSecretKey :: SomePKPayload -> SKAddendum -> Put
putSecretKey pkp ska = do
    putWord8 (0xc0 .|. 5)
    let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)
    putLengthThenPayload bs

putPublicKey :: SomePKPayload -> Put
putPublicKey pkp = do
    putWord8 (0xc0 .|. 6)
    let bs = runPut $ putPKPayload pkp
    putLengthThenPayload bs

putSecretSubkey :: SomePKPayload -> SKAddendum -> Put
putSecretSubkey pkp ska = do
    putWord8 (0xc0 .|. 7)
    let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)
    putLengthThenPayload bs

putCompressedData :: CompressionAlgorithm -> BL.ByteString -> Put
putCompressedData ca cdata = do
    putWord8 (0xc0 .|. 8)
    let bs =
            runPut $ do
                putWord8 $ fromIntegral . fromFVal $ ca
                putLazyByteString cdata
    putLengthThenPayload bs

putSymEncData :: BL.ByteString -> Put
putSymEncData b = do
    putWord8 (0xc0 .|. 9)
    putLengthThenPayload b

putMarker :: BL.ByteString -> Put
putMarker b = do
    putWord8 (0xc0 .|. 10)
    putLengthThenPayload b

putLiteralData
    :: LiteralDataType
    -> FileName
    -> ThirtyTwoBitTimeStamp
    -> BL.ByteString
    -> Put
putLiteralData dt fn ts b = do
    putWord8 (0xc0 .|. 11)
    let bs =
            runPut $ do
                putWord8 $ fromIntegral . fromFVal $ dt
                putWord8 $ fromIntegral . BL.length $ fn
                putLazyByteString fn
                putWord32be . unThirtyTwoBitTimeStamp $ ts
                putLazyByteString b
    putLengthThenPayload bs

putTrust :: BL.ByteString -> Put
putTrust b = do
    putWord8 (0xc0 .|. 12)
    putLengthThenPayload b

putUserId :: Text -> Put
putUserId u = do
    putWord8 (0xc0 .|. 13)
    let bs = encodeUtf8 u
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs

putPublicSubkey :: SomePKPayload -> Put
putPublicSubkey pkp = do
    putWord8 (0xc0 .|. 14)
    let bs = runPut $ putPKPayload pkp
    putLengthThenPayload bs

putUserAttribute :: [UserAttrSubPacket] -> Put
putUserAttribute us = do
    putWord8 (0xc0 .|. 17)
    let bs = runPut $ mapM_ put us
    putLengthThenPayload bs

putSEIPDV1 :: Word8 -> BL.ByteString -> Put
putSEIPDV1 pv b = do
    putWord8 (0xc0 .|. 18)
    putPacketLength . fromIntegral $ BL.length b + 1
    putWord8 pv
    putLazyByteString b

putSEIPDV2
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> Salt
    -> BL.ByteString
    -> Put
putSEIPDV2 symalgo aeadalgo chunkSize salt b = do
    when (B.length (unSalt salt) /= 32) $
        error "SEIPD v2 salt must be exactly 32 octets"
    when (chunkSize > 16) $
        error "SEIPD v2 chunk size octet must be between 0 and 16"
    case symalgo of
        OtherSA _ -> error "SEIPD v2 requires a known symmetric algorithm"
        Plaintext -> error "SEIPD v2 cannot use plaintext cipher"
        _ -> return ()
    case aeadalgo of
        OtherAEADAlgo _ -> error "SEIPD v2 requires a known AEAD algorithm"
        _ -> return ()
    putWord8 (0xc0 .|. 18)
    putPacketLength . fromIntegral $ BL.length b + 36
    putWord8 2
    putWord8 (fromFVal symalgo)
    putWord8 (fromFVal aeadalgo)
    putWord8 chunkSize
    putByteString (unSalt salt)
    putLazyByteString b

putModificationDetectionCode :: BL.ByteString -> Put
putModificationDetectionCode hash = do
    putWord8 (0xc0 .|. 19)
    putLengthThenPayload hash

putPadding :: BL.ByteString -> Put
putPadding padding = do
    putWord8 (0xc0 .|. 21)
    putLengthThenPayload padding

putOtherPacket :: Word8 -> BL.ByteString -> Put
putOtherPacket t payload = do
    when (t > 63) $
        error
            ("cannot serialize OtherPacket packet tag > 63: " ++ show t)
    putWord8 (0xc0 .|. t)
    putLengthThenPayload payload

{- | Validate a packet before serialization to catch constraint violations early.
Returns Left with descriptive error if validation fails.
-}
validatePkt :: Pkt -> Either String ()
validatePkt
    ( PKESKPkt
            (PKESKPayloadV6Packet (PKESKPayloadV6 recipientKeyIdentifier _ _))
        ) = do
        let keyIdentifierLen = BL.length recipientKeyIdentifier
        when (keyIdentifierLen > 255) $
            Left
                "PKESK v6 recipient key identifier must fit in one octet (max 255 bytes)"
        Right ()
validatePkt
    ( OnePassSignaturePkt
            (OPSPayloadV6Packet (OPSPayloadV6 _ ha _ salt signerFingerprint _))
        ) = do
        let saltBytes = unSignatureSalt salt
            saltSize = BL.length saltBytes
        expectedSaltSize <-
            case v6SaltSizeForHashAlgorithm ha of
                Nothing ->
                    Left $
                        "signature hash algorithm does not define a V6 salt size: "
                            ++ show ha
                Just sz -> Right sz
        when (fromIntegral saltSize /= expectedSaltSize) $
            Left
                ( "OPS v6 salt size mismatch for "
                    ++ show ha
                    ++ ": expected "
                    ++ show expectedSaltSize
                    ++ ", got "
                    ++ show saltSize
                )
        when (BL.length signerFingerprint /= 32) $
            Left "OPS v6 signer fingerprint must be exactly 32 octets"
        Right ()
validatePkt
    ( SymEncIntegrityProtectedDataPkt
            (SEIPD2 symalgo aeadalgo chunkSize salt _)
        ) = do
        when (B.length (unSalt salt) /= 32) $
            Left "SEIPD v2 salt must be exactly 32 octets"
        when (chunkSize > 16) $
            Left "SEIPD v2 chunk size octet must be between 0 and 16"
        case symalgo of
            OtherSA _ -> Left "SEIPD v2 requires a known symmetric algorithm"
            Plaintext -> Left "SEIPD v2 cannot use plaintext cipher"
            _ -> Right ()
        case aeadalgo of
            OtherAEADAlgo _ -> Left "SEIPD v2 requires a known AEAD algorithm"
            _ -> Right ()
validatePkt (OtherPacketPkt t _) = do
    when (t > 63) $
        Left ("cannot serialize OtherPacket packet tag > 63: " ++ show t)
    Right ()
validatePkt _ = Right ()

{- | Serialize a packet with explicit validation and error handling.
Validates constraints before calling putPkt to ensure errors are caught early.
-}
putPktEither :: Pkt -> Either String Put
putPktEither pkt = case validatePkt pkt of
    Left err -> Left err
    Right () -> Right (putPkt pkt)

putLengthThenPayload :: ByteString -> Put
putLengthThenPayload bs = do
    let len = BL.length bs
    if len < fromIntegral (0x100000000 :: Integer)
        then do
            putPacketLength (fromIntegral len)
            putLazyByteString bs
        else putPartialLengthPayload bs
  where
    putPartialLengthPayload :: ByteString -> Put
    putPartialLengthPayload payload = do
        leftover <- iterateUntilM done emitChunk payload
        putPacketLength (fromIntegral (BL.length leftover))
        putLazyByteString leftover
      where
        maxPartialChunkSize :: Int64
        maxPartialChunkSize = 1 `shiftL` (30 :: Int)
        done :: ByteString -> Bool
        done p = BL.length p <= maxPartialChunkSize
        emitChunk p = do
            let (chunk, rest) = BL.splitAt maxPartialChunkSize p
            putPartialLength 30
            putLazyByteString chunk
            return rest

validateSEIPDv2Header
    :: SymmetricAlgorithm
    -> AEADAlgorithm
    -> Word8
    -> ByteString
    -> Get ()
validateSEIPDv2Header symalgo aeadalgo chunkSize encrypted = do
    when (chunkSize > 16) $
        fail "SEIPD v2 chunk size octet must be between 0 and 16"
    when (BL.null encrypted) $
        fail
            "SEIPD v2 payload is missing encrypted data and final authentication tag"
    case symalgo of
        OtherSA _ -> fail "SEIPD v2 requires a known symmetric algorithm"
        Plaintext -> fail "SEIPD v2 cannot use plaintext cipher"
        _ -> return ()
    case aeadalgo of
        OtherAEADAlgo _ -> fail "SEIPD v2 requires a known AEAD algorithm"
        _ -> return ()

getMPI :: Get MPI
getMPI = do
    mpilen <- getWord16be
    bs <- getByteString (fromIntegral (mpilen + 7) `div` 8)
    return $ MPI (os2ip bs)

getPubkey :: PubKeyAlgorithm -> Get PKey
getPubkey RSA = do
    MPI n <- get
    MPI e <- get
    return $
        RSAPubKey
            ( RSA_PublicKey
                (R.PublicKey (fromIntegral . B.length . i2osp $ n) n e)
            )
getPubkey DeprecatedRSAEncryptOnly = getPubkey RSA
getPubkey DeprecatedRSASignOnly = getPubkey RSA
getPubkey DSA = do
    MPI p <- get
    MPI q <- get
    MPI g <- get
    MPI y <- get
    return $
        DSAPubKey (DSA_PublicKey (D.PublicKey (D.Params p g q) y))
getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal
getPubkey ForbiddenElgamal = do
    MPI p <- get
    MPI g <- get
    MPI y <- get
    return $ ElGamalPubKey p g y
getPubkey ECDSA = do
    curvelength <- getWord8
    when (curvelength == 0 || curvelength == 0xff) $
        fail "invalid ECC curve OID length octet (reserved value)"
    curveoid <- getByteString (fromIntegral curvelength)
    MPI mpi <- getMPI
    case curveoidBSToCurve curveoid of
        Left e -> fail e
        Right Curve25519 ->
            EdDSAPubKey P.EdSigningCurve25519
                <$> ( PrefixedNativeEPoint
                        <$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi
                    )
        Right curve ->
            case bs2Point (i2osp mpi) of
                Left e -> fail e
                Right point ->
                    return
                        . ECDSAPubKey
                        . ECDSA_PublicKey
                        . ECDSA.PublicKey (curve2Curve curve)
                        $ point
getPubkey ECDH = do
    ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA
    kdflen <- getWord8
    when (kdflen == 0 || kdflen == 0xff) $
        fail "invalid ECDH KDF field length octet (reserved value)"
    when (kdflen /= 3) $
        fail ("invalid ECDH KDF field length: " ++ show kdflen)
    one <- getWord8
    when (one /= 1) $
        fail ("invalid ECDH KDF reserved octet: " ++ show one)
    kdfHA <- get
    kdfSA <- get
    return $ ECDHPubKey ed kdfHA kdfSA
getPubkey EdDSA = do
    curvelength <- getWord8
    when (curvelength == 0 || curvelength == 0xff) $
        fail "invalid EdDSA curve OID length octet (reserved value)"
    curveoid <- getByteString (fromIntegral curvelength)
    MPI mpi <- getMPI
    case curveoidBSToEdSigningCurve curveoid of
        Left e -> fail e
        Right P.EdSigningCurve25519 ->
            EdDSAPubKey P.EdSigningCurve25519
                <$> ( PrefixedNativeEPoint
                        <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi
                    )
        Right P.EdSigningCurve448 ->
            EdDSAPubKey P.EdSigningCurve448
                <$> ( PrefixedNativeEPoint
                        <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi
                    )
getPubkey pka
    | pka == BTypes.Ed25519 =
        parseFixedLengthOrLegacyPubkey
            32
            ( EdDSAPubKey P.EdSigningCurve25519
                . NativeEPoint
                . EPoint
                . os2ip
                . BL.toStrict
            )
            (getPubkey EdDSA)
getPubkey pka
    | pka == BTypes.Ed448 =
        parseFixedLengthOrLegacyPubkey
            57
            ( EdDSAPubKey P.EdSigningCurve448
                . NativeEPoint
                . EPoint
                . os2ip
                . BL.toStrict
            )
            (getPubkey EdDSA)
getPubkey X25519 =
    parseFixedLengthOrLegacyPubkey
        32
        ( EdDSAPubKey P.EdSigningCurve25519
            . NativeEPoint
            . EPoint
            . os2ip
            . BL.toStrict
        )
        (getPubkey ECDH)
getPubkey X448 =
    parseFixedLengthOrLegacyPubkey
        56
        ( EdDSAPubKey P.EdSigningCurve448
            . NativeEPoint
            . EPoint
            . os2ip
            . BL.toStrict
        )
        (getPubkey ECDH)
getPubkey MLKEM768X25519 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey MLKEM1024X448 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey MLDSA65Ed25519 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey MLDSA87Ed448 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey SLHDSASHAKE128s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey SLHDSASHAKE128f = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey SLHDSASHAKE256s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey _ = UnknownPKey <$> getRemainingLazyByteString

parseFixedLengthOrLegacyPubkey
    :: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey
parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do
    remaining <- lookAhead getRemainingLazyByteString
    if BL.length remaining == expectedLen
        then decodeFixed <$> getLazyByteString expectedLen
        else legacyParser

getPubkeyV6 :: PubKeyAlgorithm -> Get PKey
getPubkeyV6 pka
    | pka == BTypes.Ed25519 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        when (B.length bs /= 32) $
            fail "invalid v6 Ed25519 public key length"
        return $
            EdDSAPubKey
                P.EdSigningCurve25519
                (NativeEPoint (EPoint (os2ip bs)))
    | pka == BTypes.Ed448 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        when (B.length bs /= 57) $
            fail "invalid v6 Ed448 public key length"
        return $
            EdDSAPubKey
                P.EdSigningCurve448
                (NativeEPoint (EPoint (os2ip bs)))
    | pka == BTypes.X25519 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        when (B.length bs /= 32) $
            fail "invalid v6 X25519 public key length"
        return $
            EdDSAPubKey
                P.EdSigningCurve25519
                (NativeEPoint (EPoint (os2ip bs)))
    | pka == BTypes.X448 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        when (B.length bs /= 56) $
            fail "invalid v6 X448 public key length"
        return $
            EdDSAPubKey
                P.EdSigningCurve448
                (NativeEPoint (EPoint (os2ip bs)))
    | pka == MLKEM768X25519 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ MLKEMPubKey bs
    | pka == MLKEM1024X448 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ MLKEMPubKey bs
    | pka == MLDSA65Ed25519 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ MLDSAPubKey bs
    | pka == MLDSA87Ed448 = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ MLDSAPubKey bs
    | pka == SLHDSASHAKE128s = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ SLHDSAPubKey bs
    | pka == SLHDSASHAKE128f = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ SLHDSAPubKey bs
    | pka == SLHDSASHAKE256s = do
        len <- getWord32be
        bs <- getByteString (fromIntegral len)
        return $ SLHDSAPubKey bs
    | otherwise = getPubkey pka

bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint
bs2Point bs =
    if B.null bs
        then Left "empty EC point encoding"
        else
            let xy = B.drop 1 bs
                l = B.length xy
             in if B.head bs /= 0x04
                    then Left $ "unknown type of point: " ++ show (B.unpack bs)
                    else
                        if odd l
                            then
                                Left "malformed EC point encoding: odd coordinate payload length"
                            else
                                return
                                    ( uncurry
                                        ECCT.Point
                                        ((os2ip *** os2ip) (B.splitAt (div l 2) xy))
                                    )

putPubkey :: PKey -> Put
putPubkey (UnknownPKey bs) = putLazyByteString bs
putPubkey (MLKEMPubKey bs) = putLazyByteString (BL.fromStrict bs)
putPubkey (MLDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)
putPubkey (SLHDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)
putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =
    let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)
     in putCurveOID curveoidbs
            >> mapM_ put (pubkeyToMPIs p)
putPubkey
    p@( ECDHPubKey
            (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)))
            kha
            ksa
        ) =
        let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)
         in putCurveOID curveoidbs
                >> mapM_ put (pubkeyToMPIs p)
                >> putECDHKDFParams kha ksa
putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) =
    let Right curveoidbs = curveToCurveoidBS (ed2ec curve)
     in putCurveOID curveoidbs
            >> mapM_ put (pubkeyToMPIs p)
            >> putECDHKDFParams kha ksa
  where
    ed2ec P.EdSigningCurve25519 = Curve25519
    ed2ec P.EdSigningCurve448 = Curve448
putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) =
    let Right curveoidbs = edSigningCurveToCurveoidBS curve
     in putCurveOID curveoidbs
            >> mapM_ put (pubkeyToMPIs p)
putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) =
    error
        ( "legacy ECDH serialization requires a prefixed-native "
            ++ show curve
            ++ " point"
        )
putPubkey (EdDSAPubKey curve (NativeEPoint _)) =
    error
        ( "legacy EdDSA serialization requires a prefixed-native "
            ++ show curve
            ++ " point"
        )
putPubkey p = mapM_ put (pubkeyToMPIs p)

putPubkeyV6 :: PKey -> Put
putPubkeyV6 (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) = do
    let bs = fixedLengthOctets 32 x
    putWord32be . fromIntegral . B.length $ bs
    putByteString bs
putPubkeyV6 (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) = do
    let bs = fixedLengthOctets 57 x
    putWord32be . fromIntegral . B.length $ bs
    putByteString bs
putPubkeyV6
    ( ECDHPubKey
            (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x)))
            kha
            ksa
        ) = do
        let bs = fixedLengthOctets 32 x
        putWord32be . fromIntegral . B.length $ bs
        putByteString bs
        put kha
        put ksa
putPubkeyV6
    ( ECDHPubKey
            (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x)))
            kha
            ksa
        ) = do
        let bs = fixedLengthOctets 56 x
        putWord32be . fromIntegral . B.length $ bs
        putByteString bs
        put kha
        put ksa
putPubkeyV6 (MLKEMPubKey bs) = do
    putWord32be . fromIntegral . B.length $ bs
    putByteString bs
putPubkeyV6 (MLDSAPubKey bs) = do
    putWord32be . fromIntegral . B.length $ bs
    putByteString bs
putPubkeyV6 (SLHDSAPubKey bs) = do
    putWord32be . fromIntegral . B.length $ bs
    putByteString bs
putPubkeyV6 p = putPubkey p

fixedLengthOctets :: Int -> Integer -> B.ByteString
fixedLengthOctets targetLen x =
    let bs = i2osp x
     in if B.length bs > targetLen
            then
                error
                    ( "public key element does not fit in "
                        ++ show targetLen
                        ++ " octets"
                    )
            else B.replicate (targetLen - B.length bs) 0 <> bs

validatePrefixedNativePoint
    :: Int -> String -> Integer -> Get EPoint
validatePrefixedNativePoint targetLen label i =
    let bs = i2osp i
     in if B.length bs /= targetLen + 1
            then
                fail
                    ( "invalid "
                        ++ label
                        ++ " public key length: expected "
                        ++ show (targetLen + 1)
                        ++ " octets with 0x40 prefix, got "
                        ++ show (B.length bs)
                    )
            else
                if B.head bs /= 0x40
                    then
                        fail ("invalid " ++ label ++ " public key: missing 0x40 prefix")
                    else pure (EPoint i)

putCurveOID :: B.ByteString -> Put
putCurveOID oid = do
    let oidLength = B.length oid
    when (oidLength == 0 || oidLength == 0xff) $
        error "curve OID length cannot use reserved values 0 or 255"
    putWord8 (fromIntegral oidLength)
    putByteString oid

putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put
putECDHKDFParams kdfHA kdfSA = do
    let kdfLengthOctet = 0x03
    when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $
        error "ECDH KDF field length cannot use reserved values 0 or 255"
    putWord8 kdfLengthOctet
    putWord8 0x01
    put kdfHA
    put kdfSA

parseOPSNestedFlag :: Word8 -> Get NestedFlag
parseOPSNestedFlag 0 = pure True
parseOPSNestedFlag 1 = pure False
parseOPSNestedFlag other =
    fail ("invalid OPS nested flag octet: " ++ show other)

getSecretKey :: SomePKPayload -> Get SKey
getSecretKey pkp
    | _pkalgo pkp
        `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do
        MPI d <- get
        MPI p <- get
        MPI q <- get
        MPI _ <- get -- u
        case inverse q p of
            Nothing -> fail "invalid RSA secret key: q has no inverse modulo p"
            Just qinv -> do
                let dP = d `mod` (p - 1)
                    dQ = d `mod` (q - 1)
                    pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp)
                return $
                    RSAPrivateKey
                        (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))
    | _pkalgo pkp == DSA = do
        MPI x <- get
        return $
            DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))
    | _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do
        MPI x <- get
        return $ ElGamalPrivateKey x
    | _pkalgo pkp == ECDSA = do
        let pubcurve =
                (\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)
                    (_pubkey pkp)
        getECDSAScalarPrivateKey pubcurve
    | _pkalgo pkp == ECDH =
        do
            pubcurve <- ecdhPrivateCurveFromPKPayload pkp
            getECDHScalarPrivateKey pubcurve
    | _pkalgo pkp == X25519 = do
        if _keyVersion pkp == V6
            then do
                sk <- getByteString 32
                return $ X25519PrivateKey sk
            else do
                pubcurve <- ecdhPrivateCurveFromPKPayload pkp
                getECDHScalarPrivateKey pubcurve
    | _pkalgo pkp == X448 = do
        if _keyVersion pkp == V6
            then do
                sk <- getByteString 56
                return $ X448PrivateKey sk
            else UnknownSKey <$> getRemainingLazyByteString
    | _pkalgo pkp == EdDSA = do
        if _keyVersion pkp == V6
            then do
                case _pubkey pkp of
                    EdDSAPubKey P.EdSigningCurve25519 _ -> EdDSAPrivateKey P.EdSigningCurve25519 <$> getByteString 32
                    EdDSAPubKey P.EdSigningCurve448 _ -> EdDSAPrivateKey P.EdSigningCurve448 <$> getByteString 57
                    _ -> UnknownSKey <$> getRemainingLazyByteString
            else do
                MPI x <- get
                case _pubkey pkp of
                    EdDSAPubKey P.EdSigningCurve25519 _ ->
                        return $
                            EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))
                    EdDSAPubKey P.EdSigningCurve448 _ ->
                        return $
                            EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))
                    _ -> return $ UnknownSKey (BL.fromStrict (i2osp x))
    | _pkalgo pkp `elem` [MLKEM768X25519, MLKEM1024X448] = do
        if _keyVersion pkp == V6
            then do
                len <- getWord32be
                bs <- getByteString (fromIntegral len)
                return $ MLKEMPrivateKey bs
            else UnknownSKey <$> getRemainingLazyByteString
    | _pkalgo pkp `elem` [MLDSA65Ed25519, MLDSA87Ed448] = do
        if _keyVersion pkp == V6
            then do
                len <- getWord32be
                bs <- getByteString (fromIntegral len)
                return $ MLDSAPrivateKey bs
            else UnknownSKey <$> getRemainingLazyByteString
    | _pkalgo pkp
        `elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] = do
        if _keyVersion pkp == V6
            then do
                len <- getWord32be
                bs <- getByteString (fromIntegral len)
                return $ SLHDSAPrivateKey bs
            else UnknownSKey <$> getRemainingLazyByteString
    | otherwise = UnknownSKey <$> getRemainingLazyByteString

getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey
getECDSAScalarPrivateKey curve = do
    MPI pn <- get
    pure $
        ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))

getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey
getECDHScalarPrivateKey curve = do
    MPI pn <- get
    pure $
        ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))

ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve
ecdhPrivateCurveFromPKPayload pkp =
    case _pubkey pkp of
        ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ ->
            pure (ECDSA.public_curve p)
        ECDHPubKey (EdDSAPubKey P.EdSigningCurve25519 _) _ _ ->
            pure (curve2Curve Curve25519)
        ECDHPubKey (EdDSAPubKey P.EdSigningCurve448 _) _ _ ->
            pure (curve2Curve Curve448)
        other ->
            fail
                ( "ECDH/X25519 secret key requires an ECDH public key packet, got "
                    ++ show other
                )

putSKey :: SKey -> Either String Put
putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =
    case inverse q p of
        Just u ->
            Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u))
        Nothing ->
            Left
                "putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)"
putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) =
    Right (put (MPI x))
putSKey (ElGamalPrivateKey x) =
    Right (put (MPI x))
putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =
    Right (put (MPI d))
putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =
    Right (put (MPI d))
putSKey (EdDSAPrivateKey P.EdSigningCurve25519 sk) = Right (putByteString sk)
putSKey (EdDSAPrivateKey P.EdSigningCurve448 sk) = Right (putByteString sk)
putSKey (X25519PrivateKey sk) = Right (putByteString sk)
putSKey (X448PrivateKey sk) = Right (putByteString sk)
putSKey (MLKEMPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))
putSKey (MLDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))
putSKey (SLHDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))
putSKey (UnknownSKey bs) = Right (putLazyByteString bs)

putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put
putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs)
    | _keyVersion pkp == V6 = putSKey sk
    | otherwise = Right (put (MPI (os2ip bs)))
putSKeyForPKPayload _ sk = putSKey sk

putMPI :: MPI -> Put
putMPI (MPI i) = do
    let bs = i2osp i
    putWord16be . fromIntegral . numBits $ i
    putByteString bs

data PKPayloadReadCase where
    PKPayloadReadCaseV3
        :: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase
    PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase
    PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase

pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase
pkPayloadReadCase version =
    case version of
        2 -> do
            v3e <- getWord16be
            pka <- get
            pure (PKPayloadReadCaseV3 v3e pka)
        3 -> do
            v3e <- getWord16be
            pka <- get
            pure (PKPayloadReadCaseV3 v3e pka)
        4 -> PKPayloadReadCaseV4 <$> get
        6 -> PKPayloadReadCaseV6 <$> get
        _ -> fail ("unsupported key packet version " ++ show version)

getPKPayload :: Get SomePKPayload
getPKPayload = do
    version <- getWord8
    ctime <- fmap ThirtyTwoBitTimeStamp getWord32be
    readCase <- pkPayloadReadCase version
    case readCase of
        PKPayloadReadCaseV3 v3e pka -> do
            pk <- getPubkey pka
            pure $! PKPayload DeprecatedV3 ctime v3e pka pk
        PKPayloadReadCaseV4 pka -> do
            pk <- getPubkey pka
            pure $! PKPayload V4 ctime 0 pka pk
        PKPayloadReadCaseV6 pka -> do
            pk <- getPubkeyV6 pka
            pure $! PKPayload V6 ctime 0 pka pk

data PKPayloadWriteCase where
    PKPayloadWriteCaseV3
        :: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase
    PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase
    PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase

pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase
pkPayloadWriteCase (SomePKPayload pkp) =
    case pkp of
        PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp
        PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp
        PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp

putPKPayload :: SomePKPayload -> Put
putPKPayload pkpSome =
    case pkPayloadWriteCase pkpSome of
        PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do
            putWord8 3
            putWord32be . unThirtyTwoBitTimeStamp $ ctime
            putWord16be v3e
            put pka
            putPubkey pk
        PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do
            putWord8 4
            putWord32be . unThirtyTwoBitTimeStamp $ ctime
            put pka
            putPubkeyV4ForAlgorithm pka pk
        PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do
            putWord8 6
            putWord32be . unThirtyTwoBitTimeStamp $ ctime
            put pka
            putPubkeyV6 pk

putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put
putPubkeyV4ForAlgorithm pka pk
    | pka == BTypes.Ed25519 =
        putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk
    | pka == BTypes.Ed448 =
        putPubkeyV4Fixed 57 P.EdSigningCurve448 pk
    | pka == BTypes.X25519 =
        putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk
    | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.EdSigningCurve448 pk
    | otherwise = putPubkey pk

putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put
putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x)))
    | curve == expectedCurve =
        putByteString (fixedLengthOctets targetLen x)
putPubkeyV4Fixed _ _ pk = putPubkey pk

getSKAddendum :: SomePKPayload -> Get SKAddendum
getSKAddendum (SomePKPayload pkp) =
    toSKAddendum <$> getSKAddendumTyped pkp

getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v)
getSKAddendumTyped pkp = do
    s2kusage <- getWord8
    let pkpSome = SomePKPayload pkp
        getLegacyS2KProtected constructor = do
            symencWord <- getWord8
            s2k <- getS2K
            let symenc = toFVal symencWord
            case s2k of
                OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty
                _ -> do
                    blockSize <- either fail pure (symEncBlockSize symenc)
                    iv <- IV <$> getByteString blockSize
                    encryptedblock <- getRemainingLazyByteString
                    return $ constructor symenc s2k iv encryptedblock
    case s2kusage of
        0 ->
            case pkp of
                PKPayloadV6 {} -> do
                    sk <- getSecretKey pkpSome
                    return (SKAUnencryptedV6 sk)
                PKPayloadV3 {} -> do
                    rest <- lookAhead getRemainingLazyByteString
                    secretLen <-
                        case runGetOrFail
                            ( do
                                start <- bytesRead
                                _ <- getSecretKey pkpSome
                                end <- bytesRead
                                pure (end - start)
                            )
                            rest of
                            Left (_, _, err) -> fail err
                            Right (_, _, len) -> pure len
                    sk <- getSecretKey pkpSome
                    checksum <- getWord16be
                    let expectedChecksum =
                            checksum16Bytes (BL.toStrict (BL.take secretLen rest))
                    when (checksum /= expectedChecksum) $
                        fail
                            ( "legacy unencrypted secret-key checksum mismatch: expected "
                                ++ show expectedChecksum
                                ++ ", got "
                                ++ show checksum
                            )
                    return (SKAUnencryptedLegacy sk checksum)
                PKPayloadV4 {} -> do
                    rest <- lookAhead getRemainingLazyByteString
                    secretLen <-
                        case runGetOrFail
                            ( do
                                start <- bytesRead
                                _ <- getSecretKey pkpSome
                                end <- bytesRead
                                pure (end - start)
                            )
                            rest of
                            Left (_, _, err) -> fail err
                            Right (_, _, len) -> pure len
                    sk <- getSecretKey pkpSome
                    checksum <- getWord16be
                    let expectedChecksum =
                            checksum16Bytes (BL.toStrict (BL.take secretLen rest))
                    when (checksum /= expectedChecksum) $
                        fail
                            ( "legacy unencrypted secret-key checksum mismatch: expected "
                                ++ show expectedChecksum
                                ++ ", got "
                                ++ show checksum
                            )
                    return (SKAUnencryptedLegacy sk checksum)
        255 ->
            case pkp of
                PKPayloadV6 {} ->
                    fail "v6 secret key packets MUST NOT use s2k usage 255"
                PKPayloadV3 {} ->
                    getLegacyS2KProtected SKA16bit
                PKPayloadV4 {} ->
                    getLegacyS2KProtected SKA16bit
        254 ->
            case pkp of
                PKPayloadV6 {} -> do
                    paramsLen <- getWord8
                    params <- getLazyByteString (fromIntegral paramsLen)
                    (symenc, s2k, iv) <-
                        case runGetOrFail getV6CFBParams params of
                            Left (_, _, err) -> fail err
                            Right (rest, _, parsed)
                                | not (BL.null rest) ->
                                    fail "unexpected trailing v6 CFB parameters"
                                | otherwise -> pure parsed
                    encryptedblock <- getRemainingLazyByteString
                    return (SKASHA1V6 symenc s2k (IV iv) encryptedblock)
                PKPayloadV3 {} ->
                    getLegacyS2KProtected SKASHA1Legacy
                PKPayloadV4 {} ->
                    getLegacyS2KProtected SKASHA1Legacy
          where
            getV6CFBParams = do
                symencWord <- getWord8
                s2kLen <- getWord8
                s2kBytes <- getLazyByteString (fromIntegral s2kLen)
                s2k <-
                    case runGetOrFail getS2K s2kBytes of
                        Left (_, _, err) -> fail err
                        Right (rest, _, parsed)
                            | not (BL.null rest) ->
                                fail "unexpected trailing bytes in v6 S2K specifier"
                            | otherwise -> pure parsed
                iv <- getRemainingLazyByteString
                let symenc = toFVal symencWord
                blockSize <- either fail pure (symEncBlockSize symenc)
                when (BL.length iv /= fromIntegral blockSize) $
                    fail "invalid v6 CFB IV length"
                pure (symenc, s2k, BL.toStrict iv)
        253 ->
            case pkp of
                PKPayloadV6 {} -> do
                    paramsLen <- getWord8
                    params <- getLazyByteString (fromIntegral paramsLen)
                    (symenc, aead, s2k, iv) <-
                        case runGetOrFail getV6AEADParams params of
                            Left (_, _, err) -> fail err
                            Right (rest, _, parsed)
                                | not (BL.null rest) ->
                                    fail "unexpected trailing v6 AEAD parameters"
                                | otherwise -> pure parsed
                    encryptedblock <- getRemainingLazyByteString
                    return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock)
                PKPayloadV3 {} -> do
                    (symenc, aead, s2k, iv) <- getLegacyAEADParams
                    encryptedblock <- getRemainingLazyByteString
                    return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)
                PKPayloadV4 {} -> do
                    (symenc, aead, s2k, iv) <- getLegacyAEADParams
                    encryptedblock <- getRemainingLazyByteString
                    return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)
          where
            getV6AEADParams
                :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)
            getV6AEADParams = do
                symencWord <- getWord8
                aeadWord <- getWord8
                s2kLen <- getWord8
                s2kBytes <- getLazyByteString (fromIntegral s2kLen)
                s2k <-
                    case runGetOrFail getS2K s2kBytes of
                        Left (_, _, err) -> fail err
                        Right (rest, _, parsed)
                            | not (BL.null rest) ->
                                fail "unexpected trailing bytes in v6 S2K specifier"
                            | otherwise -> pure parsed
                iv <- getRemainingLazyByteString
                let symenc = toFVal symencWord
                    aead = toFVal aeadWord
                when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $
                    fail "invalid v6 AEAD IV length"
                pure (symenc, aead, s2k, BL.toStrict iv)
            -- v3/v4: no cumulative-params-length octet, no S2K-size octet
            getLegacyAEADParams
                :: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)
            getLegacyAEADParams = do
                symencWord <- getWord8
                aeadWord <- getWord8
                s2k <- getS2K
                let aead = toFVal aeadWord
                iv <-
                    BL.toStrict
                        <$> getLazyByteString (fromIntegral (aeadNonceSize aead))
                pure (toFVal symencWord, aead, s2k, iv)
        symenc ->
            case pkp of
                PKPayloadV6 {} -> do
                    paramsLen <- getWord8
                    iv <- getByteString (fromIntegral paramsLen)
                    let symencAlg = toFVal symenc
                    blockSize <- either fail pure (symEncBlockSize symencAlg)
                    when (B.length iv /= blockSize) $
                        fail "invalid v6 CFB IV length"
                    encryptedblock <- getRemainingLazyByteString
                    return (SKASymV6 symencAlg (IV iv) encryptedblock)
                PKPayloadV3 {} -> do
                    blockSize <- either fail pure (symEncBlockSize (toFVal symenc))
                    iv <- getByteString blockSize
                    encryptedblock <- getRemainingLazyByteString
                    return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)
                PKPayloadV4 {} -> do
                    blockSize <- either fail pure (symEncBlockSize (toFVal symenc))
                    iv <- getByteString blockSize
                    encryptedblock <- getRemainingLazyByteString
                    return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)

putSKAddendum :: SKAddendum -> Either String Put
putSKAddendum (SUS16bit symenc s2k iv encryptedblock) =
    Right $ do
        putWord8 255
        put symenc
        put s2k
        putByteString (unIV iv)
        putLazyByteString encryptedblock
putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) =
    Right $ do
        putWord8 254
        put symenc
        put s2k
        putByteString (unIV iv)
        putLazyByteString encryptedblock
putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) =
    Right $ do
        putWord8 253
        put symenc
        putWord8 (fromFVal aead)
        put s2k
        putByteString (unIV iv)
        putLazyByteString encryptedblock
putSKAddendum (SUSym symenc iv encryptedblock) =
    Right $ do
        put symenc
        putByteString (unIV iv)
        putLazyByteString encryptedblock
putSKAddendum (SUUnencrypted sk checksum) =
    do
        putSecret <- putSKey sk
        Right $ do
            putWord8 0
            let skb = runPut putSecret
            putLazyByteString skb
            putWord16be
                ( if checksum == 0
                    then checksum16Bytes (BL.toStrict skb)
                    else checksum
                )

checksum16Bytes :: B.ByteString -> Word16
checksum16Bytes =
    B.foldl'
        ( \a b ->
            fromIntegral
                ((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer))
        )
        0

putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put
putSKAddendumForPKPayload pkp ska =
    case fromSKAddendumForPKPayload pkp ska of
        Left e -> error e
        Right (SomeSKAddendumV skaV) ->
            putSKAddendumForPKPayloadTyped pkp skaV

putUnencryptedSKAddendum :: SomePKPayload -> SKey -> Put
putUnencryptedSKAddendum pkp sk = do
    putWord8 0
    let putSecret =
            case putSKeyForPKPayload pkp sk of
                Left err -> error err
                Right p -> p
        skb = runPut putSecret
    putLazyByteString skb

putSKAddendumForPKPayloadTyped
    :: SomePKPayload
    -> SKAddendumV v
    -> Put
putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do
    let skb =
            runPut
                ( case putSKeyForPKPayload pkp sk of
                    Left err -> error err
                    Right p -> p
                )
    putUnencryptedSKAddendum pkp sk
    putWord16be
        ( if checksum == 0
            then
                BL.foldl
                    (\a b -> mod (a + fromIntegral b) 0xffff)
                    (0 :: Word16)
                    skb
            else checksum
        )
putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) =
    putUnencryptedSKAddendum pkp sk
putSKAddendumForPKPayloadTyped _ (SKASHA1V6 symenc s2k iv encryptedblock) = do
    let s2kbs = runPut (put s2k)
        paramsLen = 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv))
    putWord8 254
    putWord8 (fromIntegral paramsLen)
    put symenc
    putWord8 (fromIntegral (BL.length s2kbs))
    putLazyByteString s2kbs
    putByteString (unIV iv)
    putLazyByteString encryptedblock
putSKAddendumForPKPayloadTyped _ (SKAAEADV6 symenc aead s2k iv encryptedblock) = do
    let s2kbs = runPut (put s2k)
        paramsLen =
            1 + 1 + 1 + BL.length s2kbs + fromIntegral (B.length (unIV iv))
    putWord8 253
    putWord8 (fromIntegral paramsLen)
    put symenc
    putWord8 (fromFVal aead)
    putWord8 (fromIntegral (BL.length s2kbs))
    putLazyByteString s2kbs
    putByteString (unIV iv)
    putLazyByteString encryptedblock
putSKAddendumForPKPayloadTyped _ (SKAAEADLegacy symenc aead s2k iv encryptedblock) = do
    putWord8 253
    put symenc
    putWord8 (fromFVal aead)
    put s2k
    putByteString (unIV iv)
    putLazyByteString encryptedblock
putSKAddendumForPKPayloadTyped _ (SKASymV6 symenc iv encryptedblock) = do
    putWord8 (fromFVal symenc)
    putWord8 (fromIntegral (B.length (unIV iv)))
    putByteString (unIV iv)
    putLazyByteString encryptedblock
putSKAddendumForPKPayloadTyped _ skaV =
    case putSKAddendum (toSKAddendum skaV) of
        Left e -> error e
        Right p -> p

aeadNonceSize :: AEADAlgorithm -> Int
aeadNonceSize EAX = 16
aeadNonceSize OCB = 15
aeadNonceSize GCM = 12
aeadNonceSize (OtherAEADAlgo _) = 0

symEncBlockSize :: SymmetricAlgorithm -> Either String Int
symEncBlockSize Plaintext = Right 0
symEncBlockSize IDEA = Right 8
symEncBlockSize TripleDES = Right 8
symEncBlockSize CAST5 = Right 8
symEncBlockSize Blowfish = Right 8
symEncBlockSize AES128 = Right 16
symEncBlockSize AES192 = Right 16
symEncBlockSize AES256 = Right 16
symEncBlockSize Twofish = Right 16
symEncBlockSize Camellia128 = Right 16
symEncBlockSize Camellia192 = Right 16
symEncBlockSize Camellia256 = Right 16
symEncBlockSize sa =
    Left
        ( "unsupported symmetric algorithm for secret-key IV sizing: "
            ++ show sa
        )

decodeIterationCount :: Word8 -> IterationCount
decodeIterationCount c =
    IterationCount
        ( (16 + (fromIntegral c .&. 15))
            `shiftL` ((fromIntegral c `shiftR` 4) + 6)
        )

encodeIterationCount :: IterationCount -> Word8 -- should this really be a lookup table?
encodeIterationCount 1024 = 0
encodeIterationCount 1088 = 1
encodeIterationCount 1152 = 2
encodeIterationCount 1216 = 3
encodeIterationCount 1280 = 4
encodeIterationCount 1344 = 5
encodeIterationCount 1408 = 6
encodeIterationCount 1472 = 7
encodeIterationCount 1536 = 8
encodeIterationCount 1600 = 9
encodeIterationCount 1664 = 10
encodeIterationCount 1728 = 11
encodeIterationCount 1792 = 12
encodeIterationCount 1856 = 13
encodeIterationCount 1920 = 14
encodeIterationCount 1984 = 15
encodeIterationCount 2048 = 16
encodeIterationCount 2176 = 17
encodeIterationCount 2304 = 18
encodeIterationCount 2432 = 19
encodeIterationCount 2560 = 20
encodeIterationCount 2688 = 21
encodeIterationCount 2816 = 22
encodeIterationCount 2944 = 23
encodeIterationCount 3072 = 24
encodeIterationCount 3200 = 25
encodeIterationCount 3328 = 26
encodeIterationCount 3456 = 27
encodeIterationCount 3584 = 28
encodeIterationCount 3712 = 29
encodeIterationCount 3840 = 30
encodeIterationCount 3968 = 31
encodeIterationCount 4096 = 32
encodeIterationCount 4352 = 33
encodeIterationCount 4608 = 34
encodeIterationCount 4864 = 35
encodeIterationCount 5120 = 36
encodeIterationCount 5376 = 37
encodeIterationCount 5632 = 38
encodeIterationCount 5888 = 39
encodeIterationCount 6144 = 40
encodeIterationCount 6400 = 41
encodeIterationCount 6656 = 42
encodeIterationCount 6912 = 43
encodeIterationCount 7168 = 44
encodeIterationCount 7424 = 45
encodeIterationCount 7680 = 46
encodeIterationCount 7936 = 47
encodeIterationCount 8192 = 48
encodeIterationCount 8704 = 49
encodeIterationCount 9216 = 50
encodeIterationCount 9728 = 51
encodeIterationCount 10240 = 52
encodeIterationCount 10752 = 53
encodeIterationCount 11264 = 54
encodeIterationCount 11776 = 55
encodeIterationCount 12288 = 56
encodeIterationCount 12800 = 57
encodeIterationCount 13312 = 58
encodeIterationCount 13824 = 59
encodeIterationCount 14336 = 60
encodeIterationCount 14848 = 61
encodeIterationCount 15360 = 62
encodeIterationCount 15872 = 63
encodeIterationCount 16384 = 64
encodeIterationCount 17408 = 65
encodeIterationCount 18432 = 66
encodeIterationCount 19456 = 67
encodeIterationCount 20480 = 68
encodeIterationCount 21504 = 69
encodeIterationCount 22528 = 70
encodeIterationCount 23552 = 71
encodeIterationCount 24576 = 72
encodeIterationCount 25600 = 73
encodeIterationCount 26624 = 74
encodeIterationCount 27648 = 75
encodeIterationCount 28672 = 76
encodeIterationCount 29696 = 77
encodeIterationCount 30720 = 78
encodeIterationCount 31744 = 79
encodeIterationCount 32768 = 80
encodeIterationCount 34816 = 81
encodeIterationCount 36864 = 82
encodeIterationCount 38912 = 83
encodeIterationCount 40960 = 84
encodeIterationCount 43008 = 85
encodeIterationCount 45056 = 86
encodeIterationCount 47104 = 87
encodeIterationCount 49152 = 88
encodeIterationCount 51200 = 89
encodeIterationCount 53248 = 90
encodeIterationCount 55296 = 91
encodeIterationCount 57344 = 92
encodeIterationCount 59392 = 93
encodeIterationCount 61440 = 94
encodeIterationCount 63488 = 95
encodeIterationCount 65536 = 96
encodeIterationCount 69632 = 97
encodeIterationCount 73728 = 98
encodeIterationCount 77824 = 99
encodeIterationCount 81920 = 100
encodeIterationCount 86016 = 101
encodeIterationCount 90112 = 102
encodeIterationCount 94208 = 103
encodeIterationCount 98304 = 104
encodeIterationCount 102400 = 105
encodeIterationCount 106496 = 106
encodeIterationCount 110592 = 107
encodeIterationCount 114688 = 108
encodeIterationCount 118784 = 109
encodeIterationCount 122880 = 110
encodeIterationCount 126976 = 111
encodeIterationCount 131072 = 112
encodeIterationCount 139264 = 113
encodeIterationCount 147456 = 114
encodeIterationCount 155648 = 115
encodeIterationCount 163840 = 116
encodeIterationCount 172032 = 117
encodeIterationCount 180224 = 118
encodeIterationCount 188416 = 119
encodeIterationCount 196608 = 120
encodeIterationCount 204800 = 121
encodeIterationCount 212992 = 122
encodeIterationCount 221184 = 123
encodeIterationCount 229376 = 124
encodeIterationCount 237568 = 125
encodeIterationCount 245760 = 126
encodeIterationCount 253952 = 127
encodeIterationCount 262144 = 128
encodeIterationCount 278528 = 129
encodeIterationCount 294912 = 130
encodeIterationCount 311296 = 131
encodeIterationCount 327680 = 132
encodeIterationCount 344064 = 133
encodeIterationCount 360448 = 134
encodeIterationCount 376832 = 135
encodeIterationCount 393216 = 136
encodeIterationCount 409600 = 137
encodeIterationCount 425984 = 138
encodeIterationCount 442368 = 139
encodeIterationCount 458752 = 140
encodeIterationCount 475136 = 141
encodeIterationCount 491520 = 142
encodeIterationCount 507904 = 143
encodeIterationCount 524288 = 144
encodeIterationCount 557056 = 145
encodeIterationCount 589824 = 146
encodeIterationCount 622592 = 147
encodeIterationCount 655360 = 148
encodeIterationCount 688128 = 149
encodeIterationCount 720896 = 150
encodeIterationCount 753664 = 151
encodeIterationCount 786432 = 152
encodeIterationCount 819200 = 153
encodeIterationCount 851968 = 154
encodeIterationCount 884736 = 155
encodeIterationCount 917504 = 156
encodeIterationCount 950272 = 157
encodeIterationCount 983040 = 158
encodeIterationCount 1015808 = 159
encodeIterationCount 1048576 = 160
encodeIterationCount 1114112 = 161
encodeIterationCount 1179648 = 162
encodeIterationCount 1245184 = 163
encodeIterationCount 1310720 = 164
encodeIterationCount 1376256 = 165
encodeIterationCount 1441792 = 166
encodeIterationCount 1507328 = 167
encodeIterationCount 1572864 = 168
encodeIterationCount 1638400 = 169
encodeIterationCount 1703936 = 170
encodeIterationCount 1769472 = 171
encodeIterationCount 1835008 = 172
encodeIterationCount 1900544 = 173
encodeIterationCount 1966080 = 174
encodeIterationCount 2031616 = 175
encodeIterationCount 2097152 = 176
encodeIterationCount 2228224 = 177
encodeIterationCount 2359296 = 178
encodeIterationCount 2490368 = 179
encodeIterationCount 2621440 = 180
encodeIterationCount 2752512 = 181
encodeIterationCount 2883584 = 182
encodeIterationCount 3014656 = 183
encodeIterationCount 3145728 = 184
encodeIterationCount 3276800 = 185
encodeIterationCount 3407872 = 186
encodeIterationCount 3538944 = 187
encodeIterationCount 3670016 = 188
encodeIterationCount 3801088 = 189
encodeIterationCount 3932160 = 190
encodeIterationCount 4063232 = 191
encodeIterationCount 4194304 = 192
encodeIterationCount 4456448 = 193
encodeIterationCount 4718592 = 194
encodeIterationCount 4980736 = 195
encodeIterationCount 5242880 = 196
encodeIterationCount 5505024 = 197
encodeIterationCount 5767168 = 198
encodeIterationCount 6029312 = 199
encodeIterationCount 6291456 = 200
encodeIterationCount 6553600 = 201
encodeIterationCount 6815744 = 202
encodeIterationCount 7077888 = 203
encodeIterationCount 7340032 = 204
encodeIterationCount 7602176 = 205
encodeIterationCount 7864320 = 206
encodeIterationCount 8126464 = 207
encodeIterationCount 8388608 = 208
encodeIterationCount 8912896 = 209
encodeIterationCount 9437184 = 210
encodeIterationCount 9961472 = 211
encodeIterationCount 10485760 = 212
encodeIterationCount 11010048 = 213
encodeIterationCount 11534336 = 214
encodeIterationCount 12058624 = 215
encodeIterationCount 12582912 = 216
encodeIterationCount 13107200 = 217
encodeIterationCount 13631488 = 218
encodeIterationCount 14155776 = 219
encodeIterationCount 14680064 = 220
encodeIterationCount 15204352 = 221
encodeIterationCount 15728640 = 222
encodeIterationCount 16252928 = 223
encodeIterationCount 16777216 = 224
encodeIterationCount 17825792 = 225
encodeIterationCount 18874368 = 226
encodeIterationCount 19922944 = 227
encodeIterationCount 20971520 = 228
encodeIterationCount 22020096 = 229
encodeIterationCount 23068672 = 230
encodeIterationCount 24117248 = 231
encodeIterationCount 25165824 = 232
encodeIterationCount 26214400 = 233
encodeIterationCount 27262976 = 234
encodeIterationCount 28311552 = 235
encodeIterationCount 29360128 = 236
encodeIterationCount 30408704 = 237
encodeIterationCount 31457280 = 238
encodeIterationCount 32505856 = 239
encodeIterationCount 33554432 = 240
encodeIterationCount 35651584 = 241
encodeIterationCount 37748736 = 242
encodeIterationCount 39845888 = 243
encodeIterationCount 41943040 = 244
encodeIterationCount 44040192 = 245
encodeIterationCount 46137344 = 246
encodeIterationCount 48234496 = 247
encodeIterationCount 50331648 = 248
encodeIterationCount 52428800 = 249
encodeIterationCount 54525952 = 250
encodeIterationCount 56623104 = 251
encodeIterationCount 58720256 = 252
encodeIterationCount 60817408 = 253
encodeIterationCount 62914560 = 254
encodeIterationCount 65011712 = 255
encodeIterationCount n = error ("invalid iteration count" ++ show n)

getSignaturePayload :: Get SignaturePayload
getSignaturePayload = do
    pv <- getWord8
    case pv of
        3 -> do
            hashlen <- getWord8
            guard (hashlen == 5)
            st <- getWord8
            ctime <- fmap ThirtyTwoBitTimeStamp getWord32be
            eok <- getLazyByteString 8
            pka <- get
            ha <- get
            left16 <- getWord16be
            mpib <- getRemainingLazyByteString
            case runGetOrFail (some getMPI) mpib of
                Left (_, _, e) -> fail ("v3 sig MPIs " ++ e)
                Right (_, _, mpis) ->
                    return $
                        SigV3
                            (toFVal st)
                            ctime
                            (EightOctetKeyId eok)
                            (toFVal pka)
                            (toFVal ha)
                            left16
                            (NE.fromList mpis)
        4 -> do
            st <- getWord8
            pkaOctet <- get
            ha <- get
            let pka = toFVal pkaOctet :: PubKeyAlgorithm
            hlen <- getWord16be
            hb <- getLazyByteString (fromIntegral hlen)
            let hashed =
                    case runGetOrFail (many getSigSubPacket) hb of
                        Left (_, _, err) -> fail ("v4 sig hasheds " ++ err)
                        Right (_, _, h) -> h
            ulen <- getWord16be
            ub <- getLazyByteString (fromIntegral ulen)
            let unhashed =
                    case runGetOrFail (many getSigSubPacket) ub of
                        Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err)
                        Right (_, _, u) -> u
            left16 <- getWord16be
            mpib <- getRemainingLazyByteString
            let parseV4MPIs parseErrPrefix =
                    case runGetOrFail (some getMPI) mpib of
                        Left (_, _, e) -> fail (parseErrPrefix ++ e)
                        Right (_, _, mpis) ->
                            return $
                                SigV4
                                    (toFVal st)
                                    pka
                                    (toFVal ha)
                                    hashed
                                    unhashed
                                    left16
                                    (NE.fromList mpis)
            if pka == BTypes.Ed25519
                then
                    if BL.length mpib == 64
                        then do
                            let sig = BL.toStrict mpib
                                (rbs, sbs) = B.splitAt 32 sig
                            return $
                                SigV4
                                    (toFVal st)
                                    pka
                                    (toFVal ha)
                                    hashed
                                    unhashed
                                    left16
                                    (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)])
                        else parseV4MPIs "v4 Ed25519 legacy MPIs "
                else
                    if pka == BTypes.Ed448
                        then
                            if BL.length mpib == 114
                                then do
                                    let sig = BL.toStrict mpib
                                        (rbs, sbs) = B.splitAt 57 sig
                                    return $
                                        SigV4
                                            (toFVal st)
                                            pka
                                            (toFVal ha)
                                            hashed
                                            unhashed
                                            left16
                                            (NE.fromList [MPI (os2ip rbs), MPI (os2ip sbs)])
                                else parseV4MPIs "v4 Ed448 legacy MPIs "
                        else parseV4MPIs "v4 sig MPIs "
        6 -> do
            st <- getWord8
            pka <- get
            ha <- get
            hlen <- getWord32be
            hb <- getLazyByteString (fromIntegral hlen)
            let hashed =
                    case runGetOrFail (many getSigSubPacket) hb of
                        Left (_, _, err) -> fail ("v6 sig hasheds " ++ err)
                        Right (_, _, h) -> h
            ulen <- getWord32be
            ub <- getLazyByteString (fromIntegral ulen)
            let unhashed =
                    case runGetOrFail (many getSigSubPacket) ub of
                        Left (_, _, err) -> fail ("v6 sig unhasheds " ++ err)
                        Right (_, _, u) -> u
            left16 <- getWord16be
            saltSize <- getWord8
            let haVal = (toFVal ha :: HashAlgorithm)
            expectedSaltSize <-
                maybe
                    ( fail
                        ( "signature hash algorithm does not define a V6 salt size: "
                            ++ show haVal
                        )
                    )
                    pure
                    (v6SaltSizeForHashAlgorithm haVal)
            when (saltSize /= expectedSaltSize) $
                fail
                    ( "v6 signature salt size mismatch for "
                        ++ show haVal
                        ++ ": expected "
                        ++ show expectedSaltSize
                        ++ ", got "
                        ++ show saltSize
                    )
            saltbs <- getByteString (fromIntegral saltSize)
            let salt = SignatureSalt (BL.fromStrict saltbs)
            if pka == BTypes.Ed25519
                then do
                    sig <- getByteString 64
                    let (rbs, sbs) = B.splitAt 32 sig
                        mpis = [MPI (os2ip rbs), MPI (os2ip sbs)]
                    return $
                        SigV6
                            (toFVal st)
                            pka
                            (toFVal ha)
                            salt
                            hashed
                            unhashed
                            left16
                            (NE.fromList mpis)
                else
                    if pka == BTypes.Ed448
                        then do
                            sig <- getByteString 114
                            let (rbs, sbs) = B.splitAt 57 sig
                                mpis = [MPI (os2ip rbs), MPI (os2ip sbs)]
                            return $
                                SigV6
                                    (toFVal st)
                                    pka
                                    (toFVal ha)
                                    salt
                                    hashed
                                    unhashed
                                    left16
                                    (NE.fromList mpis)
                        else do
                            mpib <- getRemainingLazyByteString
                            case runGetOrFail (some getMPI) mpib of
                                Left (_, _, e) -> fail ("v6 sig MPIs " ++ e)
                                Right (_, _, mpis) ->
                                    return $
                                        SigV6
                                            (toFVal st)
                                            pka
                                            (toFVal ha)
                                            salt
                                            hashed
                                            unhashed
                                            left16
                                            (NE.fromList mpis)
        _ -> do
            bs <- getRemainingLazyByteString
            return $ SigVOther pv bs

putSignaturePayload :: SignaturePayload -> Put
putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do
    putWord8 3
    putWord8 5 -- hashlen
    put st
    putWord32be . unThirtyTwoBitTimeStamp $ ctime
    putLazyByteString (unEOKI eok)
    put pka
    put ha
    putWord16be left16
    F.mapM_ put mpis
putSignaturePayload (SigV4 st pka ha hashed unhashed left16 mpis) = do
    putWord8 4
    put st
    put pka
    put ha
    let hb = runPut $ mapM_ put hashed
    putWord16be . fromIntegral . BL.length $ hb
    putLazyByteString hb
    let ub = runPut $ mapM_ put unhashed
    putWord16be . fromIntegral . BL.length $ ub
    putLazyByteString ub
    putWord16be left16
    if pka == BTypes.Ed25519
        then case NE.toList mpis of
            [MPI r, MPI s] -> do
                putByteString (padN 32 r)
                putByteString (padN 32 s)
            _ -> error "Ed25519 v4 signatures must have two MPIs"
        else
            if pka == BTypes.Ed448
                then case NE.toList mpis of
                    [MPI r, MPI s] -> do
                        putByteString (padN 57 r)
                        putByteString (padN 57 s)
                    _ -> error "Ed448 v4 signatures must have two MPIs"
                else F.mapM_ put mpis
  where
    padN n i =
        let bs = i2osp i
         in B.replicate (max 0 (n - B.length bs)) 0 <> bs
putSignaturePayload (SigV6 st pka ha salt hashed unhashed left16 mpis) = do
    let expectedSaltSize =
            maybe
                ( error
                    ( "signature hash algorithm does not define a V6 salt size: "
                        ++ show ha
                    )
                )
                id
                (v6SaltSizeForHashAlgorithm ha)
        actualSaltSize = fromIntegral (BL.length (unSignatureSalt salt))
    when (actualSaltSize /= expectedSaltSize) $
        error
            ( "v6 signature salt size mismatch for "
                ++ show ha
                ++ ": expected "
                ++ show expectedSaltSize
                ++ ", got "
                ++ show actualSaltSize
            )
    putWord8 6
    put st
    put pka
    put ha
    let hb = runPut $ mapM_ put hashed
    putWord32be . fromIntegral . BL.length $ hb
    putLazyByteString hb
    let ub = runPut $ mapM_ put unhashed
    putWord32be . fromIntegral . BL.length $ ub
    putLazyByteString ub
    putWord16be left16
    putWord8 . fromIntegral . BL.length . unSignatureSalt $ salt
    putByteString (BL.toStrict (unSignatureSalt salt))
    if pka == BTypes.Ed25519
        then case NE.toList mpis of
            [MPI r, MPI s] -> do
                putByteString (padN 32 r)
                putByteString (padN 32 s)
            _ -> error "Ed25519 v6 signatures must have two MPIs"
        else
            if pka == BTypes.Ed448
                then case NE.toList mpis of
                    [MPI r, MPI s] -> do
                        putByteString (padN 57 r)
                        putByteString (padN 57 s)
                    _ -> error "Ed448 v6 signatures must have two MPIs"
                else F.mapM_ put mpis
  where
    padN n i =
        let bs = i2osp i
         in B.replicate (max 0 (n - B.length bs)) 0 <> bs
putSignaturePayload (SigVOther pv bs) = do
    putWord8 pv
    putLazyByteString bs

putTK :: TKUnknown -> Put
putTK tk = do
    let pkp = tk ^. tkuKey . _1
    maybe
        (put (PublicKey pkp))
        (\ska -> put (SecretKey pkp ska))
        (snd (tk ^. tkuKey))
    mapM_ (put . Signature) (_tkuRevs tk)
    mapM_ putUid' (_tkuUIDs tk)
    mapM_ putUat' (_tkuUAts tk)
    mapM_ putSub' (_tkuSubs tk)
  where
    putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps
    putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps
    putSub' (p, sps) = put p >> mapM_ (put . Signature) sps

-- | Parse the packets from a ByteString, with no error reporting
parsePkts :: ByteString -> [Pkt]
parsePkts = reverse . fst . parsePktsAccum 0 []

-- | Parse packets from a ByteString and report the first parse failure.
parsePktsEither :: ByteString -> Either PktParseError [Pkt]
parsePktsEither lbs =
    case parsePktsAccum 0 [] lbs of
        (pkts, Nothing) -> Right (reverse pkts)
        (_, Just err) -> Left err

data PktParseError
    = PktParseError
    { pktParseErrorOffset :: Int64
    , pktParseErrorMessage :: String
    }
    deriving (Eq, Show)

parsePktsAccum
    :: Int64 -> [Pkt] -> ByteString -> ([Pkt], Maybe PktParseError)
parsePktsAccum offset acc lbs
    | BL.null lbs = (acc, Nothing)
    | otherwise =
        case runGetOrFail getPkt lbs of
            Left (_, parseOffset, msg) -> (acc, err parseOffset msg)
            Right (rest, consumed, pkt) ->
                parsePktsAccum (offset + consumed) (pkt : acc) rest
  where
    err parseOffset msg =
        Just
            PktParseError
                { pktParseErrorOffset = offset + parseOffset
                , pktParseErrorMessage = msg
                }

armorPayloads :: [Armor] -> [ByteString]
armorPayloads =
    foldr collect []
  where
    collect (Armor _ _ payload) = (BL.fromStrict (BLC8.toStrict payload) :)
    collect (ClearSigned _ _ inner) = (armorPayloads [inner] ++)

looksLikeAsciiArmor :: ByteString -> Bool
looksLikeAsciiArmor =
    (armorHeaderLazy `BL.isPrefixOf`)
        . BL.dropWhile isLeadingArmorWhitespace

looksLikeAsciiArmorLenient :: ByteString -> Bool
looksLikeAsciiArmorLenient = looksLikeAsciiArmor . stripUtf8Bom

armorPayloadsOfType :: ArmorType -> [Armor] -> [ByteString]
armorPayloadsOfType atype =
    foldr collect []
  where
    collect (Armor innerType _ payload)
        | innerType == atype = (BL.fromStrict (BLC8.toStrict payload) :)
        | otherwise = id
    collect (ClearSigned _ _ inner) = (armorPayloadsOfType atype [inner] ++)

singleArmorPayloadOfType
    :: ArmorType -> [Armor] -> Either String ByteString
singleArmorPayloadOfType atype armors =
    case armorPayloadsOfType atype armors of
        [payload] -> Right payload
        [] ->
            Left
                ("ASCII armor decode returned no " ++ show atype ++ " blocks")
        payloads ->
            Left
                ( "ASCII armor decode returned "
                    ++ show (length payloads)
                    ++ " "
                    ++ show atype
                    ++ " blocks (expected exactly one)"
                )

singleClearSignedBlock
    :: [Armor]
    -> Either String ([(String, String)], ByteString, ByteString)
singleClearSignedBlock armors =
    case [ clearSignedBlockFromArmor armor | armor@ClearSigned {} <- armors
         ] of
        [Right clearSigned] -> Right clearSigned
        [Left err] -> Left err
        [] -> Left "ASCII armor decode returned no clear-signed blocks"
        clearSigneds ->
            Left
                ( "ASCII armor decode returned "
                    ++ show (length clearSigneds)
                    ++ " clear-signed blocks (expected exactly one)"
                )
  where
    clearSignedBlockFromArmor (ClearSigned hs cleartext inner) =
        case inner of
            Armor ArmorSignature _ sig ->
                Right
                    ( hs
                    , BL.fromStrict (BLC8.toStrict cleartext)
                    , BL.fromStrict (BLC8.toStrict sig)
                    )
            Armor atype _ _ ->
                Left
                    ( "clear-signed block contained inner armor type "
                        ++ show atype
                        ++ " (expected ArmorSignature)"
                    )
            ClearSigned {} ->
                Left "clear-signed block contained nested clear-signed payload"
    clearSignedBlockFromArmor _ =
        Left "internal error: expected ClearSigned armor block"

recommendedArmorType :: [Pkt] -> Maybe ArmorType
recommendedArmorType [] = Nothing
recommendedArmorType (pkt : _)
    | isPrivateKeyPacket pkt = Just ArmorPrivateKeyBlock
    | isPublicKeyPacket pkt = Just ArmorPublicKeyBlock
    | isSignaturePacket pkt = Just ArmorSignature
    | otherwise = Just ArmorMessage
  where
    isPrivateKeyPacket SecretKeyPkt {} = True
    isPrivateKeyPacket SecretSubkeyPkt {} = True
    isPrivateKeyPacket _ = False

    isPublicKeyPacket PublicKeyPkt {} = True
    isPublicKeyPacket PublicSubkeyPkt {} = True
    isPublicKeyPacket _ = False

    isSignaturePacket SignaturePkt {} = True
    isSignaturePacket _ = False

dearmorIfAsciiArmored
    :: ByteString -> Either String (Bool, ByteString)
dearmorIfAsciiArmored bs
    | looksLikeAsciiArmor bs =
        (\payload -> (True, payload)) <$> decodeSingleArmorPayload bs
    | otherwise = Right (False, bs)

dearmorIfAsciiArmoredLenient
    :: ByteString -> Either String (Bool, ByteString)
dearmorIfAsciiArmoredLenient bs
    | looksLikeAsciiArmorLenient bs =
        (\payload -> (True, payload))
            <$> decodeSingleArmorPayloadLenient (stripUtf8Bom bs)
    | otherwise = Right (False, bs)

decodeSingleArmorPayload
    :: ByteString -> Either String ByteString
decodeSingleArmorPayload bs =
    case AA.decodeLazy bs of
        Left err -> Left err
        Right armors -> singleArmorPayload armors

decodeSingleArmorPayloadLenient
    :: ByteString -> Either String ByteString
decodeSingleArmorPayloadLenient bs =
    case decodeSingleArmorPayload bs of
        Right payload -> Right payload
        Left strictErr ->
            let normalized = normalizeAsciiArmorForLenientDecode bs
             in if normalized == bs
                    then Left strictErr
                    else case decodeSingleArmorPayload normalized of
                        Left lenientErr ->
                            Left
                                ( strictErr
                                    ++ " (lenient normalization retry failed: "
                                    ++ lenientErr
                                    ++ ")"
                                )
                        Right payload -> Right payload

singleArmorPayload :: [Armor] -> Either String ByteString
singleArmorPayload armors =
    case armorPayloads armors of
        [payload] -> Right payload
        [] -> Left "ASCII armor decode succeeded but returned no blocks"
        payloads ->
            Left
                ( "ASCII armor decode returned "
                    ++ show (length payloads)
                    ++ " blocks (expected exactly one)"
                )

data WireRepInput
    = WireRepInput
    { wireRepInputRef :: WireRepRef
    , wireRepInputPayload :: ByteString
    }

wireRepRefFromInput
    :: Maybe T.Text -> ByteString -> Either String WireRepInput
wireRepRefFromInput mname bs =
    ( \(wasArmored, payload) ->
        WireRepInput
            { wireRepInputRef = BTypes.mkWireRepRef mname wasArmored payload
            , wireRepInputPayload = payload
            }
    )
        <$> dearmorIfAsciiArmored bs

data ParseState
    = ParseState
    { psOffset :: Int64
    , psIndex :: Int
    , psSource :: WireRepRef
    , psRemaining :: BL.ByteString
    }

-- | Parse packets from a source bytestream, preserving packet provenance.
parsePktsWithWireRep
    :: WireRepRef -> ByteString -> [PktWithWireRep]
parsePktsWithWireRep src input = go initialState
  where
    initialState =
        ParseState
            { psOffset = 0
            , psIndex = 0
            , psSource = src
            , psRemaining = input
            }
    go state
        | BL.null (psRemaining state) = []
        | otherwise =
            case runGetOrFail getPkt (psRemaining state) of
                Left (_, _, _) -> []
                Right (rest, consumed, pkt) ->
                    let raw = BL.take consumed (psRemaining state)
                        newState =
                            state
                                { psOffset = psOffset state + consumed
                                , psIndex = psIndex state + 1
                                , psRemaining = rest
                                }
                        pktWithSource =
                            PktWithWireRep
                                (PktWithBytes raw pkt)
                                (psSource state)
                                (ByteRange (psOffset state) consumed)
                                (psIndex state)
                     in pktWithSource : go newState

conduitParsePktsWithWireRep
    :: (Monad m)
    => Maybe T.Text -> ConduitT B.ByteString PktWithWireRep m ()
conduitParsePktsWithWireRep mname = go (UndecidedInput [])
  where
    go !state = do
        mchunk <- await
        case mchunk of
            Nothing -> mapM_ yield (finishConduitState mname state)
            Just chunk ->
                let !nextState = consumeConduitChunk chunk state
                 in go nextState

data ConduitParseState
    = UndecidedInput ![B.ByteString]
    | ArmoredInput ![B.ByteString]
    | BinaryInput !BinaryParseState

data BinaryParseState
    = BinaryParseState
    { bpsLength :: !Int64
    , bpsOffset :: !Int64
    , bpsIndex :: !Int
    , bpsBuffer :: !B.ByteString
    , bpsParsedRev :: [ParsedPacketChunk]
    }

data ArmorPrefixDecision
    = PrefixNeedsMore
    | PrefixIsArmored
    | PrefixIsBinary

consumeConduitChunk
    :: B.ByteString -> ConduitParseState -> ConduitParseState
consumeConduitChunk chunk (UndecidedInput chunksRev) =
    let prefixChunksRev = chunk : chunksRev
        prefix = B.concat (reverse prefixChunksRev)
     in case classifyArmorPrefix prefix of
            PrefixNeedsMore -> UndecidedInput prefixChunksRev
            PrefixIsArmored -> ArmoredInput prefixChunksRev
            PrefixIsBinary -> feedBinaryChunk prefix initialBinaryParseState
consumeConduitChunk chunk (ArmoredInput chunksRev) = ArmoredInput (chunk : chunksRev)
consumeConduitChunk chunk (BinaryInput state) = BinaryInput (advanceBinaryParseState chunk state)

finishConduitState
    :: Maybe T.Text -> ConduitParseState -> [PktWithWireRep]
finishConduitState mname (UndecidedInput chunksRev) =
    finalizeBinaryParseState
        mname
        ( advanceBinaryParseState
            (B.concat (reverse chunksRev))
            initialBinaryParseState
        )
finishConduitState mname (ArmoredInput chunksRev) =
    let input = BL.fromChunks (reverse chunksRev)
     in case wireRepRefFromInput mname input of
            Left _ -> []
            Right
                WireRepInput
                    { wireRepInputRef = src
                    , wireRepInputPayload = payload
                    } ->
                    parsePktsWithWireRep src payload
finishConduitState mname (BinaryInput state) = finalizeBinaryParseState mname state

initialBinaryParseState :: BinaryParseState
initialBinaryParseState =
    BinaryParseState
        { bpsLength = 0
        , bpsOffset = 0
        , bpsIndex = 0
        , bpsBuffer = B.empty
        , bpsParsedRev = []
        }

feedBinaryChunk
    :: B.ByteString -> BinaryParseState -> ConduitParseState
feedBinaryChunk chunk = BinaryInput . advanceBinaryParseState chunk

advanceBinaryParseState
    :: B.ByteString -> BinaryParseState -> BinaryParseState
advanceBinaryParseState chunk state =
    let !nextLength = bpsLength state + fromIntegral (B.length chunk)
        !(nextOffset, nextIndex, nextBuffer, nextParsedRev) =
            drainParsedPackets
                (bpsOffset state)
                (bpsIndex state)
                (bpsBuffer state <> chunk)
                (bpsParsedRev state)
     in BinaryParseState
            { bpsLength = nextLength
            , bpsOffset = nextOffset
            , bpsIndex = nextIndex
            , bpsBuffer = nextBuffer
            , bpsParsedRev = nextParsedRev
            }

finalizeBinaryParseState
    :: Maybe T.Text -> BinaryParseState -> [PktWithWireRep]
finalizeBinaryParseState mname state =
    let src = BTypes.mkWireRepRefWithLength mname False (bpsLength state)
     in map (toPktWithWireRep src) (reverse (bpsParsedRev state))

classifyArmorPrefix :: B.ByteString -> ArmorPrefixDecision
classifyArmorPrefix prefix =
    case B.dropWhile isLeadingArmorWhitespace prefix of
        rest
            | B.null rest -> PrefixNeedsMore
            | armorHeader `B.isPrefixOf` rest -> PrefixIsArmored
            | rest `B.isPrefixOf` armorHeader -> PrefixNeedsMore
            | otherwise -> PrefixIsBinary

armorHeader :: B.ByteString
armorHeader = B.pack (map (fromIntegral . fromEnum) "-----BEGIN PGP ")

armorHeaderLazy :: ByteString
armorHeaderLazy = BL.fromStrict armorHeader

utf8Bom :: ByteString
utf8Bom = BL.pack [0xef, 0xbb, 0xbf]

isLeadingArmorWhitespace :: Word8 -> Bool
isLeadingArmorWhitespace w = w == 0x20 || w == 0x09 || w == 0x0d || w == 0x0a

stripUtf8Bom :: ByteString -> ByteString
stripUtf8Bom bs
    | utf8Bom `BL.isPrefixOf` bs =
        BL.drop (fromIntegral (BL.length utf8Bom)) bs
    | otherwise = bs

normalizeAsciiArmorForLenientDecode :: ByteString -> ByteString
normalizeAsciiArmorForLenientDecode =
    ensureTrailingLf . normalizeLineEndings
  where
    ensureTrailingLf lbs
        | BL.null lbs = lbs
        | BL.last lbs == 0x0a = lbs
        | otherwise = lbs <> BL.singleton 0x0a
    normalizeLineEndings lbs =
        case BL.uncons lbs of
            Nothing -> BL.empty
            Just (0x0d, rest) ->
                case BL.uncons rest of
                    Just (0x0a, rest') -> BL.cons 0x0a (normalizeLineEndings rest')
                    _ -> BL.cons 0x0a (normalizeLineEndings rest)
            Just (w, rest) -> BL.cons w (normalizeLineEndings rest)

data ParsedPacketChunk
    = ParsedPacketChunk
    { ppcRange :: ByteRange
    , ppcRaw :: ByteString
    , ppcIndex :: Int
    , ppcValue :: Pkt
    }

toPktWithWireRep
    :: WireRepRef -> ParsedPacketChunk -> PktWithWireRep
toPktWithWireRep src ppc =
    PktWithWireRep
        (PktWithBytes (ppcRaw ppc) (ppcValue ppc))
        src
        (ppcRange ppc)
        (ppcIndex ppc)

drainParsedPackets
    :: Int64
    -> Int
    -> B.ByteString
    -> [ParsedPacketChunk]
    -> (Int64, Int, B.ByteString, [ParsedPacketChunk])
drainParsedPackets !offset !idx !buffer acc
    | B.null buffer = (offset, idx, B.empty, acc)
    | otherwise =
        case runGetOrFail getPkt (BL.fromStrict buffer) of
            Left _ -> (offset, idx, buffer, acc)
            Right (rest, consumed, pkt) ->
                let !consumedLen = fromIntegral consumed
                    !nextOffset = offset + consumed
                    !nextIdx = idx + 1
                    !nextBuffer = BL.toStrict rest
                    parsedPacket =
                        ParsedPacketChunk
                            { ppcRange = ByteRange offset consumed
                            , ppcRaw = BL.fromStrict (B.take consumedLen buffer)
                            , ppcIndex = idx
                            , ppcValue = pkt
                            }
                 in drainParsedPackets
                        nextOffset
                        nextIdx
                        nextBuffer
                        (parsedPacket : acc)
