hOpenPGP-3.1: Codec/Encryption/OpenPGP/Serialize.hs
-- Serialize.hs: OpenPGP (RFC9580) serialization (using binary)
-- Copyright © 2012-2026 Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
module Codec.Encryption.OpenPGP.Serialize
( -- * Serialization functions
putPkt
, putPktEither
, putSKAddendum
, getSecretKey
, putSKeyForPKPayload
-- * Utilities
, dearmorIfAsciiArmored
, dearmorIfAsciiArmoredLenient
, looksLikeAsciiArmor
, armorPayloadsOfType
, singleArmorPayloadOfType
, singleClearSignedBlock
, recommendedArmorType
, WireRepInput (..)
, wireRepRefFromInput
, PktParseError (..)
, parsePkts
, parsePktsEither
, parsePktsWithWireRep
, conduitParsePktsWithWireRep
) where
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types
( Armor (..)
, ArmorType (..)
)
import Control.Applicative (many, some)
import Control.Arrow ((***))
import Control.Lens ((^.), _1)
import Control.Monad (guard, replicateM, replicateM_, when)
import Crypto.Number.Basic (numBits)
import Crypto.Number.ModArithmetic (inverse)
import Crypto.Number.Serialize (i2osp, os2ip)
import qualified Crypto.PubKey.DSA as D
import qualified Crypto.PubKey.ECC.ECDSA as ECDSA
import qualified Crypto.PubKey.ECC.Types as ECCT
import qualified Crypto.PubKey.RSA as R
import Data.Bifunctor (bimap)
import Data.Binary (Binary, get, put)
import Data.Binary.Get
( ByteOffset
, Get
, bytesRead
, getByteString
, getLazyByteString
, getRemainingLazyByteString
, getWord16be
, getWord16le
, getWord32be
, getWord8
, lookAhead
, runGetOrFail
)
import Data.Binary.Put
( Put
, putByteString
, putLazyByteString
, putWord16be
, putWord16le
, putWord32be
, putWord8
, runPut
)
import Data.Bits (shiftL, shiftR, testBit, (.&.), (.|.))
import qualified Data.ByteString as B
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Conduit (ConduitT, await, yield)
import qualified Data.Foldable as F
import Data.Int (Int64)
import Data.List (mapAccumL)
import qualified Data.List.NonEmpty as NE
import 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.Types.Internal.Base as BTypes
import qualified Codec.Encryption.OpenPGP.Types.Internal.PKITypes as P
instance Binary SigSubPacket where
get = getSigSubPacket
put = putSigSubPacket
-- instance Binary (Set NotationFlag) where
-- put = putNotationFlagSet
instance Binary CompressionAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary PubKeyAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary HashAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary SymmetricAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary AEADAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary MPI where
get = getMPI
put = putMPI
instance Binary SigType where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary UserAttrSubPacket where
get = getUserAttrSubPacket
put = putUserAttrSubPacket
instance Binary S2K where
get = getS2K
put = putS2K
instance Binary (PKESK 'PKESKV3) where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary (PKESK 'PKESKV6) where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary Signature where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary (SKESK 'SKESKV4) where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary (SKESK 'SKESKV6) where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary (OnePassSignature 'OPSV3) where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary (OnePassSignature 'OPSV6) where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary SecretKey where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary PublicKey where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary SecretSubkey where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary CompressedData where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary SymEncData where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary Marker where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary LiteralData where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary Trust where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary UserId where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary PublicSubkey where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary UserAttribute where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary SymEncIntegrityProtectedData where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary ModificationDetectionCode where
get = getPkt >>= either fail pure . fromPktEither
put = putPkt . toPkt
instance Binary 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 == 35 = do
kv <- getWord8
fp <- getLazyByteString (l - 2)
when (BL.length fp /= 20 && BL.length fp /= 32) $
fail
( "invalid intended recipient fingerprint length: "
++ show (BL.length fp)
)
case BTypes.packetVersionToIssuerFingerprintVersion kv of
Nothing ->
fail
( "invalid intended recipient fingerprint version marker: "
++ show kv
)
Just ifVersion ->
return $
SigSubPacket crit (IntendedRecipient ifVersion (Fingerprint fp))
| pt == 39 = do
let payloadLen = fromIntegral (l - 1)
when (payloadLen `mod` 2 /= 0) $
fail "preferred AEAD ciphersuites subpacket length must be even"
pairs <- replicateM (payloadLen `div` 2) $ do
sa <- get
aead <- get
return (sa, aead)
return $ SigSubPacket crit (PreferredAEADCiphersuites pairs)
| 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 (IntendedRecipient kv irf)) = do
let kv' = BTypes.issuerFingerprintVersionToPacketVersion kv
let fpb = unFingerprint irf
when (BL.length fpb /= 20 && BL.length fpb /= 32) $
error
( "invalid intended-recipient fingerprint length: "
++ show (BL.length fpb)
)
putSubPacketLength . fromIntegral $ (2 + BL.length fpb)
putSigSubPacketType crit 35
putWord8 kv'
putLazyByteString fpb
putSigSubPacket (SigSubPacket crit (PreferredAEADCiphersuites ps)) = do
putSubPacketLength . fromIntegral $ (1 + 2 * length ps)
putSigSubPacketType crit 39
mapM_ (\(sa, aead) -> put sa >> put aead) ps
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
:: (FutureFlag b, Integral a) => a -> Set b -> ByteString
ffSetToFixedLengthBS len ffs =
BL.take
(fromIntegral len)
(BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))
ffSetToBS :: (FutureFlag a) => Set a -> ByteString
ffSetToBS = BL.pack . ffSetToBS'
where
ffSetToBS' :: (FutureFlag a) => Set a -> [Word8]
ffSetToBS' ks
-- Emit a single zero octet for an empty flag set so encoded flag
-- subpackets always carry an explicit flags byte.
| Set.null ks = [0]
| otherwise =
map
( ( foldl (.|.) 0
. map (shiftR 128 . flip mod 8 . fromFFlag)
. Set.toAscList
)
. (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks)
)
[0 .. fromFFlag (Set.findMax ks) `div` 8]
fromS2K :: S2K -> ByteString
fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo]
fromS2K (Salted hashalgo salt) =
BL.pack [1, fromIntegral . fromFVal $ hashalgo]
`BL.append` (BL.fromStrict . unSalt8) salt
fromS2K (IteratedSalted hashalgo salt count) =
BL.pack [3, fromIntegral . fromFVal $ hashalgo]
`BL.append` (BL.fromStrict . unSalt8) salt
`BL.snoc` encodeIterationCount count
fromS2K (Argon2 salt t p encodedM) =
BL.pack [4]
`BL.append` (BL.fromStrict . unSalt16) salt
`BL.append` BL.pack [t, p, encodedM]
fromS2K (OtherS2K _ bs) = bs
getPacketLength :: Get Integer
getPacketLength = do
firstOctet <- getWord8
lenOrPartial <- lengthOctetToLength firstOctet
case lenOrPartial of
Left _ ->
fail "Partial body length is invalid in this context"
Right len -> return len
where
lengthOctetToLength :: Word8 -> Get (Either Integer Integer)
lengthOctetToLength f
| f < 192 = return . Right . fromIntegral $ f
| f < 224 = do
secondOctet <- getWord8
return . Right . fromIntegral $
shiftL (fromIntegral (f - 192) :: Int) 8
+ (fromIntegral secondOctet :: Int)
+ 192
| f < 255 =
return . Left . fromIntegral $
(1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)
| otherwise = do
len <- getWord32be
return . Right . fromIntegral $ len
putPacketLength :: Integer -> Put
putPacketLength l
| l < 192 = putWord8 (fromIntegral l)
| l < 8384 =
putWord8
(fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int))
>> putWord8 (fromIntegral (l - 192) .&. 0xff)
| l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)
| otherwise =
error "packet length exceeds 32-bit definite length encoding"
putPartialLength :: Word8 -> Put
putPartialLength n = putWord8 (224 + n)
getPacketLengthFromOctet :: Word8 -> Get (Either Int64 Int64)
getPacketLengthFromOctet f
| f < 192 = return . Right . fromIntegral $ f
| f < 224 = do
secondOctet <- getWord8
return . Right . fromIntegral $
shiftL (fromIntegral (f - 192) :: Int) 8
+ (fromIntegral secondOctet :: Int)
+ 192
| f < 255 =
return . Left . fromIntegral $
(1 :: Integer) `shiftL` fromIntegral (f .&. 0x1f)
| otherwise = do
len <- getWord32be
return . Right . fromIntegral $ len
getS2K :: Get S2K
getS2K = getS2K' =<< getWord8
where
getS2K' :: Word8 -> Get S2K
getS2K' t
| t == 0 = do
ha <- getWord8
return $ Simple (toFVal ha)
| t == 1 = do
ha <- getWord8
salt <- getByteString 8
return $ Salted (toFVal ha) (Salt8 salt)
| t == 3 = do
ha <- getWord8
salt <- getByteString 8
count <- getWord8
return $
IteratedSalted
(toFVal ha)
(Salt8 salt)
(decodeIterationCount count)
| t == 4 = do
salt <- getByteString 16
passes <- getWord8
parallelism <- getWord8
encodedM <- getWord8
return $ Argon2 (Salt16 salt) passes parallelism encodedM
| otherwise = do
bs <- getRemainingLazyByteString
return $ OtherS2K t bs
putS2K :: S2K -> Put
putS2K (Simple hashalgo) = error ("confused by simple" ++ show hashalgo)
putS2K (Salted hashalgo salt) =
error
("confused by salted" ++ show hashalgo ++ " by " ++ show salt)
putS2K (IteratedSalted ha salt count) = do
putWord8 3
put ha
putByteString (unSalt8 salt)
putWord8 $ encodeIterationCount count
putS2K (Argon2 salt t p encodedM) = do
putWord8 4
putByteString (unSalt16 salt)
putWord8 t
putWord8 p
putWord8 encodedM
putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs
v6SaltSizeForHashAlgorithm :: HashAlgorithm -> Maybe Word8
v6SaltSizeForHashAlgorithm = signatureV6SaltSizeForHashAlgorithm
getPacketTypeAndPayload :: Get (Word8, ByteString)
getPacketTypeAndPayload = do
tag <- getWord8
guard (testBit tag 7)
case tag .&. 0x40 of
0x00 -> do
let t = shiftR (tag .&. 0x3c) 2
case tag .&. 0x03 of
0 -> do
len <- getWord8
bs <- getLazyByteString (fromIntegral len)
return (t, bs)
1 -> do
len <- getWord16be
bs <- getLazyByteString (fromIntegral len)
return (t, bs)
2 -> do
len <- getWord32be
bs <- getLazyByteString (fromIntegral len)
return (t, bs)
3 -> do
bs <- getRemainingLazyByteString
return (t, bs)
_ ->
error "This should never happen (getPacketTypeAndPayload/0x00)."
0x40 -> do
firstLenOctet <- getWord8
bs <- getPacketPayloadFromLengthOctet firstLenOctet
return (tag .&. 0x3f, bs)
_ ->
error "This should never happen (getPacketTypeAndPayload/???)."
where
getPacketPayloadFromLengthOctet :: Word8 -> Get ByteString
getPacketPayloadFromLengthOctet lenOctet = do
lenOrPartial <- getPacketLengthFromOctet lenOctet
case lenOrPartial of
Right len -> getLazyByteString len
Left partialLen -> do
chunk <- getLazyByteString partialLen
rest <- getRemainingPartialPayload
return (chunk <> rest)
getRemainingPartialPayload :: Get ByteString
getRemainingPartialPayload = do
lenOctet <- getWord8
lenOrPartial <- getPacketLengthFromOctet lenOctet
case lenOrPartial of
Right len -> getLazyByteString len
Left partialLen -> do
chunk <- getLazyByteString partialLen
(chunk <>) <$> getRemainingPartialPayload
getPkt :: Get Pkt
getPkt = do
(t, pl) <- getPacketTypeAndPayload
case runGetOrFail (getPkt' t (BL.length pl)) pl of
Left (_, _, e) -> return $! BrokenPacketPkt e t pl
Right (_, _, p) -> return p
where
parseLegacyPKESK
:: PacketVersion -> BL.ByteString -> Either String Pkt
parseLegacyPKESK pv body = do
(_, _, (eokeyid, pkaRaw, mpib)) <-
bimap (\(_, _, e) -> e) id $
runGetOrFail
( do
eokeyid <- getLazyByteString 8
pka <- getWord8
mpib <- getRemainingLazyByteString
pure (eokeyid, pka, mpib)
)
body
let pka = toFVal pkaRaw
sk <- parseLegacyPKESKMPIs pka mpib
pure $
PKESKPkt
( PKESKPayloadV3Packet
(PKESKPayloadV3 pv (EightOctetKeyId eokeyid) pka sk)
)
parseLegacyPKESKMPIs
:: PubKeyAlgorithm
-> BL.ByteString
-> Either String (NE.NonEmpty MPI)
parseLegacyPKESKMPIs pka mpib = do
case parseLegacyPKESKMPIsStrict pka mpib of
Right sk -> pure sk
Left strictErr
| pka == X25519 ->
case parseLegacyPKESKX25519V3Octets mpib of
Right sk -> Right sk
Left octetErr ->
Left
( strictErr
++ "; also failed to parse RFC9580 X25519 v3 octet layout: "
++ octetErr
)
| pka == ECDH ->
case parseLegacyPKESKECDHOctets mpib of
Right sk -> Right sk
Left octetErr ->
Left
( strictErr
++ "; also failed to parse RFC6637 ECDH v3 octet layout: "
++ octetErr
)
| otherwise -> Left strictErr
parseLegacyPKESKMPIsStrict
:: PubKeyAlgorithm
-> BL.ByteString
-> Either String (NE.NonEmpty MPI)
parseLegacyPKESKMPIsStrict pka mpib = do
(rest, _, sk) <-
bimap (\(_, _, e) -> e) id $
runGetOrFail (parserForLegacyPKESKMPIs pka) mpib
if BL.null rest
then pure (NE.fromList sk)
else
Left
("unexpected trailing PKESK MPI data for algorithm " ++ show pka)
parseLegacyPKESKX25519V3Octets
:: BL.ByteString -> Either String (NE.NonEmpty MPI)
parseLegacyPKESKX25519V3Octets mpib = do
if BL.length mpib < 33
then Left "X25519 v3 PKESK octet layout is too short"
else Right ()
let ephemeral = BL.toStrict (BL.take 32 mpib)
eskLen = fromIntegral (BL.index mpib 32) :: Int
eskWithAlgo = BL.toStrict (BL.drop 33 mpib)
if eskLen /= B.length eskWithAlgo
then
Left "X25519 v3 PKESK octet layout has inconsistent ESK length"
else Right ()
if B.null eskWithAlgo
then
Left
"X25519 v3 PKESK octet layout must include a symmetric algorithm octet"
else Right ()
let symAlgo = B.head eskWithAlgo
if symAlgo
`elem` [ fromIntegral (fromFVal AES128)
, fromIntegral (fromFVal AES192)
, fromIntegral (fromFVal AES256)
]
then
pure
(NE.fromList [MPI (os2ip ephemeral), MPI (os2ip eskWithAlgo)])
else
Left
( "X25519 v3 PKESK octet layout has unsupported symmetric algorithm octet "
++ show symAlgo
)
-- \| Parse an RFC 6637 §8 ECDH PKESKv3 body as MPI(ephemeral) || 1-octet-count || C.
-- This is the interoperable wire format produced by GnuPG and other RFC-compliant
-- implementations. hOpenPGP previously wrote both fields as MPIs; this fallback
-- allows reading RFC-compliant packets when the strict two-MPI path fails.
parseLegacyPKESKECDHOctets
:: BL.ByteString -> Either String (NE.NonEmpty MPI)
parseLegacyPKESKECDHOctets mpib = do
(rest, _, ephMPI) <-
bimap (\(_, _, e) -> e) id $ runGetOrFail getMPI mpib
let restBS = BL.toStrict rest
when (B.null restBS) $
Left
"ECDH v3 PKESK RFC6637 octet layout: missing wrapped-key length octet after ephemeral MPI"
let wrappedLen = fromIntegral (B.head restBS) :: Int
wrapped = B.tail restBS
when (wrappedLen /= B.length wrapped) $
Left
( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length field "
++ show wrappedLen
++ " does not match body length "
++ show (B.length wrapped)
)
when (wrappedLen < 24 || wrappedLen `mod` 8 /= 0) $
Left
( "ECDH v3 PKESK RFC6637 octet layout: wrapped key length "
++ show wrappedLen
++ " is not a valid RFC 3394 wrapped key size"
)
pure (ephMPI NE.:| [MPI (os2ip wrapped)])
parserForLegacyPKESKMPIs :: PubKeyAlgorithm -> Get [MPI]
parserForLegacyPKESKMPIs pka =
case expectedLegacyPKESKMPIArity pka of
Just mpiCount -> replicateM mpiCount getMPI
Nothing -> some getMPI
expectedLegacyPKESKMPIArity :: PubKeyAlgorithm -> Maybe Int
expectedLegacyPKESKMPIArity pka
| pka `elem` [RSA, DeprecatedRSAEncryptOnly] = Just 1
| pka `elem` [ElgamalEncryptOnly, ForbiddenElgamal, ECDH, X25519] =
Just 2
| otherwise = Nothing
validateV4SKESKEncryptedSessionKeyS2K
:: S2K -> Maybe BL.ByteString -> Get ()
validateV4SKESKEncryptedSessionKeyS2K _ Nothing = pure ()
validateV4SKESKEncryptedSessionKeyS2K Simple {} (Just _) =
fail
"v4 SKESK packets with encrypted session keys must not use Simple S2K"
validateV4SKESKEncryptedSessionKeyS2K _ (Just _) = pure ()
parseV6PKESK :: BL.ByteString -> Either String Pkt
parseV6PKESK body = do
(_, _, (recipientKeyIdentifier, pka, esk)) <-
bimap (\(_, _, e) -> e) id $
runGetOrFail
( do
keyIdentifierLen <- getWord8
recipientKeyIdentifier <-
getLazyByteString (fromIntegral keyIdentifierLen)
pka <- getWord8
esk <- getRemainingLazyByteString
pure (recipientKeyIdentifier, pka, esk)
)
body
validateV6PKESKRecipientIdentifier recipientKeyIdentifier
pure $
PKESKPkt
( PKESKPayloadV6Packet
(PKESKPayloadV6 recipientKeyIdentifier (toFVal pka) esk)
)
where
validateV6PKESKRecipientIdentifier
:: BL.ByteString -> Either String ()
validateV6PKESKRecipientIdentifier rid =
case BL.length rid of
0 -> Right ()
20 -> Right ()
32 -> Right ()
21 -> validateVersionedFingerprint rid
33 -> validateVersionedFingerprint rid
ridLen ->
Left
( "invalid PKESK v6 recipient identifier length: "
++ show ridLen
++ " (expected 0, 20, 21, 32, or 33)"
)
validateVersionedFingerprint :: BL.ByteString -> Either String ()
validateVersionedFingerprint rid =
let keyVersion = BL.head rid
fingerprintLen = BL.length (BL.tail rid)
in case keyVersion of
4 ->
if fingerprintLen == 20
then Right ()
else
Left
( "PKESK v6 recipient identifier length/version mismatch: key version 4 requires fingerprint length 20, got "
++ show fingerprintLen
)
6 ->
if fingerprintLen == 32
then Right ()
else
Left
( "PKESK v6 recipient identifier length/version mismatch: key version 6 requires fingerprint length 32, got "
++ show fingerprintLen
)
_ ->
Left
( "invalid PKESK v6 recipient key version: "
++ show keyVersion
++ " (expected 4 or 6)"
)
getPkt' :: Word8 -> ByteOffset -> Get Pkt
getPkt' t len
| 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
| t == 21 = do
payload <- getLazyByteString len
return $ PaddingPkt payload
| 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 (PaddingPkt padding) = do
putWord8 (0xc0 .|. 21)
putLengthThenPayload padding
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.EdSigningCurve25519
<$> ( PrefixedNativeEPoint
<$> validatePrefixedNativePoint 32 "Curve25519Legacy" mpi
)
Right curve ->
case bs2Point (i2osp mpi) of
Left e -> fail e
Right point ->
return
. ECDSAPubKey
. ECDSA_PublicKey
. ECDSA.PublicKey (curve2Curve curve)
$ point
getPubkey ECDH = do
ed <- getPubkey ECDSA -- could be an ECDSA or an EdDSA
kdflen <- getWord8
when (kdflen == 0 || kdflen == 0xff) $
fail "invalid ECDH KDF field length octet (reserved value)"
when (kdflen /= 3) $
fail ("invalid ECDH KDF field length: " ++ show kdflen)
one <- getWord8
when (one /= 1) $
fail ("invalid ECDH KDF reserved octet: " ++ show one)
kdfHA <- get
kdfSA <- get
return $ ECDHPubKey ed kdfHA kdfSA
getPubkey EdDSA = do
curvelength <- getWord8
when (curvelength == 0 || curvelength == 0xff) $
fail "invalid EdDSA curve OID length octet (reserved value)"
curveoid <- getByteString (fromIntegral curvelength)
MPI mpi <- getMPI
case curveoidBSToEdSigningCurve curveoid of
Left e -> fail e
Right P.EdSigningCurve25519 ->
EdDSAPubKey P.EdSigningCurve25519
<$> ( PrefixedNativeEPoint
<$> validatePrefixedNativePoint 32 "Ed25519Legacy" mpi
)
Right P.EdSigningCurve448 ->
EdDSAPubKey P.EdSigningCurve448
<$> ( PrefixedNativeEPoint
<$> validatePrefixedNativePoint 57 "Ed448Legacy" mpi
)
getPubkey pka
| pka == BTypes.Ed25519 =
parseFixedLengthOrLegacyPubkey
32
( EdDSAPubKey P.EdSigningCurve25519
. NativeEPoint
. EPoint
. os2ip
. BL.toStrict
)
(getPubkey EdDSA)
getPubkey pka
| pka == BTypes.Ed448 =
parseFixedLengthOrLegacyPubkey
57
( EdDSAPubKey P.EdSigningCurve448
. NativeEPoint
. EPoint
. os2ip
. BL.toStrict
)
(getPubkey EdDSA)
getPubkey X25519 =
parseFixedLengthOrLegacyPubkey
32
( EdDSAPubKey P.EdSigningCurve25519
. NativeEPoint
. EPoint
. os2ip
. BL.toStrict
)
(getPubkey ECDH)
getPubkey X448 =
parseFixedLengthOrLegacyPubkey
56
( EdDSAPubKey P.EdSigningCurve448
. NativeEPoint
. EPoint
. os2ip
. BL.toStrict
)
(getPubkey ECDH)
getPubkey MLKEM768X25519 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey MLKEM1024X448 = MLKEMPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey MLDSA65Ed25519 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey MLDSA87Ed448 = MLDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey SLHDSASHAKE128s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey SLHDSASHAKE128f = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey SLHDSASHAKE256s = SLHDSAPubKey . BL.toStrict <$> getRemainingLazyByteString
getPubkey _ = UnknownPKey <$> getRemainingLazyByteString
parseFixedLengthOrLegacyPubkey
:: Int64 -> (BL.ByteString -> PKey) -> Get PKey -> Get PKey
parseFixedLengthOrLegacyPubkey expectedLen decodeFixed legacyParser = do
remaining <- lookAhead getRemainingLazyByteString
if BL.length remaining == expectedLen
then decodeFixed <$> getLazyByteString expectedLen
else legacyParser
getPubkeyV6 :: PubKeyAlgorithm -> Get PKey
getPubkeyV6 pka
| pka == BTypes.Ed25519 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
when (B.length bs /= 32) $
fail "invalid v6 Ed25519 public key length"
return $
EdDSAPubKey
P.EdSigningCurve25519
(NativeEPoint (EPoint (os2ip bs)))
| pka == BTypes.Ed448 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
when (B.length bs /= 57) $
fail "invalid v6 Ed448 public key length"
return $
EdDSAPubKey
P.EdSigningCurve448
(NativeEPoint (EPoint (os2ip bs)))
| pka == BTypes.X25519 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
when (B.length bs /= 32) $
fail "invalid v6 X25519 public key length"
return $
EdDSAPubKey
P.EdSigningCurve25519
(NativeEPoint (EPoint (os2ip bs)))
| pka == BTypes.X448 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
when (B.length bs /= 56) $
fail "invalid v6 X448 public key length"
return $
EdDSAPubKey
P.EdSigningCurve448
(NativeEPoint (EPoint (os2ip bs)))
| pka == MLKEM768X25519 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ MLKEMPubKey bs
| pka == MLKEM1024X448 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ MLKEMPubKey bs
| pka == MLDSA65Ed25519 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ MLDSAPubKey bs
| pka == MLDSA87Ed448 = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ MLDSAPubKey bs
| pka == SLHDSASHAKE128s = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ SLHDSAPubKey bs
| pka == SLHDSASHAKE128f = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ SLHDSAPubKey bs
| pka == SLHDSASHAKE256s = do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ SLHDSAPubKey bs
| otherwise = getPubkey pka
bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint
bs2Point bs =
if B.null bs
then Left "empty EC point encoding"
else
let xy = B.drop 1 bs
l = B.length xy
in if B.head bs /= 0x04
then Left $ "unknown type of point: " ++ show (B.unpack bs)
else
if odd l
then
Left "malformed EC point encoding: odd coordinate payload length"
else
return
( uncurry
ECCT.Point
((os2ip *** os2ip) (B.splitAt (div l 2) xy))
)
putPubkey :: PKey -> Put
putPubkey (UnknownPKey bs) = putLazyByteString bs
putPubkey (MLKEMPubKey bs) = putLazyByteString (BL.fromStrict bs)
putPubkey (MLDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)
putPubkey (SLHDSAPubKey bs) = putLazyByteString (BL.fromStrict bs)
putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =
let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)
in putCurveOID curveoidbs
>> mapM_ put (pubkeyToMPIs p)
putPubkey
p@( ECDHPubKey
(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _)))
kha
ksa
) =
let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)
in putCurveOID curveoidbs
>> mapM_ put (pubkeyToMPIs p)
>> putECDHKDFParams kha ksa
putPubkey p@(ECDHPubKey (EdDSAPubKey curve (PrefixedNativeEPoint _)) kha ksa) =
let Right curveoidbs = curveToCurveoidBS (ed2ec curve)
in putCurveOID curveoidbs
>> mapM_ put (pubkeyToMPIs p)
>> putECDHKDFParams kha ksa
where
ed2ec P.EdSigningCurve25519 = Curve25519
ed2ec P.EdSigningCurve448 = Curve448
putPubkey p@(EdDSAPubKey curve (PrefixedNativeEPoint _)) =
let Right curveoidbs = edSigningCurveToCurveoidBS curve
in putCurveOID curveoidbs
>> mapM_ put (pubkeyToMPIs p)
putPubkey (ECDHPubKey (EdDSAPubKey curve (NativeEPoint _)) _ _) =
error
( "legacy ECDH serialization requires a prefixed-native "
++ show curve
++ " point"
)
putPubkey (EdDSAPubKey curve (NativeEPoint _)) =
error
( "legacy EdDSA serialization requires a prefixed-native "
++ show curve
++ " point"
)
putPubkey p = mapM_ put (pubkeyToMPIs p)
putPubkeyV6 :: PKey -> Put
putPubkeyV6 (EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x))) = do
let bs = fixedLengthOctets 32 x
putWord32be . fromIntegral . B.length $ bs
putByteString bs
putPubkeyV6 (EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x))) = do
let bs = fixedLengthOctets 57 x
putWord32be . fromIntegral . B.length $ bs
putByteString bs
putPubkeyV6
( ECDHPubKey
(EdDSAPubKey P.EdSigningCurve25519 (NativeEPoint (EPoint x)))
kha
ksa
) = do
let bs = fixedLengthOctets 32 x
putWord32be . fromIntegral . B.length $ bs
putByteString bs
put kha
put ksa
putPubkeyV6
( ECDHPubKey
(EdDSAPubKey P.EdSigningCurve448 (NativeEPoint (EPoint x)))
kha
ksa
) = do
let bs = fixedLengthOctets 56 x
putWord32be . fromIntegral . B.length $ bs
putByteString bs
put kha
put ksa
putPubkeyV6 (MLKEMPubKey bs) = do
putWord32be . fromIntegral . B.length $ bs
putByteString bs
putPubkeyV6 (MLDSAPubKey bs) = do
putWord32be . fromIntegral . B.length $ bs
putByteString bs
putPubkeyV6 (SLHDSAPubKey bs) = do
putWord32be . fromIntegral . B.length $ bs
putByteString bs
putPubkeyV6 p = putPubkey p
fixedLengthOctets :: Int -> Integer -> B.ByteString
fixedLengthOctets targetLen x =
let bs = i2osp x
in if B.length bs > targetLen
then
error
( "public key element does not fit in "
++ show targetLen
++ " octets"
)
else B.replicate (targetLen - B.length bs) 0 <> bs
validatePrefixedNativePoint
:: Int -> String -> Integer -> Get EPoint
validatePrefixedNativePoint targetLen label i =
let bs = i2osp i
in if B.length bs /= targetLen + 1
then
fail
( "invalid "
++ label
++ " public key length: expected "
++ show (targetLen + 1)
++ " octets with 0x40 prefix, got "
++ show (B.length bs)
)
else
if B.head bs /= 0x40
then
fail ("invalid " ++ label ++ " public key: missing 0x40 prefix")
else pure (EPoint i)
putCurveOID :: B.ByteString -> Put
putCurveOID oid = do
let oidLength = B.length oid
when (oidLength == 0 || oidLength == 0xff) $
error "curve OID length cannot use reserved values 0 or 255"
putWord8 (fromIntegral oidLength)
putByteString oid
putECDHKDFParams :: HashAlgorithm -> SymmetricAlgorithm -> Put
putECDHKDFParams kdfHA kdfSA = do
let kdfLengthOctet = 0x03
when (kdfLengthOctet == 0 || kdfLengthOctet == 0xff) $
error "ECDH KDF field length cannot use reserved values 0 or 255"
putWord8 kdfLengthOctet
putWord8 0x01
put kdfHA
put kdfSA
parseOPSNestedFlag :: Word8 -> Get NestedFlag
parseOPSNestedFlag 0 = pure True
parseOPSNestedFlag 1 = pure False
parseOPSNestedFlag other =
fail ("invalid OPS nested flag octet: " ++ show other)
getSecretKey :: SomePKPayload -> Get SKey
getSecretKey pkp
| _pkalgo pkp
`elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do
MPI d <- get
MPI p <- get
MPI q <- get
MPI _ <- get -- u
case inverse q p of
Nothing -> fail "invalid RSA secret key: q has no inverse modulo p"
Just qinv -> do
let dP = d `mod` (p - 1)
dQ = d `mod` (q - 1)
pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (_pubkey pkp)
return $
RSAPrivateKey
(RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv))
| _pkalgo pkp == DSA = do
MPI x <- get
return $
DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x))
| _pkalgo pkp `elem` [ElgamalEncryptOnly, ForbiddenElgamal] = do
MPI x <- get
return $ ElGamalPrivateKey x
| _pkalgo pkp == ECDSA = do
let pubcurve =
(\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)
(_pubkey pkp)
getECDSAScalarPrivateKey pubcurve
| _pkalgo pkp == ECDH =
do
pubcurve <- ecdhPrivateCurveFromPKPayload pkp
getECDHScalarPrivateKey pubcurve
| _pkalgo pkp == X25519 = do
if _keyVersion pkp == V6
then do
sk <- getByteString 32
return $ X25519PrivateKey sk
else do
pubcurve <- ecdhPrivateCurveFromPKPayload pkp
getECDHScalarPrivateKey pubcurve
| _pkalgo pkp == X448 = do
if _keyVersion pkp == V6
then do
sk <- getByteString 56
return $ X448PrivateKey sk
else UnknownSKey <$> getRemainingLazyByteString
| _pkalgo pkp == EdDSA = do
if _keyVersion pkp == V6
then do
case _pubkey pkp of
EdDSAPubKey P.EdSigningCurve25519 _ -> EdDSAPrivateKey P.EdSigningCurve25519 <$> getByteString 32
EdDSAPubKey P.EdSigningCurve448 _ -> EdDSAPrivateKey P.EdSigningCurve448 <$> getByteString 57
_ -> UnknownSKey <$> getRemainingLazyByteString
else do
MPI x <- get
case _pubkey pkp of
EdDSAPubKey P.EdSigningCurve25519 _ ->
return $
EdDSAPrivateKey P.EdSigningCurve25519 (leftPadTo 32 (i2osp x))
EdDSAPubKey P.EdSigningCurve448 _ ->
return $
EdDSAPrivateKey P.EdSigningCurve448 (leftPadTo 57 (i2osp x))
_ -> return $ UnknownSKey (BL.fromStrict (i2osp x))
| _pkalgo pkp `elem` [MLKEM768X25519, MLKEM1024X448] = do
if _keyVersion pkp == V6
then do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ MLKEMPrivateKey bs
else UnknownSKey <$> getRemainingLazyByteString
| _pkalgo pkp `elem` [MLDSA65Ed25519, MLDSA87Ed448] = do
if _keyVersion pkp == V6
then do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ MLDSAPrivateKey bs
else UnknownSKey <$> getRemainingLazyByteString
| _pkalgo pkp
`elem` [SLHDSASHAKE128s, SLHDSASHAKE128f, SLHDSASHAKE256s] = do
if _keyVersion pkp == V6
then do
len <- getWord32be
bs <- getByteString (fromIntegral len)
return $ SLHDSAPrivateKey bs
else UnknownSKey <$> getRemainingLazyByteString
| otherwise = UnknownSKey <$> getRemainingLazyByteString
getECDSAScalarPrivateKey :: ECCT.Curve -> Get SKey
getECDSAScalarPrivateKey curve = do
MPI pn <- get
pure $
ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))
getECDHScalarPrivateKey :: ECCT.Curve -> Get SKey
getECDHScalarPrivateKey curve = do
MPI pn <- get
pure $
ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey curve pn))
ecdhPrivateCurveFromPKPayload :: SomePKPayload -> Get ECCT.Curve
ecdhPrivateCurveFromPKPayload pkp =
case _pubkey pkp of
ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey p)) _ _ ->
pure (ECDSA.public_curve p)
ECDHPubKey (EdDSAPubKey P.EdSigningCurve25519 _) _ _ ->
pure (curve2Curve Curve25519)
ECDHPubKey (EdDSAPubKey P.EdSigningCurve448 _) _ _ ->
pure (curve2Curve Curve448)
other ->
fail
( "ECDH/X25519 secret key requires an ECDH public key packet, got "
++ show other
)
putSKey :: SKey -> Either String Put
putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =
case inverse q p of
Just u ->
Right (put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u))
Nothing ->
Left
"putSKey: invalid RSA key — q has no multiplicative inverse mod p (key is mathematically broken)"
putSKey (DSAPrivateKey (DSA_PrivateKey (D.PrivateKey _ x))) =
Right (put (MPI x))
putSKey (ElGamalPrivateKey x) =
Right (put (MPI x))
putSKey (ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =
Right (put (MPI d))
putSKey (ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey _ d))) =
Right (put (MPI d))
putSKey (EdDSAPrivateKey P.EdSigningCurve25519 sk) = Right (putByteString sk)
putSKey (EdDSAPrivateKey P.EdSigningCurve448 sk) = Right (putByteString sk)
putSKey (X25519PrivateKey sk) = Right (putByteString sk)
putSKey (X448PrivateKey sk) = Right (putByteString sk)
putSKey (MLKEMPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))
putSKey (MLDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))
putSKey (SLHDSAPrivateKey sk) = Right (putLazyByteString (BL.fromStrict sk))
putSKey (UnknownSKey bs) = Right (putLazyByteString bs)
putSKeyForPKPayload :: SomePKPayload -> SKey -> Either String Put
putSKeyForPKPayload pkp sk@(EdDSAPrivateKey _ bs)
| _keyVersion pkp == V6 = putSKey sk
| otherwise = Right (put (MPI (os2ip bs)))
putSKeyForPKPayload _ sk = putSKey sk
putMPI :: MPI -> Put
putMPI (MPI i) = do
let bs = i2osp i
putWord16be . fromIntegral . numBits $ i
putByteString bs
data PKPayloadReadCase where
PKPayloadReadCaseV3
:: V3Expiration -> PubKeyAlgorithm -> PKPayloadReadCase
PKPayloadReadCaseV4 :: PubKeyAlgorithm -> PKPayloadReadCase
PKPayloadReadCaseV6 :: PubKeyAlgorithm -> PKPayloadReadCase
pkPayloadReadCase :: Word8 -> Get PKPayloadReadCase
pkPayloadReadCase version =
case version of
2 -> do
v3e <- getWord16be
pka <- get
pure (PKPayloadReadCaseV3 v3e pka)
3 -> do
v3e <- getWord16be
pka <- get
pure (PKPayloadReadCaseV3 v3e pka)
4 -> PKPayloadReadCaseV4 <$> get
6 -> PKPayloadReadCaseV6 <$> get
_ -> fail ("unsupported key packet version " ++ show version)
getPKPayload :: Get SomePKPayload
getPKPayload = do
version <- getWord8
ctime <- fmap ThirtyTwoBitTimeStamp getWord32be
readCase <- pkPayloadReadCase version
case readCase of
PKPayloadReadCaseV3 v3e pka -> do
pk <- getPubkey pka
pure $! PKPayload DeprecatedV3 ctime v3e pka pk
PKPayloadReadCaseV4 pka -> do
pk <- getPubkey pka
pure $! PKPayload V4 ctime 0 pka pk
PKPayloadReadCaseV6 pka -> do
pk <- getPubkeyV6 pka
pure $! PKPayload V6 ctime 0 pka pk
data PKPayloadWriteCase where
PKPayloadWriteCaseV3
:: PKPayload 'DeprecatedV3 -> PKPayloadWriteCase
PKPayloadWriteCaseV4 :: PKPayload 'V4 -> PKPayloadWriteCase
PKPayloadWriteCaseV6 :: PKPayload 'V6 -> PKPayloadWriteCase
pkPayloadWriteCase :: SomePKPayload -> PKPayloadWriteCase
pkPayloadWriteCase (SomePKPayload pkp) =
case pkp of
PKPayloadV3 {} -> PKPayloadWriteCaseV3 pkp
PKPayloadV4 {} -> PKPayloadWriteCaseV4 pkp
PKPayloadV6 {} -> PKPayloadWriteCaseV6 pkp
putPKPayload :: SomePKPayload -> Put
putPKPayload pkpSome =
case pkPayloadWriteCase pkpSome of
PKPayloadWriteCaseV3 (PKPayloadV3 ctime v3e pka pk) -> do
putWord8 3
putWord32be . unThirtyTwoBitTimeStamp $ ctime
putWord16be v3e
put pka
putPubkey pk
PKPayloadWriteCaseV4 (PKPayloadV4 ctime pka pk) -> do
putWord8 4
putWord32be . unThirtyTwoBitTimeStamp $ ctime
put pka
putPubkeyV4ForAlgorithm pka pk
PKPayloadWriteCaseV6 (PKPayloadV6 ctime pka pk) -> do
putWord8 6
putWord32be . unThirtyTwoBitTimeStamp $ ctime
put pka
putPubkeyV6 pk
putPubkeyV4ForAlgorithm :: PubKeyAlgorithm -> PKey -> Put
putPubkeyV4ForAlgorithm pka pk
| pka == BTypes.Ed25519 =
putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk
| pka == BTypes.Ed448 =
putPubkeyV4Fixed 57 P.EdSigningCurve448 pk
| pka == BTypes.X25519 =
putPubkeyV4Fixed 32 P.EdSigningCurve25519 pk
| pka == BTypes.X448 = putPubkeyV4Fixed 56 P.EdSigningCurve448 pk
| otherwise = putPubkey pk
putPubkeyV4Fixed :: Int -> P.EdSigningCurve -> PKey -> Put
putPubkeyV4Fixed targetLen expectedCurve (EdDSAPubKey curve (NativeEPoint (EPoint x)))
| curve == expectedCurve =
putByteString (fixedLengthOctets targetLen x)
putPubkeyV4Fixed _ _ pk = putPubkey pk
getSKAddendum :: SomePKPayload -> Get SKAddendum
getSKAddendum (SomePKPayload pkp) =
toSKAddendum <$> getSKAddendumTyped pkp
getSKAddendumTyped :: PKPayload v -> Get (SKAddendumV v)
getSKAddendumTyped pkp = do
s2kusage <- getWord8
let pkpSome = SomePKPayload pkp
getLegacyS2KProtected constructor = do
symencWord <- getWord8
s2k <- getS2K
let symenc = toFVal symencWord
case s2k of
OtherS2K _ _ -> return $ constructor symenc s2k mempty BL.empty
_ -> do
blockSize <- either fail pure (symEncBlockSize symenc)
iv <- IV <$> getByteString blockSize
encryptedblock <- getRemainingLazyByteString
return $ constructor symenc s2k iv encryptedblock
case s2kusage of
0 ->
case pkp of
PKPayloadV6 {} -> do
sk <- getSecretKey pkpSome
return (SKAUnencryptedV6 sk)
PKPayloadV3 {} -> do
rest <- lookAhead getRemainingLazyByteString
secretLen <-
case runGetOrFail
( do
start <- bytesRead
_ <- getSecretKey pkpSome
end <- bytesRead
pure (end - start)
)
rest of
Left (_, _, err) -> fail err
Right (_, _, len) -> pure len
sk <- getSecretKey pkpSome
checksum <- getWord16be
let expectedChecksum =
checksum16Bytes (BL.toStrict (BL.take secretLen rest))
when (checksum /= expectedChecksum) $
fail
( "legacy unencrypted secret-key checksum mismatch: expected "
++ show expectedChecksum
++ ", got "
++ show checksum
)
return (SKAUnencryptedLegacy sk checksum)
PKPayloadV4 {} -> do
rest <- lookAhead getRemainingLazyByteString
secretLen <-
case runGetOrFail
( do
start <- bytesRead
_ <- getSecretKey pkpSome
end <- bytesRead
pure (end - start)
)
rest of
Left (_, _, err) -> fail err
Right (_, _, len) -> pure len
sk <- getSecretKey pkpSome
checksum <- getWord16be
let expectedChecksum =
checksum16Bytes (BL.toStrict (BL.take secretLen rest))
when (checksum /= expectedChecksum) $
fail
( "legacy unencrypted secret-key checksum mismatch: expected "
++ show expectedChecksum
++ ", got "
++ show checksum
)
return (SKAUnencryptedLegacy sk checksum)
255 ->
case pkp of
PKPayloadV6 {} ->
fail "v6 secret key packets MUST NOT use s2k usage 255"
PKPayloadV3 {} ->
getLegacyS2KProtected SKA16bit
PKPayloadV4 {} ->
getLegacyS2KProtected SKA16bit
254 ->
case pkp of
PKPayloadV6 {} -> do
paramsLen <- getWord8
params <- getLazyByteString (fromIntegral paramsLen)
(symenc, s2k, iv) <-
case runGetOrFail getV6CFBParams params of
Left (_, _, err) -> fail err
Right (rest, _, parsed)
| not (BL.null rest) ->
fail "unexpected trailing v6 CFB parameters"
| otherwise -> pure parsed
encryptedblock <- getRemainingLazyByteString
return (SKASHA1V6 symenc s2k (IV iv) encryptedblock)
PKPayloadV3 {} ->
getLegacyS2KProtected SKASHA1Legacy
PKPayloadV4 {} ->
getLegacyS2KProtected SKASHA1Legacy
where
getV6CFBParams = do
symencWord <- getWord8
s2kLen <- getWord8
s2kBytes <- getLazyByteString (fromIntegral s2kLen)
s2k <-
case runGetOrFail getS2K s2kBytes of
Left (_, _, err) -> fail err
Right (rest, _, parsed)
| not (BL.null rest) ->
fail "unexpected trailing bytes in v6 S2K specifier"
| otherwise -> pure parsed
iv <- getRemainingLazyByteString
let symenc = toFVal symencWord
blockSize <- either fail pure (symEncBlockSize symenc)
when (BL.length iv /= fromIntegral blockSize) $
fail "invalid v6 CFB IV length"
pure (symenc, s2k, BL.toStrict iv)
253 ->
case pkp of
PKPayloadV6 {} -> do
paramsLen <- getWord8
params <- getLazyByteString (fromIntegral paramsLen)
(symenc, aead, s2k, iv) <-
case runGetOrFail getV6AEADParams params of
Left (_, _, err) -> fail err
Right (rest, _, parsed)
| not (BL.null rest) ->
fail "unexpected trailing v6 AEAD parameters"
| otherwise -> pure parsed
encryptedblock <- getRemainingLazyByteString
return (SKAAEADV6 symenc aead s2k (IV iv) encryptedblock)
PKPayloadV3 {} -> do
(symenc, aead, s2k, iv) <- getLegacyAEADParams
encryptedblock <- getRemainingLazyByteString
return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)
PKPayloadV4 {} -> do
(symenc, aead, s2k, iv) <- getLegacyAEADParams
encryptedblock <- getRemainingLazyByteString
return (SKAAEADLegacy symenc aead s2k (IV iv) encryptedblock)
where
getV6AEADParams
:: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)
getV6AEADParams = do
symencWord <- getWord8
aeadWord <- getWord8
s2kLen <- getWord8
s2kBytes <- getLazyByteString (fromIntegral s2kLen)
s2k <-
case runGetOrFail getS2K s2kBytes of
Left (_, _, err) -> fail err
Right (rest, _, parsed)
| not (BL.null rest) ->
fail "unexpected trailing bytes in v6 S2K specifier"
| otherwise -> pure parsed
iv <- getRemainingLazyByteString
let symenc = toFVal symencWord
aead = toFVal aeadWord
when (BL.length iv /= fromIntegral (aeadNonceSize aead)) $
fail "invalid v6 AEAD IV length"
pure (symenc, aead, s2k, BL.toStrict iv)
-- v3/v4: no cumulative-params-length octet, no S2K-size octet
getLegacyAEADParams
:: Get (SymmetricAlgorithm, AEADAlgorithm, S2K, B.ByteString)
getLegacyAEADParams = do
symencWord <- getWord8
aeadWord <- getWord8
s2k <- getS2K
let aead = toFVal aeadWord
iv <-
BL.toStrict
<$> getLazyByteString (fromIntegral (aeadNonceSize aead))
pure (toFVal symencWord, aead, s2k, iv)
symenc ->
case pkp of
PKPayloadV6 {} -> do
paramsLen <- getWord8
iv <- getByteString (fromIntegral paramsLen)
let symencAlg = toFVal symenc
blockSize <- either fail pure (symEncBlockSize symencAlg)
when (B.length iv /= blockSize) $
fail "invalid v6 CFB IV length"
encryptedblock <- getRemainingLazyByteString
return (SKASymV6 symencAlg (IV iv) encryptedblock)
PKPayloadV3 {} -> do
blockSize <- either fail pure (symEncBlockSize (toFVal symenc))
iv <- getByteString blockSize
encryptedblock <- getRemainingLazyByteString
return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)
PKPayloadV4 {} -> do
blockSize <- either fail pure (symEncBlockSize (toFVal symenc))
iv <- getByteString blockSize
encryptedblock <- getRemainingLazyByteString
return (SKASymLegacy (toFVal symenc) (IV iv) encryptedblock)
putSKAddendum :: SKAddendum -> Either String Put
putSKAddendum (SUS16bit symenc s2k iv encryptedblock) =
Right $ do
putWord8 255
put symenc
put s2k
putByteString (unIV iv)
putLazyByteString encryptedblock
putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) =
Right $ do
putWord8 254
put symenc
put s2k
putByteString (unIV iv)
putLazyByteString encryptedblock
putSKAddendum (SUSAEAD symenc aead s2k iv encryptedblock) =
Right $ do
putWord8 253
put symenc
putWord8 (fromFVal aead)
put s2k
putByteString (unIV iv)
putLazyByteString encryptedblock
putSKAddendum (SUSym symenc iv encryptedblock) =
Right $ do
put symenc
putByteString (unIV iv)
putLazyByteString encryptedblock
putSKAddendum (SUUnencrypted sk checksum) =
do
putSecret <- putSKey sk
Right $ do
putWord8 0
let skb = runPut putSecret
putLazyByteString skb
putWord16be
( if checksum == 0
then checksum16Bytes (BL.toStrict skb)
else checksum
)
checksum16Bytes :: B.ByteString -> Word16
checksum16Bytes =
B.foldl'
( \a b ->
fromIntegral
((fromIntegral a + fromIntegral b) `mod` (65536 :: Integer))
)
0
putSKAddendumForPKPayload :: SomePKPayload -> SKAddendum -> Put
putSKAddendumForPKPayload pkp ska =
case fromSKAddendumForPKPayload pkp ska of
Left e -> error e
Right (SomeSKAddendumV skaV) ->
putSKAddendumForPKPayloadTyped pkp skaV
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)