-- Serialize.hs: OpenPGP (RFC4880) serialization (using cereal) -- Copyright © 2012-2016 Clint Adams -- This software is released under the terms of the Expat license. -- (See the LICENSE file). {-# LANGUAGE CPP #-} module Codec.Encryption.OpenPGP.Serialize ( putSKAddendum , getSecretKey ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif import Control.Applicative (many, some) import Control.Lens ((^.), _1) import Control.Monad (guard, liftM, replicateM, replicateM_) import Crypto.Number.Basic (numBits) import Crypto.Number.Serialize (i2osp, os2ip) import qualified Crypto.PubKey.RSA as R import qualified Crypto.PubKey.DSA as D import Data.Bits ((.&.), (.|.), shiftL, shiftR, testBit) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.List (mapAccumL) import qualified Data.List.NonEmpty as NE import Data.Binary (Binary, get, put) import Data.Binary.Get (Get, getByteString, getLazyByteString, getRemainingLazyByteString, getWord8, getWord16be, getWord32be, getWord16le, runGetOrFail, ByteOffset) import Data.Binary.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putLazyByteString, putWord16le, runPut) import qualified Data.Foldable as F #if !MIN_VERSION_base(4,8,0) import Data.Monoid (mempty) #endif import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import Data.Word (Word8, Word32) import Data.Maybe (fromMaybe) import Network.URI (nullURI, parseURI, uriToString) import Codec.Encryption.OpenPGP.Internal (pubkeyToMPIs, multiplicativeInverse) import Codec.Encryption.OpenPGP.Types instance Binary SigSubPacket where get = getSigSubPacket put = putSigSubPacket -- instance Binary (Set NotationFlag) where -- put = putNotationFlagSet instance Binary CompressionAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal instance Binary PubKeyAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal instance Binary HashAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal instance Binary SymmetricAlgorithm where get = liftM toFVal getWord8 put = putWord8 . fromFVal instance Binary MPI where get = getMPI put = putMPI instance Binary SigType where get = liftM toFVal getWord8 put = putWord8 . fromFVal instance Binary UserAttrSubPacket where get = getUserAttrSubPacket put = putUserAttrSubPacket instance Binary S2K where get = getS2K put = putS2K instance Binary PKESK where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary Signature where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary SKESK where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary OnePassSignature where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary SecretKey where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary PublicKey where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary SecretSubkey where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary CompressedData where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary SymEncData where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary Marker where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary LiteralData where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary Trust where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary UserId where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary PublicSubkey where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary UserAttribute where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary SymEncIntegrityProtectedData where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary ModificationDetectionCode where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary OtherPacket where get = fmap fromPkt getPkt put = putPkt . toPkt instance Binary Pkt where get = getPkt put = putPkt instance Binary a => Binary (Block a) where get = Block `fmap` many get put = mapM_ put . unBlock instance Binary PKPayload where get = getPKPayload put = putPKPayload instance Binary SignaturePayload where get = getSignaturePayload put = putSignaturePayload instance Binary TK where get = undefined put = putTK getSigSubPacket :: Get SigSubPacket getSigSubPacket = do l <- fmap fromIntegral getSubPacketLength (crit, pt) <- getSigSubPacketType getSigSubPacket' pt crit l where getSigSubPacket' :: Word8 -> Bool -> ByteOffset -> Get SigSubPacket getSigSubPacket' pt crit l | pt == 2 = do et <- fmap ThirtyTwoBitTimeStamp getWord32be return $ SigSubPacket crit (SigCreationTime et) | pt == 3 = do et <- fmap ThirtyTwoBitDuration 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 <- getLazyByteString (l - 2) nul <- getWord8 guard (nul == 0) return $ SigSubPacket crit (RegularExpression (BL.copy apdre)) | pt == 7 = do r <- get return $ SigSubPacket crit (Revocable r) | pt == 9 = do et <- fmap ThirtyTwoBitDuration getWord32be return $ SigSubPacket crit (KeyExpirationTime et) | pt == 11 = do sa <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredSymmetricAlgorithms sa) | pt == 12 = do rclass <- getWord8 guard (testBit rclass 7) algid <- get fp <- getLazyByteString 20 return $ SigSubPacket crit (RevocationKey (bsToFFSet . BL.singleton $ rclass .&. 0x7f) algid (TwentyOctetFingerprint fp)) | pt == 16 = do keyid <- getLazyByteString (l - 1) return $ SigSubPacket crit (Issuer (EightOctetKeyId keyid)) | pt == 20 = do flags <- getLazyByteString 4 nl <- getWord16be vl <- getWord16be nn <- getLazyByteString (fromIntegral nl) nv <- getLazyByteString (fromIntegral vl) return $ SigSubPacket crit (NotationData (bsToFFSet flags) (NotationName nn) (NotationValue nv)) | pt == 21 = do ha <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredHashAlgorithms ha) | pt == 22 = do ca <- replicateM (fromIntegral (l - 1)) get return $ SigSubPacket crit (PreferredCompressionAlgorithms ca) | pt == 23 = do ksps <- getLazyByteString (l - 1) return $ SigSubPacket crit (KeyServerPreferences (bsToFFSet ksps)) | pt == 24 = do pks <- getLazyByteString (l - 1) return $ SigSubPacket crit (PreferredKeyServer pks) | pt == 25 = do primacy <- get return $ SigSubPacket crit (PrimaryUserId primacy) | pt == 26 = do url <- fmap (URL . fromMaybe nullURI . parseURI . T.unpack . decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 1))) return $ SigSubPacket crit (PolicyURL url) | pt == 27 = do kfs <- getLazyByteString (l - 1) return $ SigSubPacket crit (KeyFlags (bsToFFSet kfs)) | pt == 28 = do uid <- getByteString (fromIntegral (l - 1)) return $ SigSubPacket crit (SignersUserId (decodeUtf8With lenientDecode uid)) | pt == 29 = do rcode <- getWord8 rreason <- fmap (decodeUtf8With lenientDecode) (getByteString (fromIntegral (l - 2))) return $ SigSubPacket crit (ReasonForRevocation (toFVal rcode) rreason) | pt == 30 = do fbs <- getLazyByteString (l - 1) return $ SigSubPacket crit (Features (bsToFFSet fbs)) | pt == 31 = do pka <- get ha <- get hash <- getLazyByteString (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 <- getLazyByteString (l - 1) return $ SigSubPacket crit (UserDefinedSigSub pt payload) | otherwise = do payload <- getLazyByteString (l - 1) return $ SigSubPacket crit (OtherSigSub pt payload) putSigSubPacket :: SigSubPacket -> Put putSigSubPacket (SigSubPacket crit (SigCreationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 2 putWord32be . unThirtyTwoBitTimeStamp $ et putSigSubPacket (SigSubPacket crit (SigExpirationTime et)) = do putSubPacketLength 5 putSigSubPacketType crit 3 putWord32be . unThirtyTwoBitDuration $ 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 + BL.length apdre) putSigSubPacketType crit 6 putLazyByteString 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 . unThirtyTwoBitDuration $ 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 putLazyByteString . ffSetToFixedLengthBS (1 :: Int) $ Set.insert (RClOther 0) rclass put algid putLazyByteString (unTOF fp) -- 20 octets putSigSubPacket (SigSubPacket crit (Issuer keyid)) = do putSubPacketLength 9 putSigSubPacketType crit 16 putLazyByteString (unEOKI keyid) -- 8 octets putSigSubPacket (SigSubPacket crit (NotationData nfs (NotationName nn) (NotationValue nv))) = do putSubPacketLength . fromIntegral $ (9 + BL.length nn + BL.length nv) putSigSubPacketType crit 20 putLazyByteString . ffSetToFixedLengthBS (4 :: Int) $ nfs putWord16be . fromIntegral . BL.length $ nn putWord16be . fromIntegral . BL.length $ nv putLazyByteString nn putLazyByteString 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 + BL.length kbs) putSigSubPacketType crit 23 putLazyByteString kbs putSigSubPacket (SigSubPacket crit (PreferredKeyServer ks)) = do putSubPacketLength . fromIntegral $ (1 + BL.length ks) putSigSubPacketType crit 24 putLazyByteString ks putSigSubPacket (SigSubPacket crit (PrimaryUserId primacy)) = do putSubPacketLength 2 putSigSubPacketType crit 25 put primacy putSigSubPacket (SigSubPacket crit (PolicyURL (URL uri))) = do let bs = encodeUtf8 (T.pack (uriToString id uri "")) putSubPacketLength . fromIntegral $ (1 + B.length bs) putSigSubPacketType crit 26 putByteString bs putSigSubPacket (SigSubPacket crit (KeyFlags kfs)) = do let kbs = ffSetToBS kfs putSubPacketLength . fromIntegral $ (1 + BL.length kbs) putSigSubPacketType crit 27 putLazyByteString kbs putSigSubPacket (SigSubPacket crit (SignersUserId userid)) = do let bs = encodeUtf8 userid putSubPacketLength . fromIntegral $ (1 + B.length bs) putSigSubPacketType crit 28 putByteString bs putSigSubPacket (SigSubPacket crit (ReasonForRevocation rcode rreason)) = do let reasonbs = encodeUtf8 rreason putSubPacketLength . fromIntegral $ (2 + B.length reasonbs) putSigSubPacketType crit 29 putWord8 . fromFVal $ rcode putByteString reasonbs putSigSubPacket (SigSubPacket crit (Features fs)) = do let fbs = ffSetToBS fs putSubPacketLength . fromIntegral $ (1 + BL.length fbs) putSigSubPacketType crit 30 putLazyByteString fbs putSigSubPacket (SigSubPacket crit (SignatureTarget pka ha hash)) = do putSubPacketLength . fromIntegral $ (3 + BL.length hash) putSigSubPacketType crit 31 put pka put ha putLazyByteString hash putSigSubPacket (SigSubPacket crit (EmbeddedSignature sp)) = do let spb = runPut (put sp) putSubPacketLength . fromIntegral $ (1 + BL.length spb) putSigSubPacketType crit 32 putLazyByteString spb putSigSubPacket (SigSubPacket crit (UserDefinedSigSub ptype payload)) = putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) putSigSubPacket (SigSubPacket crit (OtherSigSub ptype payload)) = do putSubPacketLength . fromIntegral $ (1 + BL.length payload) putSigSubPacketType crit ptype putLazyByteString 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 return (if x .&. 128 == 128 then (True, x .&. 127) else (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 (shifty acc y) [0..7])) 0 (BL.unpack bs) where shifty acc y x = [toFFlag (acc + x) | y .&. shiftR 128 x == shiftR 128 x] ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString ffSetToFixedLengthBS len ffs = BL.take (fromIntegral len) (BL.append (ffSetToBS ffs) (BL.pack (replicate 5 0))) ffSetToBS :: FutureFlag a => Set a -> ByteString ffSetToBS = BL.pack . ffSetToBS' where ffSetToBS' :: FutureFlag a => Set a -> [Word8] ffSetToBS' ks | Set.null ks = [] -- FIXME: should this be [0]? | otherwise = map ((foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . Set.toAscList) . (\ x -> Set.filter (\ y -> fromFFlag y `div` 8 == x) ks)) [0 .. fromFFlag (Set.findMax ks) `div` 8] fromS2K :: S2K -> ByteString fromS2K (Simple hashalgo) = BL.pack [0, fromIntegral . fromFVal $ hashalgo] fromS2K (Salted hashalgo salt) | B.length (unSalt salt) == 8 = BL.pack [1, fromIntegral . fromFVal $ hashalgo] `BL.append` (BL.fromStrict . unSalt) salt | otherwise = error "Confusing salt size" fromS2K (IteratedSalted hashalgo salt count) | B.length (unSalt salt) == 8 = BL.pack [3, fromIntegral . fromFVal $ hashalgo] `BL.append` (BL.fromStrict . unSalt) salt `BL.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 salt) | t == 3 = do ha <- getWord8 salt <- getByteString 8 count <- getWord8 return $ IteratedSalted (toFVal ha) (Salt salt) (decodeIterationCount count) | otherwise = do bs <- getRemainingLazyByteString return $ OtherS2K t bs 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 (unSalt salt) putWord8 $ encodeIterationCount count putS2K (OtherS2K t bs) = putWord8 t >> putLazyByteString bs 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 <- getLazyByteString (fromIntegral len) return (t, bs) 1 -> do len <- getWord16be bs <- getLazyByteString (fromIntegral len) return (t, bs) 2 -> do len <- getWord32be bs <- getLazyByteString (fromIntegral len) return (t, bs) 3 -> do bs <- getRemainingLazyByteString return (t, bs) _ -> error "This should never happen (getPacketTypeAndPayload/0x00)." 0x40 -> do len <- fmap fromIntegral getPacketLength bs <- getLazyByteString len return (tag .&. 0x3f, bs) _ -> error "This should never happen (getPacketTypeAndPayload/???)." getPkt :: Get Pkt getPkt = do (t, pl) <- getPacketTypeAndPayload case runGetOrFail (getPkt' t (BL.length pl)) pl of Left (_, _, e) -> return $! BrokenPacketPkt e t pl Right (_, _, p) -> return p where getPkt' :: Word8 -> ByteOffset -> Get Pkt getPkt' t len | t == 1 = do pv <- getWord8 eokeyid <- getLazyByteString 8 pka <- getWord8 mpib <- getRemainingLazyByteString case runGetOrFail (some getMPI) mpib of Left (_, _, e) -> fail ("PKESK MPIs " ++ e) Right (_, _, sk) -> return $ PKESKPkt pv (EightOctetKeyId eokeyid) (toFVal pka) (NE.fromList sk) | t == 2 = do bs <- getRemainingLazyByteString case runGetOrFail get bs of Left (_, _, e) -> fail ("signature packet " ++ e) Right (_, _, sp) -> return $ SignaturePkt sp | t == 3 = do pv <- getWord8 symalgo <- getWord8 s2k <- getS2K esk <- getRemainingLazyByteString return $ SKESKPkt pv (toFVal symalgo) s2k (if BL.null esk then Nothing else Just esk) | t == 4 = do pv <- getWord8 sigtype <- getWord8 ha <- getWord8 pka <- getWord8 skeyid <- getLazyByteString 8 nested <- getWord8 return $ OnePassSignaturePkt pv (toFVal sigtype) (toFVal ha) (toFVal pka) (EightOctetKeyId skeyid) (nested == 0) | t == 5 = do bs <- getLazyByteString len let ps = flip runGetOrFail bs $ do pkp <- getPKPayload ska <- getSKAddendum pkp return $ SecretKeyPkt pkp ska case ps of Left (_, _, err) -> fail ("secret key " ++ err) Right (_, _, key) -> return key | t == 6 = do pkp <- getPKPayload return $ PublicKeyPkt pkp | t == 7 = do bs <- getLazyByteString len let ps = flip runGetOrFail bs $ do pkp <- getPKPayload ska <- getSKAddendum pkp return $ SecretSubkeyPkt pkp ska case ps of Left (_, _, err) -> fail ("secret subkey " ++ err) Right (_, _, key) -> return key | t == 8 = do ca <- getWord8 cdata <- getLazyByteString (len - 1) return $ CompressedDataPkt (toFVal ca) cdata | t == 9 = do sdata <- getLazyByteString len return $ SymEncDataPkt sdata | t == 10 = do marker <- getLazyByteString len return $ MarkerPkt marker | t == 11 = do dt <- getWord8 flen <- getWord8 fn <- getLazyByteString (fromIntegral flen) ts <- fmap ThirtyTwoBitTimeStamp getWord32be ldata <- getLazyByteString (len - (6 + fromIntegral flen)) return $ LiteralDataPkt (toFVal dt) fn ts ldata | t == 12 = do tdata <- getLazyByteString len return $ TrustPkt tdata | t == 13 = do udata <- getByteString (fromIntegral len) return . UserIdPkt . decodeUtf8With lenientDecode $ udata | t == 14 = do pkp <- getPKPayload return $ PublicSubkeyPkt pkp | t == 17 = do bs <- getLazyByteString len case runGetOrFail (many getUserAttrSubPacket) bs of Left (_, _, err) -> fail ("user attribute " ++ err) Right (_, _, uas) -> return $ UserAttributePkt uas | t == 18 = do pv <- getWord8 -- should be 1 b <- getLazyByteString (len - 1) return $ SymEncIntegrityProtectedDataPkt pv b | t == 19 = do hash <- getLazyByteString 20 return $ ModificationDetectionCodePkt hash | otherwise = do payload <- getLazyByteString len return $ OtherPacketPkt t payload getUserAttrSubPacket :: Get UserAttrSubPacket getUserAttrSubPacket = do l <- fmap fromIntegral getSubPacketLength t <- getWord8 getUserAttrSubPacket' t l where getUserAttrSubPacket' :: Word8 -> ByteOffset -> Get UserAttrSubPacket getUserAttrSubPacket' t l | t == 1 = do _ <- getWord16le -- ihlen hver <- getWord8 -- should be 1 iformat <- getWord8 nuls <- getLazyByteString 12 -- should be NULs bs <- getLazyByteString (l - 17) if hver /= 1 || nuls /= BL.pack (replicate 12 0) then fail "Corrupt UAt subpacket" else return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs | otherwise = do bs <- getLazyByteString (l - 1) return $ OtherUASub t bs putUserAttrSubPacket :: UserAttrSubPacket -> Put putUserAttrSubPacket ua = do let sp = runPut $ putUserAttrSubPacket' ua putSubPacketLength . fromIntegral . BL.length $ sp putLazyByteString sp where putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do putWord8 1 putWord16le 16 putWord8 1 putWord8 (fromFVal iformat) replicateM_ 12 $ putWord8 0 putLazyByteString idata putUserAttrSubPacket' (OtherUASub t bs) = do putWord8 t putLazyByteString bs putPkt :: Pkt -> Put putPkt (PKESKPkt pv eokeyid pka mpis) = do putWord8 (0xc0 .|. 1) let bsk = runPut $ F.mapM_ put mpis putPacketLength . fromIntegral $ 10 + BL.length bsk putWord8 pv -- must be 3 putLazyByteString (unEOKI eokeyid) -- must be 8 octets putWord8 $ fromIntegral . fromFVal $ pka putLazyByteString bsk putPkt (SignaturePkt sp) = do putWord8 (0xc0 .|. 2) let bs = runPut $ put sp putLengthThenPayload bs putPkt (SKESKPkt pv symalgo s2k mesk) = do putWord8 (0xc0 .|. 3) let bs2k = fromS2K s2k let bsk = fromMaybe BL.empty mesk putPacketLength . fromIntegral $ 2 + BL.length bs2k + BL.length bsk putWord8 pv -- should be 4 putWord8 $ fromIntegral . fromFVal $ symalgo putLazyByteString bs2k putLazyByteString 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 putLazyByteString (unEOKI skeyid) putWord8 . fromIntegral . fromEnum $ not nested -- FIXME: what do other values mean? putLengthThenPayload bs putPkt (SecretKeyPkt pkp ska) = do putWord8 (0xc0 .|. 5) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) putLengthThenPayload bs putPkt (PublicKeyPkt pkp) = do putWord8 (0xc0 .|. 6) let bs = runPut $ putPKPayload pkp putLengthThenPayload bs putPkt (SecretSubkeyPkt pkp ska) = do putWord8 (0xc0 .|. 7) let bs = runPut (putPKPayload pkp >> putSKAddendum ska) putLengthThenPayload bs putPkt (CompressedDataPkt ca cdata) = do putWord8 (0xc0 .|. 8) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ ca putLazyByteString cdata putLengthThenPayload bs putPkt (SymEncDataPkt b) = do putWord8 (0xc0 .|. 9) putLengthThenPayload b putPkt (MarkerPkt b) = do putWord8 (0xc0 .|. 10) putLengthThenPayload b putPkt (LiteralDataPkt dt fn ts b) = do putWord8 (0xc0 .|. 11) let bs = runPut $ do putWord8 $ fromIntegral . fromFVal $ dt putWord8 $ fromIntegral . BL.length $ fn putLazyByteString fn putWord32be . unThirtyTwoBitTimeStamp $ ts putLazyByteString b putLengthThenPayload bs putPkt (TrustPkt b) = do putWord8 (0xc0 .|. 12) putLengthThenPayload b putPkt (UserIdPkt u) = do putWord8 (0xc0 .|. 13) let bs = encodeUtf8 u putPacketLength . fromIntegral $ B.length bs putByteString bs putPkt (PublicSubkeyPkt pkp) = do putWord8 (0xc0 .|. 14) let bs = runPut $ putPKPayload pkp putLengthThenPayload bs putPkt (UserAttributePkt us) = do putWord8 (0xc0 .|. 17) let bs = runPut $ mapM_ put us putLengthThenPayload bs putPkt (SymEncIntegrityProtectedDataPkt pv b) = do putWord8 (0xc0 .|. 18) putPacketLength . fromIntegral $ BL.length b + 1 putWord8 pv -- should be 1 putLazyByteString b putPkt (ModificationDetectionCodePkt hash) = do putWord8 (0xc0 .|. 19) putLengthThenPayload hash putPkt (OtherPacketPkt t payload) = do putWord8 (0xc0 .|. t) -- FIXME: restrict t putLengthThenPayload payload putPkt (BrokenPacketPkt _ t payload) = putPkt (OtherPacketPkt t payload) putLengthThenPayload :: ByteString -> Put putLengthThenPayload bs = do putPacketLength . fromIntegral $ BL.length bs putLazyByteString bs getMPI :: Get MPI getMPI = do mpilen <- getWord16be bs <- getByteString (fromIntegral (mpilen + 7) `div` 8) return $ MPI (os2ip bs) getPubkey :: PubKeyAlgorithm -> Get PKey getPubkey RSA = do MPI n <- get MPI e <- get return $ RSAPubKey (RSA_PublicKey (R.PublicKey (fromIntegral . B.length . i2osp $ 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 (DSA_PublicKey (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 _ = UnknownPKey <$> getRemainingLazyByteString putPubkey :: PKey -> Put putPubkey (UnknownPKey bs) = put bs 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 dP = 0 dQ = 0 qinv = 0 pub = (\(RSAPubKey (RSA_PublicKey x)) -> x) (pkp^.pubkey) return $ RSAPrivateKey (RSA_PrivateKey (R.PrivateKey pub d p q dP dQ qinv)) | _pkalgo pkp == DSA = do MPI x <- get return $ DSAPrivateKey (DSA_PrivateKey (D.PrivateKey (D.Params 0 0 0) x)) | _pkalgo pkp `elem` [ElgamalEncryptOnly,ForbiddenElgamal] = do MPI x <- get return $ ElGamalPrivateKey [x] putSKey :: SKey -> Put putSKey (RSAPrivateKey (RSA_PrivateKey (R.PrivateKey _ d p q _ _ _))) = put (MPI d) >> put (MPI p) >> put (MPI q) >> put (MPI u) where u = multiplicativeInverse q p putMPI :: MPI -> Put putMPI (MPI i) = do let bs = i2osp i putWord16be . fromIntegral . numBits $ i putByteString bs getPKPayload :: Get PKPayload getPKPayload = do version <- getWord8 ctime <- fmap ThirtyTwoBitTimeStamp 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 . unThirtyTwoBitTimeStamp $ ctime putWord16be v3e put pka putPubkey pk putPKPayload (PKPayload V4 ctime _ pka pk) = do putWord8 4 putWord32be . unThirtyTwoBitTimeStamp $ 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 case s2k of -- FIXME: this is a mess OtherS2K _ _ -> return $ SUS16bit (toFVal symenc) s2k mempty BL.empty _ -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) encryptedblock <- getRemainingLazyByteString return $ SUS16bit (toFVal symenc) s2k (IV iv) encryptedblock 254 -> do symenc <- getWord8 s2k <- getS2K case s2k of -- FIXME: this is a mess OtherS2K _ _ -> return $ SUSSHA1 (toFVal symenc) s2k mempty BL.empty _ -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) encryptedblock <- getRemainingLazyByteString return $ SUSSHA1 (toFVal symenc) s2k (IV iv) encryptedblock symenc -> do iv <- getByteString (symEncBlockSize . toFVal $ symenc) encryptedblock <- getRemainingLazyByteString return $ SUSym (toFVal symenc) (IV iv) encryptedblock putSKAddendum :: SKAddendum -> Put putSKAddendum (SUSSHA1 symenc s2k iv encryptedblock) = do putWord8 254 put symenc put s2k putByteString (unIV iv) putLazyByteString encryptedblock putSKAddendum (SUUnencrypted sk checksum) = do putWord8 0 putSKey sk putWord16be checksum 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 Camellia128 = 16 symEncBlockSize _ = 8 -- FIXME decodeIterationCount :: Word8 -> IterationCount decodeIterationCount c = IterationCount ((16 + (fromIntegral c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)) encodeIterationCount :: IterationCount -> 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 <- fmap ThirtyTwoBitTimeStamp getWord32be eok <- getLazyByteString 8 pka <- get ha <- get left16 <- getWord16be mpib <- getRemainingLazyByteString case runGetOrFail (some getMPI) mpib of Left (_, _, e) -> fail ("v3 sig MPIs " ++ e) Right (_, _, mpis) -> return $ SigV3 (toFVal st) ctime (EightOctetKeyId eok) (toFVal pka) (toFVal ha) left16 (NE.fromList mpis) 4 -> do st <- getWord8 pka <- get ha <- get hlen <- getWord16be hb <- getLazyByteString (fromIntegral hlen) let hashed = case runGetOrFail (many getSigSubPacket) hb of Left (_, _, err) -> fail ("v4 sig hasheds " ++ err) Right (_, _, h) -> h ulen <- getWord16be ub <- getLazyByteString (fromIntegral ulen) let unhashed = case runGetOrFail (many getSigSubPacket) ub of Left (_, _, err) -> fail ("v4 sig unhasheds " ++ err) Right (_, _, u) -> u left16 <- getWord16be mpib <- getRemainingLazyByteString case runGetOrFail (some getMPI) mpib of Left (_, _, e) -> fail ("v4 sig MPIs " ++ e) Right (_, _, mpis) -> return $ SigV4 (toFVal st) (toFVal pka) (toFVal ha) hashed unhashed left16 (NE.fromList mpis) _ -> do bs <- getRemainingLazyByteString return $ SigVOther pv bs putSignaturePayload :: SignaturePayload -> Put putSignaturePayload (SigV3 st ctime eok pka ha left16 mpis) = do putWord8 3 putWord8 5 -- hashlen put st putWord32be . unThirtyTwoBitTimeStamp $ ctime putLazyByteString (unEOKI eok) put pka put ha putWord16be left16 F.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 . BL.length $ hb putLazyByteString hb let ub = runPut $ mapM_ put unhashed putWord16be . fromIntegral . BL.length $ ub putLazyByteString ub putWord16be left16 F.mapM_ put mpis putSignaturePayload (SigVOther pv bs) = do putWord8 pv putLazyByteString bs putTK :: TK -> Put putTK key = do put (PublicKey (key^.tkKey._1)) mapM_ (put . Signature) (_tkRevs key) mapM_ putUid' (_tkUIDs key) mapM_ putUat' (_tkUAts key) mapM_ putSub' (_tkSubs key) where putUid' (u, sps) = put (UserId u) >> mapM_ (put . Signature) sps putUat' (us, sps) = put (UserAttribute us) >> mapM_ (put . Signature) sps putSub' (p, sps) = put p >> mapM_ (put . Signature) sps