HsOpenSSL 0.10.1.1 → 0.10.1.2

raw patch · 19 files changed

+557/−567 lines, 19 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• HsOpenSSL.cabal +20/−18
• NEWS +17/−1
• OpenSSL/DH.hsc +17/−13
• OpenSSL/ERR.hsc +7/−18
• OpenSSL/EVP/Cipher.hsc +11/−131
• OpenSSL/EVP/Digest.hsc +18/−122
• OpenSSL/EVP/Internal.hsc +307/−0
• OpenSSL/EVP/Open.hsc +2/−1
• OpenSSL/EVP/PKey.hsc +18/−78
• OpenSSL/EVP/Seal.hsc +2/−1
• OpenSSL/EVP/Sign.hsc +14/−15
• OpenSSL/EVP/Verify.hsc +1/−0
• OpenSSL/PEM.hsc +1/−0
• OpenSSL/PKCS7.hsc +1/−0
• OpenSSL/Session.hsc +110/−169
• OpenSSL/X509.hsc +1/−0
• OpenSSL/X509/Request.hsc +1/−0
• OpenSSL/X509/Revocation.hsc +1/−0
• README.rst +8/−0

@@ -1,26 +1,27 @@-Name: HsOpenSSL-Synopsis: (Incomplete) OpenSSL binding for Haskell+Name:         HsOpenSSL+Synopsis:     (Incomplete) OpenSSL binding for Haskell Description:-        HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It-        can generate RSA and DSA keys, read and write PEM files,-        generate message digests, sign and verify messages, encrypt-        and decrypt messages. It also has some capabilities of-        creating SSL clients and servers.-Version: 0.10.1.1-License: PublicDomain-License-File: COPYING-Author: Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen-Maintainer: PHO <pho at cielonegro dot org>-Stability: stable-Homepage: http://cielonegro.org/HsOpenSSL.html-Bug-Reports: http://static.cielonegro.org/ditz/HsOpenSSL/-Category: Cryptography-Tested-With: GHC == 7.0.3+    HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It can+    generate RSA and DSA keys, read and write PEM files, generate+    message digests, sign and verify messages, encrypt and decrypt+    messages. It has also some capabilities of creating SSL clients+    and servers.+Version:       0.10.1.2+License:       PublicDomain+License-File:  COPYING+Author:        Adam Langley, Mikhail Vorozhtsov, PHO, Taru Karttunen+Maintainer:    PHO <pho at cielonegro dot org>+Stability:     stable+Homepage:      https://github.com/phonohawk/HsOpenSSL+Bug-Reports:   https://github.com/phonohawk/HsOpenSSL/issues+Category:      Cryptography+Tested-With:   GHC == 7.0.3 Cabal-Version: >= 1.6-Build-Type: Simple+Build-Type:    Simple Extra-Source-Files:     AUTHORS     NEWS+    README.rst     cbits/HsOpenSSL.h     cbits/mutex.h     examples/Makefile@@ -87,6 +88,7 @@           OpenSSL.Stack           OpenSSL.Utils           OpenSSL.X509.Name+          OpenSSL.EVP.Internal           OpenSSL.DH.Internal   Extensions:           ForeignFunctionInterface, EmptyDataDecls, MagicHash,

@@ -1,7 +1,23 @@ -*- coding: utf-8 -*- +Changes from 0.10.1.1 to 0.10.1.2+---------------------------------+* Applied a patch by Mikhail Vorozhtsov:+  - Moved all EVP-related private functions to OpenSSL.EVP.Internal.++* Improve the error handling in OpenSSL.Session:+  - SSL_get_error() must be called within the OS thread which caused+    the failed operation as it inspects the thread-local storage.+  - write/tryWrite should throw EPIPE for cleanly-closed connections+    rather than EOF.+  - shutdown/tryShutdown shouldn't throw an exception when a remote+    peer sends us a "close notify" alert and closes the connection+    without waiting for our reply.+  - ProtocolError should contain an error message string.++ Changes from 0.10.1 to 0.10.1.1------------------------------------+------------------------------- * Applied a patch by Peter Gammie:   - GHC 6.12.3 friendliness: don't use Control.Monad.void 

@@ -1,23 +1,27 @@ -- | Diffie-Hellman key exchange-module OpenSSL.DH (-    DHP,-    DH,-    DHGen(..),-    genDHParams,-    getDHLength,-    checkDHParams,-    genDH,-    getDHParams,-    getDHPublicKey,-    computeDHKey,-  ) where-+module OpenSSL.DH+    ( DHP+    , DH+    , DHGen(..)+    , genDHParams+    , getDHLength+    , checkDHParams+    , genDH+    , getDHParams+    , getDHPublicKey+    , computeDHKey+    )+    where import Data.Word (Word8) 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

@@ -5,29 +5,18 @@     , errorString     )     where--import           Foreign-import           Foreign.C-+import Foreign+import Foreign.C  foreign import ccall unsafe "ERR_get_error"-        _get_error :: IO CULong+    getError :: IO CULong  foreign import ccall unsafe "ERR_peek_error"-        _peek_error :: IO CULong+    peekError :: IO CULong  foreign import ccall unsafe "ERR_error_string"-        _error_string :: CULong -> CString -> IO CString---getError :: IO Integer-getError = fmap fromIntegral _get_error---peekError :: IO Integer-peekError = fmap fromIntegral _peek_error-+    _error_string :: CULong -> CString -> IO CString -errorString :: Integer -> IO String+errorString :: CULong -> IO String errorString code-    = _error_string (fromIntegral code) nullPtr >>= peekCString+    = _error_string code nullPtr >>= peekCString

@@ -1,71 +1,34 @@ {- -*- haskell -*- -} -{-# OPTIONS_HADDOCK prune #-}- -- |An interface to symmetric cipher algorithms.  #include "HsOpenSSL.h"  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     , cipherStrictLBS     )     where--import           Control.Exception(bracket_)-import           Control.Monad-import           Data.ByteString.Internal (createAndTrim)-import           Data.ByteString.Unsafe (unsafeUseAsCStringLen)+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 Foreign+import Foreign.C+import OpenSSL.Objects+import OpenSSL.Utils+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 +46,21 @@ 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 +76,7 @@                 -> 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 +85,6 @@   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 +97,7 @@                      --   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 +122,3 @@     = 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

@@ -1,26 +1,14 @@ {- -*- haskell -*- -} -{-# OPTIONS_HADDOCK prune #-}- -- |An interface to message digest algorithms.  #include "HsOpenSSL.h"  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 +19,19 @@     )     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 +49,8 @@ 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 +61,17 @@ -- |@'digestBS'@ digests a chunk of data. digestBS :: Digest -> B8.ByteString -> String digestBS md input-    = unsafePerformIO-      (digestStrictly md input >>= digestFinal)+    = unsafePerformIO $ digestStrictly md input >>= digestFinal +-- |Same as 'digestBS' but returns 'B8.ByteString' instead. 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 +89,11 @@   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 +113,9 @@            (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+

@@ -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+

@@ -16,6 +16,7 @@ import           Foreign.C import           OpenSSL.EVP.Cipher hiding (cipher) import           OpenSSL.EVP.PKey+import           OpenSSL.EVP.Internal import           OpenSSL.Utils  @@ -31,7 +32,7 @@  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 ->

@@ -1,57 +1,28 @@ {- -*- haskell -*- -} -{-# OPTIONS_HADDOCK prune #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- |An interface to asymmetric cipher keypair.  #include "HsOpenSSL.h"  module OpenSSL.EVP.PKey-    ( PublicKey(..)+    ( PKey+    , PublicKey(..)     , KeyPair(..)     , SomePublicKey     , SomeKeyPair--    -- private-    , PKey(..)-    , EVP_PKEY-    , withPKeyPtr-    , withPKeyPtr'-    , wrapPKeyPtr-    , unsafePKeyToPtr-    , touchPKey     )     where--import           Data.Typeable-import           Data.Maybe-import           Foreign-import           Foreign.C-import           OpenSSL.DSA-import           OpenSSL.EVP.Digest hiding (digest)-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+import Data.Typeable+import Data.Maybe+import Foreign+import Foreign.C+import OpenSSL.DSA+import OpenSSL.EVP.Digest+import OpenSSL.EVP.Internal+import OpenSSL.RSA+import OpenSSL.Utils  -- |Instances of this class has at least public portion of a -- keypair. They might or might not have the private key.@@ -175,35 +146,6 @@         = 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 +157,9 @@  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 +196,9 @@  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

@@ -16,6 +16,7 @@ import           Foreign.C import           OpenSSL.EVP.Cipher hiding (cipher) import           OpenSSL.EVP.PKey+import           OpenSSL.EVP.Internal import           OpenSSL.Utils  @@ -36,7 +37,7 @@     = 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.

@@ -7,35 +7,33 @@     ( 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 @@      -> 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 @@     = do ctx <- digestLazily md input          sig <- signFinal ctx pkey          return $ L8.fromChunks [sig]+

@@ -18,6 +18,7 @@ import           Foreign.C import           OpenSSL.EVP.Digest import           OpenSSL.EVP.PKey+import           OpenSSL.EVP.Internal import           OpenSSL.Utils  -- |@'VerifyStatus'@ represents a result of verification.

@@ -48,6 +48,7 @@ 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

@@ -35,6 +35,7 @@ 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

@@ -48,27 +48,21 @@      -- * SSL Exceptions   , SomeSSLException-  , ConnectionCleanlyClosed   , ConnectionAbruptlyTerminated-  , WantConnect-  , WantAccept-  , WantX509Lookup-  , SSLIOError-  , ProtocolError-  , UnknownError(..)+  , ProtocolError(..)   ) where  #include "openssl/ssl.h"  import Prelude hiding (catch, read, ioError, mapM, mapM_)-import Control.Concurrent (threadWaitWrite, threadWaitRead)+import Control.Concurrent (threadWaitWrite, threadWaitRead, runInBoundThread) import Control.Concurrent.QSem import Control.Exception import Control.Applicative ((<$>), (<$)) import Control.Monad (unless) import Data.Typeable import Data.Foldable (Foldable, mapM_, forM_)-import Data.Traversable (Traversable, mapM, forM)+import Data.Traversable (Traversable, mapM) import Data.Maybe (fromMaybe) import Data.IORef import Foreign@@ -79,12 +73,13 @@ import qualified Data.ByteString.Unsafe as B import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Internal as L-import System.IO.Error (mkIOError, eofErrorType, isEOFError) import System.IO.Unsafe import System.Posix.Types (Fd(..)) import Network.Socket (Socket(..)) +import OpenSSL.ERR import OpenSSL.EVP.PKey+import OpenSSL.EVP.Internal import OpenSSL.Utils import OpenSSL.X509 (X509, X509_, wrapX509, withX509Ptr) import OpenSSL.X509.Store@@ -331,46 +326,52 @@ foreign import ccall "SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt foreign import ccall unsafe "SSL_get_error" _ssl_get_error :: Ptr SSL_ -> CInt -> IO CInt -throwSSLException :: CInt -> IO a-throwSSLException (#const SSL_ERROR_ZERO_RETURN     ) = throwIO ConnectionCleanlyClosed-throwSSLException (#const SSL_ERROR_WANT_CONNECT    ) = throwIO WantConnect-throwSSLException (#const SSL_ERROR_WANT_ACCEPT     ) = throwIO WantAccept-throwSSLException (#const SSL_ERROR_WANT_X509_LOOKUP) = throwIO WantX509Lookup-throwSSLException (#const SSL_ERROR_SYSCALL         ) = throwIO SSLIOError-throwSSLException (#const SSL_ERROR_SSL             ) = throwIO ProtocolError-throwSSLException x = throwIO (UnknownError (fromIntegral x))+throwSSLException :: String -> CInt -> IO a+throwSSLException loc ret+    = do e <- getError+         if e == 0 then+             case ret of+               0 -> throwIO ConnectionAbruptlyTerminated+               _ -> throwErrno loc+           else+             errorString e >>= throwIO . ProtocolError --- | This is the type of an SSL IO operation. EOF and termination are handled---   by exceptions while everything else is one of these. Note that reading---   from an SSL socket can result in WantWrite and vice versa.+-- | This is the type of an SSL IO operation. Errors are handled by+-- exceptions while everything else is one of these. Note that reading+-- from an SSL socket can result in WantWrite and vice versa. data SSLResult a = SSLDone a  -- ^ operation finished successfully-                 | WantRead  -- ^ needs more data from the network+                 | WantRead   -- ^ needs more data from the network                  | WantWrite  -- ^ needs more outgoing buffer space                  deriving (Eq, Show, Functor, Foldable, Traversable)  -- | Block until the operation is finished. sslBlock :: (SSL -> IO (SSLResult a)) -> SSL -> IO a-sslBlock action ssl = do-  result <- action ssl-  case result of-    SSLDone r -> return r-    WantRead  -> threadWaitRead  (sslFd ssl) >> sslBlock action ssl-    WantWrite -> threadWaitWrite (sslFd ssl) >> sslBlock action ssl+sslBlock action ssl+    = do result <- action ssl+         case result of+           SSLDone r -> return r+           WantRead  -> threadWaitRead  (sslFd ssl) >> sslBlock action ssl+           WantWrite -> threadWaitWrite (sslFd ssl) >> sslBlock action ssl  -- | Perform an SSL operation which can return non-blocking error codes, thus --   requesting that the operation be performed when data or buffer space is --   availible.-sslTryHandshake :: (Ptr SSL_ -> IO CInt) -> SSL -> IO (SSLResult CInt)-sslTryHandshake action = flip withSSL $ \pSsl -> do-  n <- action pSsl-  if n >= 0-    then return $ SSLDone n-    else do-      err <- _ssl_get_error pSsl n-      case err of-        (#const SSL_ERROR_WANT_READ)  -> return WantRead-        (#const SSL_ERROR_WANT_WRITE) -> return WantWrite-        _ -> throwSSLException err+sslTryHandshake :: String+                -> (Ptr SSL_ -> IO CInt)+                -> SSL+                -> IO (SSLResult CInt)+sslTryHandshake loc action ssl+    = runInBoundThread $+      withSSL ssl $ \sslPtr ->+      do n <- action sslPtr+         if n == 1 then+             return $ SSLDone n+           else+             do err <- _ssl_get_error sslPtr n+                case err of+                  (#const SSL_ERROR_WANT_READ ) -> return WantRead+                  (#const SSL_ERROR_WANT_WRITE) -> return WantWrite+                  _ -> throwSSLException loc n  -- | Perform an SSL server handshake accept :: SSL -> IO ()@@ -378,9 +379,8 @@  -- | Try to perform an SSL server handshake without blocking tryAccept :: SSL -> IO (SSLResult ())-tryAccept ssl = do-  result <- sslTryHandshake _ssl_accept ssl-  forM result $ failIf_ (/= 1)+tryAccept ssl+    = (() <$) <$> sslTryHandshake "SSL_accept" _ssl_accept ssl  -- | Perform an SSL client handshake connect :: SSL -> IO ()@@ -388,79 +388,78 @@  -- | Try to perform an SSL client handshake without blocking tryConnect :: SSL -> IO (SSLResult ())-tryConnect ssl = do-  result <- sslTryHandshake _ssl_connect ssl-  forM result $ failIf_ (/= 1)+tryConnect ssl+    = (() <$) <$> sslTryHandshake "SSL_connect" _ssl_connect ssl  foreign import ccall "SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt foreign import ccall unsafe "SSL_get_shutdown" _ssl_get_shutdown :: Ptr SSL_ -> IO CInt  -- | Perform an SSL operation which operates of a buffer and can return --   non-blocking error codes, thus requesting that it be performed again when---   more data or buffer space is availible.+--   more data or buffer space is available. -- --   Note that these SSL functions generally require that the arguments to the --   repeated call be exactly the same. This presents an issue because multiple --   threads could try writing at the same time (with different buffers) so the --   calling function should probably hold the lock on the SSL object over the --   whole time (include repeated calls)-sslIOInner :: (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)  -- ^ the SSL IO function to call+sslIOInner :: String -- ^ the name of SSL IO function to call+           -> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)  -- ^ the SSL IO function to call            -> Ptr CChar  -- ^ the buffer to pass            -> Int  -- ^ the length to pass-           -> Ptr SSL_+           -> SSL            -> IO (SSLResult CInt)-sslIOInner f ptr nbytes ssl = do-  n <- f ssl (castPtr ptr) $ fromIntegral nbytes-  case n of-       n | n > 0 -> return $ SSLDone $ fromIntegral n-         | n == 0 -> do-           shutdown <- _ssl_get_shutdown ssl-           if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0-              then throw ConnectionAbruptlyTerminated-              else ioError $ mkIOError eofErrorType  "" Nothing Nothing-       _ -> do-           err <- _ssl_get_error ssl n-           case err of-                (#const SSL_ERROR_WANT_READ) -> return WantRead-                (#const SSL_ERROR_WANT_WRITE) -> return WantWrite-                _ -> throwSSLException err--catchEOF :: a -> IO a -> IO a-catchEOF x m = m `catch` \e -> if isEOFError e then return x else throwIO e+sslIOInner loc f ptr nbytes ssl+    = runInBoundThread $+      withSSL ssl      $ \sslPtr ->+      do n <- f sslPtr (castPtr ptr) $ fromIntegral nbytes+         if n > 0 then+             return $ SSLDone $ fromIntegral n+           else+             do err <- _ssl_get_error sslPtr n+                case err of+                  (#const SSL_ERROR_ZERO_RETURN) -> return $ SSLDone $ 0+                  (#const SSL_ERROR_WANT_READ  ) -> return WantRead+                  (#const SSL_ERROR_WANT_WRITE ) -> return WantWrite+                  _ -> throwSSLException loc n  -- | Try to read the given number of bytes from an SSL connection. On EOF an --   empty ByteString is returned. If the connection dies without a graceful --   SSL shutdown, an exception is raised. read :: SSL -> Int -> IO B.ByteString-read ssl nbytes = B.createAndTrim nbytes $ \ptr -> do-  let doRead = withSSL ssl $ sslIOInner _ssl_read (castPtr ptr) nbytes-  catchEOF 0 $ fromIntegral <$> sslBlock (const doRead) ssl+read ssl nBytes = sslBlock (`tryRead` nBytes) ssl  -- | Try to read the given number of bytes from an SSL connection --   without blocking. tryRead :: SSL -> Int -> IO (SSLResult B.ByteString)-tryRead ssl nbytes = do-  (bs, result) <- B.createAndTrim' nbytes $ \ptr -> do-    result <- catchEOF (SSLDone 0) $ withSSL ssl $-                sslIOInner _ssl_read (castPtr ptr) nbytes-    return $ case result of-      SSLDone n -> (0, fromIntegral n, SSLDone ())-      WantRead  -> (0, 0,              WantRead)-      WantWrite -> (0, 0,              WantWrite)-  return $ bs <$ result+tryRead ssl nBytes+    = do (bs, result) <- B.createAndTrim' nBytes $ \bufPtr ->+                         do result <- sslIOInner "SSL_read" _ssl_read (castPtr bufPtr) nBytes ssl+                            case result of+                              SSLDone n -> return (0, fromIntegral n, SSLDone ())+                              WantRead  -> return (0,              0, WantRead  )+                              WantWrite -> return (0,              0, WantWrite )+         return $ bs <$ result  foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt  -- | Write a given ByteString to the SSL connection. Either all the data is---   written or an exception is raised because of an error+--   written or an exception is raised because of an error. write :: SSL -> B.ByteString -> IO () write ssl bs = sslBlock (`tryWrite` bs) ssl >> return ()  -- | Try to write a given ByteString to the SSL connection without blocking. tryWrite :: SSL -> B.ByteString -> IO (SSLResult ())-tryWrite ssl bs =-  B.unsafeUseAsCStringLen bs $ \(ptr, len) ->-    ((() <$) <$>) $ withSSL ssl $ sslIOInner _ssl_write ptr len+tryWrite ssl bs+    | B.null bs = return $ SSLDone ()+    | otherwise+        = B.unsafeUseAsCStringLen bs $ \(ptr, len) ->+          do result <- sslIOInner "SSL_write" _ssl_write ptr len ssl+             case result of+               SSLDone 0 -> ioError $ errnoToIOError "SSL_write" ePIPE Nothing Nothing+               SSLDone _ -> return $ SSLDone ()+               WantRead  -> return WantRead+               WantWrite -> return WantWrite  -- | Lazily read all data until reaching EOF. If the connection dies --   without a graceful SSL shutdown, an exception is raised.@@ -491,6 +490,7 @@  data ShutdownType = Bidirectional  -- ^ wait for the peer to also shutdown                   | Unidirectional  -- ^ only send our shutdown+                    deriving (Eq, Show)  -- | Cleanly shutdown an SSL connection. Note that SSL has a concept of a --   secure shutdown, which is distinct from just closing the TCP connection.@@ -503,14 +503,33 @@  -- | Try to cleanly shutdown an SSL connection without blocking. tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ())-tryShutdown ssl ty = do-  result <- sslTryHandshake _ssl_shutdown ssl-  case result of-    SSLDone n -> case ty of-      Bidirectional | n /= 1 -> tryShutdown ssl ty-      _ -> return $ SSLDone ()-    WantRead  -> return WantRead-    WantWrite -> return WantWrite+tryShutdown ssl ty+    = runInBoundThread $+      withSSL ssl $ \sslPtr ->+      do n <- _ssl_shutdown sslPtr+         case n of+           1 -> return $ SSLDone ()+           0 -> if ty == Bidirectional then+                    tryShutdown ssl ty+                else+                    return $ SSLDone ()+           _ -> do err <- _ssl_get_error sslPtr n+                   case err of+                     (#const SSL_ERROR_WANT_READ ) -> return WantRead+                     (#const SSL_ERROR_WANT_WRITE) -> return WantWrite+                     -- SSL_ERROR_SYSCALL/-1 happens when we are+                     -- trying to send the remote peer a "close+                     -- notify" alert but the underlying socket was+                     -- closed at the time. We don't treat this an+                     -- error /if and only if/ we have already+                     -- received a "close notify" from the peer.+                     (#const SSL_ERROR_SYSCALL)+                         -> do sd <- _ssl_get_shutdown sslPtr+                               if sd .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 then+                                   throwSSLException "SSL_shutdown" n+                                 else+                                   return $ SSLDone ()+                     _   -> throwSSLException "SSL_shutdown" n  foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_) @@ -559,20 +578,6 @@     = do SomeSSLException a <- fromException x          cast a --- | The TLS\/SSL connection has been closed. If the protocol version--- is SSL 3.0 or TLS 1.0, this result code is returned only if a--- closure alert has occurred in the protocol, i.e. if the connection--- has been closed cleanly. Note that in this case--- 'ConnectionCleanlyClosed' does not necessarily indicate that the--- underlying transport has been closed.-data ConnectionCleanlyClosed-    = ConnectionCleanlyClosed-      deriving (Typeable, Show, Eq)--instance Exception ConnectionCleanlyClosed where-    toException   = sslExceptionToException-    fromException = sslExceptionFromException- -- | The peer uncleanly terminated the connection without sending the -- \"close notify\" alert. data ConnectionAbruptlyTerminated@@ -583,76 +588,12 @@     toException   = sslExceptionToException     fromException = sslExceptionFromException --- | The operation did not complete; the same TLS\/SSL I\/O function--- should be called again later. The underlying socket was not--- connected yet to the peer and the call would block in--- 'connect'. The SSL function should be called again when the--- connection is established. This message can only appear with--- 'connect'.-data WantConnect-    = WantConnect-      deriving (Typeable, Show, Eq)--instance Exception WantConnect where-    toException   = sslExceptionToException-    fromException = sslExceptionFromException---- | The operation did not complete; the same TLS\/SSL I\/O function--- should be called again later. The underlying socket was not--- connected yet to the peer and the call would block in 'accept'. The--- SSL function should be called again when the connection is--- established. This message can only appear with 'accept'.-data WantAccept-    = WantAccept-      deriving (Typeable, Show, Eq)--instance Exception WantAccept where-    toException   = sslExceptionToException-    fromException = sslExceptionFromException---- | The operation did not complete because an application callback--- set by SSL_CTX_set_client_cert_cb() has asked to be called--- again. The TLS\/SSL I\/O function should be called again--- later. Details depend on the application.-data WantX509Lookup-    = WantX509Lookup-      deriving (Typeable, Show, Eq)--instance Exception WantX509Lookup where-    toException   = sslExceptionToException-    fromException = sslExceptionFromException---- | Some I\/O error occurred. The OpenSSL error queue may contain--- more information on the error. If the error queue is empty--- (i.e. ERR_get_error() returns 0), ret can be used to find out more--- about the error: If ret == 0, an EOF was observed that violates the--- protocol. If ret == -1, the underlying BIO reported an I\/O error--- (for socket I\/O on Unix systems, consult errno for details).-data SSLIOError-    = SSLIOError-      deriving (Typeable, Show, Eq)--instance Exception SSLIOError where-    toException   = sslExceptionToException-    fromException = sslExceptionFromException- -- | A failure in the SSL library occurred, usually a protocol--- error. The OpenSSL error queue contains more information on the -- error. data ProtocolError-    = ProtocolError+    = ProtocolError !String       deriving (Typeable, Show, Eq)  instance Exception ProtocolError where-    toException   = sslExceptionToException-    fromException = sslExceptionFromException---- | SSL_get_error() returned an error code which is unknown to this--- library.-data UnknownError-    = UnknownError !Int-      deriving (Typeable, Show, Eq)--instance Exception UnknownError where     toException   = sslExceptionToException     fromException = sslExceptionFromException

@@ -60,6 +60,7 @@ 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

@@ -41,6 +41,7 @@ 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

@@ -55,6 +55,7 @@ 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

@@ -0,0 +1,8 @@+======+README+======++HsOpenSSL is an (incomplete) OpenSSL binding for Haskell. It can+generate RSA and DSA keys, read and write PEM files, generate message+digests, sign and verify messages, encrypt and decrypt messages. It+also has some capabilities of creating SSL clients and servers.