module Codec.Encryption.OpenPGP.Serialize (
) where
import Control.Applicative ((<$>),(<*>))
import Control.Monad (replicateM, mplus, when)
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.Maybe (isJust, fromJust)
import Data.Serialize (Serialize, get, put)
import Data.Serialize.Get (Get, getWord8, getWord16be, getWord32be, getBytes, getByteString, getWord16le, runGet, remaining)
import Data.Serialize.Put (Put, putWord8, putWord16be, putWord32be, putByteString, putWord16le, runPut)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Word (Word8, Word16)
import Codec.Encryption.OpenPGP.Internal (countBits, beBSToInteger, integerToBEBS)
import Codec.Encryption.OpenPGP.Types
instance Serialize SigSubPacket where
get = getSigSubPacket
put = putSigSubPacket
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 <- 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
spb <- getByteString (l 1)
return $ EmbeddedSignature crit spb
| pt > 99 && pt < 111 = do
payload <- getByteString (l 1)
return $ UserDefinedSigSub crit pt payload
| otherwise = do
payload <- getByteString (l 1)
return $ OtherSigSub crit pt payload
putSigSubPacket :: SigSubPacket -> Put
putSigSubPacket (SigCreationTime crit et) = do
putSubPacketLength 5
putSigSubPacketType crit 2
putWord32be et
putSigSubPacket (SigExpirationTime crit et) = do
putSubPacketLength 5
putSigSubPacketType crit 3
putWord32be et
putSigSubPacket (ExportableCertification crit e) = do
putSubPacketLength 2
putSigSubPacketType crit 4
put e
putSigSubPacket (TrustSignature crit tl ta) = do
putSubPacketLength 3
putSigSubPacketType crit 5
put tl
put ta
putSigSubPacket (RegularExpression crit apdre) = do
putSubPacketLength (2 + B.length apdre)
putSigSubPacketType crit 6
putByteString apdre
putWord8 0
putSigSubPacket (Revocable crit r) = do
putSubPacketLength 2
putSigSubPacketType crit 7
put r
putSigSubPacket (KeyExpirationTime crit et) = do
putSubPacketLength 5
putSigSubPacketType crit 9
putWord32be et
putSigSubPacket (PreferredSymmetricAlgorithms crit ess) = do
putSubPacketLength (1 + length ess)
putSigSubPacketType crit 11
mapM_ put ess
putSigSubPacket (RevocationKey crit rclass algid fp) = do
putSubPacketLength 23
putSigSubPacketType crit 12
putByteString . ffSetToFixedLengthBS 1 $ rclass
put algid
putByteString (unTOF fp)
putSigSubPacket (Issuer crit keyid) = do
putSubPacketLength 9
putSigSubPacketType crit 16
putByteString (unEOKI keyid)
putSigSubPacket (NotationData crit nfs nn nv) = do
putSubPacketLength (9 + B.length nn + B.length nv)
putSigSubPacketType crit 20
putByteString . ffSetToFixedLengthBS 4 $ nfs
putWord16be . fromIntegral . B.length $ nn
putWord16be . fromIntegral . B.length $ nv
putByteString nn
putByteString nv
putSigSubPacket (PreferredHashAlgorithms crit ehs) = do
putSubPacketLength (1 + length ehs)
putSigSubPacketType crit 21
mapM_ put ehs
putSigSubPacket (PreferredCompressionAlgorithms crit ecs) = do
putSubPacketLength (1 + length ecs)
putSigSubPacketType crit 22
mapM_ put ecs
putSigSubPacket (KeyServerPreferences crit ksps) = do
let kbs = ffSetToBS ksps
putSubPacketLength (1 + B.length kbs)
putSigSubPacketType crit 23
putByteString kbs
putSigSubPacket (PreferredKeyServer crit ks) = do
putSubPacketLength (1 + B.length ks)
putSigSubPacketType crit 24
putByteString ks
putSigSubPacket (PrimaryUserId crit primacy) = do
putSubPacketLength 2
putSigSubPacketType crit 25
put primacy
putSigSubPacket (PolicyURL crit url) = do
putSubPacketLength (1 + B.length url)
putSigSubPacketType crit 26
putByteString url
putSigSubPacket (KeyFlags crit kfs) = do
let kbs = ffSetToBS kfs
putSubPacketLength (1 + B.length kbs)
putSigSubPacketType crit 27
putByteString kbs
putSigSubPacket (SignersUserId crit userid) = do
putSubPacketLength (1 + B.length userid)
putSigSubPacketType crit 28
putByteString userid
putSigSubPacket (ReasonForRevocation crit rcode rreason) = do
putSubPacketLength (2 + B.length rreason)
putSigSubPacketType crit 29
putWord8 . fromFVal $ rcode
putByteString rreason
putSigSubPacket (Features crit fs) = do
let fbs = ffSetToBS fs
putSubPacketLength (1 + B.length fbs)
putSigSubPacketType crit 30
putByteString fbs
putSigSubPacket (SignatureTarget crit pka ha hash) = do
putSubPacketLength (3 + B.length hash)
putSigSubPacketType crit 31
put pka
put ha
putByteString hash
putSigSubPacket (EmbeddedSignature crit spb) = do
putSubPacketLength (1 + B.length spb)
putSigSubPacketType crit 32
putByteString spb
putSigSubPacket (UserDefinedSigSub crit ptype payload) = do
putSubPacketLength (1 + B.length payload)
putSigSubPacketType crit ptype
putByteString payload
putSigSubPacket (OtherSigSub crit ptype payload) = do
putSubPacketLength (1 + B.length payload)
putSigSubPacketType crit ptype
putByteString payload
getSubPacketLength :: Integral a => Get a
getSubPacketLength = getSubPacketLength' =<< getWord8
where
getSubPacketLength' :: Integral a => Word8 -> Get a
getSubPacketLength' f
| f < 192 = return . fromIntegral $ f
| f < 224 = do
secondOctet <- getWord8
return . fromIntegral $ shiftL (fromIntegral (f 192) :: Int) 8 + (fromIntegral secondOctet :: Int) + 192
| f == 255 = do
len <- getWord32be
return . fromIntegral $ len
| otherwise = fail "Partial body length invalid."
putSubPacketLength :: Integral a => a -> Put
putSubPacketLength l
| l < 192 = putWord8 (fromIntegral l)
| l < 8384 = putWord8 (fromIntegral ((fromIntegral (l 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l 192) .&. 0xff)
| l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)
| otherwise = fail "too big"
getSigSubPacketType :: Get (Bool, Word8)
getSigSubPacketType = do
x <- getWord8
if x .&. 0x80 == 0x80 then return (True, x .&. 0x7f) else return (False, x)
putSigSubPacketType :: Bool -> Word8 -> Put
putSigSubPacketType False sst = putWord8 sst
putSigSubPacketType True sst = putWord8 (sst .|. 0x80)
bsToFFSet :: FutureFlag a => ByteString -> Set a
bsToFFSet bs = Set.fromAscList . concat . snd $ mapAccumL (\acc y -> (acc+8, concatMap (\x -> if y .&. (shiftR 128 x) == (shiftR 128 x) then [toFFlag (acc + x)] else []) [0..7])) 0 (B.unpack bs)
ffSetToFixedLengthBS :: (Integral a, FutureFlag b) => a -> Set b -> ByteString
ffSetToFixedLengthBS len ffs = B.take (fromIntegral len) (B.append (ffSetToBS ffs) (B.pack (replicate 5 0)))
ffSetToBS :: FutureFlag a => Set a -> ByteString
ffSetToBS = B.pack . ffSetToBS'
where
ffSetToBS' :: FutureFlag a => Set a -> [Word8]
ffSetToBS' ks = map (foldl (.|.) 0 . map (shiftR 128 . flip mod 8 . fromFFlag) . Set.toAscList) (map (\x -> Set.filter (\y -> fromFFlag y `div` 8 == x) ks) [0..(fromFFlag $ Set.findMax ks) `div` 8])
fromS2K :: S2K -> ByteString
fromS2K (Simple hashalgo) = B.pack [0, fromIntegral . fromFVal $ hashalgo]
fromS2K (Salted hashalgo salt)
| B.length salt == 8 = B.pack [1, fromIntegral . fromFVal $ hashalgo] `B.append` salt
fromS2K (IteratedSalted hashalgo salt count)
| B.length salt == 8 = B.pack [3, fromIntegral . fromFVal $ hashalgo] `B.append` salt `B.snoc` (encodeIterationCount count)
fromS2K (OtherS2K t bs) = bs
getPacketLength :: Integral a => Get a
getPacketLength = do
firstOctet <- getWord8
getPacketLength' firstOctet
where
getPacketLength' :: Integral a => Word8 -> Get a
getPacketLength' f
| f < 192 = return . fromIntegral $ f
| f < 224 = do
secondOctet <- getWord8
return . fromIntegral $ shiftL (fromIntegral (f 192) :: Int) 8 + (fromIntegral secondOctet :: Int) + 192
| f == 255 = do
len <- getWord32be
return . fromIntegral $ len
| otherwise = fail "Partial body length support missing." --FIXME
putPacketLength :: Integral a => a -> Put
putPacketLength l
| l < 192 = putWord8 (fromIntegral l)
| l < 8384 = putWord8 (fromIntegral ((fromIntegral (l 192) `shiftR` 8) + 192 :: Int)) >> putWord8 (fromIntegral (l 192) .&. 0xff)
| l < 0x100000000 = putWord8 255 >> putWord32be (fromIntegral l)
| otherwise = fail "partial body length support needed"
getS2K :: Get S2K
getS2K = getS2K' =<< getWord8
where
getS2K' :: Word8 -> Get S2K
getS2K' t
| t == 0 = do
ha <- getWord8
return $ Simple (toFVal ha)
| t == 1 = do
ha <- getWord8
salt <- getByteString 8
return $ Salted (toFVal ha) salt
| t == 3 = do
ha <- getWord8
salt <- getByteString 8
count <- getWord8
return $ IteratedSalted (toFVal ha) salt (decodeIterationCount count)
| otherwise = error "Unknown S2K"
putS2K :: S2K -> Put
putS2K (IteratedSalted ha salt count) = do
putWord8 3
put ha
putByteString salt
putWord8 $ encodeIterationCount count
getPacketTypeAndPayload :: Get (Word8, ByteString)
getPacketTypeAndPayload = do
tag <- getWord8
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 <- getPacketLength
bs <- getByteString len
return (tag .&. 0x3f, bs)
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
sk <- getByteString (len 10)
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
let partiallen = case s2k of
Simple _ -> 1 + 3
Salted _ _ -> 9 + 3
IteratedSalted _ _ _ -> 10 + 3
msk <- getMSK len partiallen
return $ SKESK pv (toFVal symalgo) s2k msk
| t == 4 = do
pv <- getWord8
sigtype <- getWord8
ha <- getWord8
pka <- getWord8
skeyid <- getByteString 8
nested <- getWord8
return $ OnePassSignature pv (toFVal sigtype) (toFVal ha) (toFVal pka) (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
b <- getByteString (len 1)
return $ SymEncIntegrityProtectedData pv b
| t == 19 = do
hash <- getByteString 20
return $ ModificationDetectionCode hash
| otherwise = do
payload <- getByteString len
return $ OtherPacket t payload
where
getMSK :: Int -> Int -> Get (Maybe SessionKey)
getMSK len partiallen
| len == partiallen = return Nothing
| len > partiallen = do
sk <- getByteString (len partiallen)
return $ Just sk
| otherwise = error "Overread"
getUserAttrSubPacket :: Get UserAttrSubPacket
getUserAttrSubPacket = do
l <- getSubPacketLength
t <- getWord8
getUserAttrSubPacket' t l
where
getUserAttrSubPacket' :: Word8 -> Int -> Get UserAttrSubPacket
getUserAttrSubPacket' t l
| t == 1 = do
ihlen <- getWord16le
hver <- getWord8
iformat <- getWord8
_ <- getBytes 12
bs <- getByteString (l 17)
return $ ImageAttribute (ImageHV1 (toFVal iformat)) bs
| otherwise = do
bs <- getByteString (l 1)
return $ OtherUASub t bs
putUserAttrSubPacket :: UserAttrSubPacket -> Put
putUserAttrSubPacket ua = do
let sp = runPut $ putUserAttrSubPacket' ua
putSubPacketLength . B.length $ sp
putByteString sp
where
putUserAttrSubPacket' (ImageAttribute (ImageHV1 iformat) idata) = do
putWord8 1
putWord16le 16
putWord8 1
putWord8 (fromFVal iformat)
mapM_ putWord8 $ replicate 12 0
putByteString idata
putUserAttrSubPacket' (OtherUASub t bs) = do
putWord8 t
putByteString bs
putPacket :: Packet -> Put
putPacket (PKESK pv eokeyid pkalgo sk) = do
putWord8 (0xc0 .|. 1)
let bsk = sk
putPacketLength $ 10 + (B.length bsk)
putWord8 pv
putByteString (unEOKI eokeyid)
putWord8 $ fromIntegral . fromFVal $ pkalgo
putByteString bsk
putPacket (Signature sp) = do
putWord8 (0xc0 .|. 2)
let bs = runPut $ put sp
putPacketLength . B.length $ bs
putByteString bs
putPacket (SKESK pv symalgo s2k msk) = do
putWord8 (0xc0 .|. 3)
let bs2k = fromS2K s2k
putPacketLength $ 2 + (B.length bs2k) + (maybe 0 B.length msk)
putWord8 pv
putWord8 $ fromIntegral . fromFVal $ symalgo
putByteString bs2k
when (isJust msk) $ putByteString (fromJust msk)
putPacket (OnePassSignature pv sigtype ha pka skeyid nested) = do
putWord8 (0xc0 .|. 4)
let bs = runPut $ do
putWord8 pv
putWord8 $ fromIntegral . fromFVal $ sigtype
putWord8 $ fromIntegral . fromFVal $ ha
putWord8 $ fromIntegral . fromFVal $ pka
putByteString (unEOKI skeyid)
putWord8 . fromIntegral . fromEnum $ not nested
putPacketLength $ B.length bs
putByteString bs
putPacket (SecretKey pkp ska) = do
putWord8 (0xc0 .|. 5)
let bs = runPut (putPKPayload pkp >> putSKAddendum ska)
putPacketLength $ B.length bs
putByteString bs
putPacket (PublicKey pkp) = do
putWord8 (0xc0 .|. 6)
let bs = runPut $ putPKPayload pkp
putPacketLength $ B.length bs
putByteString bs
putPacket (SecretSubkey pkp ska) = do
putWord8 (0xc0 .|. 7)
let bs = runPut (putPKPayload pkp >> putSKAddendum ska)
putPacketLength $ B.length bs
putByteString bs
putPacket (CompressedData ca cdata) = do
putWord8 (0xc0 .|. 8)
let bs = runPut $ do
putWord8 $ fromIntegral . fromFVal $ ca
putByteString cdata
putPacketLength $ B.length bs
putByteString bs
putPacket (SymEncData b) = do
putWord8 (0xc0 .|. 9)
putPacketLength $ B.length b
putByteString b
putPacket (Marker b) = do
putWord8 (0xc0 .|. 10)
putPacketLength $ B.length b
putByteString b
putPacket (LiteralData dt fn ts b) = do
putWord8 (0xc0 .|. 11)
let bs = runPut $ do
putWord8 $ fromIntegral . fromFVal $ dt
putWord8 $ fromIntegral . B.length $ fn
putByteString fn
putWord32be ts
putByteString b
putPacketLength $ B.length bs
putByteString bs
putPacket (Trust b) = do
putWord8 (0xc0 .|. 12)
putPacketLength . B.length $ b
putByteString b
putPacket (UserId u) = do
putWord8 (0xc0 .|. 13)
let bs = BC8.pack u
putPacketLength $ B.length bs
putByteString bs
putPacket (PublicSubkey pkp) = do
putWord8 (0xc0 .|. 14)
let bs = runPut $ putPKPayload pkp
putPacketLength $ B.length bs
putByteString bs
putPacket (UserAttribute us) = do
putWord8 (0xc0 .|. 17)
let bs = runPut $ mapM_ put us
putPacketLength $ B.length bs
putByteString bs
putPacket (SymEncIntegrityProtectedData pv b) = do
putWord8 (0xc0 .|. 18)
putPacketLength $ (B.length b) + 1
putWord8 pv
putByteString b
putPacket (ModificationDetectionCode hash) = do
putWord8 (0xc0 .|. 19)
putPacketLength . B.length $ hash
putByteString hash
putPacket (OtherPacket t payload) = do
putWord8 (0xc0 .|. t)
putPacketLength . 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]
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 u <- 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
symEncBlockSize :: SymmetricAlgorithm -> Int
symEncBlockSize (Plaintext) = 0
symEncBlockSize (IDEA) = 8
symEncBlockSize (TripleDES) = 8
symEncBlockSize (CAST5) = 8
symEncBlockSize (Blowfish) = 8
symEncBlockSize (AES128) = 16
symEncBlockSize (AES192) = 16
symEncBlockSize (AES256) = 16
symEncBlockSize (Twofish) = 16
symEncBlockSize x = 8
decodeIterationCount :: Word8 -> Int
decodeIterationCount c = fromIntegral $ (16 + (c .&. 15)) `shiftL` ((fromIntegral c `shiftR` 4) + 6)
encodeIterationCount :: Int -> Word8
encodeIterationCount c = fromIntegral c
getSignaturePayload :: Get SignaturePayload
getSignaturePayload = do
pv <- getWord8
case pv of
3 -> do
hashlen <- getWord8
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
otherwise -> do
remainder <- remaining
bs <- getByteString remainder
return $ SigVOther pv bs
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
many :: Get a -> Get [a]
many p = many1 p `mplus` return []
many1 :: Get a -> Get [a]
many1 p = (:) <$> p <*> many p