-- 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 (
    getPackets
  , putPackets
) where

import Control.Applicative ((<$>),(<*>))
import Control.Monad (replicateM, mplus, when)
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)

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

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 fp
            | pt == 16 = do
                       keyid <- getByteString (l - 1)
                       return $ Issuer crit 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 fp -- 20 octets
putSigSubPacket (Issuer crit keyid) = do
    putSubPacketLength 9
    putSigSubPacketType crit 16
    putByteString 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

getPacketTypeAndLength :: Get (Word8, Int)
getPacketTypeAndLength = 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
                               return (t, fromIntegral len)
                       1 -> do len <- getWord16be
                               return (t, fromIntegral len)
                       2 -> do len <- getWord32be
                               return (t, fromIntegral len)
                       3 -> return (t, maxBound)  -- FIXME: express this better
        0x40 -> do
                   len <- getPacketLength
                   return (tag .&. 0x3f, len)

getPacket :: Get Packet
getPacket = do
               (t, len) <- getPacketTypeAndLength
               getPacket' t len
    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 eokeyid (toFVal pkalgo) sk
            | t == 2 = 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
                                      mpib <- getBytes (len - 19)
                                      case runGet (many getMPI) mpib of
                                          Left e -> error e
                                          Right mpis -> return $ Signature $ SigV3 (toFVal st) ctime 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
                                      mpib <- getBytes (len - (10 + (fromIntegral hlen) + (fromIntegral ulen)))
                                      case runGet (many getMPI) mpib of
                                          Left e -> error e
                                          Right mpis -> return $ Signature $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 mpis
                              otherwise -> do
                                               bs <- getByteString (len - 1)
                                               return $ Signature $ SigVOther pv bs
            | 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) 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 eokeyid -- must be 8 octets
    putWord8 $ fromIntegral . fromFVal $ pkalgo
    putByteString bsk
putPacket (Signature (SigV3 st ctime eok pka ha left16 mpis)) = do
    putWord8 (0xc0 .|. 2)
    let bs = runPut $ do
                        putWord8 3
                        put st
                        putWord32be ctime
                        putByteString eok
                        put pka
                        put ha
                        putWord16be left16
                        mapM_ put mpis
    putPacketLength . B.length $ bs
    putByteString bs
putPacket (Signature (SigV4 st pka ha hashed unhashed left16 mpis)) = do
    putWord8 (0xc0 .|. 2)
    let bs = runPut $ 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
    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 skeyid
                putWord8 . fromIntegral . fromEnum $ 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 bs

getMPIs :: PubKeyAlgorithm -> Get [MPI]
getMPIs RSA = replicateM 2 get
getMPIs RSAEncryptOnly = replicateM 2 get
getMPIs RSASignOnly = replicateM 2 get
getMPIs DSA = replicateM 4 get
getMPIs ElgamalEncryptOnly = replicateM 3 get
getMPIs Elgamal = replicateM 3 get

getSecretMPIs :: PubKeyAlgorithm -> Get [MPI]
getSecretMPIs RSA = replicateM 4 get
getSecretMPIs RSAEncryptOnly = replicateM 4 get
getSecretMPIs RSASignOnly = replicateM 1 get
getSecretMPIs DSA = replicateM 1 get
getSecretMPIs ElgamalEncryptOnly = replicateM 1 get
getSecretMPIs Elgamal = replicateM 1 get

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

putMPI :: MPI -> Put
putMPI (MPI bs) = do putWord16be . (*8) . fromIntegral . B.length $ bs -- FIXME: odd bits
                     putByteString bs

getPackets :: Get [Packet]
getPackets = many getPacket

putPackets :: [Packet] -> Put
putPackets = mapM_ putPacket

getPKPayload :: Get PKPayload
getPKPayload = do
    version <- getWord8
    ctime <- getWord32be
    case version `elem` [2,3] of
                               True -> do v3exp <-  getWord16be
                                          pka <- get
                                          mpis <- getMPIs pka
                                          return $ PubV3 ctime v3exp pka mpis
                               False -> do
                                          pka <- get
                                          mpis <- getMPIs pka
                                          return $ PubV4 ctime pka mpis

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

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 mpis <- getSecretMPIs pka
                checksum <- getWord16be
                return $ SUUnencrypted mpis 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

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

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