Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Browse files

Added optional verification callback to VerifyPeer.

Ignore-this: 4fa4e32f9f51aef5fd770731f7878852

darcs-hash:20110730123828-3a530-80fb40014b8f22af2b18f4dd0cba8115e49849c1.gz
  • Loading branch information...
commit bd47ae334c248b87df0684979029599b675de92a 1 parent a2a77f8
@mvv mvv authored
Showing with 63 additions and 26 deletions.
  1. +38 −19 OpenSSL/Session.hsc
  2. +25 −7 OpenSSL/X509/Store.hsc
View
57 OpenSSL/Session.hsc
@@ -60,17 +60,20 @@ module OpenSSL.Session
#include "openssl/ssl.h"
-import Prelude hiding (catch, read, ioError, mapM)
+import Prelude hiding (catch, read, ioError, mapM, mapM_)
import Control.Concurrent (threadWaitWrite, threadWaitRead)
import Control.Concurrent.QSem
import Control.Exception
import Control.Applicative ((<$>), (<$))
import Control.Monad (void, unless)
import Data.Typeable
-import Data.Foldable (Foldable)
-import Data.Traversable (Traversable, forM)
+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
@@ -86,6 +89,10 @@ import OpenSSL.Utils
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
@@ -96,32 +103,37 @@ data SSLContext_
-- 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 ()
@@ -203,22 +215,29 @@ data VerificationMode = VerifyNone
| 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
View
32 OpenSSL/X509/Store.hsc
@@ -15,15 +15,22 @@ module OpenSSL.X509.Store
, 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
@@ -76,4 +83,15 @@ addCRLToStore store crl
withCRLPtr crl $ \ crlPtr ->
_add_crl storePtr crlPtr
>>= failIf (/= 1)
- >> return ()
+ >> 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
+
Please sign in to comment.
Something went wrong with that request. Please try again.