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 (cfb,unCfb,hash,sign,verify,encode) import Data.Tagged (untag, asTaggedTypeOf, Tagged(..)) import Crypto.Modes (cfb, unCfb, zeroIV) import Crypto.Types (IV) 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 -- | An encryption routine type Encrypt g = (LZ.ByteString -> g -> (LZ.ByteString, g)) -- | A decryption routine, Bool=True to do resynchronization type Decrypt = (Bool -> LZ.ByteString -> (LZ.ByteString, LZ.ByteString)) -- Start differently-formatted section -- | This should be in Crypto.Classes and is based on buildKeyIO 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 -- End differently-formatted section 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 -- http://tools.ietf.org/html/rfc3447#page-43 -- http://tools.ietf.org/html/rfc4880#section-5.2.2 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) -- Drops 2 because the value is an MPI 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 = -- Invert p and q because u is pinv not qinv RSA.PrivateKey pubkey d q p (d `mod` (q-1)) (d `mod` (p-1)) (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) -- | Generate a key fingerprint from a PublicKeyPacket or SecretKeyPacket -- 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 a message signature verify :: OpenPGP.Message -- ^ Keys that may have made the signature -> OpenPGP.SignatureOver -- ^ Signatures to verify -> OpenPGP.SignatureOver -- ^ Will only contain signatures that passed 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 -- | Make a signature -- -- In order to set more options on a signature, pass in a signature packet. sign :: (CryptoRandomGen g) => OpenPGP.Message -- ^ SecretKeys, one of which will be used -> OpenPGP.SignatureOver -- ^ Data to sign, and optional signature packet -> OpenPGP.HashAlgorithm -- ^ HashAlgorithm to use in signature -> String -- ^ KeyID of key to choose -> Integer -- ^ Timestamp for signature (unless sig supplied) -> g -- ^ Random number generator -> (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 -- Either a SignaturePacket was found, or we need to make one findSigOrDefault (Just s) = OpenPGP.signaturePacket (OpenPGP.version s) (OpenPGP.signature_type s) (OpenPGP.key_algorithm k) -- force to algo of key hsh -- force hash algorithm (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) -- force to algo of key hsh ([ -- Do we really need to pass in timestamp just for the default? 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 -- TODO (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] -- ^ Passphrases, all of which will be used -> OpenPGP.Message -- ^ PublicKeys, all of which will be used -> OpenPGP.SymmetricAlgorithm -- ^ Cipher to use -> OpenPGP.Message -- ^ The 'OpenPGP.Message' to encrypt -> g -- ^ Random number generator -> 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 -- ^ Passphrase -> OpenPGP.Packet -- ^ Encrypted SecretKeyPacket -> Maybe OpenPGP.Packet -- ^ Decrypted SecretKeyPacket 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 -- | Decrypt an OpenPGP message using secret key decryptAsymmetric :: OpenPGP.Message -- ^ SecretKeys, one of which will be used -> OpenPGP.Message -- ^ A 'OpenPGP.Message' containing AsymmetricSessionKey and EncryptedData -> Maybe OpenPGP.Message decryptAsymmetric keys msg@(OpenPGP.Message pkts) = do (_, d) <- getAsymmetricSessionKey keys msg pkt <- find isEncryptedData pkts decryptPacket d pkt -- | Decrypt an OpenPGP message using passphrase decryptSymmetric :: [BS.ByteString] -- ^ Passphrases, one of which will be used -> OpenPGP.Message -- ^ A 'OpenPGP.Message' containing SymetricSessionKey and EncryptedData -> 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 -- | Decrypt a single packet, given the decryptor 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] -- ^ Passphrases, one of which will be used -> OpenPGP.Message -- ^ An OpenPGP Message containing SymmetricSessionKey -> [(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 -- | Decrypt an asymmetrically encrypted symmetric session key getAsymmetricSessionKey :: OpenPGP.Message -- ^ SecretKeys, one of which will be used -> OpenPGP.Message -- ^ An OpenPGP Message containing AssymetricSessionKey -> 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