module Data.OpenPGP.CryptoAPI (fingerprint, sign, verify, encrypt, decryptAsymmetric, decryptSymmetric, decryptSecretKey) where
import Data.Char
import Data.Bits
import Data.List (find)
import Data.Maybe (mapMaybe, catMaybes, listToMaybe)
import Control.Arrow
import Control.Applicative
import Control.Monad
import Control.Monad.Trans.Class (lift)
import Control.Monad.Trans.State (StateT(..), runStateT)
import Data.Binary (encode, decode, get, Word16)
import Crypto.Classes hiding (hash,sign,verify,encode)
import Data.Tagged (untag, asTaggedTypeOf, Tagged(..))
import Crypto.Modes (cfb, unCfb, IV, zeroIV)
import Crypto.Random (CryptoRandomGen, GenError(GenErrorOther), genBytes)
import Crypto.Hash.MD5 (MD5)
import Crypto.Hash.SHA1 (SHA1)
import Crypto.Hash.RIPEMD160 (RIPEMD160)
import Crypto.Hash.SHA256 (SHA256)
import Crypto.Hash.SHA384 (SHA384)
import Crypto.Hash.SHA512 (SHA512)
import Crypto.Hash.SHA224 (SHA224)
import Crypto.Cipher.AES (AES128,AES192,AES256)
import qualified Data.Serialize as Serialize
import qualified Crypto.Cipher.RSA as RSA
import qualified Crypto.Cipher.DSA as DSA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LZ
import qualified Data.OpenPGP as OpenPGP
import Data.OpenPGP.CryptoAPI.Util
import Data.OpenPGP.CryptoAPI.Blowfish128
type Encrypt g = (LZ.ByteString -> g -> (LZ.ByteString, g))
type Decrypt = (Bool -> LZ.ByteString -> (LZ.ByteString, LZ.ByteString))
buildKeyGen :: (BlockCipher k, CryptoRandomGen g) => g -> Either GenError (k, g)
buildKeyGen = runStateT (go (0::Int))
where
go 1000 = lift $ Left $ GenErrorOther
"Tried 1000 times to generate a key from the system entropy.\
\ No keys were returned! Perhaps the system entropy is broken\
\ or perhaps the BlockCipher instance being used has a non-flat\
\ keyspace."
go i = do
let bs = keyLength
kd <- StateT $ genBytes ((7 + untag bs) `div` 8)
case buildKey kd of
Nothing -> go (i+1)
Just k -> return $ k `asTaggedTypeOf` bs
find_key :: OpenPGP.Message -> String -> Maybe OpenPGP.Packet
find_key = OpenPGP.find_key fingerprint
hash :: OpenPGP.HashAlgorithm -> LZ.ByteString -> (BS.ByteString, String)
hash OpenPGP.MD5 = hash_ (undefined :: MD5)
hash OpenPGP.SHA1 = hash_ (undefined :: SHA1)
hash OpenPGP.RIPEMD160 = hash_ (undefined :: RIPEMD160)
hash OpenPGP.SHA256 = hash_ (undefined :: SHA256)
hash OpenPGP.SHA384 = hash_ (undefined :: SHA384)
hash OpenPGP.SHA512 = hash_ (undefined :: SHA512)
hash OpenPGP.SHA224 = hash_ (undefined :: SHA224)
hash _ = error "Unsupported HashAlgorithm in hash"
hash_ :: (Hash c d) => d -> LZ.ByteString -> (BS.ByteString, String)
hash_ d bs = (hbs, map toUpper $ pad $ hexString $ BS.unpack hbs)
where
hbs = Serialize.encode $ hashFunc d bs
pad s = replicate (len length s) '0' ++ s
len = (outputLength `for` d) `div` 8
emsa_pkcs1_v1_5_hash_padding :: OpenPGP.HashAlgorithm -> BS.ByteString
emsa_pkcs1_v1_5_hash_padding OpenPGP.MD5 = BS.pack [0x30, 0x20, 0x30, 0x0c, 0x06, 0x08, 0x2a, 0x86, 0x48, 0x86, 0xf7, 0x0d, 0x02, 0x05, 0x05, 0x00, 0x04, 0x10]
emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA1 = BS.pack [0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2b, 0x0e, 0x03, 0x02, 0x1a, 0x05, 0x00, 0x04, 0x14]
emsa_pkcs1_v1_5_hash_padding OpenPGP.RIPEMD160 = BS.pack [0x30, 0x21, 0x30, 0x09, 0x06, 0x05, 0x2B, 0x24, 0x03, 0x02, 0x01, 0x05, 0x00, 0x04, 0x14]
emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA256 = BS.pack [0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x01, 0x05, 0x00, 0x04, 0x20]
emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA384 = BS.pack [0x30, 0x41, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x02, 0x05, 0x00, 0x04, 0x30]
emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA512 = BS.pack [0x30, 0x51, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x03, 0x05, 0x00, 0x04, 0x40]
emsa_pkcs1_v1_5_hash_padding OpenPGP.SHA224 = BS.pack [0x30, 0x31, 0x30, 0x0d, 0x06, 0x09, 0x60, 0x86, 0x48, 0x01, 0x65, 0x03, 0x04, 0x02, 0x04, 0x05, 0x00, 0x04, 0x1C]
emsa_pkcs1_v1_5_hash_padding _ =
error "Unsupported HashAlgorithm in emsa_pkcs1_v1_5_hash_padding."
blockBytes :: (BlockCipher k, Num n) => k -> n
blockBytes k = fromIntegral $ blockSizeBytes `for` k
pgpCFBPrefix :: (BlockCipher k, CryptoRandomGen g) => k -> g -> (LZ.ByteString, g)
pgpCFBPrefix k g =
(toLazyBS $ str `BS.append` BS.reverse (BS.take 2 $ BS.reverse str), g')
where
Right (str,g') = genBytes (blockSizeBytes `for` k) g
pgpCFB :: (BlockCipher k, CryptoRandomGen g) => k -> (LZ.ByteString -> LZ.ByteString -> LZ.ByteString) -> Encrypt g
pgpCFB k sufGen bs g =
(simpleCFB k zeroIV (LZ.concat [p, bs, sufGen p bs]), g')
where
(p,g') = pgpCFBPrefix k g
simpleCFB :: (BlockCipher k) => k -> IV k -> LZ.ByteString -> LZ.ByteString
simpleCFB k iv = padThenUnpad k (fst . cfb k iv)
pgpUnCFB :: (BlockCipher k) => k -> Decrypt
pgpUnCFB k False s = LZ.splitAt (2 + blockBytes k) $ simpleUnCFB k zeroIV s
pgpUnCFB k True s = (simpleUnCFB k zeroIV prefix, simpleUnCFB k iv content)
where
Just iv = sDecode $ toStrictBS $ LZ.drop 2 prefix
(prefix, content) = LZ.splitAt (2 + blockBytes k) s
simpleUnCFB :: (BlockCipher k) => k -> IV k -> LZ.ByteString -> LZ.ByteString
simpleUnCFB k iv = padThenUnpad k (fst . unCfb k iv)
padThenUnpad :: (BlockCipher k) => k -> (LZ.ByteString -> LZ.ByteString) -> LZ.ByteString -> LZ.ByteString
padThenUnpad k f s = dropPadEnd (f padded)
where
dropPadEnd s = LZ.take (LZ.length s padAmount) s
padded = s `LZ.append` LZ.replicate padAmount 0
padAmount = blockBytes k (LZ.length s `mod` blockBytes k)
addBitLen :: LZ.ByteString -> LZ.ByteString
addBitLen bytes = encode (bitLen bytes :: Word16) `LZ.append` bytes
where
bitLen bytes = (fromIntegral (LZ.length bytes) 1) * 8 + sigBit bytes
sigBit bytes = fst $ until ((==0) . snd)
(first (+1) . second (`shiftR` 1)) (0,LZ.index bytes 0)
rsaDecrypt :: RSA.PrivateKey -> BS.ByteString -> Maybe BS.ByteString
rsaDecrypt pk = hush . RSA.decrypt pk . BS.drop 2
rsaEncrypt :: (CryptoRandomGen g) => RSA.PublicKey -> BS.ByteString -> StateT g (Either GenError) BS.ByteString
rsaEncrypt pk bs = StateT (\g ->
case RSA.encrypt g pk bs of
(Left (RSA.RandomGenFailure e)) -> Left e
(Left e) -> Left (GenErrorOther $ show e)
(Right v) -> Right v
)
integerBytesize :: Integer -> Int
integerBytesize i = fromIntegral $ LZ.length (encode (OpenPGP.MPI i)) 2
keyParam :: Char -> OpenPGP.Packet -> Integer
keyParam c k = fromJustMPI $ lookup c (OpenPGP.key k)
keyAlgorithmIs :: OpenPGP.KeyAlgorithm -> OpenPGP.Packet -> Bool
keyAlgorithmIs algo p = OpenPGP.key_algorithm p == algo
secretKeys :: OpenPGP.Message -> ([(String, RSA.PrivateKey)], [(String, DSA.PrivateKey)])
secretKeys (OpenPGP.Message keys) =
(
map (fingerprint &&& privateRSAkey) rsa,
map (fingerprint &&& privateDSAkey) dsa
)
where
dsa = secrets OpenPGP.DSA
rsa = secrets OpenPGP.RSA
secrets algo = filter (swing all [isSecretKey, keyAlgorithmIs algo]) keys
privateRSAkey :: OpenPGP.Packet -> RSA.PrivateKey
privateRSAkey k =
RSA.PrivateKey pubkey d q p
(d `mod` (q1))
(d `mod` (p1))
(keyParam 'u' k)
where
d = keyParam 'd' k
p = keyParam 'p' k
q = keyParam 'q' k
pubkey = rsaKey k
rsaKey :: OpenPGP.Packet -> RSA.PublicKey
rsaKey k =
RSA.PublicKey (integerBytesize n) n (keyParam 'e' k)
where
n = keyParam 'n' k
privateDSAkey :: OpenPGP.Packet -> DSA.PrivateKey
privateDSAkey k = DSA.PrivateKey
(keyParam 'p' k, keyParam 'g' k, keyParam 'q' k) (keyParam 'x' k)
dsaKey :: OpenPGP.Packet -> DSA.PublicKey
dsaKey k = DSA.PublicKey
(keyParam 'p' k, keyParam 'g' k, keyParam 'q' k) (keyParam 'y' k)
fingerprint :: OpenPGP.Packet -> String
fingerprint p
| OpenPGP.version p == 4 = snd $ hash OpenPGP.SHA1 material
| OpenPGP.version p `elem` [2, 3] = snd $ hash OpenPGP.MD5 material
| otherwise = error "Unsupported Packet version or type in fingerprint"
where
material = LZ.concat $ OpenPGP.fingerprint_material p
verify ::
OpenPGP.Message
-> OpenPGP.SignatureOver
-> OpenPGP.SignatureOver
verify keys over =
over {OpenPGP.signatures_over = mapMaybe (uncurry $ verifyOne keys) sigs}
where
sigs = map (\s -> (s, toStrictBS $ encode over `LZ.append` OpenPGP.trailer s))
(OpenPGP.signatures_over over)
verifyOne :: OpenPGP.Message -> OpenPGP.Packet -> BS.ByteString -> Maybe OpenPGP.Packet
verifyOne keys sig over = fmap (const sig) $ maybeKey >>=
case OpenPGP.key_algorithm sig of
OpenPGP.DSA -> dsaVerify
alg | alg `elem` [OpenPGP.RSA,OpenPGP.RSA_S] -> rsaVerify
| otherwise -> const Nothing
where
dsaVerify k = let k' = dsaKey k in
hush $ DSA.verify dsaSig (dsaTruncate k' . bhash) k' over
rsaVerify k = hush $ RSA.verify bhash padding (rsaKey k) over rsaSig
[rsaSig] = map (toStrictBS . LZ.drop 2 . encode) (OpenPGP.signature sig)
dsaSig = let [OpenPGP.MPI r, OpenPGP.MPI s] = OpenPGP.signature sig in
(r, s)
dsaTruncate (DSA.PublicKey (_,_,q) _) = BS.take (integerBytesize q)
bhash = fst . hash hash_algo . toLazyBS
padding = emsa_pkcs1_v1_5_hash_padding hash_algo
hash_algo = OpenPGP.hash_algorithm sig
maybeKey = OpenPGP.signature_issuer sig >>= find_key keys
sign :: (CryptoRandomGen g) =>
OpenPGP.Message
-> OpenPGP.SignatureOver
-> OpenPGP.HashAlgorithm
-> String
-> Integer
-> g
-> (OpenPGP.SignatureOver, g)
sign keys over hsh keyid timestamp g = (over {OpenPGP.signatures_over = [sig]}, g')
where
(final, g') = case OpenPGP.key_algorithm sig of
OpenPGP.DSA -> ([dsaR, dsaS], dsaG)
kalgo | kalgo `elem` [OpenPGP.RSA,OpenPGP.RSA_S] -> ([toNum rsaFinal], g)
| otherwise ->
error ("Unsupported key algorithm " ++ show kalgo ++ "in sign")
Right ((dsaR,dsaS),dsaG) = let k' = privateDSAkey k in
DSA.sign g (dsaTruncate k' . bhash) k' dta
Right rsaFinal = RSA.sign bhash padding (privateRSAkey k) dta
dsaTruncate (DSA.PrivateKey (_,_,q) _) = BS.take (integerBytesize q)
dta = toStrictBS $ encode over `LZ.append` OpenPGP.trailer sig
sig = findSigOrDefault (listToMaybe $ OpenPGP.signatures_over over)
padding = emsa_pkcs1_v1_5_hash_padding hsh
bhash = fst . hash hsh . toLazyBS
toNum = BS.foldl (\a b -> a `shiftL` 8 .|. fromIntegral b) 0
Just k = find_key keys keyid
findSigOrDefault (Just s) = OpenPGP.signaturePacket
(OpenPGP.version s)
(OpenPGP.signature_type s)
(OpenPGP.key_algorithm k)
hsh
(OpenPGP.hashed_subpackets s)
(OpenPGP.unhashed_subpackets s)
(OpenPGP.hash_head s)
(map OpenPGP.MPI final)
findSigOrDefault Nothing = OpenPGP.signaturePacket
4
defaultStype
(OpenPGP.key_algorithm k)
hsh
([
OpenPGP.SignatureCreationTimePacket $ fromIntegral timestamp,
OpenPGP.IssuerPacket $ fingerprint k
] ++ (case over of
OpenPGP.KeySignature {} -> [OpenPGP.KeyFlagsPacket {
OpenPGP.certify_keys = True,
OpenPGP.sign_data = True,
OpenPGP.encrypt_communication = False,
OpenPGP.encrypt_storage = False,
OpenPGP.split_key = False,
OpenPGP.authentication = False,
OpenPGP.group_key = False
}]
_ -> []
))
[]
0
(map OpenPGP.MPI final)
defaultStype = case over of
OpenPGP.DataSignature ld _
| OpenPGP.format ld == 'b' -> 0x00
| otherwise -> 0x01
OpenPGP.KeySignature {} -> 0x1F
OpenPGP.SubkeySignature {} -> 0x18
OpenPGP.CertificationSignature {} -> 0x13
encrypt :: (CryptoRandomGen g) =>
[BS.ByteString]
-> OpenPGP.Message
-> OpenPGP.SymmetricAlgorithm
-> OpenPGP.Message
-> g
-> Either GenError (OpenPGP.Message, g)
encrypt pass (OpenPGP.Message keys) algo msg = runStateT $ do
(sk, encP) <- sessionFor algo msg
OpenPGP.Message . (++[encP]) <$> liftA2 (++)
(mapM (encryptSessionKeyAsymmetric sk) (filter isKey keys))
(mapM (encryptSessionKeySymmetric (LZ.take (LZ.length sk 2) sk) algo) pass)
encryptSessionKeyAsymmetric :: (CryptoRandomGen g) => LZ.ByteString -> OpenPGP.Packet -> StateT g (Either GenError) OpenPGP.Packet
encryptSessionKeyAsymmetric sk pk = OpenPGP.AsymmetricSessionKeyPacket 3
(fingerprint pk)
(OpenPGP.key_algorithm pk)
. addBitLen <$> encd (OpenPGP.key_algorithm pk)
where
encd OpenPGP.RSA = toLazyBS <$> rsaEncrypt (rsaKey pk) (toStrictBS sk)
encd _ = lift $ Left $ GenErrorOther $ "Unsupported PublicKey: " ++ show pk
encryptSessionKeySymmetric :: (CryptoRandomGen g) => LZ.ByteString -> OpenPGP.SymmetricAlgorithm -> BS.ByteString -> StateT g (Either GenError) OpenPGP.Packet
encryptSessionKeySymmetric sk salgo pass = do
s2k <- s2k
return $ OpenPGP.SymmetricSessionKeyPacket 4 salgo s2k
(string2sencrypt salgo s2k (toLazyBS pass) sk)
where
halgo = s2kHashAlgorithmFor salgo
s2k = OpenPGP.IteratedSaltedS2K halgo . decode . toLazyBS <$>
(StateT $ genBytes 8) <*> pure 65536
s2kHashAlgorithmFor :: OpenPGP.SymmetricAlgorithm -> OpenPGP.HashAlgorithm
s2kHashAlgorithmFor OpenPGP.AES128 = s2kHashAlgorithm `for` (undefined :: AES128)
s2kHashAlgorithmFor OpenPGP.AES192 = s2kHashAlgorithm `for` (undefined :: AES192)
s2kHashAlgorithmFor OpenPGP.AES256 = s2kHashAlgorithm `for` (undefined :: AES256)
s2kHashAlgorithmFor OpenPGP.Blowfish = s2kHashAlgorithm `for` (undefined :: Blowfish128)
s2kHashAlgorithmFor algo = error $ "Unsupported SymmetricAlgorithm " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.s2kHashAlgorithmFor"
s2kHashAlgorithm :: (BlockCipher k) => Tagged k OpenPGP.HashAlgorithm
s2kHashAlgorithm = v
where
v = Tagged $ case () of
_ | ksize <= 160 -> OpenPGP.SHA1
| ksize <= 256 -> OpenPGP.SHA256
| otherwise -> OpenPGP.SHA512
ksize = keyLength `tagOfTag` v
tagOfTag :: Tagged a c -> Tagged a b -> c
tagOfTag a b = a `for` (undefined `asTaggedTypeOf` b)
sessionFor :: (CryptoRandomGen g) => OpenPGP.SymmetricAlgorithm -> OpenPGP.Message -> StateT g (Either GenError) (LZ.ByteString, OpenPGP.Packet)
sessionFor algo@OpenPGP.AES128 msg = do
sk <- StateT buildKeyGen
encP <- newSession (sk :: AES128) msg
return (sessionKeyEncode sk algo, encP)
sessionFor algo@OpenPGP.AES192 msg = do
sk <- StateT buildKeyGen
encP <- newSession (sk :: AES192) msg
return (sessionKeyEncode sk algo, encP)
sessionFor algo@OpenPGP.AES256 msg = do
sk <- StateT buildKeyGen
encP <- newSession (sk :: AES256) msg
return (sessionKeyEncode sk algo, encP)
sessionFor algo@OpenPGP.Blowfish msg = do
sk <- StateT buildKeyGen
encP <- newSession (sk :: Blowfish128) msg
return (sessionKeyEncode sk algo, encP)
sessionFor algo _ = lift $ Left $ GenErrorOther $ "Unsupported cipher: " ++ show algo
sessionKeyEncode :: (BlockCipher k) => k -> OpenPGP.SymmetricAlgorithm -> LZ.ByteString
sessionKeyEncode sk algo =
LZ.concat [encode algo, toLazyBS bs, encode $ checksum bs]
where
bs = Serialize.encode sk
newSession :: (BlockCipher k, CryptoRandomGen g, Monad m) => k -> OpenPGP.Message -> StateT g m OpenPGP.Packet
newSession sk msg = do
encd <- StateT $ return . pgpCFB sk (encode `oo` mkMDC) (encode msg)
return $ OpenPGP.EncryptedDataPacket 1 encd
mkMDC :: LZ.ByteString -> LZ.ByteString -> OpenPGP.Packet
mkMDC prefix msg = OpenPGP.ModificationDetectionCodePacket $ toLazyBS $ fst $
hash OpenPGP.SHA1 $ LZ.concat [prefix, msg, LZ.pack [0xD3, 0x14]]
checksum :: BS.ByteString -> Word16
checksum key = fromIntegral $
BS.foldl' (\x y -> x + fromIntegral y) (0::Integer) key `mod` 65536
decryptSecretKey ::
BS.ByteString
-> OpenPGP.Packet
-> Maybe OpenPGP.Packet
decryptSecretKey pass k@(OpenPGP.SecretKeyPacket {
OpenPGP.version = 4, OpenPGP.key_algorithm = kalgo,
OpenPGP.s2k = s2k, OpenPGP.symmetric_algorithm = salgo,
OpenPGP.key = existing, OpenPGP.encrypted_data = encd
}) | chkF material == toStrictBS chk =
fmap (\m -> k {
OpenPGP.s2k_useage = 0,
OpenPGP.symmetric_algorithm = OpenPGP.Unencrypted,
OpenPGP.encrypted_data = LZ.empty,
OpenPGP.key = m
}) parseMaterial
| otherwise = Nothing
where
parseMaterial = maybeGet
(foldM (\m f -> do {mpi <- get; return $ (f,mpi):m}) existing
(OpenPGP.secret_key_fields kalgo)) material
(material, chk) = LZ.splitAt (LZ.length decd chkSize) decd
(chkSize, chkF)
| OpenPGP.s2k_useage k == 254 = (20, fst . hash OpenPGP.SHA1)
| otherwise = (2, Serialize.encode . checksum . toStrictBS)
decd = string2sdecrypt salgo s2k (toLazyBS pass) (EncipheredWithIV encd)
decryptSecretKey _ _ = Nothing
decryptAsymmetric ::
OpenPGP.Message
-> OpenPGP.Message
-> Maybe OpenPGP.Message
decryptAsymmetric keys msg@(OpenPGP.Message pkts) = do
(_, d) <- getAsymmetricSessionKey keys msg
pkt <- find isEncryptedData pkts
decryptPacket d pkt
decryptSymmetric ::
[BS.ByteString]
-> OpenPGP.Message
-> Maybe OpenPGP.Message
decryptSymmetric pass msg@(OpenPGP.Message pkts) = do
let ds = map snd $ getSymmetricSessionKey pass msg
pkt <- find isEncryptedData pkts
listToMaybe $ mapMaybe (`decryptPacket` pkt) ds
decryptPacket :: Decrypt -> OpenPGP.Packet -> Maybe OpenPGP.Message
decryptPacket d (OpenPGP.EncryptedDataPacket {
OpenPGP.version = 1,
OpenPGP.encrypted_data = encd
}) | Just (mkMDC prefix msg) == maybeDecode mdc = maybeDecode msg
| otherwise = Nothing
where
(msg,mdc) = LZ.splitAt (LZ.length content 22) content
(prefix, content) = d False encd
decryptPacket d (OpenPGP.EncryptedDataPacket {
OpenPGP.version = 0,
OpenPGP.encrypted_data = encd
}) = maybeDecode (snd $ d True encd)
decryptPacket _ _ = error "Can only decrypt EncryptedDataPacket in Data.OpenPGP.CryptoAPI.decryptPacket"
getSymmetricSessionKey ::
[BS.ByteString]
-> OpenPGP.Message
-> [(OpenPGP.SymmetricAlgorithm, Decrypt)]
getSymmetricSessionKey pass (OpenPGP.Message ps) =
concatMap (\OpenPGP.SymmetricSessionKeyPacket {
OpenPGP.s2k = s2k, OpenPGP.symmetric_algorithm = algo,
OpenPGP.encrypted_data = encd
} ->
if LZ.null encd then
map ((,) algo . string2decrypt algo s2k) pass'
else
mapMaybe (\p -> decodeSess $ string2sdecrypt algo s2k p (EncipheredZeroIV encd)) pass'
) sessionKeys
where
decodeSess s = let (a, k) = LZ.splitAt 1 s in
(,) (decode a) <$> decodeSymKey (decode a) (toStrictBS k)
sessionKeys = filter isSymmetricSessionKey ps
pass' = map toLazyBS pass
getAsymmetricSessionKey ::
OpenPGP.Message
-> OpenPGP.Message
-> Maybe (OpenPGP.SymmetricAlgorithm, Decrypt)
getAsymmetricSessionKey keys (OpenPGP.Message ps) =
listToMaybe $ mapMaybe decodeSessionKey $ catMaybes $
concatMap (\(sk,ks) ->
map ($ toStrictBS $ OpenPGP.encrypted_data sk) ks
) toTry
where
toTry = map (id &&& lookupKey) sessionKeys
lookupKey (OpenPGP.AsymmetricSessionKeyPacket {
OpenPGP.key_algorithm = OpenPGP.RSA,
OpenPGP.key_id = key_id
}) | all (=='0') key_id = map (rsaDecrypt . snd) rsa
| otherwise = map (rsaDecrypt . snd) $
filter (keyIdMatch key_id . fst) rsa
lookupKey _ = []
sessionKeys = filter isAsymmetricSessionKey ps
(rsa, _) = secretKeys keys
decodeSessionKey :: BS.ByteString -> Maybe (OpenPGP.SymmetricAlgorithm, Decrypt)
decodeSessionKey sk
| checksum key == (decode (toLazyBS chk) :: Word16) = do
algo <- maybeDecode (toLazyBS algoByte)
decrypt <- decodeSymKey algo key
return (algo, decrypt)
| otherwise = Nothing
where
(key, chk) = BS.splitAt (BS.length rest 2) rest
(algoByte, rest) = BS.splitAt 1 sk
decodeSymKey :: OpenPGP.SymmetricAlgorithm -> BS.ByteString -> Maybe Decrypt
decodeSymKey OpenPGP.AES128 k = pgpUnCFB <$> (`asTypeOf` (undefined :: AES128)) <$> sDecode k
decodeSymKey OpenPGP.AES192 k = pgpUnCFB <$> (`asTypeOf` (undefined :: AES192)) <$> sDecode k
decodeSymKey OpenPGP.AES256 k = pgpUnCFB <$> (`asTypeOf` (undefined :: AES256)) <$> sDecode k
decodeSymKey OpenPGP.Blowfish k = pgpUnCFB <$> (`asTypeOf` (undefined :: Blowfish128)) <$> sDecode k
decodeSymKey _ _ = Nothing
string2sencrypt :: OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> LZ.ByteString -> LZ.ByteString
string2sencrypt OpenPGP.AES128 s2k s = simpleCFB (string2key s2k s :: AES128) zeroIV
string2sencrypt OpenPGP.AES192 s2k s = simpleCFB (string2key s2k s :: AES192) zeroIV
string2sencrypt OpenPGP.AES256 s2k s = simpleCFB (string2key s2k s :: AES256) zeroIV
string2sencrypt OpenPGP.Blowfish s2k s = simpleCFB (string2key s2k s :: Blowfish128) zeroIV
string2sencrypt algo _ _ = error $ "Unsupported symmetric algorithm : " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.string2sencrypt"
string2decrypt :: OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> Decrypt
string2decrypt OpenPGP.AES128 s2k s = pgpUnCFB (string2key s2k s :: AES128)
string2decrypt OpenPGP.AES192 s2k s = pgpUnCFB (string2key s2k s :: AES192)
string2decrypt OpenPGP.AES256 s2k s = pgpUnCFB (string2key s2k s :: AES256)
string2decrypt OpenPGP.Blowfish s2k s = pgpUnCFB (string2key s2k s :: Blowfish128)
string2decrypt algo _ _ = error $ "Unsupported symmetric algorithm : " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.string2decrypt"
string2sdecrypt :: OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> Enciphered -> LZ.ByteString
string2sdecrypt OpenPGP.AES128 s2k s = withIV $ simpleUnCFB (string2key s2k s :: AES128)
string2sdecrypt OpenPGP.AES192 s2k s = withIV $ simpleUnCFB (string2key s2k s :: AES192)
string2sdecrypt OpenPGP.AES256 s2k s = withIV $ simpleUnCFB (string2key s2k s :: AES256)
string2sdecrypt OpenPGP.Blowfish s2k s = withIV $ simpleUnCFB (string2key s2k s :: Blowfish128)
string2sdecrypt algo _ _ = error $ "Unsupported symmetric algorithm : " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.string2sdecrypt"
data Enciphered = EncipheredWithIV !LZ.ByteString | EncipheredZeroIV !LZ.ByteString
withIV :: (BlockCipher k) => (IV k -> LZ.ByteString -> LZ.ByteString) -> Enciphered -> LZ.ByteString
withIV f (EncipheredWithIV s) = f iv $ LZ.drop (fromIntegral $ BS.length $ Serialize.encode iv) s
where
iv = let Right x = Serialize.decode (toStrictBS s) in x
withIV f (EncipheredZeroIV s) = f zeroIV s
string2key :: (BlockCipher k) => OpenPGP.S2K -> LZ.ByteString -> k
string2key s2k s = k
where
Just k = buildKey $ toStrictBS $
LZ.take ksize $ OpenPGP.string2key (fst `oo` hash) s2k s
ksize = fromIntegral (keyLength `for` k) `div` 8