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

module Codec.Encryption.OpenPGP.Serialize (
   putSKAddendum
) where

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

import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS, pubkeyToMPIs)
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 PKESK where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize Signature where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize SKESK where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize OnePassSignature where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize SecretKey where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize PublicKey where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize SecretSubkey where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize CompressedData where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize SymEncData where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize Marker where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize LiteralData where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize Trust where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize UserId where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize PublicSubkey where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize UserAttribute where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize SymEncIntegrityProtectedData where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize ModificationDetectionCode where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize OtherPacket where
    get = fmap fromPkt getPkt
    put = putPkt . toPkt

instance Serialize Pkt where
    get = getPkt
    put = putPkt

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 <- fmap fromIntegral 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 $ SigSubPacket crit (SigCreationTime et)
            | pt == 3 = do
                       et <- 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 <- getByteString (l - 2)
                       return $ SigSubPacket crit (RegularExpression (B.copy apdre))
            | pt == 7 = do
                       r <- get
                       return $ SigSubPacket crit (Revocable r)
            | pt == 9 = do
                       et <- getWord32be
                       return $ SigSubPacket crit (KeyExpirationTime et)
            | pt == 11 = do
                       sa <- replicateM (l - 1) get
                       return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa)
            | pt == 12 = do
                       rclass <- getWord8
                       algid <- get
                       fp <- getByteString 20
                       return $ SigSubPacket crit (RevocationKey (bsToFFSet . B.singleton $ rclass) algid (TwentyOctetFingerprint fp))
            | pt == 16 = do
                       keyid <- getByteString (l - 1)
                       return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid))
            | pt == 20 = do
                       flags <- getByteString 4
                       nl <- getWord16be
                       vl <- getWord16be
                       nd <- getByteString (fromIntegral nl)
                       nv <- getByteString (fromIntegral vl)
                       return $ SigSubPacket crit (NotationData (bsToFFSet flags) nd nv)
            | pt == 21 = do
                       ha <- replicateM (l - 1) get
                       return $ SigSubPacket crit (PreferredHashAlgorithms ha)
            | pt == 22 = do
                       ca <- replicateM (l - 1) get
                       return $ SigSubPacket crit (PreferredCompressionAlgorithms ca)
            | pt == 23 = do
                       ksps <- getByteString (l - 1)
                       return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps))
            | pt == 24 = do
                       pks <- getByteString (l - 1)
                       return $ SigSubPacket crit (PreferredKeyServer pks)
            | pt == 25 = do
                       primacy <- get
                       return $ SigSubPacket crit (PreferredKeyServer primacy)
            | pt == 26 = do
                       url <- getByteString (l - 1)
                       return $ SigSubPacket crit (PolicyURL url)
            | pt == 27 = do
                       kfs <- getByteString (l - 1)
                       return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs))
            | pt == 28 = do
                       uid <- getByteString (l - 1)
                       return $ SigSubPacket crit (SignersUserId (BC8.unpack uid))
            | pt == 29 = do
                       rcode <- getWord8
                       rreason <- getByteString (l - 2)
                       return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason)
            | pt == 30 = do
                       fbs <- getByteString (l - 1)
                       return $ SigSubPacket crit (Features (bsToFFSet fbs))
            | pt == 31 = do
                       pka <- get
                       ha <- get
                       hash <- getByteString (l - 3)
                       return $ SigSubPacket crit (SignatureTarget pka ha hash)
            | pt == 32 = do
		       sp <- get :: Get SignaturePayload
                       return $ SigSubPacket crit (EmbeddedSignature sp)
            | pt > 99 && pt < 111 = do
                       payload <- getByteString (l - 1)
                       return $ SigSubPacket crit (UserDefinedSigSub pt payload)
            | otherwise = do
                       payload <- getByteString (l - 1)
                       return $ SigSubPacket crit (OtherSigSub pt payload)

putSigSubPacket :: SigSubPacket -> Put
putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do
    putSubPacketLength 5
    putSigSubPacketType crit 2
    putWord32be et
putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do
    putSubPacketLength 5
    putSigSubPacketType crit 3
    putWord32be 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 + B.length apdre)
    putSigSubPacketType crit 6
    putByteString 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 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
    putByteString . ffSetToFixedLengthBS 1 $ rclass
    put algid
    putByteString (unTOF fp) -- 20 octets
putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do
    putSubPacketLength 9
    putSigSubPacketType crit 16
    putByteString (unEOKI keyid) -- 8 octets
putSigSubPacket (SigSubPacket crit (NotationData nfs nn nv)) = do
    putSubPacketLength . fromIntegral $ (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 (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 + B.length kbs)
    putSigSubPacketType crit 23
    putByteString kbs
putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do
    putSubPacketLength . fromIntegral $ (1 + B.length ks)
    putSigSubPacketType crit 24
    putByteString ks
putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do
    putSubPacketLength 2
    putSigSubPacketType crit 25
    put primacy
putSigSubPacket (SigSubPacket crit (PolicyURL url)) = do
    putSubPacketLength . fromIntegral $ (1 + B.length url)
    putSigSubPacketType crit 26
    putByteString url
putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do
    let kbs = ffSetToBS kfs
    putSubPacketLength . fromIntegral $ (1 + B.length kbs)
    putSigSubPacketType crit 27
    putByteString kbs
putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do
    let bs = BC8.pack userid
    putSubPacketLength . fromIntegral $ (1 + B.length bs)
    putSigSubPacketType crit 28
    putByteString bs
putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do
    putSubPacketLength . fromIntegral $ (2 + B.length rreason)
    putSigSubPacketType crit 29
    putWord8 . fromFVal $ rcode
    putByteString rreason
putSigSubPacket (SigSubPacket crit (Features  fs)) = do
    let fbs = ffSetToBS fs
    putSubPacketLength . fromIntegral $ (1 + B.length fbs)
    putSigSubPacketType crit 30
    putByteString fbs
putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do
    putSubPacketLength . fromIntegral $ (3 + B.length hash)
    putSigSubPacketType crit 31
    put pka
    put ha
    putByteString hash
putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do
    let spb = runPut (put sp)
    putSubPacketLength . fromIntegral $ (1 + B.length spb)
    putSigSubPacketType crit 32
    putByteString spb
putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = do
    putSubPacketLength . fromIntegral $ (1 + B.length payload)
    putSigSubPacketType crit ptype
    putByteString payload
putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do
    putSubPacketLength . fromIntegral $ (1 + B.length payload)
    putSigSubPacketType crit ptype
    putByteString 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
                         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
    | otherwise = error "Confusing salt size"
fromS2K (IteratedSalted hashalgo salt count)
    | B.length salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.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." --FIXME

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" -- 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 (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 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 <- fmap fromIntegral getPacketLength
                   bs <- getByteString len
                   return (tag .&. 0x3f, bs)
        _ -> error "This should never happen."

getPkt :: Get Pkt
getPkt = do
    (t, pl) <- getPacketTypeAndPayload
    case runGet (getPkt' t (B.length pl)) pl of
        Left e -> fail e
        Right p -> return p
    where
        getPkt' :: Word8 -> Int -> Get Pkt
        getPkt' t len
            | t == 1 = do
                          pv <- getWord8
                          eokeyid <- getByteString 8
                          pkalgo <- getWord8
                          remainder <- remaining
                          mpib <- getBytes remainder
                          case runGet (many getMPI) mpib of
                              Left e -> error e
                              Right sk -> return $ PKESKPkt 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 $ SignaturePkt sp
            | t == 3 = do
                          pv <- getWord8
                          symalgo <- getWord8
                          s2k <- getS2K
                          remainder <- remaining
                          mpib <- getBytes remainder
                          case runGet (many getMPI) mpib of
                              Left _ -> return $ SKESKPkt pv (toFVal symalgo) s2k []
                              Right mpis -> return $ SKESKPkt pv (toFVal symalgo) s2k mpis
            | t == 4 = do
                          pv <- getWord8
                          sigtype <- getWord8
                          ha <- getWord8
                          pka <- getWord8
                          skeyid <- getByteString 8
                          nested <- getWord8
                          return $ OnePassSignaturePkt 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 pkp
                                                       return $ SecretKeyPkt pkp ska
                          case ps of
                              Left err -> error err
                              Right key -> return key
            | t == 6 = do
                          pkp <- getPKPayload
                          return $ PublicKeyPkt pkp
            | t == 7 = do
                          bs <- getBytes len
                          let ps = flip runGet bs $ do pkp <- getPKPayload
                                                       ska <- getSKAddendum pkp
                                                       return $ SecretSubkeyPkt pkp ska
                          case ps of
                              Left err -> error err
                              Right key -> return key
            | t == 8 = do
                          ca <- getWord8
                          cdata <- getByteString (len - 1)
                          return $ CompressedDataPkt (toFVal ca) cdata
            | t == 9 = do
                          sdata <- getByteString len
                          return $ SymEncDataPkt sdata
            | t == 10 = do
                          marker <- getByteString len
                          return $ MarkerPkt marker
            | t == 11 = do
                          dt <- getWord8
                          flen <- getWord8
                          fn <- getByteString (fromIntegral flen)
                          ts <- getWord32be
                          ldata <- getByteString (len - (6 + (fromIntegral flen)))
                          return $ LiteralDataPkt (toFVal dt) fn ts ldata
            | t == 12 = do
                          tdata <- getByteString len
                          return $ TrustPkt tdata
            | t == 13 = do
                          udata <- getBytes len
                          return $ UserIdPkt (BC8.unpack udata)
            | t == 14 = do
                          pkp <- getPKPayload
                          return $ PublicSubkeyPkt pkp
            | t == 17 = do
                        bs <- getBytes len
                        case runGet (many getUserAttrSubPacket) bs of
                            Left err -> error err
                            Right uas -> return $ UserAttributePkt uas
            | t == 18 = do
                          pv <- getWord8 -- should be 1
                          b <- getByteString (len - 1)
                          return $ SymEncIntegrityProtectedDataPkt pv b
            | t == 19 = do
                          hash <- getByteString 20
                          return $ ModificationDetectionCodePkt hash
            | otherwise = do
                          payload <- getByteString len
                          return $ OtherPacketPkt t payload

getUserAttrSubPacket :: Get UserAttrSubPacket
getUserAttrSubPacket = do
    l <- fmap fromIntegral 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
                              nuls <- getBytes 12 -- should be NULs
                              bs <- getByteString (l - 17)
                              if hver /= 1 || nuls /= (B.pack (replicate 12 0)) then fail "Corrupt UAt subpacket" else 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 . fromIntegral . 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

putPkt :: Pkt -> Put
putPkt (PKESKPkt pv eokeyid pkalgo mpis) = do
    putWord8 (0xc0 .|. 1)
    let bsk = runPut $ mapM_ put mpis
    putPacketLength . fromIntegral $ 10 + (B.length bsk)
    putWord8 pv -- must be 3
    putByteString (unEOKI eokeyid) -- must be 8 octets
    putWord8 $ fromIntegral . fromFVal $ pkalgo
    putByteString bsk
putPkt (SignaturePkt sp) = do
    putWord8 (0xc0 .|. 2)
    let bs = runPut $ put sp
    putPacketLength . fromIntegral . B.length $ bs
    putByteString bs
putPkt (SKESKPkt pv symalgo s2k mpis) = do
    putWord8 (0xc0 .|. 3)
    let bs2k = fromS2K s2k
    let bsk = runPut $ mapM_ put mpis
    putPacketLength . fromIntegral $ 2 + (B.length bs2k) + (B.length bsk)
    putWord8 pv -- should be 4
    putWord8 $ fromIntegral . fromFVal $ symalgo
    putByteString bs2k
    putByteString bsk
putPkt (OnePassSignaturePkt 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 . fromIntegral $ B.length bs
    putByteString bs
putPkt (SecretKeyPkt pkp ska) = do
    putWord8 (0xc0 .|. 5)
    let bs = runPut (putPKPayload pkp >> putSKAddendum ska)
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (PublicKeyPkt pkp) = do
    putWord8 (0xc0 .|. 6)
    let bs = runPut $ putPKPayload pkp
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (SecretSubkeyPkt pkp ska) = do
    putWord8 (0xc0 .|. 7)
    let bs = runPut (putPKPayload pkp >> putSKAddendum ska)
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (CompressedDataPkt ca cdata) = do
    putWord8 (0xc0 .|. 8)
    let bs = runPut $ do
                         putWord8 $ fromIntegral . fromFVal $ ca
                         putByteString cdata
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (SymEncDataPkt b) = do
    putWord8 (0xc0 .|. 9)
    putPacketLength . fromIntegral $ B.length b
    putByteString b
putPkt (MarkerPkt b) = do
    putWord8 (0xc0 .|. 10)
    putPacketLength . fromIntegral $ B.length b
    putByteString b
putPkt (LiteralDataPkt 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 . fromIntegral $ B.length bs
    putByteString bs
putPkt (TrustPkt b) = do
    putWord8 (0xc0 .|. 12)
    putPacketLength . fromIntegral . B.length $ b
    putByteString b
putPkt (UserIdPkt u) = do
    putWord8 (0xc0 .|. 13)
    let bs = BC8.pack u
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (PublicSubkeyPkt pkp) = do
    putWord8 (0xc0 .|. 14)
    let bs = runPut $ putPKPayload pkp
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (UserAttributePkt us) = do
    putWord8 (0xc0 .|. 17)
    let bs = runPut $ mapM_ put us
    putPacketLength . fromIntegral $ B.length bs
    putByteString bs
putPkt (SymEncIntegrityProtectedDataPkt pv b) = do
    putWord8 (0xc0 .|. 18)
    putPacketLength . fromIntegral $ (B.length b) + 1
    putWord8 pv -- should be 1
    putByteString b
putPkt (ModificationDetectionCodePkt hash) = do
    putWord8 (0xc0 .|. 19)
    putPacketLength . fromIntegral . B.length $ hash
    putByteString hash
putPkt (OtherPacketPkt t payload) = do
    putWord8 (0xc0 .|. t) -- FIXME: restrict t
    putPacketLength . fromIntegral . 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]
getPubkey t = fail ("Unsupported pubkey type " ++ show t)

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

getSecretKey :: PKPayload -> Get SKey
getSecretKey pkp
    | pubKeyAlgo pkp `elem` [RSA, RSAEncryptOnly, RSASignOnly] =
        do MPI d <- get
           MPI p <- get
           MPI q <- get
           MPI _ <- get -- u
           let n = p * q
               dP = 0
               dQ = 0
               qinv = 0
               pub = (\(RSAPubKey x) -> x) (pubKeyKey pkp)
           return $ RSAPrivateKey (R.PrivateKey pub d p q dP dQ qinv)
    | pubKeyAlgo pkp == DSA = do MPI x <- get
                                 return $ DSAPrivateKey (D.PrivateKey (0,0,0) x)
    | pubKeyAlgo pkp `elem` [ElgamalEncryptOnly,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 Pkt)
-- getPackets = Block `fmap` many getPkt

-- putPackets :: Block Pkt -> Put
-- putPackets = mapM_ putPkt . 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 $ DeprecatedPubV3 ctime v3exp pka pk
    else
        do pka <- get
           pk <- getPubkey pka
           return $ PubV4 ctime pka pk

putPKPayload :: PKPayload -> Put
putPKPayload (DeprecatedPubV3 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 (DeprecatedPubV3 _ _ pka _) = pka
pubKeyAlgo (PubV4 _ pka _) = pka

pubKeyKey :: PKPayload -> PKey
pubKeyKey (DeprecatedPubV3 _ _ _ k) = k
pubKeyKey (PubV4 _ _ k) = k

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

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

encodeIterationCount :: Int -> Word8  -- should this really be a lookup table?
encodeIterationCount 1024 = 0
encodeIterationCount 1088 = 1
encodeIterationCount 1152 = 2
encodeIterationCount 1216 = 3
encodeIterationCount 1280 = 4
encodeIterationCount 1344 = 5
encodeIterationCount 1408 = 6
encodeIterationCount 1472 = 7
encodeIterationCount 1536 = 8
encodeIterationCount 1600 = 9
encodeIterationCount 1664 = 10
encodeIterationCount 1728 = 11
encodeIterationCount 1792 = 12
encodeIterationCount 1856 = 13
encodeIterationCount 1920 = 14
encodeIterationCount 1984 = 15
encodeIterationCount 2048 = 16
encodeIterationCount 2176 = 17
encodeIterationCount 2304 = 18
encodeIterationCount 2432 = 19
encodeIterationCount 2560 = 20
encodeIterationCount 2688 = 21
encodeIterationCount 2816 = 22
encodeIterationCount 2944 = 23
encodeIterationCount 3072 = 24
encodeIterationCount 3200 = 25
encodeIterationCount 3328 = 26
encodeIterationCount 3456 = 27
encodeIterationCount 3584 = 28
encodeIterationCount 3712 = 29
encodeIterationCount 3840 = 30
encodeIterationCount 3968 = 31
encodeIterationCount 4096 = 32
encodeIterationCount 4352 = 33
encodeIterationCount 4608 = 34
encodeIterationCount 4864 = 35
encodeIterationCount 5120 = 36
encodeIterationCount 5376 = 37
encodeIterationCount 5632 = 38
encodeIterationCount 5888 = 39
encodeIterationCount 6144 = 40
encodeIterationCount 6400 = 41
encodeIterationCount 6656 = 42
encodeIterationCount 6912 = 43
encodeIterationCount 7168 = 44
encodeIterationCount 7424 = 45
encodeIterationCount 7680 = 46
encodeIterationCount 7936 = 47
encodeIterationCount 8192 = 48
encodeIterationCount 8704 = 49
encodeIterationCount 9216 = 50
encodeIterationCount 9728 = 51
encodeIterationCount 10240 = 52
encodeIterationCount 10752 = 53
encodeIterationCount 11264 = 54
encodeIterationCount 11776 = 55
encodeIterationCount 12288 = 56
encodeIterationCount 12800 = 57
encodeIterationCount 13312 = 58
encodeIterationCount 13824 = 59
encodeIterationCount 14336 = 60
encodeIterationCount 14848 = 61
encodeIterationCount 15360 = 62
encodeIterationCount 15872 = 63
encodeIterationCount 16384 = 64
encodeIterationCount 17408 = 65
encodeIterationCount 18432 = 66
encodeIterationCount 19456 = 67
encodeIterationCount 20480 = 68
encodeIterationCount 21504 = 69
encodeIterationCount 22528 = 70
encodeIterationCount 23552 = 71
encodeIterationCount 24576 = 72
encodeIterationCount 25600 = 73
encodeIterationCount 26624 = 74
encodeIterationCount 27648 = 75
encodeIterationCount 28672 = 76
encodeIterationCount 29696 = 77
encodeIterationCount 30720 = 78
encodeIterationCount 31744 = 79
encodeIterationCount 32768 = 80
encodeIterationCount 34816 = 81
encodeIterationCount 36864 = 82
encodeIterationCount 38912 = 83
encodeIterationCount 40960 = 84
encodeIterationCount 43008 = 85
encodeIterationCount 45056 = 86
encodeIterationCount 47104 = 87
encodeIterationCount 49152 = 88
encodeIterationCount 51200 = 89
encodeIterationCount 53248 = 90
encodeIterationCount 55296 = 91
encodeIterationCount 57344 = 92
encodeIterationCount 59392 = 93
encodeIterationCount 61440 = 94
encodeIterationCount 63488 = 95
encodeIterationCount 65536 = 96
encodeIterationCount 69632 = 97
encodeIterationCount 73728 = 98
encodeIterationCount 77824 = 99
encodeIterationCount 81920 = 100
encodeIterationCount 86016 = 101
encodeIterationCount 90112 = 102
encodeIterationCount 94208 = 103
encodeIterationCount 98304 = 104
encodeIterationCount 102400 = 105
encodeIterationCount 106496 = 106
encodeIterationCount 110592 = 107
encodeIterationCount 114688 = 108
encodeIterationCount 118784 = 109
encodeIterationCount 122880 = 110
encodeIterationCount 126976 = 111
encodeIterationCount 131072 = 112
encodeIterationCount 139264 = 113
encodeIterationCount 147456 = 114
encodeIterationCount 155648 = 115
encodeIterationCount 163840 = 116
encodeIterationCount 172032 = 117
encodeIterationCount 180224 = 118
encodeIterationCount 188416 = 119
encodeIterationCount 196608 = 120
encodeIterationCount 204800 = 121
encodeIterationCount 212992 = 122
encodeIterationCount 221184 = 123
encodeIterationCount 229376 = 124
encodeIterationCount 237568 = 125
encodeIterationCount 245760 = 126
encodeIterationCount 253952 = 127
encodeIterationCount 262144 = 128
encodeIterationCount 278528 = 129
encodeIterationCount 294912 = 130
encodeIterationCount 311296 = 131
encodeIterationCount 327680 = 132
encodeIterationCount 344064 = 133
encodeIterationCount 360448 = 134
encodeIterationCount 376832 = 135
encodeIterationCount 393216 = 136
encodeIterationCount 409600 = 137
encodeIterationCount 425984 = 138
encodeIterationCount 442368 = 139
encodeIterationCount 458752 = 140
encodeIterationCount 475136 = 141
encodeIterationCount 491520 = 142
encodeIterationCount 507904 = 143
encodeIterationCount 524288 = 144
encodeIterationCount 557056 = 145
encodeIterationCount 589824 = 146
encodeIterationCount 622592 = 147
encodeIterationCount 655360 = 148
encodeIterationCount 688128 = 149
encodeIterationCount 720896 = 150
encodeIterationCount 753664 = 151
encodeIterationCount 786432 = 152
encodeIterationCount 819200 = 153
encodeIterationCount 851968 = 154
encodeIterationCount 884736 = 155
encodeIterationCount 917504 = 156
encodeIterationCount 950272 = 157
encodeIterationCount 983040 = 158
encodeIterationCount 1015808 = 159
encodeIterationCount 1048576 = 160
encodeIterationCount 1114112 = 161
encodeIterationCount 1179648 = 162
encodeIterationCount 1245184 = 163
encodeIterationCount 1310720 = 164
encodeIterationCount 1376256 = 165
encodeIterationCount 1441792 = 166
encodeIterationCount 1507328 = 167
encodeIterationCount 1572864 = 168
encodeIterationCount 1638400 = 169
encodeIterationCount 1703936 = 170
encodeIterationCount 1769472 = 171
encodeIterationCount 1835008 = 172
encodeIterationCount 1900544 = 173
encodeIterationCount 1966080 = 174
encodeIterationCount 2031616 = 175
encodeIterationCount 2097152 = 176
encodeIterationCount 2228224 = 177
encodeIterationCount 2359296 = 178
encodeIterationCount 2490368 = 179
encodeIterationCount 2621440 = 180
encodeIterationCount 2752512 = 181
encodeIterationCount 2883584 = 182
encodeIterationCount 3014656 = 183
encodeIterationCount 3145728 = 184
encodeIterationCount 3276800 = 185
encodeIterationCount 3407872 = 186
encodeIterationCount 3538944 = 187
encodeIterationCount 3670016 = 188
encodeIterationCount 3801088 = 189
encodeIterationCount 3932160 = 190
encodeIterationCount 4063232 = 191
encodeIterationCount 4194304 = 192
encodeIterationCount 4456448 = 193
encodeIterationCount 4718592 = 194
encodeIterationCount 4980736 = 195
encodeIterationCount 5242880 = 196
encodeIterationCount 5505024 = 197
encodeIterationCount 5767168 = 198
encodeIterationCount 6029312 = 199
encodeIterationCount 6291456 = 200
encodeIterationCount 6553600 = 201
encodeIterationCount 6815744 = 202
encodeIterationCount 7077888 = 203
encodeIterationCount 7340032 = 204
encodeIterationCount 7602176 = 205
encodeIterationCount 7864320 = 206
encodeIterationCount 8126464 = 207
encodeIterationCount 8388608 = 208
encodeIterationCount 8912896 = 209
encodeIterationCount 9437184 = 210
encodeIterationCount 9961472 = 211
encodeIterationCount 10485760 = 212
encodeIterationCount 11010048 = 213
encodeIterationCount 11534336 = 214
encodeIterationCount 12058624 = 215
encodeIterationCount 12582912 = 216
encodeIterationCount 13107200 = 217
encodeIterationCount 13631488 = 218
encodeIterationCount 14155776 = 219
encodeIterationCount 14680064 = 220
encodeIterationCount 15204352 = 221
encodeIterationCount 15728640 = 222
encodeIterationCount 16252928 = 223
encodeIterationCount 16777216 = 224
encodeIterationCount 17825792 = 225
encodeIterationCount 18874368 = 226
encodeIterationCount 19922944 = 227
encodeIterationCount 20971520 = 228
encodeIterationCount 22020096 = 229
encodeIterationCount 23068672 = 230
encodeIterationCount 24117248 = 231
encodeIterationCount 25165824 = 232
encodeIterationCount 26214400 = 233
encodeIterationCount 27262976 = 234
encodeIterationCount 28311552 = 235
encodeIterationCount 29360128 = 236
encodeIterationCount 30408704 = 237
encodeIterationCount 31457280 = 238
encodeIterationCount 32505856 = 239
encodeIterationCount 33554432 = 240
encodeIterationCount 35651584 = 241
encodeIterationCount 37748736 = 242
encodeIterationCount 39845888 = 243
encodeIterationCount 41943040 = 244
encodeIterationCount 44040192 = 245
encodeIterationCount 46137344 = 246
encodeIterationCount 48234496 = 247
encodeIterationCount 50331648 = 248
encodeIterationCount 52428800 = 249
encodeIterationCount 54525952 = 250
encodeIterationCount 56623104 = 251
encodeIterationCount 58720256 = 252
encodeIterationCount 60817408 = 253
encodeIterationCount 62914560 = 254
encodeIterationCount 65011712 = 255
encodeIterationCount n = error ("invalid iteration count" ++ show n)

getSignaturePayload :: Get SignaturePayload
getSignaturePayload = do
    pv <- getWord8
    case pv of
        3 -> do
            hashlen <- getWord8 -- FIXME: 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
        _ -> do
            remainder <- remaining
            bs <- getByteString remainder
            return $ SigVOther pv bs

putSignaturePayload :: SignaturePayload -> Put
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
putSignaturePayload _ = fail "Signature version not supported"

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

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