-- 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) import Codec.Encryption.OpenPGP.Types instance Serialize SigSubPacket where get = getSigSubPacket put = putSigSubPacket -- instance Serialize (Set NotationFlag) where -- put = putNotationFlagSet instance Serialize CompressionAlgorithm where get = getWord8 >>= return . toFVal put = putWord8 . fromFVal instance Serialize PubKeyAlgorithm where get = getWord8 >>= return . toFVal put = putWord8 . fromFVal instance Serialize HashAlgorithm where get = getWord8 >>= return . toFVal put = putWord8 . fromFVal instance Serialize SymmetricAlgorithm where get = getWord8 >>= return . toFVal put = putWord8 . fromFVal instance Serialize MPI where get = getMPI put = putMPI instance Serialize SigType where get = getWord8 >>= return . toFVal put = putWord8 . fromFVal instance Serialize UserAttrSubPacket where get = getUserAttrSubPacket put = putUserAttrSubPacket instance Serialize S2K where get = getS2K put = putS2K instance Serialize Packet where get = getPacket put = putPacket instance Serialize a => Serialize (Block a) where get = Block `fmap` many get put = mapM_ put . unBlock instance Serialize PKPayload where get = getPKPayload put = putPKPayload instance Serialize SignaturePayload where get = getSignaturePayload put = putSignaturePayload getSigSubPacket :: Get SigSubPacket getSigSubPacket = do l <- 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 $ SigCreationTime crit et | pt == 3 = do et <- getWord32be return $ SigExpirationTime crit et | pt == 4 = do e <- get return $ ExportableCertification crit e | pt == 5 = do tl <- getWord8 ta <- getWord8 return $ TrustSignature crit tl ta | pt == 6 = do apdre <- getByteString (l - 2) return $ RegularExpression crit (B.copy apdre) | pt == 7 = do r <- get return $ Revocable crit r | pt == 9 = do et <- getWord32be return $ KeyExpirationTime crit et | pt == 11 = do sa <- replicateM (l - 1) get return $ PreferredSymmetricAlgorithms crit sa | pt == 12 = do rclass <- getWord8 algid <- get fp <- getByteString 20 return $ RevocationKey crit (bsToFFSet . B.singleton $ rclass) algid (TwentyOctetFingerprint fp) | pt == 16 = do keyid <- getByteString (l - 1) return $ Issuer crit (EightOctetKeyId keyid) | pt == 20 = do flags <- getByteString 4 nl <- getWord16be vl <- getWord16be nd <- getByteString (fromIntegral nl) nv <- getByteString (fromIntegral vl) return $ NotationData crit (bsToFFSet flags) nd nv | pt == 21 = do ha <- replicateM (l - 1) get return $ PreferredHashAlgorithms crit ha | pt == 22 = do ca <- replicateM (l - 1) get return $ PreferredCompressionAlgorithms crit ca | pt == 23 = do ksps <- getByteString (l - 1) return $ KeyServerPreferences crit (bsToFFSet ksps) | pt == 24 = do pks <- getByteString (l - 1) return $ PreferredKeyServer crit pks | pt == 25 = do primacy <- get return $ PreferredKeyServer crit primacy | pt == 26 = do url <- getByteString (l - 1) return $ PolicyURL crit url | pt == 27 = do kfs <- getByteString (l - 1) return $ KeyFlags crit (bsToFFSet kfs) | pt == 28 = do uid <- getByteString (l - 1) return $ SignersUserId crit uid | pt == 29 = do rcode <- getWord8 rreason <- getByteString (l - 2) return $ ReasonForRevocation crit (toFVal rcode) rreason | pt == 30 = do fbs <- getByteString (l - 1) return $ Features crit (bsToFFSet fbs) | pt == 31 = do pka <- get ha <- get hash <- getByteString (l - 3) return $ SignatureTarget crit pka ha hash | pt == 32 = do sp <- get :: Get SignaturePayload return $ EmbeddedSignature crit sp | 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 . fromIntegral $ (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 . fromIntegral $ (1 + length ess) putSigSubPacketType crit 11 mapM_ put ess putSigSubPacket (RevocationKey crit rclass algid fp) = do putSubPacketLength 23 putSigSubPacketType crit 12 putByteString . ffSetToFixedLengthBS 1 $ rclass put algid putByteString (unTOF fp) -- 20 octets putSigSubPacket (Issuer crit keyid) = do putSubPacketLength 9 putSigSubPacketType crit 16 putByteString (unEOKI keyid) -- 8 octets putSigSubPacket (NotationData crit nfs nn nv) = do putSubPacketLength . 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 (PreferredHashAlgorithms crit ehs) = do putSubPacketLength . fromIntegral $ (1 + length ehs) putSigSubPacketType crit 21 mapM_ put ehs putSigSubPacket (PreferredCompressionAlgorithms crit ecs) = do putSubPacketLength . fromIntegral $ (1 + length ecs) putSigSubPacketType crit 22 mapM_ put ecs putSigSubPacket (KeyServerPreferences crit ksps) = do let kbs = ffSetToBS ksps putSubPacketLength . fromIntegral $ (1 + B.length kbs) putSigSubPacketType crit 23 putByteString kbs putSigSubPacket (PreferredKeyServer crit ks) = do putSubPacketLength . fromIntegral $ (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 . fromIntegral $ (1 + B.length url) putSigSubPacketType crit 26 putByteString url putSigSubPacket (KeyFlags crit kfs) = do let kbs = ffSetToBS kfs putSubPacketLength . fromIntegral $ (1 + B.length kbs) putSigSubPacketType crit 27 putByteString kbs putSigSubPacket (SignersUserId crit userid) = do putSubPacketLength . fromIntegral $ (1 + B.length userid) putSigSubPacketType crit 28 putByteString userid putSigSubPacket (ReasonForRevocation crit rcode rreason) = do putSubPacketLength . fromIntegral $ (2 + B.length rreason) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode putByteString rreason putSigSubPacket (Features crit fs) = do let fbs = ffSetToBS fs putSubPacketLength . fromIntegral $ (1 + B.length fbs) putSigSubPacketType crit 30 putByteString fbs putSigSubPacket (SignatureTarget crit pka ha hash) = do putSubPacketLength . fromIntegral $ (3 + B.length hash) putSigSubPacketType crit 31 put pka put ha putByteString hash putSigSubPacket (EmbeddedSignature crit sp) = do let spb = runPut (put sp) putSubPacketLength . fromIntegral $ (1 + B.length spb) putSigSubPacketType crit 32 putByteString spb putSigSubPacket (UserDefinedSigSub crit ptype payload) = do putSubPacketLength . fromIntegral $ (1 + B.length payload) putSigSubPacketType crit ptype putByteString payload putSigSubPacket (OtherSigSub crit 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 < 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 | 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." getPacket :: Get Packet getPacket = do (t, pl) <- getPacketTypeAndPayload case runGet (getPacket' t (B.length pl)) pl of Left e -> fail e Right p -> return p where getPacket' :: Word8 -> Int -> Get Packet getPacket' t len | t == 1 = do pv <- getWord8 eokeyid <- getByteString 8 pkalgo <- getWord8 remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of Left e -> error e Right sk -> return $ PKESK pv (EightOctetKeyId eokeyid) (toFVal pkalgo) sk | t == 2 = do remainder <- remaining bs <- getBytes remainder case runGet get bs of Left e -> error e Right sp -> return $ Signature sp | t == 3 = do pv <- getWord8 symalgo <- getWord8 s2k <- getS2K remainder <- remaining mpib <- getBytes remainder case runGet (many getMPI) mpib of Left _ -> return $ SKESK pv (toFVal symalgo) s2k [] Right mpis -> return $ SKESK pv (toFVal symalgo) s2k mpis | t == 4 = do pv <- getWord8 sigtype <- getWord8 ha <- getWord8 pka <- getWord8 skeyid <- getByteString 8 nested <- getWord8 return $ OnePassSignature pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0) | t == 5 = do bs <- getBytes len let ps = flip runGet bs $ do pkp <- getPKPayload ska <- getSKAddendum (pubKeyAlgo pkp) return $ SecretKey pkp ska case ps of Left err -> error err Right key -> return key | t == 6 = do pkp <- getPKPayload return $ PublicKey pkp | t == 7 = do bs <- getBytes len let ps = flip runGet bs $ do pkp <- getPKPayload ska <- getSKAddendum (pubKeyAlgo pkp) return $ SecretSubkey pkp ska case ps of Left err -> error err Right key -> return key | t == 8 = do ca <- getWord8 cdata <- getByteString (len - 1) return $ CompressedData (toFVal ca) cdata | t == 9 = do sdata <- getByteString len return $ SymEncData sdata | t == 10 = do marker <- getByteString len return $ Marker marker | t == 11 = do dt <- getWord8 flen <- getWord8 fn <- getByteString (fromIntegral flen) ts <- getWord32be ldata <- getByteString (len - (6 + (fromIntegral flen))) return $ LiteralData (toFVal dt) fn ts ldata | t == 12 = do tdata <- getByteString len return $ Trust tdata | t == 13 = do udata <- getBytes len return $ UserId (BC8.unpack udata) | t == 14 = do pkp <- getPKPayload return $ PublicSubkey pkp | t == 17 = do bs <- getBytes len case runGet (many getUserAttrSubPacket) bs of Left err -> error err Right uas -> return $ UserAttribute uas | t == 18 = do pv <- getWord8 -- should be 1 b <- getByteString (len - 1) return $ SymEncIntegrityProtectedData pv b | t == 19 = do hash <- getByteString 20 return $ ModificationDetectionCode hash | otherwise = do payload <- getByteString len return $ OtherPacket t payload 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 putPacket :: Packet -> Put putPacket (PKESK 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 putPacket (Signature sp) = do putWord8 (0xc0 .|. 2) let bs = runPut $ put sp putPacketLength . fromIntegral . B.length $ bs putByteString bs putPacket (SKESK 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 putPacket (OnePassSignature pv sigtype ha pka skeyid nested) = do putWord8 (0xc0 .|. 4) let bs = runPut $ do putWord8 pv -- should be 3 putWord8 $ fromIntegral . fromFVal $ sigtype putWord8 $ fromIntegral . fromFVal $ ha putWord8 $ fromIntegral . fromFVal $ pka putByteString (unEOKI skeyid) putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean? putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SecretKey pkp ska) = do putWord8 (0xc0 .|. 5) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (PublicKey pkp) = do putWord8 (0xc0 .|. 6) let bs = runPut $ putPKPayload pkp putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SecretSubkey pkp ska) = do putWord8 (0xc0 .|. 7) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (CompressedData ca cdata) = do putWord8 (0xc0 .|. 8) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ ca putByteString cdata putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SymEncData b) = do putWord8 (0xc0 .|. 9) putPacketLength . fromIntegral $ B.length b putByteString b putPacket (Marker b) = do putWord8 (0xc0 .|. 10) putPacketLength . fromIntegral $ 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 . fromIntegral $ B.length bs putByteString bs putPacket (Trust b) = do putWord8 (0xc0 .|. 12) putPacketLength . fromIntegral . B.length $ b putByteString b putPacket (UserId u) = do putWord8 (0xc0 .|. 13) let bs = BC8.pack u putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (PublicSubkey pkp) = do putWord8 (0xc0 .|. 14) let bs = runPut $ putPKPayload pkp putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (UserAttribute us) = do putWord8 (0xc0 .|. 17) let bs = runPut $ mapM_ put us putPacketLength . fromIntegral $ B.length bs putByteString bs putPacket (SymEncIntegrityProtectedData pv b) = do putWord8 (0xc0 .|. 18) putPacketLength . fromIntegral $ (B.length b) + 1 putWord8 pv -- should be 1 putByteString b putPacket (ModificationDetectionCode hash) = do putWord8 (0xc0 .|. 19) putPacketLength . fromIntegral . B.length $ hash putByteString hash putPacket (OtherPacket 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) pubkeyToMPIs :: PKey -> [MPI] pubkeyToMPIs (RSAPubKey k) = [MPI (R.public_n k), MPI (R.public_e k)] pubkeyToMPIs (DSAPubKey k) = (\(p,g,q) y -> [MPI p,MPI q,MPI g,MPI y]) (D.public_params k) (D.public_y k) pubkeyToMPIs (ElGamalPubKey k) = fmap MPI k putPubkey :: PKey -> Put putPubkey p = mapM_ put (pubkeyToMPIs p) getSecretKey :: PubKeyAlgorithm -> Get SKey getSecretKey RSA = do MPI d <- get MPI p <- get MPI q <- get MPI _ <- get let n = p * q let dP = 0 let dQ = 0 let qinv = 0 return $ RSAPrivateKey (R.PrivateKey 0 n d p q dP dQ qinv) getSecretKey RSAEncryptOnly = getSecretKey RSA getSecretKey RSASignOnly = getSecretKey RSA getSecretKey DSA = do MPI x <- get return $ DSAPrivateKey (D.PrivateKey (0,0,0) x) getSecretKey ElgamalEncryptOnly = getSecretKey Elgamal getSecretKey Elgamal = do MPI x <- get return $ ElGamalPrivateKey [x] -- indefiniteMPIs :: ByteString -> [MPI] -- indefiniteMPIs bs = do -- case runGet (many getMPI) bs of -- Left e -> error e -- Right mpis -> mpis putMPI :: MPI -> Put putMPI (MPI i) = do let bs = integerToBEBS i putWord16be . countBits $ bs putByteString bs -- getPackets :: Get (Block Packet) -- getPackets = Block `fmap` many getPacket -- putPackets :: Block Packet -> Put -- putPackets = mapM_ putPacket . unBlock getPKPayload :: Get PKPayload getPKPayload = do version <- getWord8 ctime <- getWord32be if version `elem` [2,3] then do v3exp <- getWord16be pka <- get pk <- getPubkey pka return $ PubV3 ctime v3exp pka pk else do pka <- get pk <- getPubkey pka return $ PubV4 ctime pka pk putPKPayload :: PKPayload -> Put putPKPayload (PubV3 ctime v3exp pka pk) = do putWord8 3 putWord32be ctime putWord16be v3exp put pka putPubkey pk putPKPayload (PubV4 ctime pka pk) = do putWord8 4 putWord32be ctime put pka putPubkey pk pubKeyAlgo :: PKPayload -> PubKeyAlgorithm pubKeyAlgo (PubV3 _ _ pka _) = pka pubKeyAlgo (PubV4 _ pka _) = pka getSKAddendum :: PubKeyAlgorithm -> Get SKAddendum getSKAddendum pka = do s2kusage <- getWord8 case s2kusage of 0 -> do sk <- getSecretKey pka checksum <- getWord16be return $ SUUnencrypted sk checksum 255 -> do symenc <- getWord8 s2k <- getS2K iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining encryptedblock <- getByteString remainder return $ SUS16bit (toFVal symenc) s2k iv encryptedblock 254 -> do symenc <- getWord8 s2k <- getS2K iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining encryptedblock <- getByteString remainder return $ SUSSHA1 (toFVal symenc) s2k iv encryptedblock symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) remainder <- remaining encryptedblock <- getByteString remainder return $ SUSym (toFVal symenc) iv encryptedblock putSKAddendum :: SKAddendum -> Put putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do putWord8 254 put symenc put s2k putByteString iv putByteString encryptedblock 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