-- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal) -- Copyright © 2012-2013 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). module Codec.Encryption.OpenPGP.Serialize ( putSKAddendum ) where import Control.Applicative ((<$>),(<*>)) import Control.Lens ((^.)) import Control.Monad (guard, mplus, replicateM) import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit) 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 guard (testBit tag 7) case tag .&. 0x40 of 0x00 -> do let t = shiftR (tag .&. 0x3c) 2 case tag .&. 0x03 of 0 -> do len <- getWord8 bs <- 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) _ -> error "This should never happen." 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 DeprecatedRSAEncryptOnly = getPubkey RSA getPubkey DeprecatedRSASignOnly = getPubkey RSA getPubkey DSA = do MPI p <- get MPI q <- get MPI g <- get MPI y <- get return $ DSAPubKey (D.PublicKey (D.Params p g q) y) getPubkey ElgamalEncryptOnly = getPubkey ForbiddenElgamal getPubkey ForbiddenElgamal = do MPI p <- get MPI g <- get MPI y <- get return $ ElGamalPubKey [p,g,y] getPubkey t = fail ("Unsupported pubkey type " ++ show t) putPubkey :: PKey -> Put putPubkey p = mapM_ put (pubkeyToMPIs p) getSecretKey :: PKPayload -> Get SKey getSecretKey pkp | _pkalgo pkp `elem` [RSA, DeprecatedRSAEncryptOnly, DeprecatedRSASignOnly] = do MPI d <- get MPI p <- get MPI q <- get MPI _ <- get -- u let n = p * q dP = 0 dQ = 0 qinv = 0 pub = (\(RSAPubKey x) -> x) (pkp^.pubkey) return $ RSAPrivateKey (R.PrivateKey pub d p q dP dQ qinv) | _pkalgo pkp == DSA = do MPI x <- get return $ DSAPrivateKey (D.PrivateKey (D.Params 0 0 0) x) | _pkalgo pkp `elem` [ElgamalEncryptOnly,ForbiddenElgamal] = do MPI x <- get return $ ElGamalPrivateKey [x] putMPI :: MPI -> Put putMPI (MPI i) = do let bs = integerToBEBS i putWord16be . countBits $ bs putByteString bs getPKPayload :: Get PKPayload getPKPayload = do version <- getWord8 ctime <- getWord32be if version `elem` [2,3] then do v3e <- getWord16be pka <- get pk <- getPubkey pka return $! PKPayload DeprecatedV3 ctime v3e pka pk else do pka <- get pk <- getPubkey pka return $! PKPayload V4 ctime 0 pka pk putPKPayload :: PKPayload -> Put putPKPayload (PKPayload DeprecatedV3 ctime v3e pka pk) = do putWord8 3 putWord32be ctime putWord16be v3e put pka putPubkey pk putPKPayload (PKPayload V4 ctime _ pka pk) = do putWord8 4 putWord32be ctime put pka putPubkey pk getSKAddendum :: PKPayload -> Get SKAddendum getSKAddendum pkp = do s2kusage <- getWord8 case s2kusage of 0 -> do sk <- getSecretKey pkp checksum <- getWord16be return $ SUUnencrypted sk checksum 255 -> do symenc <- getWord8 s2k <- getS2K 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 guard (hashlen == 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