HsOpenSSL 0.10 → 0.10.1

raw patch · 11 files changed

+416/−107 lines, 11 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• AUTHORS +2/−1
• HsOpenSSL.cabal +9/−7
• NEWS +13/−1
• OpenSSL/BN.hsc +2/−2
• OpenSSL/DH.hsc +93/−0
• OpenSSL/DH/Internal.hsc +51/−0
• OpenSSL/PEM.hsc +46/−0
• OpenSSL/Session.hsc +140/−77
• OpenSSL/X509/Revocation.hsc +26/−13
• OpenSSL/X509/Store.hsc +24/−6
• cbits/HsOpenSSL.c +10/−0

@@ -1,7 +1,8 @@-This is a list of contributors to the HsOpenSSL.+This is the list of contributors to the HsOpenSSL.  * Adam Langley <agl@imperialviolet.org> * John Van Enk <vanenkj@gmail.com> and his friend+* Mikhail Vorozhtsov <mikhail.vorozhtsov@gmail.com> * Taru Karttunen <taruti@taruti.net> * PHO <pho@cielonegro.org> 

@@ -4,16 +4,16 @@         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.-Version: 0.10+        and decrypt messages. It also has some capabilities of+        creating SSL clients and servers.+Version: 0.10.1 License: PublicDomain License-File: COPYING-Author: Adam Langley <agl at imperialviolet dot org>,-        PHO <pho at cielonegro dot org>,-        Taru Karttunen <taruti at taruti dot net>+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 Cabal-Version: >= 1.6@@ -33,8 +33,8 @@     tests/Makefile  Source-Repository head-    Type: darcs-    Location: http://darcs.cielonegro.org/HsOpenSSL/+    Type: git+    Location: git://github.com/phonohawk/HsOpenSSL.git  Library   Build-Depends: base >= 4 && < 5, bytestring, ghc-prim, time >= 1.1.1, old-locale, network>=2.1.0.0@@ -77,6 +77,7 @@           OpenSSL.X509.Request           OpenSSL.X509.Store           OpenSSL.Session+          OpenSSL.DH   Other-Modules:           OpenSSL.ASN1           OpenSSL.BIO@@ -86,6 +87,7 @@           OpenSSL.Stack           OpenSSL.Utils           OpenSSL.X509.Name+          OpenSSL.DH.Internal   Extensions:           ForeignFunctionInterface, EmptyDataDecls, MagicHash,           UnboxedTuples, UnliftedFFITypes, DeriveDataTypeable,

@@ -1,8 +1,20 @@ -*- coding: utf-8 -*- +Changes from 0.10 to 0.10.1+---------------------------+* Applied patches by Mikhail Vorozhtsov:+  - Added optional verification callback to VerifyPeer.+  - Added revocation lookup function.+  - Added bindings to Diffie-Hellman functions.+  - Expose low-level asynchronous versions of accept, connect, read,+    write and shutdown.++* Moved the repository to GitHub:+  git://github.com/phonohawk/HsOpenSSL.git++ Changes from 0.9.0.1 to 0.10 ----------------------------- * Applied a patch by Mikhail Vorozhtsov to support wrapping plain file   descriptors in SSL connections. 

@@ -153,8 +153,8 @@         _copy_out :: Ptr () -> ByteArray## -> CSize -> IO ()  -- These are taken from Data.Binary's disabled fast Integer support-data ByteArray = BA  {-# UNPACK #-} !ByteArray##-data MBA       = MBA {-# UNPACK #-} !(MutableByteArray## RealWorld)+data ByteArray = BA  !ByteArray##+data MBA       = MBA !(MutableByteArray## RealWorld)  newByteArray :: Int## -> IO MBA newByteArray sz = IO $ \s ->

@@ -0,0 +1,93 @@+-- | Diffie-Hellman key exchange+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)+import Foreign.C.Types (CInt)+import Foreign.Marshal.Alloc (alloca)+import OpenSSL.BN+import OpenSSL.DH.Internal+import OpenSSL.Utils++data DHGen = DHGen2+           | DHGen5+           deriving (Eq, Ord, Show)++-- | @'genDHParams' gen n@ generates @n@-bit long DH parameters.+genDHParams :: DHGen -> Int -> IO DHP+genDHParams gen len = do+    _DH_generate_parameters (fromIntegral len) gen' nullPtr nullPtr+      >>= failIfNull+      >>= wrapDHPPtr+  where gen' = case gen of+                 DHGen2 -> 2+                 DHGen5 -> 5++-- | Get DH parameters length (in bits).+getDHLength :: DHP -> IO Int+getDHLength dh = fromIntegral <$> withDHPPtr dh _DH_length++-- | Check that DH parameters are coherent.+checkDHParams :: DHP -> IO Bool+checkDHParams dh = alloca $ \pErr ->+                     withDHPPtr dh $ \dhPtr -> _DH_check dhPtr pErr++-- | The first step of a key exchange. Public and private keys are generated.+genDH :: DHP -> IO DH+genDH dh = do+  dh' <- withDHPPtr dh _DH_dup >>= failIfNull >>= wrapDHPPtr+  withDHPPtr dh' _DH_generate_key >>= failIf_ (/= 1)+  return $ asDH dh'++-- | Get parameters of a key exchange.+getDHParams :: DH -> DHP+getDHParams = asDHP++-- | Get the public key.+getDHPublicKey :: DH -> IO Integer+getDHPublicKey dh =+  withDHPtr dh $ \dhPtr -> do+    pKey <- _DH_get_pub_key dhPtr+    bnToInteger (wrapBN pKey)++-- | Compute the shared key using the other party's public key.+computeDHKey :: DH -> Integer -> IO ByteString+computeDHKey dh pubKey =+  withDHPtr dh $ \dhPtr ->+    withBN pubKey $ \bn -> do+      size <- fromIntegral <$> _DH_size dhPtr+      BS.createAndTrim size $ \bsPtr ->+        fromIntegral <$> _DH_compute_key bsPtr (unwrapBN bn) dhPtr+          >>= failIf (< 0)++foreign import ccall "DH_generate_parameters"+  _DH_generate_parameters :: CInt -> CInt -> Ptr () -> Ptr () -> IO (Ptr DH_)+foreign import ccall "DH_generate_key"+  _DH_generate_key :: Ptr DH_ -> IO CInt+foreign import ccall "DH_compute_key"+  _DH_compute_key :: Ptr Word8 -> Ptr BIGNUM -> Ptr DH_ -> IO CInt+foreign import ccall "DH_check"+  _DH_check :: Ptr DH_ -> Ptr CInt -> IO Bool+foreign import ccall unsafe "DH_size"+  _DH_size :: Ptr DH_ -> IO CInt+foreign import ccall unsafe "DHparams_dup"+  _DH_dup :: Ptr DH_ -> IO (Ptr DH_)+foreign import ccall unsafe "HsOpenSSL_DH_get_pub_key"+  _DH_get_pub_key :: Ptr DH_ -> IO (Ptr BIGNUM)+foreign import ccall unsafe "HsOpenSSL_DH_length"+  _DH_length :: Ptr DH_ -> IO CInt+

@@ -0,0 +1,51 @@+module OpenSSL.DH.Internal (+    DH_,+    DHP,+    withDHPPtr,+    wrapDHPPtrWith,+    wrapDHPPtr,+    DH,+    withDHPtr,+    wrapDHPtrWith,+    wrapDHPtr,+    asDH,+    asDHP+  ) where++import Control.Applicative ((<$>))+import Foreign.Ptr (Ptr)+import Foreign.ForeignPtr (ForeignPtr, withForeignPtr)+import qualified Foreign.Concurrent as FC++data DH_+newtype DHP = DHP (ForeignPtr DH_)++withDHPPtr :: DHP -> (Ptr DH_ -> IO a) -> IO a+withDHPPtr (DHP fp) = withForeignPtr fp++wrapDHPPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DHP+wrapDHPPtrWith fin p = DHP <$> FC.newForeignPtr p (fin p)++wrapDHPPtr :: Ptr DH_ -> IO DHP+wrapDHPPtr = wrapDHPPtrWith _DH_free++newtype DH = DH (ForeignPtr DH_)++withDHPtr :: DH -> (Ptr DH_ -> IO a) -> IO a+withDHPtr (DH fp) = withForeignPtr fp++wrapDHPtrWith :: (Ptr DH_ -> IO ()) -> Ptr DH_ -> IO DH+wrapDHPtrWith fin p = DH <$> FC.newForeignPtr p (fin p)++wrapDHPtr :: Ptr DH_ -> IO DH+wrapDHPtr = wrapDHPtrWith _DH_free++asDH :: DHP -> DH+asDH (DHP fp) = DH fp++asDHP :: DH -> DHP+asDHP (DH fp) = DHP fp++foreign import ccall "DH_free"+  _DH_free :: Ptr DH_ -> IO ()+

@@ -32,6 +32,10 @@       -- * PKCS#7 structure     , writePkcs7     , readPkcs7++      -- * DH parameters+    , writeDHParams+    , readDHParams     )     where @@ -44,6 +48,7 @@ import           OpenSSL.BIO import           OpenSSL.EVP.Cipher hiding (cipher) import           OpenSSL.EVP.PKey+import           OpenSSL.DH.Internal import           OpenSSL.PKCS7 import           OpenSSL.Utils import           OpenSSL.X509@@ -464,6 +469,47 @@ readPkcs7 :: String -> IO Pkcs7 readPkcs7 pemStr     = newConstMem pemStr >>= readPkcs7'++{- DH parameters ------------------------------------------------------------- -}++foreign import ccall unsafe "PEM_write_bio_DHparams"+        _write_bio_DH :: Ptr BIO_+                      -> Ptr DH_+                      -> IO CInt++foreign import ccall safe "PEM_read_bio_DHparams"+        _read_bio_DH :: Ptr BIO_+                     -> Ptr (Ptr DH_)+                     -> FunPtr PemPasswordCallback'+                     -> Ptr ()+                     -> IO (Ptr DH_)++writeDHParams' :: BIO -> DHP -> IO ()+writeDHParams' bio dh+    = withBioPtr bio $ \ bioPtr ->+      withDHPPtr dh  $ \ dhPtr ->+        _write_bio_DH bioPtr dhPtr >>= failIf_ (/= 1)++-- |@'writeDHParams' dh@ writes DH parameters to PEM string.+writeDHParams :: DHP -> IO String+writeDHParams dh+    = do mem <- newMem+         writeDHParams' mem dh+         bioRead mem++readDHParams' :: BIO -> IO DHP+readDHParams' bio+    = withBioPtr bio $ \ bioPtr ->+      withCString "" $ \ passPtr ->+        _read_bio_DH bioPtr nullPtr nullFunPtr (castPtr passPtr)+          >>= failIfNull+          >>= wrapDHPPtr++-- |@'readDHParams' pem@ reads DH parameters in PEM string.+readDHParams :: String -> IO DHP+readDHParams pemStr+    = newConstMem pemStr >>= readDHParams'+  withBS :: B8.ByteString -> ((Ptr CChar, Int) -> IO t) -> IO t withBS passStr act =

@@ -1,4 +1,8 @@ {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE NamedFieldPuns #-} -- | Functions for handling SSL connections. These functions use GHC specific --   calls to cooperative the with the scheduler so that 'blocking' functions --   only actually block the Haskell thread, not a whole OS thread.@@ -21,15 +25,21 @@      -- * SSL connections   , SSL+  , SSLResult(..)   , connection   , fdConnection   , accept+  , tryAccept   , connect+  , tryConnect   , read+  , tryRead   , write+  , tryWrite   , lazyRead   , lazyWrite   , shutdown+  , tryShutdown   , ShutdownType(..)   , getPeerCertificate   , getVerifyResult@@ -50,14 +60,20 @@  #include "openssl/ssl.h" -import Prelude hiding (catch, read, ioError)+import Prelude hiding (catch, read, ioError, mapM, mapM_) import Control.Concurrent (threadWaitWrite, threadWaitRead) import Control.Concurrent.QSem import Control.Exception-import Control.Monad+import Control.Applicative ((<$>), (<$))+import Control.Monad (void, unless) import Data.Typeable-import Foreign+import Data.Foldable (Foldable, mapM_, forM_)+import Data.Traversable (Traversable, mapM, forM)+import Data.Maybe (fromMaybe)+import Data.IORef+import Foreign hiding (void) import Foreign.C+import qualified Foreign.Concurrent as FC import qualified Data.ByteString as B import qualified Data.ByteString.Internal as B import qualified Data.ByteString.Unsafe as B@@ -73,6 +89,10 @@ import OpenSSL.X509 (X509, X509_, wrapX509, withX509Ptr) import OpenSSL.X509.Store +type VerifyCb = Bool -> Ptr X509_STORE_CTX -> IO Bool++foreign import ccall "wrapper" mkVerifyCb :: VerifyCb -> IO (FunPtr VerifyCb)+ data SSLContext_ -- | An SSL context. Contexts carry configuration such as a server's private --   key, root CA certiifcates etc. Contexts are stateful IO objects; they@@ -83,32 +103,37 @@ --   Contexts are not thread safe so they carry a QSem with them which only --   lets a single thread work inside them at a time. Thus, one must always use --   withContext, not withForeignPtr directly.-newtype SSLContext = SSLContext (QSem, ForeignPtr SSLContext_)+data SSLContext = SSLContext { ctxSem  :: QSem+                             , ctxPtr  :: ForeignPtr SSLContext_+                             , ctxVfCb :: IORef (Maybe (FunPtr VerifyCb))+                             }  data SSLMethod_  foreign import ccall unsafe "SSL_CTX_new" _ssl_ctx_new :: Ptr SSLMethod_ -> IO (Ptr SSLContext_)-foreign import ccall unsafe "&SSL_CTX_free" _ssl_ctx_free :: FunPtr (Ptr SSLContext_ -> IO ())+foreign import ccall unsafe "SSL_CTX_free" _ssl_ctx_free :: Ptr SSLContext_ -> IO () foreign import ccall unsafe "SSLv23_method" _ssl_method :: IO (Ptr SSLMethod_)  -- | Create a new SSL context. context :: IO SSLContext context = do-  ctx <- _ssl_method >>= _ssl_ctx_new-  context <- newForeignPtr _ssl_ctx_free ctx-  sem <- newQSem 1-  return $ SSLContext (sem, context)+  ctx   <- _ssl_method >>= _ssl_ctx_new+  cbRef <- newIORef Nothing+  ptr   <- FC.newForeignPtr ctx $ do+    _ssl_ctx_free ctx+    readIORef cbRef >>= mapM_ freeHaskellFunPtr+  sem   <- newQSem 1+  return $ SSLContext { ctxSem = sem, ctxPtr = ptr, ctxVfCb = cbRef }  -- | Run the given action with the raw context pointer and obtain the lock --   while doing so. withContext :: SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a-withContext (SSLContext (sem, ctxfp)) action = do-  waitQSem sem-  finally (withForeignPtr ctxfp action) $ signalQSem sem+withContext (SSLContext {ctxSem, ctxPtr}) action = do+  waitQSem ctxSem+  finally (withForeignPtr ctxPtr action) $ signalQSem ctxSem  touchContext :: SSLContext -> IO ()-touchContext (SSLContext (_, fp))-    = touchForeignPtr fp+touchContext = touchForeignPtr . ctxPtr  contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt)                 -> SSLContext -> String -> IO ()@@ -190,22 +215,29 @@                       | VerifyPeer {                           vpFailIfNoPeerCert :: Bool  -- ^ is a certificate required                         , vpClientOnce       :: Bool  -- ^ only request once per connection+                        , vpCallback         :: Maybe (Bool -> X509StoreCtx -> IO Bool) -- ^ optional callback                         }  foreign import ccall unsafe "SSL_CTX_set_verify"-   _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> Ptr () -> IO ()+   _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> FunPtr VerifyCb -> IO ()  contextSetVerificationMode :: SSLContext -> VerificationMode -> IO () contextSetVerificationMode context VerifyNone =   withContext context $ \ctx ->-    _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullPtr >> return ()+    void $ _ssl_set_verify_mode ctx (#const SSL_VERIFY_NONE) nullFunPtr -contextSetVerificationMode context (VerifyPeer reqp oncep) = do+contextSetVerificationMode context (VerifyPeer reqp oncep cbp) = do   let mode = (#const SSL_VERIFY_PEER) .|.              (if reqp then (#const SSL_VERIFY_FAIL_IF_NO_PEER_CERT) else 0) .|.              (if oncep then (#const SSL_VERIFY_CLIENT_ONCE) else 0)-  withContext context $ \ctx ->-    _ssl_set_verify_mode ctx mode nullPtr >> return ()+  withContext context $ \ctx -> do+    let cbRef = ctxVfCb context+    newCb <- mapM mkVerifyCb $ (<$> cbp) $ \cb pvf pStoreCtx ->+      cb pvf =<< wrapX509StoreCtx (return ()) pStoreCtx+    oldCb <- readIORef cbRef+    writeIORef cbRef newCb+    forM_ oldCb freeHaskellFunPtr+    void $ _ssl_set_verify_mode ctx mode $ fromMaybe nullFunPtr newCb  foreign import ccall unsafe "SSL_CTX_load_verify_locations"   _ssl_load_verify_locations :: Ptr SSLContext_ -> Ptr CChar -> Ptr CChar -> IO CInt@@ -253,7 +285,11 @@ --   times. Thus multiple OS threads can be 'blocked' inside IO in the same SSL --   object at a time, because they aren't really in the SSL object, they are --   waiting for the RTS to wake the Haskell thread.-newtype SSL = SSL (QSem, ForeignPtr SSL_, Fd, Maybe Socket)+data SSL = SSL { sslSem    :: QSem+               , sslPtr    :: ForeignPtr SSL_+               , sslFd     :: Fd+               , sslSocket :: Maybe Socket+               }  foreign import ccall unsafe "SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_) foreign import ccall unsafe "&SSL_free" _ssl_free :: FunPtr (Ptr SSL_ -> IO ())@@ -267,7 +303,11 @@     _ssl_set_fd ssl fdInt     return ssl   fpssl <- newForeignPtr _ssl_free ssl-  return $ SSL (sem, fpssl, fd, sock)+  return $ SSL { sslSem    = sem+               , sslPtr    = fpssl+               , sslFd     = fd+               , sslSocket = sock+               }  -- | Wrap a Socket in an SSL connection. Reading and writing to the Socket --   after this will cause weird errors in the SSL code. The SSL object@@ -282,9 +322,9 @@ fdConnection context fd = connection' context fd Nothing  withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a-withSSL (SSL (sem, ssl, _, _)) action = do-  waitQSem sem-  finally (withForeignPtr ssl action) $ signalQSem sem+withSSL (SSL {sslSem, sslPtr}) action = do+  waitQSem sslSem+  finally (withForeignPtr sslPtr action) $ signalQSem sslSem  foreign import ccall "SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt foreign import ccall "SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt@@ -302,41 +342,55 @@ -- | 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.-data SSLIOResult = Done CInt  -- ^ successfully mananged *n* bytes+data SSLResult a = SSLDone a  -- ^ operation finished successfully                  | WantRead  -- ^ needs more data from the network                  | WantWrite  -- ^ needs more outgoing buffer space-                 deriving (Eq)+                 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  -- | 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.-sslDoHandshake :: (Ptr SSL_ -> IO CInt) -> SSL -> IO CInt-sslDoHandshake action ssl@(SSL (_, _, fd, _)) = do-  let f ssl = do-        n <- action ssl-        case n of-             n | n >= 0 -> return $ Done n-             _ -> 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-  result <- withSSL ssl f-  case result of-       Done n -> return n-       WantRead -> threadWaitRead fd >> sslDoHandshake action ssl-       WantWrite -> threadWaitWrite fd >> sslDoHandshake action ssl+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  -- | Perform an SSL server handshake accept :: SSL -> IO ()-accept ssl = sslDoHandshake _ssl_accept ssl >>= failIf_ (/= 1)+accept = sslBlock tryAccept +-- | 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)+ -- | Perform an SSL client handshake connect :: SSL -> IO ()-connect ssl = sslDoHandshake _ssl_connect ssl >>= failIf_ (/= 1)+connect = sslBlock tryConnect +-- | 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)+ 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 @@ -353,11 +407,11 @@            -> Ptr CChar  -- ^ the buffer to pass            -> Int  -- ^ the length to pass            -> Ptr SSL_-           -> IO SSLIOResult+           -> IO (SSLResult CInt) sslIOInner f ptr nbytes ssl = do   n <- f ssl (castPtr ptr) $ fromIntegral nbytes   case n of-       n | n > 0 -> return $ Done $ fromIntegral n+       n | n > 0 -> return $ SSLDone $ fromIntegral n          | n == 0 -> do            shutdown <- _ssl_get_shutdown ssl            if shutdown .&. (#const SSL_RECEIVED_SHUTDOWN) == 0@@ -370,38 +424,43 @@                 (#const SSL_ERROR_WANT_WRITE) -> return WantWrite                 _ -> throwSSLException err --- | Try the read the given number of bytes from an SSL connection. On EOF an+catchEOF :: a -> IO a -> IO a+catchEOF x m = m `catch` \e -> if isEOFError e then return x else throwIO e++-- | 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@(SSL (_, _, fd, _)) nbytes = B.createAndTrim nbytes $ f ssl-    where-      f ssl ptr-          = do result <- withSSL ssl $ sslIOInner _ssl_read (castPtr ptr) nbytes-               case result of-                 Done n -> return $ fromIntegral n-                 WantRead -> threadWaitRead fd >> f ssl ptr-                 WantWrite -> threadWaitWrite fd >> f ssl ptr-            `catch`-            \ ioe ->-                if isEOFError ioe then-                    return 0-                else-                    ioError ioe -- rethrow+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 +-- | 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+ 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 write :: SSL -> B.ByteString -> IO ()-write ssl@(SSL (_, _, fd, _)) bs = B.unsafeUseAsCStringLen bs $ f ssl where-  f ssl (ptr, len) = do-    result <- withSSL ssl $ sslIOInner _ssl_write ptr len-    case result of-         Done _ -> return ()-         WantRead -> threadWaitRead fd >> f ssl (ptr, len)-         WantWrite -> threadWaitWrite fd >> f ssl (ptr, len)+write ssl bs = void $ sslBlock (`tryWrite` bs) ssl +-- | 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+ -- | Lazily read all data until reaching EOF. If the connection dies --   without a graceful SSL shutdown, an exception is raised. lazyRead :: SSL -> IO L.ByteString@@ -439,13 +498,19 @@ --   This can either just send a shutdown, or can send and wait for the peer's --   shutdown message. shutdown :: SSL -> ShutdownType -> IO ()-shutdown ssl ty = do-  n <- sslDoHandshake _ssl_shutdown ssl-  case ty of-       Unidirectional -> return ()-       Bidirectional  -> unless (n == 1)-                             $ shutdown ssl ty+shutdown ssl ty = sslBlock (`tryShutdown` ty) ssl +-- | 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+ foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_)  -- | After a successful connection, get the certificate of the other party. If@@ -477,11 +542,9 @@  -- | Get the socket underlying an SSL connection sslSocket :: SSL -> Maybe Socket-sslSocket (SSL (_, _, _, socket)) = socket  -- | Get the underlying socket Fd sslFd :: SSL -> Fd-sslFd (SSL (_, _, fd, _)) = fd  -- | The root exception type for all SSL exceptions. data SomeSSLException

@@ -39,6 +39,7 @@      , getRevokedList     , addRevoked+    , getRevoked     )     where @@ -119,6 +120,10 @@ foreign import ccall unsafe "X509_CRL_add0_revoked"         _add0_revoked :: Ptr X509_CRL -> Ptr X509_REVOKED -> IO CInt +foreign import ccall unsafe "X509_CRL_get0_by_serial"+        _get0_by_serial :: Ptr X509_CRL -> Ptr (Ptr X509_REVOKED)+                        -> Ptr ASN1_INTEGER -> IO CInt+ foreign import ccall unsafe "X509_CRL_sort"         _sort :: Ptr X509_CRL -> IO CInt @@ -278,17 +283,16 @@ getRevokedList :: CRL -> IO [RevokedCertificate] getRevokedList crl     = withCRLPtr crl $ \ crlPtr ->-      (_get_REVOKED crlPtr >>= mapStack peekRevoked)-    where-      peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate-      peekRevoked rev-          = do serial <- peekASN1Integer =<< (#peek X509_REVOKED, serialNumber  ) rev-               date   <- peekASN1Time    =<< (#peek X509_REVOKED, revocationDate) rev-               return RevokedCertificate {-                            revSerialNumber   = serial-                          , revRevocationDate = date-                          }+        _get_REVOKED crlPtr >>= mapStack peekRevoked +peekRevoked :: Ptr X509_REVOKED -> IO RevokedCertificate+peekRevoked rev = do+  serial <- peekASN1Integer =<< (#peek X509_REVOKED, serialNumber  ) rev+  date   <- peekASN1Time    =<< (#peek X509_REVOKED, revocationDate) rev+  return RevokedCertificate { revSerialNumber   = serial+                            , revRevocationDate = date+                            }+ newRevoked :: RevokedCertificate -> IO (Ptr X509_REVOKED) newRevoked revoked     = do revPtr  <- _new_revoked@@ -315,10 +319,19 @@            1 -> return ()            _ -> freeRevoked revPtr >> raiseOpenSSLError +-- |@'getRevoked' crl serial@ looks up the corresponding revocation.+getRevoked :: CRL -> Integer -> IO (Maybe RevokedCertificate)+getRevoked crl serial =+  withCRLPtr crl  $ \crlPtr ->+  alloca          $ \revPtr ->+  withASN1Integer serial $ \serialPtr -> do+    r <- _get0_by_serial crlPtr revPtr serialPtr+    if r == 1+      then fmap Just $ peek revPtr >>= peekRevoked+      else return Nothing+ -- |@'sortCRL' crl@ sorts the certificates in the revocation list. sortCRL :: CRL -> IO () sortCRL crl     = withCRLPtr crl $ \ crlPtr ->-      _sort crlPtr-           >>= failIf (/= 1)-           >>  return ()+        _sort crlPtr >>= failIf_ (/= 1)

@@ -15,15 +15,22 @@      , addCertToStore     , addCRLToStore++    , X509StoreCtx+    , X509_STORE_CTX -- private++    , withX509StoreCtxPtr -- private+    , wrapX509StoreCtx -- private     )     where -import           Foreign-import           Foreign.C-import           Foreign.Concurrent as FC-import           OpenSSL.X509-import           OpenSSL.X509.Revocation-import           OpenSSL.Utils+import Control.Applicative ((<$>))+import Foreign+import Foreign.C+import Foreign.Concurrent as FC+import OpenSSL.X509+import OpenSSL.X509.Revocation+import OpenSSL.Utils  -- |@'X509Store'@ is an opaque object that represents X.509 -- certificate store. The certificate store is usually used for chain@@ -77,3 +84,14 @@       _add_crl storePtr crlPtr            >>= failIf (/= 1)            >>  return ()++data    X509_STORE_CTX+newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX)++withX509StoreCtxPtr :: X509StoreCtx -> (Ptr X509_STORE_CTX -> IO a) -> IO a+withX509StoreCtxPtr (X509StoreCtx fp) = withForeignPtr fp++wrapX509StoreCtx :: IO () -> Ptr X509_STORE_CTX -> IO X509StoreCtx+wrapX509StoreCtx finaliser ptr =+  X509StoreCtx <$> FC.newForeignPtr ptr finaliser+

@@ -105,6 +105,16 @@ }  +/* DH *************************************************************************/+BIGNUM *HsOpenSSL_DH_get_pub_key(DH *dh) {+    return dh->pub_key;+}++int HsOpenSSL_DH_length(DH *dh) {+    return BN_num_bits(dh->p);+}++ /* ASN1 ***********************************************************************/ ASN1_INTEGER* HsOpenSSL_M_ASN1_INTEGER_new() {     return M_ASN1_INTEGER_new();