module Codec.Encryption.OpenPGP.Serialize
(
putSKAddendum
, getSecretKey
, parsePkts
) where
import Control.Applicative (many, some)
import Control.Lens ((^.), _1)
import Control.Monad (guard, replicateM, replicateM_)
import Crypto.Number.Basic (numBits)
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
, getByteString
, getLazyByteString
, getRemainingLazyByteString
, getWord16be
, getWord16le
, getWord32be
, getWord8
, 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.Foldable as F
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
, multiplicativeInverse
, pubkeyToMPIs
)
import Codec.Encryption.OpenPGP.Types
instance Binary SigSubPacket where
get = getSigSubPacket
put = putSigSubPacket
instance Binary CompressionAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary PubKeyAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary HashAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary SymmetricAlgorithm where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary MPI where
get = getMPI
put = putMPI
instance Binary SigType where
get = toFVal <$> getWord8
put = putWord8 . fromFVal
instance Binary UserAttrSubPacket where
get = getUserAttrSubPacket
put = putUserAttrSubPacket
instance Binary S2K where
get = getS2K
put = putS2K
instance Binary PKESK where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary Signature where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary SKESK where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary OnePassSignature where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary SecretKey where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary PublicKey where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary SecretSubkey where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary CompressedData where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary SymEncData where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary Marker where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary LiteralData where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary Trust where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary UserId where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary PublicSubkey where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary UserAttribute where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary SymEncIntegrityProtectedData where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary ModificationDetectionCode where
get = fmap fromPkt getPkt
put = putPkt . toPkt
instance Binary OtherPacket where
get = fmap fromPkt getPkt
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 PKPayload where
get = getPKPayload
put = putPKPayload
instance Binary SignaturePayload where
get = getSignaturePayload
put = putSignaturePayload
instance Binary TK where
get = undefined
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 20
return $
SigSubPacket
crit
(RevocationKey
(bsToFFSet . BL.singleton $ rclass .&. 0x7f)
algid
(TwentyOctetFingerprint 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
sp <- get :: Get SignaturePayload
return $ SigSubPacket crit (EmbeddedSignature sp)
| pt == 33 = do
kv <- getWord8
fp <-
getLazyByteString
(if kv == 4
then 20
else 32)
return $
SigSubPacket crit (IssuerFingerprint kv (TwentyOctetFingerprint fp))
| pt > 99 && pt < 111 = do
payload <- getLazyByteString (l - 1)
return $ SigSubPacket crit (UserDefinedSigSub pt payload)
| otherwise = do
payload <- getLazyByteString (l - 1)
return $ SigSubPacket crit (OtherSigSub pt payload)
putSigSubPacket :: SigSubPacket -> Put
putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do
putSubPacketLength 5
putSigSubPacketType crit 2
putWord32be . unThirtyTwoBitTimeStamp $ et
putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do
putSubPacketLength 5
putSigSubPacketType crit 3
putWord32be . unThirtyTwoBitDuration $ et
putSigSubPacket (SigSubPacket crit (ExportableCertification e)) = do
putSubPacketLength 2
putSigSubPacketType crit 4
put e
putSigSubPacket (SigSubPacket crit (TrustSignature tl ta)) = do
putSubPacketLength 3
putSigSubPacketType crit 5
put tl
put ta
putSigSubPacket (SigSubPacket crit (RegularExpression apdre)) = do
putSubPacketLength . fromIntegral $ (2 + BL.length apdre)
putSigSubPacketType crit 6
putLazyByteString apdre
putWord8 0
putSigSubPacket (SigSubPacket crit (Revocable r)) = do
putSubPacketLength 2
putSigSubPacketType crit 7
put r
putSigSubPacket (SigSubPacket crit (KeyExpirationTime et)) = do
putSubPacketLength 5
putSigSubPacketType crit 9
putWord32be . unThirtyTwoBitDuration $ et
putSigSubPacket (SigSubPacket crit (PreferredSymmetricAlgorithms ess)) = do
putSubPacketLength . fromIntegral $ (1 + length ess)
putSigSubPacketType crit 11
mapM_ put ess
putSigSubPacket (SigSubPacket crit (RevocationKey rclass algid fp)) = do
putSubPacketLength 23
putSigSubPacketType crit 12
putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $
Set.insert (RClOther 0) rclass
put algid
putLazyByteString (unTOF fp)
putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do
putSubPacketLength 9
putSigSubPacketType crit 16
putLazyByteString (unEOKI keyid)
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 fpb = unTOF fp
putSubPacketLength . fromIntegral $ (2 + BL.length fpb)
putSigSubPacketType crit 33
putWord8 kv
putLazyByteString fpb
putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) =
putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload))
putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do
putSubPacketLength . fromIntegral $ (1 + BL.length payload)
putSigSubPacketType crit ptype
putLazyByteString payload
getSubPacketLength :: Get Word32
getSubPacketLength = getSubPacketLength' =<< getWord8
where
getSubPacketLength' :: Integral a => Word8 -> Get a
getSubPacketLength' f
| f < 192 = return . fromIntegral $ f
| f < 224 = do
secondOctet <- getWord8
return . fromIntegral $ shiftL (fromIntegral (f - 192) :: Int) 8 +
(fromIntegral secondOctet :: Int) +
192
| f == 255 = do
len <- getWord32be
return . fromIntegral $ len
| otherwise = fail "Partial body length invalid."
putSubPacketLength :: Word32 -> Put
putSubPacketLength l
| l < 192 = putWord8 (fromIntegral l)
| l < 8384 =
putWord8 (fromIntegral ((fromIntegral (l - 192) `shiftR` 8) + 192 :: Int)) >>
putWord8 (fromIntegral (l - 192) .&. 0xff)
| l <= 0xffffffff = putWord8 255 >> putWord32be (fromIntegral l)
| otherwise = fail ("too big (" ++ show l ++ ")")
getSigSubPacketType :: Get (Bool, Word8)
getSigSubPacketType = do
x <- getWord8
return
(if x .&. 128 == 128
then (True, x .&. 127)
else (False, x))
putSigSubPacketType :: Bool -> Word8 -> Put
putSigSubPacketType False sst = putWord8 sst
putSigSubPacketType True sst = putWord8 (sst .|. 0x80)
bsToFFSet :: FutureFlag a => ByteString -> Set a
bsToFFSet bs =
Set.fromAscList . concat . snd $
mapAccumL
(\acc y -> (acc + 8, concatMap (shifty acc y) [0 .. 7]))
0
(BL.unpack bs)
where
shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x]
ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString
ffSetToFixedLengthBS len ffs =
BL.take
(fromIntegral len)
(BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0)))
ffSetToBS :: FutureFlag a => Set a -> ByteString
ffSetToBS = BL.pack . ffSetToBS'
where
ffSetToBS' :: FutureFlag a => Set a -> [Word8]
ffSetToBS' ks
| Set.null ks = []
| 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)
| B.length (unSalt salt) == 8 =
BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append`
(BL.fromStrict . unSalt) salt
| otherwise = error "Confusing salt size"
fromS2K (IteratedSalted hashalgo salt count)
| B.length (unSalt salt) == 8 =
BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append`
(BL.fromStrict . unSalt) salt `BL.snoc`
encodeIterationCount count
| otherwise = error "Confusing salt size"
fromS2K (OtherS2K _ bs) = bs
getPacketLength :: Get Integer
getPacketLength = do
firstOctet <- getWord8
getPacketLength' firstOctet
where
getPacketLength' :: Integral a => Word8 -> Get a
getPacketLength' 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 support missing."
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 = fail "partial body length support needed"
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) (Salt salt)
| t == 3 = do
ha <- getWord8
salt <- getByteString 8
count <- getWord8
return $
IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count)
| 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 (unSalt salt)
putWord8 $ encodeIterationCount count
putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs
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
len <- fmap fromIntegral getPacketLength
bs <- getLazyByteString len
return (tag .&. 0x3f, bs)
_ -> error "This should never happen (getPacketTypeAndPayload/???)."
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
getPkt' :: Word8 -> ByteOffset -> Get Pkt
getPkt' t len
| t == 1 = do
pv <- getWord8
eokeyid <- getLazyByteString 8
pka <- getWord8
mpib <- getRemainingLazyByteString
case runGetOrFail (some getMPI) mpib of
Left (_, _, e) -> fail ("PKESK MPIs " ++ e)
Right (_, _, sk) ->
return $
PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk)
| 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
symalgo <- getWord8
s2k <- getS2K
esk <- getRemainingLazyByteString
return $
SKESKPkt
pv
(toFVal symalgo)
s2k
(if BL.null esk
then Nothing
else Just esk)
| t == 4 = do
pv <- getWord8
sigtype <- getWord8
ha <- getWord8
pka <- getWord8
skeyid <- getLazyByteString 8
nested <- getWord8
return $
OnePassSignaturePkt
pv
(toFVal sigtype)
(toFVal ha)
(toFVal pka)
(EightOctetKeyId skeyid)
(nested == 0)
| 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 (_, _, key) -> return key
| 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 (_, _, key) -> return key
| 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 (_, _, key) -> return key
| 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
b <- getLazyByteString (len - 1)
return $ SymEncIntegrityProtectedDataPkt pv b
| t == 19 = do
hash <- getLazyByteString 20
return $ ModificationDetectionCodePkt hash
| otherwise = do
payload <- getLazyByteString len
return $ OtherPacketPkt t payload
getUserAttrSubPacket :: Get UserAttrSubPacket
getUserAttrSubPacket = do
l <- fmap fromIntegral getSubPacketLength
t <- getWord8
getUserAttrSubPacket' t l
where
getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket
getUserAttrSubPacket' t l
| t == 1 = do
_ <- getWord16le
hver <- getWord8
iformat <- getWord8
nuls <- getLazyByteString 12
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
putPkt :: Pkt -> Put
putPkt (PKESKPkt pv eokeyid pka mpis) = do
putWord8 (0xc0 .|. 1)
let bsk = runPut $ F.mapM_ put mpis
putPacketLength . fromIntegral $ 10 + BL.length bsk
putWord8 pv
putLazyByteString (unEOKI eokeyid)
putWord8 $ fromIntegral . fromFVal $ pka
putLazyByteString bsk
putPkt (SignaturePkt sp) = do
putWord8 (0xc0 .|. 2)
let bs = runPut $ put sp
putLengthThenPayload bs
putPkt (SKESKPkt pv 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 pv
putWord8 $ fromIntegral . fromFVal $ symalgo
putLazyByteString bs2k
putLazyByteString bsk
putPkt (OnePassSignaturePkt pv sigtype ha pka skeyid nested) = do
putWord8 (0xc0 .|. 4)
let bs =
runPut $ do
putWord8 pv
putWord8 $ fromIntegral . fromFVal $ sigtype
putWord8 $ fromIntegral . fromFVal $ ha
putWord8 $ fromIntegral . fromFVal $ pka
putLazyByteString (unEOKI skeyid)
putWord8 . fromIntegral . fromEnum $ not nested
putLengthThenPayload bs
putPkt (SecretKeyPkt pkp ska) = do
putWord8 (0xc0 .|. 5)
let bs = runPut (putPKPayload pkp >> putSKAddendum 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 >> putSKAddendum 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 pv b) = do
putWord8 (0xc0 .|. 18)
putPacketLength . fromIntegral $ BL.length b + 1
putWord8 pv
putLazyByteString b
putPkt (ModificationDetectionCodePkt hash) = do
putWord8 (0xc0 .|. 19)
putLengthThenPayload hash
putPkt (OtherPacketPkt t payload) = do
putWord8 (0xc0 .|. t)
putLengthThenPayload payload
putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload)
putLengthThenPayload :: ByteString -> Put
putLengthThenPayload bs = do
putPacketLength . fromIntegral $ BL.length bs
putLazyByteString bs
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
curveoid <- getByteString (fromIntegral curvelength)
MPI mpi <- getMPI
case curveoidBSToCurve curveoid of
Left e -> fail e
Right Curve25519 -> return $ EdDSAPubKey Ed25519 (EPoint 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
kdflen <- getWord8
one <- getWord8
kdfHA <- get
kdfSA <- get
return $ ECDHPubKey ed kdfHA kdfSA
getPubkey EdDSA = do
curvelength <- getWord8
curveoid <- getByteString (fromIntegral curvelength)
MPI mpi <- getMPI
case curveoidBSToEdSigningCurve curveoid of
Left e -> fail e
Right Ed25519 -> return . EdDSAPubKey Ed25519 $ EPoint mpi
getPubkey _ = UnknownPKey <$> getRemainingLazyByteString
bs2Point :: B.ByteString -> Either String ECDSA.PublicPoint
bs2Point bs =
let xy = B.drop 1 bs
in let l = B.length xy
in if B.head bs == 0x04
then return
(uncurry
ECCT.Point
(bimap os2ip os2ip (B.splitAt (div l 2) xy)))
else fail $ "unknown type of point: " ++ show (B.unpack bs)
putPubkey :: PKey -> Put
putPubkey (UnknownPKey bs) = putLazyByteString bs
putPubkey p@(ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) =
let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)
in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>
mapM_ put (pubkeyToMPIs p)
putPubkey p@(ECDHPubKey (ECDSAPubKey (ECDSA_PublicKey (ECDSA.PublicKey curve _))) kha ksa) =
let Right curveoidbs = curveToCurveoidBS (curveFromCurve curve)
in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>
mapM_ put (pubkeyToMPIs p) >>
putWord8 0x03 >>
putWord8 0x01 >>
put kha >>
put ksa
putPubkey p@(ECDHPubKey (EdDSAPubKey curve _) kha ksa) =
let Right curveoidbs = curveToCurveoidBS (ed2ec curve)
in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>
mapM_ put (pubkeyToMPIs p) >>
putWord8 0x03 >>
putWord8 0x01 >>
put kha >>
put ksa
where
ed2ec Ed25519 = Curve25519
putPubkey p@(EdDSAPubKey curve _) =
let Right curveoidbs = edSigningCurveToCurveoidBS curve
in putWord8 (fromIntegral (B.length curveoidbs)) >> putByteString curveoidbs >>
mapM_ put (pubkeyToMPIs p)
putPubkey p = mapM_ put (pubkeyToMPIs p)
getSecretKey :: PKPayload -> Get SKey
getSecretKey pkp
| _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do
MPI d <- get
MPI p <- get
MPI q <- get
MPI _ <- get
let dP = 0
dQ = 0
qinv = 0
pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp ^. pubkey)
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
MPI pn <- get
let pubcurve =
(\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)
(pkp ^. pubkey)
return $ ECDSAPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))
| _pkalgo pkp == ECDH
= do
MPI pn <- get
let pubcurve =
(\(ECDSAPubKey (ECDSA_PublicKey p)) -> ECDSA.public_curve p)
(pkp ^. pubkey)
return $ ECDHPrivateKey (ECDSA_PrivateKey (ECDSA.PrivateKey pubcurve pn))
putSKey :: SKey -> Put
putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) =
put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u)
where
u = multiplicativeInverse q p
putMPI :: MPI -> Put
putMPI (MPI i) = do
let bs = i2osp i
putWord16be . fromIntegral . numBits $ i
putByteString bs
getPKPayload :: Get PKPayload
getPKPayload = do
version <- getWord8
ctime <- fmap ThirtyTwoBitTimeStamp getWord32be
if version `elem` [2, 3]
then do
v3e <- getWord16be
pka <- get
pk <- getPubkey pka
return $! PKPayload DeprecatedV3 ctime v3e pka pk
else do
pka <- get
pk <- getPubkey pka
return $! PKPayload V4 ctime 0 pka pk
putPKPayload :: PKPayload -> Put
putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do
putWord8 3
putWord32be . unThirtyTwoBitTimeStamp $ ctime
putWord16be v3e
put pka
putPubkey pk
putPKPayload (PKPayload V4 ctime _ pka pk) = do
putWord8 4
putWord32be . unThirtyTwoBitTimeStamp $ ctime
put pka
putPubkey pk
getSKAddendum :: PKPayload -> Get SKAddendum
getSKAddendum pkp = do
s2kusage <- getWord8
case s2kusage of
0 -> do
sk <- getSecretKey pkp
checksum <- getWord16be
return $ SUUnencrypted sk checksum
255 -> do
symenc <- getWord8
s2k <- getS2K
case s2k
of
OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty
_ -> do
iv <- getByteString (symEncBlockSize . toFVal $ symenc)
encryptedblock <- getRemainingLazyByteString
return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock
254 -> do
symenc <- getWord8
s2k <- getS2K
case s2k
of
OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty
_ -> do
iv <- getByteString (symEncBlockSize . toFVal $ symenc)
encryptedblock <- getRemainingLazyByteString
return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock
symenc -> do
iv <- getByteString (symEncBlockSize . toFVal $ symenc)
encryptedblock <- getRemainingLazyByteString
return $ SUSym (toFVal symenc) (IV iv) encryptedblock
putSKAddendum :: SKAddendum -> Put
putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do
putWord8 254
put symenc
put s2k
putByteString (unIV iv)
putLazyByteString encryptedblock
putSKAddendum (SUUnencrypted sk checksum) = do
putWord8 0
let skb = runPut (putSKey sk)
putLazyByteString skb
putWord16be
(if checksum == 0
then BL.foldl (\a b -> mod (a + fromIntegral b) 0xffff) (0 :: Word16) skb
else checksum)
putSKAddendum _ = fail "Type not supported"
symEncBlockSize :: SymmetricAlgorithm -> Int
symEncBlockSize Plaintext = 0
symEncBlockSize IDEA = 8
symEncBlockSize TripleDES = 8
symEncBlockSize CAST5 = 8
symEncBlockSize Blowfish = 8
symEncBlockSize AES128 = 16
symEncBlockSize AES192 = 16
symEncBlockSize AES256 = 16
symEncBlockSize Twofish = 16
symEncBlockSize Camellia128 = 16
symEncBlockSize _ = 8
decodeIterationCount :: Word8 -> IterationCount
decodeIterationCount c =
IterationCount
((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6))
encodeIterationCount :: IterationCount -> Word8
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
pka <- get
ha <- get
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
case runGetOrFail (some getMPI) mpib of
Left (_, _, e) -> fail ("v4 sig MPIs " ++ e)
Right (_, _, mpis) ->
return $
SigV4
(toFVal st)
(toFVal pka)
(toFVal ha)
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
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
F.mapM_ put mpis
putSignaturePayload (SigVOther pv bs) = do
putWord8 pv
putLazyByteString bs
putTK :: TK -> Put
putTK key = do
let pkp = key ^. tkKey . _1
maybe
(put (PublicKey pkp))
(\ska -> put (SecretKey pkp ska))
(snd (key ^. tkKey))
mapM_ (put . Signature) (_tkRevs key)
mapM_ putUid' (_tkUIDs key)
mapM_ putUat' (_tkUAts key)
mapM_ putSub' (_tkSubs key)
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
parsePkts :: ByteString -> [Pkt]
parsePkts lbs =
case runGetOrFail (some getPkt) lbs of
Left (_, _, e) -> []
Right (_, _, p) -> p