-- 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