Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Merge pull request #4 from mvv/evp-refactoring

EVP refactoring
  • Loading branch information...
commit e9ed30afae7c151e828990aef2a556e17f43a98f 2 parents 0d599fb + b2c35c8
@phonohawk phonohawk authored
View
1  HsOpenSSL.cabal
@@ -87,6 +87,7 @@ Library
OpenSSL.Stack
OpenSSL.Utils
OpenSSL.X509.Name
+ OpenSSL.EVP.Internal
OpenSSL.DH.Internal
Extensions:
ForeignFunctionInterface, EmptyDataDecls, MagicHash,
View
4 OpenSSL/DH.hsc
@@ -17,7 +17,11 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString.Internal as BS
import Control.Applicative ((<$>))
import Foreign.Ptr (Ptr, nullPtr)
+#if __GLASGOW_HASKELL__ >= 703
+import Foreign.C.Types (CInt(..))
+#else
import Foreign.C.Types (CInt)
+#endif
import Foreign.Marshal.Alloc (alloca)
import OpenSSL.BN
import OpenSSL.DH.Internal
View
129 OpenSSL/EVP/Cipher.hsc
@@ -8,24 +8,11 @@
module OpenSSL.EVP.Cipher
( Cipher
- , EVP_CIPHER -- private
- , withCipherPtr -- private
-
, getCipherByName
, getCipherNames
- , cipherIvLength -- private
-
- , CipherCtx -- private
- , EVP_CIPHER_CTX -- private
- , newCtx -- private
- , withCipherCtxPtr -- private
-
, CryptoMode(..)
- , cipherStrictly -- private
- , cipherLazily -- private
-
, cipher
, cipherBS
, cipherLBS
@@ -33,39 +20,18 @@ module OpenSSL.EVP.Cipher
)
where
-import Control.Exception(bracket_)
-import Control.Monad
-import Data.ByteString.Internal (createAndTrim)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
-import qualified Data.ByteString.Lazy.Internal as L8Internal
import Foreign
import Foreign.C
import OpenSSL.Objects
import OpenSSL.Utils
-import System.IO.Unsafe
-
-
-{- EVP_CIPHER ---------------------------------------------------------------- -}
-
--- |@Cipher@ is an opaque object that represents an algorithm of
--- symmetric cipher.
-newtype Cipher = Cipher (Ptr EVP_CIPHER)
-data EVP_CIPHER
-
+import OpenSSL.EVP.Internal
foreign import ccall unsafe "EVP_get_cipherbyname"
_get_cipherbyname :: CString -> IO (Ptr EVP_CIPHER)
-
-foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_iv_length"
- _iv_length :: Ptr EVP_CIPHER -> CInt
-
-
-withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a
-withCipherPtr (Cipher cipherPtr) f = f cipherPtr
-
-- |@'getCipherByName' name@ returns a symmetric cipher algorithm
-- whose name is @name@. If no algorithms are found, the result is
-- @Nothing@.
@@ -83,65 +49,21 @@ getCipherByName name
getCipherNames :: IO [String]
getCipherNames = getObjNames CipherMethodType True
-
-cipherIvLength :: Cipher -> Int
-cipherIvLength (Cipher cipherPtr) = fromIntegral $ _iv_length cipherPtr
-
-
-{- EVP_CIPHER_CTX ------------------------------------------------------------ -}
-
-newtype CipherCtx = CipherCtx (ForeignPtr EVP_CIPHER_CTX)
-data EVP_CIPHER_CTX
-
-
-foreign import ccall unsafe "EVP_CIPHER_CTX_init"
- _ctx_init :: Ptr EVP_CIPHER_CTX -> IO ()
-
-foreign import ccall unsafe "&EVP_CIPHER_CTX_cleanup"
- _ctx_cleanup :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ())
-
-foreign import ccall unsafe "EVP_CIPHER_CTX_cleanup"
- _ctx_cleanup' :: Ptr EVP_CIPHER_CTX -> IO ()
-
-foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_CTX_block_size"
- _ctx_block_size :: Ptr EVP_CIPHER_CTX -> CInt
-
-
-newCtx :: IO CipherCtx
-newCtx = do ctx <- mallocForeignPtrBytes (#size EVP_CIPHER_CTX)
- withForeignPtr ctx _ctx_init
- addForeignPtrFinalizer _ctx_cleanup ctx
- return $ CipherCtx ctx
-
-
-withCipherCtxPtr :: CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
-withCipherCtxPtr (CipherCtx ctx) = withForeignPtr ctx
-
-
{- encrypt/decrypt ----------------------------------------------------------- -}
-- |@CryptoMode@ represents instruction to 'cipher' and such like.
data CryptoMode = Encrypt | Decrypt
-
-foreign import ccall unsafe "EVP_CipherInit"
- _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> CInt -> IO CInt
-
-foreign import ccall unsafe "EVP_CipherUpdate"
- _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> Ptr CChar -> CInt -> IO CInt
-
-foreign import ccall unsafe "EVP_CipherFinal"
- _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt
-
-
cryptoModeToInt :: CryptoMode -> CInt
cryptoModeToInt Encrypt = 1
cryptoModeToInt Decrypt = 0
+foreign import ccall unsafe "EVP_CipherInit"
+ _CipherInit :: Ptr EVP_CIPHER_CTX -> Ptr EVP_CIPHER -> CString -> CString -> CInt -> IO CInt
cipherInit :: Cipher -> String -> String -> CryptoMode -> IO CipherCtx
cipherInit (Cipher c) key iv mode
- = do ctx <- newCtx
+ = do ctx <- newCipherCtx
withCipherCtxPtr ctx $ \ ctxPtr ->
withCString key $ \ keyPtr ->
withCString iv $ \ ivPtr ->
@@ -157,8 +79,7 @@ cipherStrictLBS :: Cipher -- ^ Cipher
-> L8.ByteString -- ^ Input
-> IO L8.ByteString
cipherStrictLBS (Cipher c) key iv mode input =
- allocaBytes (#size EVP_CIPHER_CTX) $ \cptr ->
- bracket_ (_ctx_init cptr) (_ctx_cleanup' cptr) $
+ withNewCipherCtxPtr $ \cptr ->
unsafeUseAsCStringLen key $ \(keyp,_) ->
unsafeUseAsCStringLen iv $ \(ivp, _) -> do
failIf_ (/= 1) =<< _CipherInit cptr c keyp ivp (cryptoModeToInt mode)
@@ -167,26 +88,6 @@ cipherStrictLBS (Cipher c) key iv mode input =
rf <- cipherFinalBS cc
return $ L8.fromChunks (rr++[rf])
-cipherUpdateBS :: CipherCtx -> B8.ByteString -> IO B8.ByteString
-cipherUpdateBS ctx inBS
- = withCipherCtxPtr ctx $ \ ctxPtr ->
- unsafeUseAsCStringLen inBS $ \ (inBuf, inLen) ->
- createAndTrim (inLen + fromIntegral (_ctx_block_size ctxPtr) - 1) $ \ outBuf ->
- alloca $ \ outLenPtr ->
- _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf (fromIntegral inLen)
- >>= failIf (/= 1)
- >> liftM fromIntegral (peek outLenPtr)
-
-
-cipherFinalBS :: CipherCtx -> IO B8.ByteString
-cipherFinalBS ctx
- = withCipherCtxPtr ctx $ \ ctxPtr ->
- createAndTrim (fromIntegral $ _ctx_block_size ctxPtr) $ \ outBuf ->
- alloca $ \ outLenPtr ->
- _CipherFinal ctxPtr (castPtr outBuf) outLenPtr
- >>= failIf (/= 1)
- >> liftM fromIntegral (peek outLenPtr)
-
-- |@'cipher'@ lazilly encrypts or decrypts a stream of data. The
-- input string doesn't necessarily have to be finite.
cipher :: Cipher -- ^ algorithm to use
@@ -199,7 +100,7 @@ cipher :: Cipher -- ^ algorithm to use
-- U+00FF.
-> IO String -- ^ the result string
cipher c key iv mode input
- = liftM L8.unpack $ cipherLBS c key iv mode $ L8.pack input
+ = fmap L8.unpack $ cipherLBS c key iv mode $ L8.pack input
-- |@'cipherBS'@ strictly encrypts or decrypts a chunk of data.
cipherBS :: Cipher -- ^ algorithm to use
@@ -224,21 +125,3 @@ cipherLBS c key iv mode input
= do ctx <- cipherInit c key iv mode
cipherLazily ctx input
-
-cipherStrictly :: CipherCtx -> B8.ByteString -> IO B8.ByteString
-cipherStrictly ctx input
- = do output' <- cipherUpdateBS ctx input
- output'' <- cipherFinalBS ctx
- return $ B8.append output' output''
-
-
-cipherLazily :: CipherCtx -> L8.ByteString -> IO L8.ByteString
-
-cipherLazily ctx (L8Internal.Empty) =
- cipherFinalBS ctx >>= \ bs -> (return . L8.fromChunks) [bs]
-
-cipherLazily ctx (L8Internal.Chunk x xs) = do
- y <- cipherUpdateBS ctx x
- ys <- unsafeInterleaveIO $
- cipherLazily ctx xs
- return $ L8Internal.Chunk y ys
View
137 OpenSSL/EVP/Digest.hsc
@@ -8,19 +8,9 @@
module OpenSSL.EVP.Digest
( Digest
- , EVP_MD -- private
- , withMDPtr -- private
-
, getDigestByName
, getDigestNames
- , DigestCtx -- private
- , EVP_MD_CTX -- private
- , withDigestCtxPtr -- private
-
- , digestStrictly -- private
- , digestLazily -- private
-
, digest
, digestBS
, digestBS'
@@ -31,32 +21,19 @@ module OpenSSL.EVP.Digest
)
where
-import Control.Monad
-import Data.ByteString.Internal (createAndTrim, create)
+import Data.ByteString.Internal (create)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
+import Control.Applicative ((<$>))
import Foreign
import Foreign.C
+import OpenSSL.EVP.Internal
import OpenSSL.Objects
-import OpenSSL.Utils
-
-
-{- EVP_MD -------------------------------------------------------------------- -}
-
--- |@Digest@ is an opaque object that represents an algorithm of
--- message digest.
-newtype Digest = Digest (Ptr EVP_MD)
-data EVP_MD
-
foreign import ccall unsafe "EVP_get_digestbyname"
_get_digestbyname :: CString -> IO (Ptr EVP_MD)
-
-withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a
-withMDPtr (Digest mdPtr) f = f mdPtr
-
-- |@'getDigestByName' name@ returns a message digest algorithm whose
-- name is @name@. If no algorithms are found, the result is
-- @Nothing@.
@@ -74,89 +51,8 @@ getDigestByName name
getDigestNames :: IO [String]
getDigestNames = getObjNames MDMethodType True
-
-{- EVP_MD_CTX ---------------------------------------------------------------- -}
-
-newtype DigestCtx = DigestCtx (ForeignPtr EVP_MD_CTX)
-data EVP_MD_CTX
-
-
-foreign import ccall unsafe "EVP_MD_CTX_init"
- _ctx_init :: Ptr EVP_MD_CTX -> IO ()
-
-foreign import ccall unsafe "&EVP_MD_CTX_cleanup"
- _ctx_cleanup :: FunPtr (Ptr EVP_MD_CTX -> IO ())
-
-
-newCtx :: IO DigestCtx
-newCtx = do ctx <- mallocForeignPtrBytes (#size EVP_MD_CTX)
- withForeignPtr ctx _ctx_init
- addForeignPtrFinalizer _ctx_cleanup ctx
- return $ DigestCtx ctx
-
-
-withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
-withDigestCtxPtr (DigestCtx ctx) = withForeignPtr ctx
-
-
{- digest -------------------------------------------------------------------- -}
-foreign import ccall unsafe "EVP_DigestInit"
- _DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt
-
-foreign import ccall unsafe "EVP_DigestUpdate"
- _DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO CInt
-
-foreign import ccall unsafe "EVP_DigestFinal"
- _DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO CInt
-
-
-digestInit :: Digest -> IO DigestCtx
-digestInit (Digest md)
- = do ctx <- newCtx
- withDigestCtxPtr ctx $ \ ctxPtr ->
- _DigestInit ctxPtr md >>= failIf_ (/= 1)
- return ctx
-
-
-digestUpdateBS :: DigestCtx -> B8.ByteString -> IO ()
-digestUpdateBS ctx bs
- = withDigestCtxPtr ctx $ \ ctxPtr ->
- unsafeUseAsCStringLen bs $ \ (buf, len) ->
- _DigestUpdate ctxPtr buf (fromIntegral len) >>= failIf (/= 1) >> return ()
-
-
-digestFinal :: DigestCtx -> IO String
-digestFinal ctx
- = withDigestCtxPtr ctx $ \ ctxPtr ->
- allocaArray (#const EVP_MAX_MD_SIZE) $ \ bufPtr ->
- alloca $ \ bufLenPtr ->
- do _DigestFinal ctxPtr bufPtr bufLenPtr >>= failIf_ (/= 1)
- bufLen <- liftM fromIntegral $ peek bufLenPtr
- peekCStringLen (bufPtr, bufLen)
-
-digestFinalBS :: DigestCtx -> IO B8.ByteString
-digestFinalBS ctx =
- withDigestCtxPtr ctx $ \ctxPtr ->
- createAndTrim (#const EVP_MAX_MD_SIZE) $ \bufPtr ->
- alloca $ \bufLenPtr ->
- do _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1)
- liftM fromIntegral $ peek bufLenPtr
-
-
-digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx
-digestStrictly md input
- = do ctx <- digestInit md
- digestUpdateBS ctx input
- return ctx
-
-
-digestLazily :: Digest -> L8.ByteString -> IO DigestCtx
-digestLazily md lbs
- = do ctx <- digestInit md
- mapM_ (digestUpdateBS ctx) $ L8.toChunks lbs
- return ctx
-
-- |@'digest'@ digests a stream of data. The string must
-- not contain any letters which aren't in the range of U+0000 -
-- U+00FF.
@@ -167,19 +63,16 @@ digest md input
-- |@'digestBS'@ digests a chunk of data.
digestBS :: Digest -> B8.ByteString -> String
digestBS md input
- = unsafePerformIO
- (digestStrictly md input >>= digestFinal)
+ = unsafePerformIO $ digestStrictly md input >>= digestFinal
digestBS' :: Digest -> B8.ByteString -> B8.ByteString
digestBS' md input
- = unsafePerformIO
- (digestStrictly md input >>= digestFinalBS)
+ = unsafePerformIO $ digestStrictly md input >>= digestFinalBS
-- |@'digestLBS'@ digests a stream of data.
digestLBS :: Digest -> L8.ByteString -> String
digestLBS md input
- = unsafePerformIO
- (digestLazily md input >>= digestFinal)
+ = unsafePerformIO $ digestLazily md input >>= digestFinal
{- HMAC ---------------------------------------------------------------------- -}
@@ -197,9 +90,11 @@ hmacBS (Digest md) key input =
allocaArray (#const EVP_MAX_MD_SIZE) $ \bufPtr ->
alloca $ \bufLenPtr ->
unsafeUseAsCStringLen key $ \(keydata, keylen) ->
- unsafeUseAsCStringLen input $ \(inputdata, inputlen) ->
- do _HMAC md keydata (fromIntegral keylen) inputdata (fromIntegral inputlen) bufPtr bufLenPtr
- bufLen <- liftM fromIntegral $ peek bufLenPtr
+ unsafeUseAsCStringLen input $ \(inputdata, inputlen) -> do
+ _HMAC md
+ keydata (fromIntegral keylen) inputdata (fromIntegral inputlen)
+ bufPtr bufLenPtr
+ bufLen <- fromIntegral <$> peek bufLenPtr
B8.packCStringLen (bufPtr, bufLen)
-- | Calculate a PKCS5-PBKDF2 SHA1-HMAC suitable for password hashing.
@@ -219,7 +114,9 @@ pkcs5_pbkdf2_hmac_sha1 pass salt iter dkeylen =
(fromIntegral iter) (fromIntegral dkeylen) (castPtr dkeydata)
>> return ()
-foreign import ccall unsafe "PKCS5_PBKDF2_HMAC_SHA1" _PKCS5_PBKDF2_HMAC_SHA1 :: Ptr CChar -> CInt
- -> Ptr CChar -> CInt
- -> CInt -> CInt -> Ptr CChar
- -> IO CInt
+foreign import ccall unsafe "PKCS5_PBKDF2_HMAC_SHA1"
+ _PKCS5_PBKDF2_HMAC_SHA1 :: Ptr CChar -> CInt
+ -> Ptr CChar -> CInt
+ -> CInt -> CInt -> Ptr CChar
+ -> IO CInt
+
View
307 OpenSSL/EVP/Internal.hsc
@@ -0,0 +1,307 @@
+
+module OpenSSL.EVP.Internal (
+ Cipher(..),
+ EVP_CIPHER,
+ withCipherPtr,
+
+ cipherIvLength,
+
+ CipherCtx(..),
+ EVP_CIPHER_CTX,
+ newCipherCtx,
+ withCipherCtxPtr,
+ withNewCipherCtxPtr,
+
+ cipherUpdateBS,
+ cipherFinalBS,
+ cipherStrictly,
+ cipherLazily,
+
+ Digest(..),
+ EVP_MD,
+ withMDPtr,
+
+ DigestCtx(..),
+ EVP_MD_CTX,
+ withDigestCtxPtr,
+
+ digestUpdateBS,
+ digestFinalBS,
+ digestFinal,
+ digestStrictly,
+ digestLazily,
+
+ VaguePKey(..),
+ EVP_PKEY,
+ PKey(..),
+ createPKey,
+ wrapPKeyPtr,
+ withPKeyPtr,
+ withPKeyPtr',
+ unsafePKeyToPtr,
+ touchPKey
+ ) where
+
+#include "HsOpenSSL.h"
+
+import qualified Data.ByteString.Internal as B8
+import qualified Data.ByteString.Unsafe as B8
+import qualified Data.ByteString.Char8 as B8
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Lazy.Internal as L8
+import Control.Applicative ((<$>))
+import Control.Exception (mask, mask_, bracket_, onException)
+import Foreign.C.Types (CChar)
+#if __GLASGOW_HASKELL__ >= 703
+import Foreign.C.Types (CInt(..), CUInt(..), CSize(..))
+#else
+import Foreign.C.Types (CInt, CUInt, CSize)
+#endif
+import Foreign.Ptr (Ptr, castPtr, FunPtr)
+import Foreign.C.String (peekCStringLen)
+import Foreign.ForeignPtr (
+ ForeignPtr, newForeignPtr, withForeignPtr, addForeignPtrFinalizer,
+ mallocForeignPtrBytes, touchForeignPtr, unsafeForeignPtrToPtr)
+import Foreign.Storable (Storable(..))
+import Foreign.Marshal.Alloc (alloca, allocaBytes)
+import Foreign.Marshal.Array (allocaArray)
+import System.IO.Unsafe (unsafeInterleaveIO)
+import OpenSSL.Utils
+
+{- EVP_CIPHER ---------------------------------------------------------------- -}
+
+-- |@Cipher@ is an opaque object that represents an algorithm of
+-- symmetric cipher.
+newtype Cipher = Cipher (Ptr EVP_CIPHER)
+data EVP_CIPHER
+
+withCipherPtr :: Cipher -> (Ptr EVP_CIPHER -> IO a) -> IO a
+withCipherPtr (Cipher cipherPtr) f = f cipherPtr
+
+foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_iv_length"
+ _iv_length :: Ptr EVP_CIPHER -> CInt
+
+cipherIvLength :: Cipher -> Int
+cipherIvLength (Cipher cipherPtr) = fromIntegral $ _iv_length cipherPtr
+
+{- EVP_CIPHER_CTX ------------------------------------------------------------ -}
+
+newtype CipherCtx = CipherCtx (ForeignPtr EVP_CIPHER_CTX)
+data EVP_CIPHER_CTX
+
+foreign import ccall unsafe "EVP_CIPHER_CTX_init"
+ _cipher_ctx_init :: Ptr EVP_CIPHER_CTX -> IO ()
+
+foreign import ccall unsafe "&EVP_CIPHER_CTX_cleanup"
+ _cipher_ctx_cleanup :: FunPtr (Ptr EVP_CIPHER_CTX -> IO ())
+
+foreign import ccall unsafe "EVP_CIPHER_CTX_cleanup"
+ _cipher_ctx_cleanup' :: Ptr EVP_CIPHER_CTX -> IO ()
+
+foreign import ccall unsafe "HsOpenSSL_EVP_CIPHER_CTX_block_size"
+ _cipher_ctx_block_size :: Ptr EVP_CIPHER_CTX -> CInt
+
+newCipherCtx :: IO CipherCtx
+newCipherCtx = do
+ ctx <- mallocForeignPtrBytes (#size EVP_CIPHER_CTX)
+ mask_ $ do
+ withForeignPtr ctx _cipher_ctx_init
+ addForeignPtrFinalizer _cipher_ctx_cleanup ctx
+ return $ CipherCtx ctx
+
+withCipherCtxPtr :: CipherCtx -> (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
+withCipherCtxPtr (CipherCtx ctx) = withForeignPtr ctx
+
+withNewCipherCtxPtr :: (Ptr EVP_CIPHER_CTX -> IO a) -> IO a
+withNewCipherCtxPtr f =
+ allocaBytes (#size EVP_CIPHER_CTX) $ \ptr ->
+ bracket_ (_cipher_ctx_init ptr) (_cipher_ctx_cleanup' ptr) (f ptr)
+
+{- encrypt/decrypt ----------------------------------------------------------- -}
+
+foreign import ccall unsafe "EVP_CipherUpdate"
+ _CipherUpdate :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt
+ -> Ptr CChar -> CInt -> IO CInt
+
+cipherUpdateBS :: CipherCtx -> B8.ByteString -> IO B8.ByteString
+cipherUpdateBS ctx inBS =
+ withCipherCtxPtr ctx $ \ctxPtr ->
+ B8.unsafeUseAsCStringLen inBS $ \(inBuf, inLen) ->
+ let len = inLen + fromIntegral (_cipher_ctx_block_size ctxPtr) - 1 in
+ B8.createAndTrim len $ \outBuf ->
+ alloca $ \outLenPtr ->
+ _CipherUpdate ctxPtr (castPtr outBuf) outLenPtr inBuf
+ (fromIntegral inLen)
+ >>= failIf (/= 1)
+ >> fromIntegral <$> peek outLenPtr
+
+foreign import ccall unsafe "EVP_CipherFinal"
+ _CipherFinal :: Ptr EVP_CIPHER_CTX -> Ptr CChar -> Ptr CInt -> IO CInt
+
+cipherFinalBS :: CipherCtx -> IO B8.ByteString
+cipherFinalBS ctx =
+ withCipherCtxPtr ctx $ \ctxPtr ->
+ let len = fromIntegral $ _cipher_ctx_block_size ctxPtr in
+ B8.createAndTrim len $ \outBuf ->
+ alloca $ \outLenPtr ->
+ _CipherFinal ctxPtr (castPtr outBuf) outLenPtr
+ >>= failIf (/= 1)
+ >> fromIntegral <$> peek outLenPtr
+
+cipherStrictly :: CipherCtx -> B8.ByteString -> IO B8.ByteString
+cipherStrictly ctx input = do
+ output' <- cipherUpdateBS ctx input
+ output'' <- cipherFinalBS ctx
+ return $ B8.append output' output''
+
+cipherLazily :: CipherCtx -> L8.ByteString -> IO L8.ByteString
+cipherLazily ctx (L8.Empty) =
+ cipherFinalBS ctx >>= return . L8.fromChunks . return
+cipherLazily ctx (L8.Chunk x xs) = do
+ y <- cipherUpdateBS ctx x
+ ys <- unsafeInterleaveIO $ cipherLazily ctx xs
+ return $ L8.Chunk y ys
+
+{- EVP_MD -------------------------------------------------------------------- -}
+
+-- |@Digest@ is an opaque object that represents an algorithm of
+-- message digest.
+newtype Digest = Digest (Ptr EVP_MD)
+data EVP_MD
+
+withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a
+withMDPtr (Digest mdPtr) f = f mdPtr
+
+{- EVP_MD_CTX ---------------------------------------------------------------- -}
+
+newtype DigestCtx = DigestCtx (ForeignPtr EVP_MD_CTX)
+data EVP_MD_CTX
+
+foreign import ccall unsafe "EVP_MD_CTX_init"
+ _md_ctx_init :: Ptr EVP_MD_CTX -> IO ()
+
+foreign import ccall unsafe "&EVP_MD_CTX_cleanup"
+ _md_ctx_cleanup :: FunPtr (Ptr EVP_MD_CTX -> IO ())
+
+newDigestCtx :: IO DigestCtx
+newDigestCtx = do
+ ctx <- mallocForeignPtrBytes (#size EVP_MD_CTX)
+ mask_ $ do
+ withForeignPtr ctx _md_ctx_init
+ addForeignPtrFinalizer _md_ctx_cleanup ctx
+ return $ DigestCtx ctx
+
+withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
+withDigestCtxPtr (DigestCtx ctx) = withForeignPtr ctx
+
+{- digest -------------------------------------------------------------------- -}
+
+foreign import ccall unsafe "EVP_DigestInit"
+ _DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt
+
+digestInit :: Digest -> IO DigestCtx
+digestInit (Digest md) = do
+ ctx <- newDigestCtx
+ withDigestCtxPtr ctx $ \ctxPtr ->
+ _DigestInit ctxPtr md
+ >>= failIf_ (/= 1)
+ >> return ctx
+
+foreign import ccall unsafe "EVP_DigestUpdate"
+ _DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO CInt
+
+digestUpdateBS :: DigestCtx -> B8.ByteString -> IO ()
+digestUpdateBS ctx bs =
+ withDigestCtxPtr ctx $ \ctxPtr ->
+ B8.unsafeUseAsCStringLen bs $ \(buf, len) ->
+ _DigestUpdate ctxPtr buf (fromIntegral len)
+ >>= failIf (/= 1)
+ >> return ()
+
+foreign import ccall unsafe "EVP_DigestFinal"
+ _DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO CInt
+
+digestFinalBS :: DigestCtx -> IO B8.ByteString
+digestFinalBS ctx =
+ withDigestCtxPtr ctx $ \ctxPtr ->
+ B8.createAndTrim (#const EVP_MAX_MD_SIZE) $ \bufPtr ->
+ alloca $ \bufLenPtr -> do
+ _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1)
+ fromIntegral <$> peek bufLenPtr
+
+digestFinal :: DigestCtx -> IO String
+digestFinal ctx =
+ withDigestCtxPtr ctx $ \ctxPtr ->
+ allocaArray (#const EVP_MAX_MD_SIZE) $ \bufPtr ->
+ alloca $ \bufLenPtr -> do
+ _DigestFinal ctxPtr bufPtr bufLenPtr >>= failIf_ (/= 1)
+ bufLen <- fromIntegral <$> peek bufLenPtr
+ peekCStringLen (bufPtr, bufLen)
+
+digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx
+digestStrictly md input = do
+ ctx <- digestInit md
+ digestUpdateBS ctx input
+ return ctx
+
+digestLazily :: Digest -> L8.ByteString -> IO DigestCtx
+digestLazily md lbs = do
+ ctx <- digestInit md
+ mapM_ (digestUpdateBS ctx) $ L8.toChunks lbs
+ return ctx
+
+{- EVP_PKEY ------------------------------------------------------------------ -}
+
+-- VaguePKey is a ForeignPtr to EVP_PKEY, that is either public key or
+-- a ker pair. We can't tell which at compile time.
+newtype VaguePKey = VaguePKey (ForeignPtr EVP_PKEY)
+data EVP_PKEY
+
+-- Instances of class PKey can be converted back and forth to
+-- VaguePKey.
+class PKey k where
+ -- Wrap the key (i.g. RSA) into EVP_PKEY.
+ toPKey :: k -> IO VaguePKey
+
+ -- Extract the concrete key from the EVP_PKEY. Returns Nothing if
+ -- the type mismatches.
+ fromPKey :: VaguePKey -> IO (Maybe k)
+
+ -- Do the same as EVP_PKEY_size().
+ pkeySize :: k -> Int
+
+ -- Return the default digesting algorithm for the key.
+ pkeyDefaultMD :: k -> IO Digest
+
+foreign import ccall unsafe "EVP_PKEY_new"
+ _pkey_new :: IO (Ptr EVP_PKEY)
+
+foreign import ccall unsafe "&EVP_PKEY_free"
+ _pkey_free :: FunPtr (Ptr EVP_PKEY -> IO ())
+
+foreign import ccall unsafe "EVP_PKEY_free"
+ _pkey_free' :: Ptr EVP_PKEY -> IO ()
+
+wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey
+wrapPKeyPtr = fmap VaguePKey . newForeignPtr _pkey_free
+
+createPKey :: (Ptr EVP_PKEY -> IO a) -> IO VaguePKey
+createPKey f = mask $ \restore -> do
+ ptr <- _pkey_new >>= failIfNull
+ (restore $ f ptr >> return ()) `onException` _pkey_free' ptr
+ wrapPKeyPtr ptr
+
+withPKeyPtr :: VaguePKey -> (Ptr EVP_PKEY -> IO a) -> IO a
+withPKeyPtr (VaguePKey pkey) = withForeignPtr pkey
+
+withPKeyPtr' :: PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
+withPKeyPtr' k f = do
+ pk <- toPKey k
+ withPKeyPtr pk f
+
+unsafePKeyToPtr :: VaguePKey -> Ptr EVP_PKEY
+unsafePKeyToPtr (VaguePKey pkey) = unsafeForeignPtrToPtr pkey
+
+touchPKey :: VaguePKey -> IO ()
+touchPKey (VaguePKey pkey) = touchForeignPtr pkey
+
View
3  OpenSSL/EVP/Open.hsc
@@ -16,6 +16,7 @@ import Foreign
import Foreign.C
import OpenSSL.EVP.Cipher hiding (cipher)
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
@@ -31,7 +32,7 @@ foreign import ccall unsafe "EVP_OpenInit"
openInit :: KeyPair key => Cipher -> String -> String -> key -> IO CipherCtx
openInit cipher encKey iv pkey
- = do ctx <- newCtx
+ = do ctx <- newCipherCtx
withCipherCtxPtr ctx $ \ ctxPtr ->
withCStringLen encKey $ \ (encKeyPtr, encKeyLen) ->
withCString iv $ \ ivPtr ->
View
83 OpenSSL/EVP/PKey.hsc
@@ -1,5 +1,6 @@
{- -*- haskell -*- -}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
{-# OPTIONS_HADDOCK prune #-}
-- |An interface to asymmetric cipher keypair.
@@ -7,21 +8,12 @@
#include "HsOpenSSL.h"
module OpenSSL.EVP.PKey
- ( PublicKey(..)
+ ( PKey
+ , PublicKey(..)
, KeyPair(..)
, SomePublicKey
, SomeKeyPair
-
- -- private
- , PKey(..)
- , EVP_PKEY
- , withPKeyPtr
- , withPKeyPtr'
- , wrapPKeyPtr
- , unsafePKeyToPtr
- , touchPKey
- )
- where
+ ) where
import Data.Typeable
import Data.Maybe
@@ -29,30 +21,10 @@ import Foreign
import Foreign.C
import OpenSSL.DSA
import OpenSSL.EVP.Digest hiding (digest)
+import OpenSSL.EVP.Internal
import OpenSSL.RSA
import OpenSSL.Utils
--- VaguePKey is a ForeignPtr to EVP_PKEY, that is either public key or
--- a ker pair. We can't tell which at compile time.
-newtype VaguePKey = VaguePKey (ForeignPtr EVP_PKEY)
-data EVP_PKEY
-
--- Instances of class PKey can be converted back and forth to
--- VaguePKey.
-class PKey k where
- -- Wrap the key (i.g. RSA) into EVP_PKEY.
- toPKey :: k -> IO VaguePKey
-
- -- Extract the concrete key from the EVP_PKEY. Returns Nothing if
- -- the type mismatches.
- fromPKey :: VaguePKey -> IO (Maybe k)
-
- -- Do the same as EVP_PKEY_size().
- pkeySize :: k -> Int
-
- -- Return the default digesting algorithm for the key.
- pkeyDefaultMD :: k -> IO Digest
-
-- |Instances of this class has at least public portion of a
-- keypair. They might or might not have the private key.
class (Eq k, Typeable k, PKey k) => PublicKey k where
@@ -175,35 +147,6 @@ instance PKey SomeKeyPair where
= withConcreteKeyPair pk (return . Just . SomeKeyPair)
-foreign import ccall unsafe "EVP_PKEY_new"
- _pkey_new :: IO (Ptr EVP_PKEY)
-
-foreign import ccall unsafe "&EVP_PKEY_free"
- _pkey_free :: FunPtr (Ptr EVP_PKEY -> IO ())
-
-
-wrapPKeyPtr :: Ptr EVP_PKEY -> IO VaguePKey
-wrapPKeyPtr
- = fmap VaguePKey . newForeignPtr _pkey_free
-
-
-withPKeyPtr' :: PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
-withPKeyPtr' k f = do pk <- toPKey k
- withPKeyPtr pk f
-
-
-withPKeyPtr :: VaguePKey -> (Ptr EVP_PKEY -> IO a) -> IO a
-withPKeyPtr (VaguePKey pkey) = withForeignPtr pkey
-
-
-unsafePKeyToPtr :: VaguePKey -> Ptr EVP_PKEY
-unsafePKeyToPtr (VaguePKey pkey) = unsafeForeignPtrToPtr pkey
-
-
-touchPKey :: VaguePKey -> IO ()
-touchPKey (VaguePKey pkey) = touchForeignPtr pkey
-
-
#ifndef OPENSSL_NO_RSA
-- The resulting Ptr RSA must be freed by caller.
foreign import ccall unsafe "EVP_PKEY_get1_RSA"
@@ -215,10 +158,9 @@ foreign import ccall unsafe "EVP_PKEY_set1_RSA"
rsaToPKey :: RSAKey k => k -> IO VaguePKey
rsaToPKey rsa
- = withRSAPtr rsa $ \ rsaPtr ->
- do pkeyPtr <- _pkey_new >>= failIfNull
- _set1_RSA pkeyPtr rsaPtr >>= failIf_ (/= 1)
- wrapPKeyPtr pkeyPtr
+ = withRSAPtr rsa $ \rsaPtr ->
+ createPKey $ \pkeyPtr ->
+ _set1_RSA pkeyPtr rsaPtr >>= failIf_ (/= 1)
rsaFromPKey :: RSAKey k => VaguePKey -> IO (Maybe k)
rsaFromPKey pk
@@ -255,10 +197,9 @@ foreign import ccall unsafe "EVP_PKEY_set1_DSA"
dsaToPKey :: DSAKey k => k -> IO VaguePKey
dsaToPKey dsa
- = withDSAPtr dsa $ \ dsaPtr ->
- do pkeyPtr <- _pkey_new >>= failIfNull
- _set1_DSA pkeyPtr dsaPtr >>= failIf_ (/= 1)
- wrapPKeyPtr pkeyPtr
+ = withDSAPtr dsa $ \dsaPtr ->
+ createPKey $ \pkeyPtr ->
+ _set1_DSA pkeyPtr dsaPtr >>= failIf_ (/= 1)
dsaFromPKey :: DSAKey k => VaguePKey -> IO (Maybe k)
dsaFromPKey pk
@@ -283,4 +224,4 @@ instance PKey DSAKeyPair where
fromPKey = dsaFromPKey
pkeySize = dsaSize
pkeyDefaultMD _ = return . fromJust =<< getDigestByName "dss1"
-#endif
+#endif
View
3  OpenSSL/EVP/Seal.hsc
@@ -16,6 +16,7 @@ import Foreign
import Foreign.C
import OpenSSL.EVP.Cipher hiding (cipher)
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
@@ -36,7 +37,7 @@ sealInit _ []
= fail "sealInit: at least one public key is required"
sealInit cipher pubKeys
- = do ctx <- newCtx
+ = do ctx <- newCipherCtx
-- Allocate a list of buffers to write encrypted symmetric
-- keys. Each keys will be at most pkeySize bytes long.
View
29 OpenSSL/EVP/Sign.hsc
@@ -7,35 +7,33 @@ module OpenSSL.EVP.Sign
( sign
, signBS
, signLBS
- , signFinal -- private
)
where
-import Control.Monad
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Internal as B8
import qualified Data.ByteString.Lazy.Char8 as L8
+import Control.Applicative ((<$>))
import Foreign
import Foreign.C
import OpenSSL.EVP.Digest
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
-
foreign import ccall unsafe "EVP_SignFinal"
- _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt -> Ptr EVP_PKEY -> IO CInt
-
+ _SignFinal :: Ptr EVP_MD_CTX -> Ptr Word8 -> Ptr CUInt
+ -> Ptr EVP_PKEY -> IO CInt
signFinal :: KeyPair k => DigestCtx -> k -> IO B8.ByteString
-signFinal ctx k
- = do let maxLen = pkeySize k
- withDigestCtxPtr ctx $ \ ctxPtr ->
- withPKeyPtr' k $ \ pkeyPtr ->
- B8.createAndTrim maxLen $ \ bufPtr ->
- alloca $ \ bufLenPtr ->
- do failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr
- liftM fromIntegral $ peek bufLenPtr
-
+signFinal ctx k = do
+ let maxLen = pkeySize k
+ withDigestCtxPtr ctx $ \ ctxPtr ->
+ withPKeyPtr' k $ \ pkeyPtr ->
+ B8.createAndTrim maxLen $ \ bufPtr ->
+ alloca $ \ bufLenPtr -> do
+ failIf_ (/= 1) =<< _SignFinal ctxPtr bufPtr bufLenPtr pkeyPtr
+ fromIntegral <$> peek bufLenPtr
-- |@'sign'@ generates a signature from a stream of data. The string
-- must not contain any letters which aren't in the range of U+0000 -
@@ -46,7 +44,7 @@ sign :: KeyPair key =>
-> String -- ^ input string
-> IO String -- ^ the result signature
sign md pkey input
- = liftM L8.unpack $ signLBS md pkey $ L8.pack input
+ = fmap L8.unpack $ signLBS md pkey $ L8.pack input
-- |@'signBS'@ generates a signature from a chunk of data.
signBS :: KeyPair key =>
@@ -68,3 +66,4 @@ signLBS md pkey input
= do ctx <- digestLazily md input
sig <- signFinal ctx pkey
return $ L8.fromChunks [sig]
+
View
1  OpenSSL/EVP/Verify.hsc
@@ -18,6 +18,7 @@ import Foreign
import Foreign.C
import OpenSSL.EVP.Digest
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
-- |@'VerifyStatus'@ represents a result of verification.
View
1  OpenSSL/PEM.hsc
@@ -48,6 +48,7 @@ import Foreign.C
import OpenSSL.BIO
import OpenSSL.EVP.Cipher hiding (cipher)
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.DH.Internal
import OpenSSL.PKCS7
import OpenSSL.Utils
View
1  OpenSSL/PKCS7.hsc
@@ -35,6 +35,7 @@ import Foreign.C
import OpenSSL.BIO
import OpenSSL.EVP.Cipher hiding (cipher)
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.Stack
import OpenSSL.Utils
import OpenSSL.X509
View
1  OpenSSL/Session.hsc
@@ -85,6 +85,7 @@ import System.Posix.Types (Fd(..))
import Network.Socket (Socket(..))
import OpenSSL.EVP.PKey
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
import OpenSSL.X509 (X509, X509_, wrapX509, withX509Ptr)
import OpenSSL.X509.Store
View
3  OpenSSL/X509.hsc
@@ -60,6 +60,7 @@ import OpenSSL.BIO
import OpenSSL.EVP.Digest hiding (digest)
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Verify
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
import OpenSSL.Stack
import OpenSSL.X509.Name
@@ -374,4 +375,4 @@ getSubjectEmail x509
do st <- _get1_email x509Ptr
list <- mapStack peekCString st
_email_free st
- return list
+ return list
View
3  OpenSSL/X509/Request.hsc
@@ -41,6 +41,7 @@ import OpenSSL.BIO
import OpenSSL.EVP.Digest hiding (digest)
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Verify
+import OpenSSL.EVP.Internal
import OpenSSL.Utils
import OpenSSL.X509 (X509)
import qualified OpenSSL.X509 as Cert
@@ -251,4 +252,4 @@ makeX509FromReq req caCert
Cert.setSubjectName cert =<< getSubjectName req False
Cert.setPublicKey cert =<< getPublicKey req
- return cert
+ return cert
View
1  OpenSSL/X509/Revocation.hsc
@@ -55,6 +55,7 @@ import OpenSSL.BIO
import OpenSSL.EVP.Digest hiding (digest)
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Verify
+import OpenSSL.EVP.Internal
import OpenSSL.Stack
import OpenSSL.Utils
import OpenSSL.X509.Name
Please sign in to comment.
Something went wrong with that request. Please try again.