{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE CPP #-} {-# LANGUAGE Rank2Types #-} module Data.OpenPGP.Util.DecryptSecretKey where import qualified Data.OpenPGP as OpenPGP import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LZ import Data.Word (Word16) import Data.Maybe import Control.Monad (foldM) import Data.Binary (get,Binary,Get,encode,put) #if MIN_VERSION_binary(0,6,4) import Data.Binary.Get (runGetOrFail) #else import Control.Exception as Exception (handle,ErrorCall(..)) import System.IO.Unsafe import Data.Binary.Get (runGet) #endif import Control.Exception as Exception (IOException(..),catch) import Data.Binary.Put (runPut) import Control.Applicative ( (<$>) ) import Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Cipher.AES as Vincent import qualified Crypto.Cipher.Blowfish as Vincent import qualified Crypto.Cipher.Types as Vincent import qualified Data.Byteable as Vincent import qualified Crypto.Random as Vincent import Crypto.Cipher.Cast5 (CAST5_128) import Crypto.Cipher.ThomasToVincent import Data.OpenPGP.Util.Base (toStrictBS,toLazyBS,hashBySymbol) data Enciphered = EncipheredWithIV !LZ.ByteString -- initial vector is appended to front of ByteString | EncipheredZeroIV !LZ.ByteString -- initial vector is zero, ByteString contains only the block withIV :: (Vincent.BlockCipher k) => (Vincent.IV k -> LZ.ByteString -> LZ.ByteString) -> Enciphered -> LZ.ByteString withIV f (EncipheredWithIV s) = f iv bs where Just iv = Vincent.makeIV (toStrictBS ivbs) (ivbs,bs) = LZ.splitAt (fromIntegral ivlen) s ivlen = Vincent.byteableLength z z = Vincent.nullIV _ = Vincent.constEqBytes z iv withIV f (EncipheredZeroIV s) = f Vincent.nullIV s decryptSecretKey :: BS.ByteString -- ^ Passphrase -> OpenPGP.Packet -- ^ Encrypted SecretKeyPacket -> Maybe OpenPGP.Packet -- ^ Decrypted SecretKeyPacket decryptSecretKey _ k@(OpenPGP.SecretKeyPacket { OpenPGP.symmetric_algorithm = OpenPGP.Unencrypted }) = Just k 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, SHA1.hash . toStrictBS) | otherwise = (2, toStrictBS . encode . checksum . toStrictBS) -- Words16s are written as 2 bytes in big-endian (network) order decd = withS2K simpleUnCFB salgo s2k (toLazyBS pass) (EncipheredWithIV encd) decryptSecretKey _ _ = Nothing checksum :: BS.ByteString -> Word16 checksum key = fromIntegral $ BS.foldl' (\x y -> x + fromIntegral y) (0::Integer) key `mod` 65536 #if MIN_VERSION_binary(0,6,4) maybeGet :: (Binary a) => Get a -> LZ.ByteString -> Maybe a maybeGet g bs = (\(_,_,x) -> x) <$> hush (runGetOrFail g bs) where hush :: Either a b -> Maybe b hush (Left _) = Nothing hush (Right x) = Just x #else maybeGet :: (Binary a) => Get a -> LZ.ByteString -> Maybe a maybeGet g bs = unsafePerformIO $ handle (\(ErrorCall _)-> return Nothing) $ return . Just $ runGet g bs #endif withS2K :: (forall k. (Vincent.BlockCipher k) => k -> Vincent.IV k -> LZ.ByteString -> LZ.ByteString) -> OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> Enciphered -> LZ.ByteString withS2K codec OpenPGP.AES128 s2k s = withIV $ codec (string2key s2k s :: Vincent.AES128) withS2K codec OpenPGP.AES192 s2k s = withIV $ codec (string2key s2k s :: Vincent.AES192) withS2K codec OpenPGP.AES256 s2k s = withIV $ codec (string2key s2k s :: Vincent.AES256) withS2K codec OpenPGP.Blowfish s2k s = withIV $ codec (string2key s2k s :: Vincent.Blowfish128) withS2K codec OpenPGP.CAST5 s2k s = withIV $ codec (string2key s2k s :: ThomasToVincent CAST5_128) withS2K codec algo _ _ = error $ "Unsupported symmetric algorithm : " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.withS2K" withS2K' :: OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> (forall b. Vincent.BlockCipher b => b -> x) -> x withS2K' OpenPGP.AES128 s2k s f = f (string2key s2k s :: Vincent.AES128) withS2K' OpenPGP.AES192 s2k s f = f (string2key s2k s :: Vincent.AES192) withS2K' OpenPGP.AES256 s2k s f = f (string2key s2k s :: Vincent.AES256) withS2K' OpenPGP.Blowfish s2k s f = f (string2key s2k s :: Vincent.Blowfish128) withS2K' OpenPGP.CAST5 s2k s f = f (string2key s2k s :: ThomasToVincent CAST5_128) -- decryption codec for withS2K simpleUnCFB :: (Vincent.BlockCipher k) => k -> Vincent.IV k -> LZ.ByteString -> LZ.ByteString simpleUnCFB k iv = padThenUnpad k (toLazyBS . Vincent.cfbDecrypt k iv . toStrictBS) simpleCFB :: (Vincent.BlockCipher k, Vincent.CPRG g) => g -> k -> LZ.ByteString -> (LZ.ByteString, g) simpleCFB g k bs = ( padThenUnpad k (LZ.fromChunks . (ivbs:) . (:[]) . Vincent.cfbEncrypt k iv . toStrictBS) bs , g' ) where Just iv = Vincent.makeIV ivbs (ivbs,g') = Vincent.cprgGenerate ivlen g ivlen = Vincent.byteableLength z z = Vincent.nullIV _ = Vincent.constEqBytes z iv -- Apply a function f to a zero-padded bytestring s to a multiple -- of the blocksize for cyper k. -- Then drop the same number of bytes from the result of f. padThenUnpad :: (Vincent.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 = blksize - (LZ.length s `mod` blksize) blksize = fromIntegral $ Vincent.blockSize k string2key :: (Vincent.BlockCipher k) => OpenPGP.S2K -> LZ.ByteString -> k string2key s2k s = cipher where cipher = Vincent.cipherInit k Right k = Vincent.makeKey $ toStrictBS $ LZ.take ksize $ OpenPGP.string2key hashBySymbol s2k s ksize = case Vincent.cipherKeySize cipher of Vincent.KeySizeFixed n -> fromIntegral n Vincent.KeySizeEnum xs -> error $ "Unknown key size in string2key" Vincent.KeySizeRange min max -> error $ "Unknown key size range in string2key" catchIO_ :: IO a -> IO a -> IO a catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) encryptSecretKey :: BS.ByteString -> OpenPGP.S2K -> OpenPGP.SymmetricAlgorithm -> OpenPGP.Packet -> IO (Maybe OpenPGP.Packet) encryptSecretKey passphrase s2k salgo plain = do flip catchIO_ (return Nothing) $ do g <- fmap Vincent.cprgCreate $ Vincent.createEntropyPool let _ = g :: Vincent.SystemRNG return $ Just plain { OpenPGP.key = [ x | x <- OpenPGP.key plain , fst x `elem` OpenPGP.public_key_fields (OpenPGP.key_algorithm plain) ] , OpenPGP.symmetric_algorithm = salgo , OpenPGP.s2k = s2k , OpenPGP.s2k_useage = s2k_usage_octet , OpenPGP.encrypted_data = encd g } where material = runPut $ mapM_ put $ do f <- OpenPGP.secret_key_fields (OpenPGP.key_algorithm plain) maybeToList $ lookup f (OpenPGP.key plain) chk = LZ.fromChunks [ chkF material ] decd = LZ.append material chk encd g = fst $ withS2K' salgo s2k (toLazyBS passphrase) (simpleCFB g) decd -- If the string-to-key usage octet is zero or 255, then a two-octet -- checksum of the plaintext of the algorithm-specific portion (sum -- of all octets, mod 65536). If the string-to-key usage octet was -- 254, then a 20-octet SHA-1 hash of the plaintext of the -- algorithm-specific portion. This checksum or hash is encrypted -- together with the algorithm-specific fields (if string-to-key -- usage octet is not zero). Note that for all other values, a -- two-octet checksum is required. s2k_usage_octet = 255 -- chkSize = 2 chkF = toStrictBS . encode . checksum . toStrictBS -- k = string2key s2k passphrase -- OpenPGP.string2key hashBySymbol s2k passphrase