encryptSecretKey

2 files changed, 87 insertions, 16 deletions

diff --git a/Data/OpenPGP/Util.hs b/Data/OpenPGP/Util.hs
index 8a1a449..19d98ec 100644
--- a/Data/OpenPGP/Util.hs
+++ b/Data/OpenPGP/Util.hs
@@ -1,6 +1,7 @@
 module Data.OpenPGP.Util 
     ( fingerprint
     , decryptSecretKey
+    , encryptSecretKey
     , verify
     , pgpSign
     , GenerateKeyParams(..)
diff --git a/Data/OpenPGP/Util/DecryptSecretKey.hs b/Data/OpenPGP/Util/DecryptSecretKey.hs
index 6bfc2af..11627d5 100644
--- a/Data/OpenPGP/Util/DecryptSecretKey.hs
+++ b/Data/OpenPGP/Util/DecryptSecretKey.hs
@@ -1,12 +1,15 @@
+{-# 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)
+import Data.Binary (get,Binary,Get,encode,put)
 #if MIN_VERSION_binary(0,6,4)
 import Data.Binary.Get (runGetOrFail)
 #else
@@ -14,6 +17,8 @@ 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
@@ -24,6 +29,8 @@ 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)
@@ -70,14 +77,14 @@ decryptSecretKey pass k@(OpenPGP.SecretKeyPacket {
         | 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 = string2sdecrypt salgo s2k (toLazyBS pass) (EncipheredWithIV encd)
-
-    checksum :: BS.ByteString -> Word16
-    checksum key = fromIntegral $
-        BS.foldl' (\x y -> x + fromIntegral y) (0::Integer) key `mod` 65536
+    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
@@ -94,20 +101,45 @@ maybeGet g bs = unsafePerformIO $
 
 
 
-string2sdecrypt :: OpenPGP.SymmetricAlgorithm -> OpenPGP.S2K -> LZ.ByteString -> Enciphered -> LZ.ByteString
-string2sdecrypt OpenPGP.AES128 s2k s = withIV $ simpleUnCFB (string2key s2k s :: Vincent.AES128)
-string2sdecrypt OpenPGP.AES192 s2k s = withIV $ simpleUnCFB (string2key s2k s :: Vincent.AES192)
-string2sdecrypt OpenPGP.AES256 s2k s = withIV $ simpleUnCFB (string2key s2k s :: Vincent.AES256)
-string2sdecrypt OpenPGP.Blowfish s2k s = withIV $ simpleUnCFB (string2key s2k s :: Vincent.Blowfish128)
-string2sdecrypt OpenPGP.CAST5 s2k s = withIV $ simpleUnCFB (string2key s2k s :: ThomasToVincent CAST5_128)
-string2sdecrypt algo _ _ = error $ "Unsupported symmetric algorithm : " ++ show algo ++ " in Data.OpenPGP.CryptoAPI.string2sdecrypt"
+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
-    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)
@@ -124,3 +156,41 @@ string2key s2k s = cipher
                 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