-- 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 GADTs #-}
{-# LANGUAGE FlexibleInstances #-}

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 Control.Applicative (many, some)
import Control.Arrow ((***))
import Control.Lens ((^.), _1)
import Control.Monad (guard, replicateM, replicateM_, when)
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 qualified Data.Foldable as F
import Data.Int (Int64)
import Data.List (mapAccumL)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromMaybe)
import Data.Set (Set)
import qualified Data.Set as Set
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.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))
import Data.Conduit (ConduitT, await, yield)
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 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 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

getSigSubPacket :: Get SigSubPacket
getSigSubPacket = do
  l <- fmap fromIntegral getSubPacketLength
  (crit, pt) <- getSigSubPacketType
  getSigSubPacket' pt crit l
  where
    getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket
    getSigSubPacket' pt crit l
      | pt == 2 = do
        et <- fmap ThirtyTwoBitTimeStamp getWord32be
        return $ SigSubPacket crit (SigCreationTime et)
      | pt == 3 = do
        et <- fmap ThirtyTwoBitDuration getWord32be
        return $ SigSubPacket crit (SigExpirationTime et)
      | pt == 4 = do
        e <- get
        return $ SigSubPacket crit (ExportableCertification e)
      | pt == 5 = do
        tl <- getWord8
        ta <- getWord8
        return $ SigSubPacket crit (TrustSignature tl ta)
      | pt == 6 = do
        apdre <- getLazyByteString (l - 2)
        nul <- getWord8
        guard (nul == 0)
        return $ SigSubPacket crit (RegularExpression (BL.copy apdre))
      | pt == 7 = do
        r <- get
        return $ SigSubPacket crit (Revocable r)
      | pt == 9 = do
        et <- fmap ThirtyTwoBitDuration getWord32be
        return $ SigSubPacket crit (KeyExpirationTime et)
      | pt == 11 = do
        sa <- replicateM (fromIntegral (l - 1)) get
        return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)
      | pt == 12 = 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))
      | pt == 16 = do
        keyid <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))
      | pt == 20 = 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))
      | pt == 21 = do
        ha <- replicateM (fromIntegral (l - 1)) get
        return $ SigSubPacket crit (PreferredHashAlgorithms ha)
      | pt == 22 = do
        ca <- replicateM (fromIntegral (l - 1)) get
        return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)
      | pt == 23 = do
        ksps <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))
      | pt == 24 = do
        pks <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (PreferredKeyServer pks)
      | pt == 25 = do
        primacy <- get
        return $ SigSubPacket crit (PrimaryUserId primacy)
      | pt == 26 = do
        url <-
          fmap
            (URL . fromMaybe nullURI . parseURI . T.unpack .
             decodeUtf8With lenientDecode)
            (getByteString (fromIntegral (l - 1)))
        return $ SigSubPacket crit (PolicyURL url)
      | pt == 27 = do
        kfs <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))
      | pt == 28 = do
        uid <- getByteString (fromIntegral (l - 1))
        return $
          SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid))
      | pt == 29 = do
        rcode <- getWord8
        rreason <-
          fmap
            (decodeUtf8With lenientDecode)
            (getByteString (fromIntegral (l - 2)))
        return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)
      | pt == 30 = do
        fbs <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (Features (bsToFFSet fbs))
      | pt == 31 = do
        pka <- get
        ha <- get
        hash <- getLazyByteString (l - 3)
        return $ SigSubPacket crit (SignatureTarget pka ha hash)
      | pt == 32 = do
        spbs <- getLazyByteString (l - 1)
        case runGetOrFail get spbs of
            Left (_, _, e) -> fail ("embedded signature subpacket " ++ e)
            Right (_, _, sp) -> return $ SigSubPacket crit (EmbeddedSignature sp)
      | pt == 33 = 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))
      | pt > 99 && pt < 111 = do
        payload <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (UserDefinedSigSub pt payload)
      | otherwise = do
        payload <- getLazyByteString (l - 1)
        return $ SigSubPacket crit (OtherSigSub pt payload)

putSigSubPacket :: SigSubPacket -> Put
putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do
  putSubPacketLength 5
  putSigSubPacketType crit 2
  putWord32be . unThirtyTwoBitTimeStamp $ et
putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do
  putSubPacketLength 5
  putSigSubPacketType crit 3
  putWord32be . unThirtyTwoBitDuration $ et
putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do
  putSubPacketLength 2
  putSigSubPacketType crit 4
  put e
putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do
  putSubPacketLength 3
  putSigSubPacketType crit 5
  put tl
  put ta
putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do
  putSubPacketLength . fromIntegral $ (2 + BL.length apdre)
  putSigSubPacketType crit 6
  putLazyByteString apdre
  putWord8 0
putSigSubPacket (SigSubPacket crit (Revocable r)) = do
  putSubPacketLength 2
  putSigSubPacketType crit 7
  put r
putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do
  putSubPacketLength 5
  putSigSubPacketType crit 9
  putWord32be . unThirtyTwoBitDuration $ et
putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do
  putSubPacketLength . fromIntegral $ (1 + length ess)
  putSigSubPacketType crit 11
  mapM_ put ess
putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do
  let fpLen = BL.length (unFingerprint fp)
  putSubPacketLength (fromIntegral (3 + fpLen))  -- type(1) + rclass(1) + algid(1) + fingerprint
  putSigSubPacketType crit 12
  putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $
    Set.insert (RClOther 0) rclass
  put algid
  putLazyByteString (unFingerprint fp)
putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do
  putSubPacketLength 9
  putSigSubPacketType crit 16
  putLazyByteString (unEOKI keyid) -- 8 octets
putSigSubPacket (SigSubPacket crit (NotationData 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
putSigSubPacket (SigSubPacket crit (PreferredHashAlgorithms ehs)) = do
  putSubPacketLength . fromIntegral $ (1 + length ehs)
  putSigSubPacketType crit 21
  mapM_ put ehs
putSigSubPacket (SigSubPacket crit (PreferredCompressionAlgorithms ecs)) = do
  putSubPacketLength . fromIntegral $ (1 + length ecs)
  putSigSubPacketType crit 22
  mapM_ put ecs
putSigSubPacket (SigSubPacket crit (KeyServerPreferences ksps)) = do
  let kbs = ffSetToBS ksps
  putSubPacketLength . fromIntegral $ (1 + BL.length kbs)
  putSigSubPacketType crit 23
  putLazyByteString kbs
putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do
  putSubPacketLength . fromIntegral $ (1 + BL.length ks)
  putSigSubPacketType crit 24
  putLazyByteString ks
putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do
  putSubPacketLength 2
  putSigSubPacketType crit 25
  put primacy
putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do
  let bs = encodeUtf8 (T.pack (uriToString id uri ""))
  putSubPacketLength . fromIntegral $ (1 + B.length bs)
  putSigSubPacketType crit 26
  putByteString bs
putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do
  let kbs = ffSetToBS kfs
  putSubPacketLength . fromIntegral $ (1 + BL.length kbs)
  putSigSubPacketType crit 27
  putLazyByteString kbs
putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do
  let bs = encodeUtf8 userid
  putSubPacketLength . fromIntegral $ (1 + B.length bs)
  putSigSubPacketType crit 28
  putByteString bs
putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do
  let reasonbs = encodeUtf8 rreason
  putSubPacketLength . fromIntegral $ (2 + B.length reasonbs)
  putSigSubPacketType crit 29
  putWord8 . fromFVal $ rcode
  putByteString reasonbs
putSigSubPacket (SigSubPacket crit (Features fs)) = do
  let fbs = ffSetToBS fs
  putSubPacketLength . fromIntegral $ (1 + BL.length fbs)
  putSigSubPacketType crit 30
  putLazyByteString fbs
putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do
  putSubPacketLength . fromIntegral $ (3 + BL.length hash)
  putSigSubPacketType crit 31
  put pka
  put ha
  putLazyByteString hash
putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do
  let spb = runPut (put sp)
  putSubPacketLength . fromIntegral $ (1 + BL.length spb)
  putSigSubPacketType crit 32
  putLazyByteString spb
putSigSubPacket (SigSubPacket crit (IssuerFingerprint 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
putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) =
  putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload))
putSigSubPacket (SigSubPacket crit (OtherSigSub 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 :: (Integral a, FutureFlag b) => 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
      | t == 1 = do
        pv <- getWord8
        body <- getRemainingLazyByteString
        if pv == 6
          then case parseV6PKESK body of
                 Right pkt -> return pkt
                 Left v6Err -> fail ("PKESK v6 parse failed: " ++ v6Err)
          else case parseLegacyPKESK pv body of
                 Right pkt -> return pkt
                 Left legacyErr -> fail ("PKESK MPIs " ++ legacyErr)
      | t == 2 = do
        bs <- getRemainingLazyByteString
        case runGetOrFail get bs of
          Left (_, _, e) -> fail ("signature packet " ++ e)
          Right (_, _, sp) -> return $ SignaturePkt sp
      | t == 3 = do
        pv <- getWord8
        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)
        case pv of
          6 -> do
            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))
          4 -> 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))
          _ -> fail ("unsupported SKESK packet version " ++ show pv)
      | t == 4 = do
        pv <- getWord8
        sigtype <- toFVal <$> getWord8
        ha <- toFVal <$> getWord8
        pka <- toFVal <$> getWord8
        case pv of
          3 -> do
            skeyid <- getLazyByteString 8
            nested <- getWord8 >>= parseOPSNestedFlag
            return $
              OnePassSignaturePkt
                (OPSPayloadV3Packet
                  (OPSPayloadV3
                  pv
                  sigtype
                  ha
                  pka
                  (EightOctetKeyId skeyid)
                  nested))
          6 -> 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))
          _ -> fail ("Unsupported OPS version: " ++ show pv)
      | t == 5 = do
        bs <- getLazyByteString len
        let ps =
              flip runGetOrFail bs $ do
                pkp <- getPKPayload
                ska <- getSKAddendum pkp
                return $ SecretKeyPkt pkp ska
        case ps of
          Left (_, _, err) -> fail ("secret key " ++ err)
          Right (_, _, pkt) -> return pkt
      | t == 6 = do
        pkp <- getPKPayload
        return $ PublicKeyPkt pkp
      | t == 7 = do
        bs <- getLazyByteString len
        let ps =
              flip runGetOrFail bs $ do
                pkp <- getPKPayload
                ska <- getSKAddendum pkp
                return $ SecretSubkeyPkt pkp ska
        case ps of
          Left (_, _, err) -> fail ("secret subkey " ++ err)
          Right (_, _, pkt) -> return pkt
      | t == 8 = do
        ca <- getWord8
        cdata <- getLazyByteString (len - 1)
        return $ CompressedDataPkt (toFVal ca) cdata
      | t == 9 = do
        sdata <- getLazyByteString len
        return $ SymEncDataPkt sdata
      | t == 10 = do
        marker <- getLazyByteString len
        return $ MarkerPkt marker
      | t == 11 = 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
      | t == 12 = do
        tdata <- getLazyByteString len
        return $ TrustPkt tdata
      | t == 13 = do
        udata <- getByteString (fromIntegral len)
        return . UserIdPkt . decodeUtf8With lenientDecode $ udata
      | t == 14 = do
        bs <- getLazyByteString len
        let ps =
              flip runGetOrFail bs $ do
                pkp <- getPKPayload
                return $ PublicSubkeyPkt pkp
        case ps of
          Left (_, _, err) -> fail ("public subkey " ++ err)
          Right (_, _, pkt) -> return pkt
      | t == 17 = do
        bs <- getLazyByteString len
        case runGetOrFail (many getUserAttrSubPacket) bs of
          Left (_, _, err) -> fail ("user attribute " ++ err)
          Right (_, _, uas) -> return $ UserAttributePkt uas
      | t == 18 = 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)
      | t == 19 = do
        hash <- getLazyByteString 20
        return $ ModificationDetectionCodePkt hash
      | otherwise = do
        payload <- getLazyByteString len
        return $ OtherPacketPkt t payload

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 (PKESKPkt (PKESKPayloadV3Packet (PKESKPayloadV3 pv eokeyid pka mpis))) = do
  putWord8 (0xc0 .|. 1)
  let bsk = runPut $ putPKESKv3SessionKeyMaterial pka mpis
  putPacketLength . fromIntegral $ 10 + BL.length bsk
  putWord8 pv -- must be 3
  putLazyByteString (unEOKI eokeyid) -- must be 8 octets
  putWord8 $ fromIntegral . fromFVal $ pka
  putLazyByteString bsk
putPkt (PKESKPkt (PKESKPayloadV6Packet (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
putPkt (SignaturePkt sp) = do
  putWord8 (0xc0 .|. 2)
  let bs = runPut $ put sp
  putLengthThenPayload bs
putPkt (SKESKPkt (SKESKPayloadV4Packet (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
putPkt (SKESKPkt (SKESKPayloadV6Packet (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
putPkt (OnePassSignaturePkt (OPSPayloadV3Packet (OPSPayloadV3 pv sigtype ha pka skeyid nested))) = do
  putWord8 (0xc0 .|. 4)
  let bs =
        runPut $ do
          putWord8 pv -- should be 3
          putWord8 $ fromIntegral . fromFVal $ sigtype
          putWord8 $ fromIntegral . fromFVal $ ha
          putWord8 $ fromIntegral . fromFVal $ pka
          putLazyByteString (unEOKI skeyid)
          putWord8 . fromIntegral . fromEnum $ not nested
  putLengthThenPayload bs
putPkt (OnePassSignaturePkt (OPSPayloadV6Packet (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
putPkt (SecretKeyPkt pkp ska) = do
  putWord8 (0xc0 .|. 5)
  let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)
  putLengthThenPayload bs
putPkt (PublicKeyPkt pkp) = do
  putWord8 (0xc0 .|. 6)
  let bs = runPut $ putPKPayload pkp
  putLengthThenPayload bs
putPkt (SecretSubkeyPkt pkp ska) = do
  putWord8 (0xc0 .|. 7)
  let bs = runPut (putPKPayload pkp >> putSKAddendumForPKPayload pkp ska)
  putLengthThenPayload bs
putPkt (CompressedDataPkt ca cdata) = do
  putWord8 (0xc0 .|. 8)
  let bs =
        runPut $ do
          putWord8 $ fromIntegral . fromFVal $ ca
          putLazyByteString cdata
  putLengthThenPayload bs
putPkt (SymEncDataPkt b) = do
  putWord8 (0xc0 .|. 9)
  putLengthThenPayload b
putPkt (MarkerPkt b) = do
  putWord8 (0xc0 .|. 10)
  putLengthThenPayload b
putPkt (LiteralDataPkt 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
putPkt (TrustPkt b) = do
  putWord8 (0xc0 .|. 12)
  putLengthThenPayload b
putPkt (UserIdPkt u) = do
  putWord8 (0xc0 .|. 13)
  let bs = encodeUtf8 u
  putPacketLength . fromIntegral $ B.length bs
  putByteString bs
putPkt (PublicSubkeyPkt pkp) = do
  putWord8 (0xc0 .|. 14)
  let bs = runPut $ putPKPayload pkp
  putLengthThenPayload bs
putPkt (UserAttributePkt us) = do
  putWord8 (0xc0 .|. 17)
  let bs = runPut $ mapM_ put us
  putLengthThenPayload bs
putPkt (SymEncIntegrityProtectedDataPkt (SEIPD1 pv b)) = do
  putWord8 (0xc0 .|. 18)
  putPacketLength . fromIntegral $ BL.length b + 1
  putWord8 pv -- should be 1
  putLazyByteString b
putPkt (SymEncIntegrityProtectedDataPkt (SEIPD2 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
putPkt (ModificationDetectionCodePkt hash) = do
  putWord8 (0xc0 .|. 19)
  putLengthThenPayload hash
putPkt (OtherPacketPkt t payload) = do
  when (t > 63) $
    error ("cannot serialize OtherPacket packet tag > 63: " ++ show t)
  putWord8 (0xc0 .|. t)
  putLengthThenPayload payload
putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t 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
    maxPartialChunkSize :: Int64
    maxPartialChunkSize = 1 `shiftL` (30 :: Int)
    putPartialLengthPayload :: ByteString -> Put
    putPartialLengthPayload payload
      | BL.length payload > maxPartialChunkSize = do
        let (chunk, rest) = BL.splitAt maxPartialChunkSize payload
        putPartialLength 30
        putLazyByteString chunk
        putPartialLengthPayload rest
      | otherwise = do
        putPacketLength (fromIntegral (BL.length payload))
        putLazyByteString payload

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.Ed25519 <$> (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.Ed25519 ->
      EdDSAPubKey P.Ed25519 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi)
    Right P.Ed448 ->
      EdDSAPubKey P.Ed448 <$> (PrefixedNativeEPoint <$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi)
getPubkey pka | pka == BTypes.Ed25519 =
  parseFixedLengthOrLegacyPubkey
    32
    (EdDSAPubKey P.Ed25519 . NativeEPoint . EPoint . os2ip . BL.toStrict)
    (getPubkey EdDSA)
getPubkey pka | pka == BTypes.Ed448 =
  parseFixedLengthOrLegacyPubkey
    57
    (EdDSAPubKey P.Ed448 . NativeEPoint . EPoint . os2ip . BL.toStrict)
    (getPubkey EdDSA)
getPubkey X25519 =
  parseFixedLengthOrLegacyPubkey
    32
    (EdDSAPubKey P.Ed25519 . NativeEPoint . EPoint . os2ip . BL.toStrict)
    (getPubkey ECDH)
getPubkey X448 =
  parseFixedLengthOrLegacyPubkey
    56
    (EdDSAPubKey P.Ed448 . NativeEPoint . EPoint . os2ip . BL.toStrict)
    (getPubkey ECDH)
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.Ed25519 (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.Ed448 (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.Ed25519 (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.Ed448 (NativeEPoint (EPoint (os2ip 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 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.Ed25519 = Curve25519
    ed2ec P.Ed448 = 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.Ed25519 (NativeEPoint (EPoint x))) = do
  let bs = fixedLengthOctets 32 x
  putWord32be . fromIntegral . B.length $ bs
  putByteString bs
putPubkeyV6 (EdDSAPubKey P.Ed448 (NativeEPoint (EPoint x))) = do
  let bs = fixedLengthOctets 57 x
  putWord32be . fromIntegral . B.length $ bs
  putByteString bs
putPubkeyV6 (ECDHPubKey (EdDSAPubKey P.Ed25519 (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.Ed448 (NativeEPoint (EPoint x))) kha ksa) = do
  let bs = fixedLengthOctets 56 x
  putWord32be . fromIntegral . B.length $ bs
  putByteString bs
  put kha
  put ksa
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.Ed25519 _ -> EdDSAPrivateKey P.Ed25519 <$> getByteString 32
          EdDSAPubKey P.Ed448 _ -> EdDSAPrivateKey P.Ed448 <$> getByteString 57
          _ -> UnknownSKey <$> getRemainingLazyByteString
      else do
        MPI x <- get
        case _pubkey pkp of
          EdDSAPubKey P.Ed25519 _ ->
            return $ EdDSAPrivateKey P.Ed25519 (leftPadTo 32 (i2osp x))
          EdDSAPubKey P.Ed448 _ ->
            return $ EdDSAPrivateKey P.Ed448 (leftPadTo 57 (i2osp x))
          _ -> return $ UnknownSKey (BL.fromStrict (i2osp x))
  | 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.Ed25519 _) _ _ ->
      pure (curve2Curve Curve25519)
    ECDHPubKey (EdDSAPubKey P.Ed448 _) _ _ ->
      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.Ed25519 sk) = Right (putByteString sk)
putSKey (EdDSAPrivateKey P.Ed448 sk) = Right (putByteString sk)
putSKey (X25519PrivateKey sk) = Right (putByteString sk)
putSKey (X448PrivateKey sk) = Right (putByteString 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.Ed25519 pk
  | pka == BTypes.Ed448 = putPubkeyV4Fixed 57 P.Ed448 pk
  | pka == BTypes.X25519 = putPubkeyV4Fixed 32 P.Ed25519 pk
  | pka == BTypes.X448 = putPubkeyV4Fixed 56 P.Ed448 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

putSKAddendumForPKPayloadTyped ::
     SomePKPayload
  -> SKAddendumV v
  -> Put
putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedLegacy sk checksum) = do
  putWord8 0
  let putSecret =
        case putSKeyForPKPayload pkp sk of
          Left err -> error err
          Right p -> p
      skb = runPut putSecret
  putLazyByteString skb
  putWord16be
    (if checksum == 0
       then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb
       else checksum)
putSKAddendumForPKPayloadTyped pkp (SKAUnencryptedV6 sk) = do
  putWord8 0
  let putSecret =
        case putSKeyForPKPayload pkp sk of
          Left err -> error err
          Right p -> p
      skb = runPut putSecret
  putLazyByteString skb
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
                      (psSource state)
                      (ByteRange (psOffset state) consumed)
                      raw
                      (psIndex state)
                      pkt
               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 src (ppcRange ppc) (ppcRaw ppc) (ppcIndex ppc) (ppcValue 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)
