-- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal)
-- Copyright Ⓒ 2012  Clint Adams
-- This software is released under the terms of the Expat (MIT) license.
-- (See the LICENSE file).

module Codec.Encryption.OpenPGP.Serialize (
) where

import Control.Applicative ((<$>),(<*>))
import Control.Monad (replicateM, mplus, when)
import qualified Crypto.Cipher.RSA as R
import qualified Crypto.Cipher.DSA as D
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import Data.List (mapAccumL)
import Data.Maybe (isJust, fromJust)
import Data.Serialize (Serialize, get, put)
import Data.Serialize.Get (Get, getWord8, getWord16be, getWord32be, getBytes, getByteString, getWord16le, runGet, remaining)
import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putWord16le, runPut)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word8, Word16)

import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS)
import Codec.Encryption.OpenPGP.Types

instance Serialize SigSubPacket where
    get = getSigSubPacket
    put = putSigSubPacket

-- instance Serialize (Set NotationFlag) where
--     put = putNotationFlagSet

instance Serialize CompressionAlgorithm where
    get = getWord8 >>= return . toFVal
    put = putWord8 . fromFVal

instance Serialize PubKeyAlgorithm where
    get = getWord8 >>= return . toFVal
    put = putWord8 . fromFVal

instance Serialize HashAlgorithm where
    get = getWord8 >>= return . toFVal
    put = putWord8 . fromFVal

instance Serialize SymmetricAlgorithm where
    get = getWord8 >>= return . toFVal
    put = putWord8 . fromFVal

instance Serialize MPI where
    get = getMPI
    put = putMPI

instance Serialize SigType where
    get = getWord8 >>= return . toFVal
    put = putWord8 . fromFVal

instance Serialize UserAttrSubPacket where
    get = getUserAttrSubPacket
    put = putUserAttrSubPacket

instance Serialize S2K where
    get = getS2K
    put = putS2K

instance Serialize Packet where
    get = getPacket
    put = putPacket

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

instance Serialize PKPayload where
    get = getPKPayload
    put = putPKPayload

instance Serialize SignaturePayload where
    get = getSignaturePayload
    put = putSignaturePayload

getSigSubPacket :: Get SigSubPacket
getSigSubPacket = do
    l <- getSubPacketLength
    (crit, pt) <- getSigSubPacketType
    getSigSubPacket' pt crit l
    where
        getSigSubPacket' :: Word8 -> Bool -> Int -> Get SigSubPacket
        getSigSubPacket' pt crit l
            | pt == 2 = do
                       et <- getWord32be
                       return $ SigCreationTime crit et
            | pt == 3 = do
                       et <- getWord32be
                       return $ SigExpirationTime crit et
            | pt == 4 = do
                       e <- get
                       return $ ExportableCertification crit e
            | pt == 5 = do
                       tl <- getWord8
                       ta <- getWord8
                       return $ TrustSignature crit tl ta
            | pt == 6 = do
                       apdre <- getByteString (l - 2)
                       return $ RegularExpression crit (B.copy apdre)
            | pt == 7 = do
                       r <- get
                       return $ Revocable crit r
            | pt == 9 = do
                       et <- getWord32be
                       return $ KeyExpirationTime crit et
            | pt == 11 = do
                       sa <- replicateM (l - 1) get
                       return $ PreferredSymmetricAlgorithms crit sa
            | pt == 12 = do
                       rclass <- getWord8
                       algid <- get
                       fp <- getByteString 20
                       return $ RevocationKey crit (bsToFFSet . B.singleton $ rclass) algid (TwentyOctetFingerprint fp)
            | pt == 16 = do
                       keyid <- getByteString (l - 1)
                       return $ Issuer crit (EightOctetKeyId keyid)
            | pt == 20 = do
                       flags <- getByteString 4
                       nl <- getWord16be
                       vl <- getWord16be
                       nd <- getByteString (fromIntegral nl)
                       nv <- getByteString (fromIntegral vl)
                       return $ NotationData crit (bsToFFSet flags) nd nv
            | pt == 21 = do
                       ha <- replicateM (l - 1) get
                       return $ PreferredHashAlgorithms crit ha
            | pt == 22 = do
                       ca <- replicateM (l - 1) get
                       return $ PreferredCompressionAlgorithms crit ca
            | pt == 23 = do
                       ksps <- getByteString (l - 1)
                       return $ KeyServerPreferences crit (bsToFFSet ksps)
            | pt == 24 = do
                       pks <- getByteString (l - 1)
                       return $ PreferredKeyServer crit pks
            | pt == 25 = do
                       primacy <- get
                       return $ PreferredKeyServer crit primacy
            | pt == 26 = do
                       url <- getByteString (l - 1)
                       return $ PolicyURL crit url
            | pt == 27 = do
                       kfs <- getByteString (l - 1)
                       return $ KeyFlags crit (bsToFFSet kfs)
            | pt == 28 = do
                       uid <- getByteString (l - 1)
                       return $ SignersUserId crit uid
            | pt == 29 = do
                       rcode <- getWord8
                       rreason <- getByteString (l - 2)
                       return $ ReasonForRevocation crit (toFVal rcode) rreason
            | pt == 30 = do
                       fbs <- getByteString (l - 1)
                       return $ Features crit (bsToFFSet fbs)
            | pt == 31 = do
                       pka <- get
                       ha <- get
                       hash <- getByteString (l - 3)
                       return $ SignatureTarget crit pka ha hash
            | pt == 32 = do
                       spb <- getByteString (l - 1)
                       return $ EmbeddedSignature crit spb -- FIXME: should be sigpacket
            | pt > 99 && pt < 111 = do
                       payload <- getByteString (l - 1)
                       return $ UserDefinedSigSub crit pt payload
            | otherwise = do
                       payload <- getByteString (l - 1)
                       return $ OtherSigSub crit pt payload

putSigSubPacket :: SigSubPacket -> Put
putSigSubPacket (SigCreationTime crit et) = do
    putSubPacketLength 5
    putSigSubPacketType crit 2
    putWord32be et
putSigSubPacket (SigExpirationTime crit et) = do
    putSubPacketLength 5
    putSigSubPacketType crit 3
    putWord32be et
putSigSubPacket (ExportableCertification crit e) = do
    putSubPacketLength 2
    putSigSubPacketType crit 4
    put e
putSigSubPacket (TrustSignature crit tl ta) = do
    putSubPacketLength 3
    putSigSubPacketType crit 5
    put tl
    put ta
putSigSubPacket (RegularExpression crit apdre) = do
    putSubPacketLength (2 + B.length apdre)
    putSigSubPacketType crit 6
    putByteString apdre
    putWord8 0
putSigSubPacket (Revocable crit r) = do
    putSubPacketLength 2
    putSigSubPacketType crit 7
    put r
putSigSubPacket (KeyExpirationTime crit et) = do
    putSubPacketLength 5
    putSigSubPacketType crit 9
    putWord32be et
putSigSubPacket (PreferredSymmetricAlgorithms crit ess) = do
    putSubPacketLength (1 + length ess)
    putSigSubPacketType crit 11
    mapM_ put ess
putSigSubPacket (RevocationKey crit rclass algid fp) = do
    putSubPacketLength 23
    putSigSubPacketType crit 12
    putByteString . ffSetToFixedLengthBS 1 $ rclass
    put algid
    putByteString (unTOF fp) -- 20 octets
putSigSubPacket (Issuer crit keyid) = do
    putSubPacketLength 9
    putSigSubPacketType crit 16
    putByteString (unEOKI keyid) -- 8 octets
putSigSubPacket (NotationData crit nfs nn nv) = do
    putSubPacketLength (9 + B.length nn + B.length nv)
    putSigSubPacketType crit 20
    putByteString . ffSetToFixedLengthBS 4 $ nfs
    putWord16be . fromIntegral . B.length $ nn
    putWord16be . fromIntegral . B.length $ nv
    putByteString nn
    putByteString nv
putSigSubPacket (PreferredHashAlgorithms crit ehs) = do
    putSubPacketLength (1 + length ehs)
    putSigSubPacketType crit 21
    mapM_ put ehs
putSigSubPacket (PreferredCompressionAlgorithms crit ecs) = do
    putSubPacketLength (1 + length ecs)
    putSigSubPacketType crit 22
    mapM_ put ecs
putSigSubPacket (KeyServerPreferences crit ksps) = do
    let kbs = ffSetToBS ksps
    putSubPacketLength (1 + B.length kbs)
    putSigSubPacketType crit 23
    putByteString kbs
putSigSubPacket (PreferredKeyServer crit ks) = do
    putSubPacketLength (1 + B.length ks)
    putSigSubPacketType crit 24
    putByteString ks
putSigSubPacket (PrimaryUserId crit primacy) = do
    putSubPacketLength 2
    putSigSubPacketType crit 25
    put primacy
putSigSubPacket (PolicyURL crit url) = do
    putSubPacketLength (1 + B.length url)
    putSigSubPacketType crit 26
    putByteString url
putSigSubPacket (KeyFlags crit kfs) = do
    let kbs = ffSetToBS kfs
    putSubPacketLength (1 + B.length kbs)
    putSigSubPacketType crit 27
    putByteString kbs
putSigSubPacket (SignersUserId crit userid) = do
    putSubPacketLength (1 + B.length userid)
    putSigSubPacketType crit 28
    putByteString userid
putSigSubPacket (ReasonForRevocation crit rcode rreason) = do
    putSubPacketLength (2 + B.length rreason)
    putSigSubPacketType crit 29
    putWord8 . fromFVal $ rcode
    putByteString rreason
putSigSubPacket (Features crit fs) = do
    let fbs = ffSetToBS fs
    putSubPacketLength (1 + B.length fbs)
    putSigSubPacketType crit 30
    putByteString fbs
putSigSubPacket (SignatureTarget crit pka ha hash) = do
    putSubPacketLength (3 + B.length hash)
    putSigSubPacketType crit 31
    put pka
    put ha
    putByteString hash
putSigSubPacket (EmbeddedSignature crit spb) = do
    putSubPacketLength (1 + B.length spb)
    putSigSubPacketType crit 32
    putByteString spb
putSigSubPacket (UserDefinedSigSub crit ptype payload) = do
    putSubPacketLength (1 + B.length payload)
    putSigSubPacketType crit ptype
    putByteString payload
putSigSubPacket (OtherSigSub crit ptype payload) = do
    putSubPacketLength (1 + B.length payload)
    putSigSubPacketType crit ptype
    putByteString payload

getSubPacketLength :: Integral a => Get a
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 :: Integral a => a -> 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 < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)
    | otherwise = fail "too big"

getSigSubPacketType :: Get (Bool, Word8)
getSigSubPacketType = do
                         x <- getWord8
                         if x .&. 0x80 == 0x80 then return (True, x .&. 0x7f) else return (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 (\x -> if y .&. (shiftR 128 x) == (shiftR 128 x) then [toFFlag (acc + x)] else []) [0..7])) 0 (B.unpack bs)

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

ffSetToBS :: FutureFlag a => Set a -> ByteString
ffSetToBS = B.pack . ffSetToBS'
    where
        ffSetToBS' :: FutureFlag a => Set a -> [Word8]
        ffSetToBS' ks = map (foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . Set.toAscList) (map (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks) [0..(fromFFlag $ Set.findMax ks) `div` 8])

fromS2K :: S2K -> ByteString
fromS2K (Simple hashalgo) = B.pack [0, fromIntegral . fromFVal $ hashalgo]
fromS2K (Salted hashalgo salt)
    | B.length salt == 8 = B.pack [1, fromIntegral . fromFVal $ hashalgo] `B.append` salt
fromS2K (IteratedSalted hashalgo salt count)
    | B.length salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.snoc` (encodeIterationCount count)
fromS2K (OtherS2K t bs) = bs


getPacketLength :: Integral a => Get a
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." --FIXME

putPacketLength :: Integral a => a -> 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" -- FIXME

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
            | t == 3 = do
                          ha <- getWord8
                          salt <- getByteString 8
                          count <- getWord8
                          return $ IteratedSalted (toFVal ha) salt (decodeIterationCount count)
            | otherwise = error "Unknown S2K"

putS2K :: S2K -> Put
putS2K (IteratedSalted ha salt count) = do
    putWord8 3
    put ha
    putByteString salt
    putWord8 $ encodeIterationCount count

getPacketTypeAndPayload :: Get (Word8, ByteString)
getPacketTypeAndPayload = do
    tag <- getWord8 -- FIXME: bit 7 must be 1, check?
    case tag .&. 0x40 of
        0x00 -> do
                   let t = shiftR (tag .&. 0x3c) 2
                   case tag .&. 0x03 of
                       0 -> do len <- getWord8
                               bs <- getByteString (fromIntegral len)
                               return (t, bs)
                       1 -> do len <- getWord16be
                               bs <- getByteString (fromIntegral len)
                               return (t, bs)
                       2 -> do len <- getWord32be
                               bs <- getByteString (fromIntegral len)
                               return (t, bs)
                       3 -> do len <- remaining
                               bs <- getByteString len
                               return (t, bs)
        0x40 -> do
                   len <- getPacketLength
                   bs <- getByteString len
                   return (tag .&. 0x3f, bs)

getPacket :: Get Packet
getPacket = do
    (t, pl) <- getPacketTypeAndPayload
    case runGet (getPacket' t (B.length pl)) pl of
        Left e -> fail e
        Right p -> return p
    where
        getPacket' :: Word8 -> Int -> Get Packet
        getPacket' t len
            | t == 1 = do
                          pv <- getWord8
                          eokeyid <- getByteString 8
                          pkalgo <- getWord8
                          sk <- getByteString (len - 10)
                          return $ PKESK pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk
            | t == 2 = do
                          remainder <- remaining
                          bs <- getBytes remainder
                          case runGet get bs of
                              Left e -> error e
                              Right sp -> return $ Signature sp
            | t == 3 = do
                          pv <- getWord8
                          symalgo <- getWord8
                          s2k <- getS2K
                          let partiallen = case s2k of
                                               Simple _ -> 1 + 3
                                               Salted _ _ -> 9 + 3
                                               IteratedSalted _ _ _ -> 10 + 3
                          msk <- getMSK len partiallen
                          return $ SKESK pv (toFVal symalgo) s2k msk
            | t == 4 = do
                          pv <- getWord8
                          sigtype <- getWord8
                          ha <- getWord8
                          pka <- getWord8
                          skeyid <- getByteString 8
                          nested <- getWord8
                          return $ OnePassSignature pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0)
            | t == 5 = do
                          bs <- getBytes len
                          let ps = flip runGet bs $ do pkp <- getPKPayload
                                                       ska <- getSKAddendum (pubKeyAlgo pkp)
                                                       return $ SecretKey pkp ska
                          case ps of
                              Left err -> error err
                              Right key -> return key
            | t == 6 = do
                          pkp <- getPKPayload
                          return $ PublicKey pkp
            | t == 7 = do
                          bs <- getBytes len
                          let ps = flip runGet bs $ do pkp <- getPKPayload
                                                       ska <- getSKAddendum (pubKeyAlgo pkp)
                                                       return $ SecretSubkey pkp ska
                          case ps of
                              Left err -> error err
                              Right key -> return key
            | t == 8 = do
                          ca <- getWord8
                          cdata <- getByteString (len - 1)
                          return $ CompressedData (toFVal ca) cdata
            | t == 9 = do
                          sdata <- getByteString len
                          return $ SymEncData sdata
            | t == 10 = do
                          marker <- getByteString len
                          return $ Marker marker
            | t == 11 = do
                          dt <- getWord8
                          flen <- getWord8
                          fn <- getByteString (fromIntegral flen)
                          ts <- getWord32be
                          ldata <- getByteString (len - (6 + (fromIntegral flen)))
                          return $ LiteralData (toFVal dt) fn ts ldata
            | t == 12 = do
                          tdata <- getByteString len
                          return $ Trust tdata
            | t == 13 = do
                          udata <- getBytes len
                          return $ UserId (BC8.unpack udata)
            | t == 14 = do
                          pkp <- getPKPayload
                          return $ PublicSubkey pkp
            | t == 17 = do
                        bs <- getBytes len
                        case runGet (many getUserAttrSubPacket) bs of
                            Left err -> error err
                            Right uas -> return $ UserAttribute uas
            | t == 18 = do
                          pv <- getWord8 -- should be 1
                          b <- getByteString (len - 1)
                          return $ SymEncIntegrityProtectedData pv b
            | t == 19 = do
                          hash <- getByteString 20
                          return $ ModificationDetectionCode hash
            | otherwise = do
                          payload <- getByteString len
                          return $ OtherPacket t payload
            where
                          getMSK :: Int -> Int -> Get (Maybe SessionKey)
                          getMSK len partiallen
                              | len == partiallen = return Nothing
                              | len > partiallen = do
                                                      sk <- getByteString (len - partiallen)
                                                      return $ Just sk
                              | otherwise = error "Overread"

getUserAttrSubPacket :: Get UserAttrSubPacket
getUserAttrSubPacket = do
    l <- getSubPacketLength
    t <- getWord8
    getUserAttrSubPacket' t l
        where
            getUserAttrSubPacket' :: Word8 -> Int -> Get UserAttrSubPacket
            getUserAttrSubPacket' t l
                | t == 1 = do
                              ihlen <- getWord16le
                              hver <- getWord8 -- should be 1
                              iformat <- getWord8
                              _ <- getBytes 12 -- should be NULs
                              bs <- getByteString (l - 17)
                              return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs
                | otherwise = do
                                 bs <- getByteString (l - 1)
                                 return $ OtherUASub t bs

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

putPacket :: Packet -> Put
putPacket (PKESK pv eokeyid pkalgo sk) = do
    putWord8 (0xc0 .|. 1)
    let bsk = sk
    putPacketLength $ 10 + (B.length bsk)
    putWord8 pv -- must be 3
    putByteString (unEOKI eokeyid) -- must be 8 octets
    putWord8 $ fromIntegral . fromFVal $ pkalgo
    putByteString bsk
putPacket (Signature sp) = do
    putWord8 (0xc0 .|. 2)
    let bs = runPut $ put sp
    putPacketLength . B.length $ bs
    putByteString bs
putPacket (SKESK pv symalgo s2k msk) = do
    putWord8 (0xc0 .|. 3)
    let bs2k = fromS2K s2k
    putPacketLength $ 2 + (B.length bs2k) + (maybe 0 B.length msk)
    putWord8 pv -- should be 4
    putWord8 $ fromIntegral . fromFVal $ symalgo
    putByteString bs2k
    when (isJust msk) $ putByteString (fromJust msk)
putPacket (OnePassSignature 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
                putByteString (unEOKI skeyid)
                putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean?
    putPacketLength $ B.length bs
    putByteString bs
putPacket (SecretKey pkp ska) = do
    putWord8 (0xc0 .|. 5)
    let bs = runPut (putPKPayload pkp >> putSKAddendum ska)
    putPacketLength $ B.length bs
    putByteString bs
putPacket (PublicKey pkp) = do
    putWord8 (0xc0 .|. 6)
    let bs = runPut $ putPKPayload pkp
    putPacketLength $ B.length bs
    putByteString bs
putPacket (SecretSubkey pkp ska) = do
    putWord8 (0xc0 .|. 7)
    let bs = runPut (putPKPayload pkp >> putSKAddendum ska)
    putPacketLength $ B.length bs
    putByteString bs
putPacket (CompressedData ca cdata) = do
    putWord8 (0xc0 .|. 8)
    let bs = runPut $ do
                         putWord8 $ fromIntegral . fromFVal $ ca
                         putByteString cdata
    putPacketLength $ B.length bs
    putByteString bs
putPacket (SymEncData b) = do
    putWord8 (0xc0 .|. 9)
    putPacketLength $ B.length b
    putByteString b
putPacket (Marker b) = do
    putWord8 (0xc0 .|. 10)
    putPacketLength $ B.length b
    putByteString b
putPacket (LiteralData dt fn ts b) = do
    putWord8 (0xc0 .|. 11)
    let bs = runPut $ do
                        putWord8 $ fromIntegral . fromFVal $ dt
                        putWord8 $ fromIntegral . B.length $ fn
                        putByteString fn
                        putWord32be ts
                        putByteString b
    putPacketLength $ B.length bs
    putByteString bs
putPacket (Trust b) = do
    putWord8 (0xc0 .|. 12)
    putPacketLength . B.length $ b
    putByteString b
putPacket (UserId u) = do
    putWord8 (0xc0 .|. 13)
    let bs = BC8.pack u
    putPacketLength $ B.length bs
    putByteString bs
putPacket (PublicSubkey pkp) = do
    putWord8 (0xc0 .|. 14)
    let bs = runPut $ putPKPayload pkp
    putPacketLength $ B.length bs
    putByteString bs
putPacket (UserAttribute us) = do
    putWord8 (0xc0 .|. 17)
    let bs = runPut $ mapM_ put us
    putPacketLength $ B.length bs
    putByteString bs
putPacket (SymEncIntegrityProtectedData pv b) = do
    putWord8 (0xc0 .|. 18)
    putPacketLength $ (B.length b) + 1
    putWord8 pv -- should be 1
    putByteString b
putPacket (ModificationDetectionCode hash) = do
    putWord8 (0xc0 .|. 19)
    putPacketLength . B.length $ hash
    putByteString hash
putPacket (OtherPacket t payload) = do
    putWord8 (0xc0 .|. t) -- FIXME: restrict t
    putPacketLength . B.length $ payload
    putByteString payload

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

getPubkey :: PubKeyAlgorithm -> Get PKey
getPubkey RSA = do MPI n <- get
                   MPI e <- get
                   return $ RSAPubKey (R.PublicKey (B.length . integerToBEBS $ n) n e)
getPubkey RSAEncryptOnly = getPubkey RSA
getPubkey RSASignOnly = getPubkey RSA
getPubkey DSA = do MPI p <- get
                   MPI q <- get
                   MPI g <- get
                   MPI y <- get
                   return $ DSAPubKey (D.PublicKey (p, g, q) y)
getPubkey ElgamalEncryptOnly = getPubkey Elgamal
getPubkey Elgamal = do MPI p <- get
                       MPI g <- get
                       MPI y <- get
                       return $ ElGamalPubKey [p,g,y]

pubkeyToMPIs :: PKey -> [MPI]
pubkeyToMPIs (RSAPubKey k) = [MPI (R.public_n k), MPI (R.public_e k)]
pubkeyToMPIs (DSAPubKey k) = (\(p,g,q) y -> [MPI p,MPI q,MPI g,MPI y]) (D.public_params k) (D.public_y k)
pubkeyToMPIs (ElGamalPubKey k) = fmap MPI k

putPubkey :: PKey -> Put
putPubkey p = mapM_ put (pubkeyToMPIs p)

getSecretKey :: PubKeyAlgorithm -> Get SKey
getSecretKey RSA = do MPI d <- get
                      MPI p <- get
                      MPI q <- get
                      MPI u <- get
                      let n = p * q
                      let dP = 0
                      let dQ = 0
                      let qinv = 0
                      return $ RSAPrivateKey (R.PrivateKey 0 n d p q dP dQ qinv)
getSecretKey RSAEncryptOnly = getSecretKey RSA
getSecretKey RSASignOnly = getSecretKey RSA
getSecretKey DSA = do MPI x <- get
                      return $ DSAPrivateKey (D.PrivateKey (0,0,0) x)
getSecretKey ElgamalEncryptOnly = getSecretKey Elgamal
getSecretKey Elgamal = do MPI x <- get
                          return $ ElGamalPrivateKey [x]

indefiniteMPIs :: ByteString -> [MPI]
indefiniteMPIs bs = do
    case runGet (many getMPI) bs of
        Left e -> error e
        Right mpis -> mpis

putMPI :: MPI -> Put
putMPI (MPI i) = do let bs = integerToBEBS i
                    putWord16be . countBits $ bs
                    putByteString bs

getPackets :: Get (Block Packet)
getPackets = Block `fmap` many getPacket

putPackets :: Block Packet -> Put
putPackets = mapM_ putPacket . unBlock

getPKPayload :: Get PKPayload
getPKPayload = do
    version <- getWord8
    ctime <- getWord32be
    if version `elem` [2,3] then
        do v3exp <-  getWord16be
           pka <- get
           pk <- getPubkey pka
           return $ PubV3 ctime v3exp pka pk
    else
        do pka <- get
           pk <- getPubkey pka
           return $ PubV4 ctime pka pk

putPKPayload :: PKPayload -> Put
putPKPayload (PubV3 ctime v3exp pka pk) = do
    putWord8 3
    putWord32be ctime
    putWord16be v3exp
    put pka
    putPubkey pk
putPKPayload (PubV4 ctime pka pk) = do
    putWord8 4
    putWord32be ctime
    put pka
    putPubkey pk

pubKeyAlgo :: PKPayload -> PubKeyAlgorithm
pubKeyAlgo (PubV3 _ _ pka _) = pka
pubKeyAlgo (PubV4 _ pka _) = pka

getSKAddendum :: PubKeyAlgorithm -> Get SKAddendum
getSKAddendum pka = do
    s2kusage <- getWord8
    case s2kusage of
        0 -> do sk <- getSecretKey pka
                checksum <- getWord16be
                return $ SUUnencrypted sk checksum
        255 -> do symenc <- getWord8
                  s2k <- getS2K
                  iv <- getByteString (symEncBlockSize . toFVal $ symenc)
                  remainder <- remaining
                  encryptedblock <- getByteString remainder
                  return $ SUS16bit (toFVal symenc) s2k iv encryptedblock
        254 -> do symenc <- getWord8
                  s2k <- getS2K
                  iv <- getByteString (symEncBlockSize . toFVal $ symenc)
                  remainder <- remaining
                  encryptedblock <- getByteString remainder
                  return $ SUSSHA1 (toFVal symenc) s2k iv encryptedblock
        symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc)
                     remainder <- remaining
                     encryptedblock <- getByteString remainder
                     return $ SUSym (toFVal symenc) iv encryptedblock

putSKAddendum :: SKAddendum -> Put
putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do
    putWord8 254
    put symenc
    put s2k
    putByteString iv
    putByteString encryptedblock

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 x = 8 -- FIXME

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

encodeIterationCount :: Int -> Word8
encodeIterationCount c = fromIntegral c -- FIXME

getSignaturePayload :: Get SignaturePayload
getSignaturePayload = do
    pv <- getWord8
    case pv of
        3 -> do
            hashlen <- getWord8 -- must be 5
            st <- getWord8
            ctime <- getWord32be
            eok <- getByteString 8
            pka <- get
            ha <- get
            left16 <- getWord16be
            remainder <- remaining
            mpib <- getBytes remainder
            case runGet (many getMPI) mpib of
                Left e -> error e
                Right mpis -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 mpis
        4 -> do
            st <- getWord8
            pka <- get
            ha <- get
            hlen <- getWord16be
            hb <- getBytes (fromIntegral hlen)
            let hashed = case runGet (many getSigSubPacket) hb of
                            Left err -> error err
                            Right h -> h
            ulen <- getWord16be
            ub <- getBytes (fromIntegral ulen)
            let unhashed = case runGet (many getSigSubPacket) ub of
                            Left err -> error err
                            Right u -> u
            left16 <- getWord16be
            remainder <- remaining
            mpib <- getBytes remainder
            case runGet (many getMPI) mpib of
                    Left e -> error e
                    Right mpis -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 mpis
        otherwise -> do
            remainder <- remaining
            bs <- getByteString remainder
            return $ SigVOther pv bs

putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do
    putWord8 3
    put st
    putWord32be ctime
    putByteString (unEOKI eok)
    put pka
    put ha
    putWord16be left16
    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 . B.length $ hb
    putByteString hb
    let ub = runPut $ mapM_ put unhashed
    putWord16be . fromIntegral . B.length $ ub
    putByteString ub
    putWord16be left16
    mapM_ put mpis

-- Stolen from Axman6
many :: Get a -> Get [a]
many p = many1 p `mplus` return []

many1 :: Get a -> Get [a]
many1 p = (:) <$> p <*> many p