Merge pull request #12 from mvv/x509-store-ctx

Bindings to some of the X509_STORE_CTX functions.

OpenSSL/Session.hsc

@@ -231,7 +231,7 @@ 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 -> do
+  withContext context $ \ctx -> mask_ $ do
     let cbRef = ctxVfCb context
     newCb <- mapM mkVerifyCb $ (<$> cbp) $ \cb pvf pStoreCtx ->
       cb pvf =<< wrapX509StoreCtx (return ()) pStoreCtx

OpenSSL/X509/Store.hsc

@@ -21,15 +21,22 @@ module OpenSSL.X509.Store
 
     , withX509StoreCtxPtr -- private
     , wrapX509StoreCtx -- private
+
+    , getStoreCtxCert
+    , getStoreCtxIssuer
+    , getStoreCtxCRL
+    , getStoreCtxChain
     )
     where
 
 import Control.Applicative ((<$>))
+import Control.Exception (throwIO, mask_)
 import Foreign
 import Foreign.C
 import Foreign.Concurrent as FC
 import OpenSSL.X509
 import OpenSSL.X509.Revocation
+import OpenSSL.Stack
 import OpenSSL.Utils
 
 -- |@'X509Store'@ is an opaque object that represents X.509
@@ -88,10 +95,54 @@ addCRLToStore store crl
 data    X509_STORE_CTX
 newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX)
 
+foreign import ccall unsafe "X509_STORE_CTX_get_current_cert"
+  _store_ctx_get_current_cert :: Ptr X509_STORE_CTX -> IO (Ptr X509_)
+
+foreign import ccall unsafe "X509_STORE_CTX_get0_current_issuer"
+  _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_)
+
+foreign import ccall unsafe "X509_STORE_CTX_get0_current_crl"
+  _store_ctx_get0_current_crl :: Ptr X509_STORE_CTX -> IO (Ptr X509_CRL)
+
+foreign import ccall unsafe "X509_STORE_CTX_get_chain"
+  _store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)
+
+foreign import ccall unsafe "HsOpenSSL_X509_ref"
+  _x509_ref :: Ptr X509_ -> IO ()
+
+foreign import ccall unsafe "HsOpenSSL_X509_CRL_ref"
+  _crl_ref :: Ptr X509_CRL -> IO ()
+
 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
 
+getStoreCtxCert :: X509StoreCtx -> IO X509
+getStoreCtxCert ctx = withX509StoreCtxPtr ctx $ \pCtx -> do
+  pCert <- _store_ctx_get_current_cert pCtx
+  if pCert == nullPtr
+    then throwIO $ userError "BUG: NULL certificate in X509_STORE_CTX"
+    else mask_ $ _x509_ref pCert >> wrapX509 pCert
+
+getStoreCtxIssuer :: X509StoreCtx -> IO (Maybe X509)
+getStoreCtxIssuer ctx = withX509StoreCtxPtr ctx $ \pCtx -> do
+  pCert <- _store_ctx_get0_current_issuer pCtx
+  if pCert == nullPtr
+    then return Nothing
+    else fmap Just $ mask_ $ _x509_ref pCert >> wrapX509 pCert
+
+getStoreCtxCRL :: X509StoreCtx -> IO (Maybe CRL)
+getStoreCtxCRL ctx = withX509StoreCtxPtr ctx $ \pCtx -> do
+  pCrl <- _store_ctx_get0_current_crl pCtx
+  if pCrl == nullPtr
+    then return Nothing
+    else fmap Just $ mask_ $ _crl_ref pCrl >> wrapCRL pCrl
+
+getStoreCtxChain :: X509StoreCtx -> IO [X509]
+getStoreCtxChain ctx = withX509StoreCtxPtr ctx $ \pCtx -> do
+  stack <- _store_ctx_get_chain pCtx
+  (`mapStack` stack) $ \pCert -> mask_ $ _x509_ref pCert >> wrapX509 pCert
+

cbits/HsOpenSSL.c

@@ -103,6 +103,13 @@ STACK_OF(X509_REVOKED)* HsOpenSSL_X509_CRL_get_REVOKED(X509_CRL* crl) {
     return X509_CRL_get_REVOKED(crl);
 }
 
+void HsOpenSSL_X509_ref(X509* x509) {
+    CRYPTO_add(&x509->references, 1, CRYPTO_LOCK_X509);
+}
+
+void HsOpenSSL_X509_CRL_ref(X509_CRL* crl) {
+    CRYPTO_add(&crl->references, 1, CRYPTO_LOCK_X509_CRL);
+}
 
 /* PKCS#7 *********************************************************************/
 long HsOpenSSL_PKCS7_is_detached(PKCS7* pkcs7) {