Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

file 147 lines (113 sloc) 4.665 kb
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147
{- -*- haskell -*- -}

{-# OPTIONS_HADDOCK prune #-}

-- |An interface to X.509 certificate store.

module OpenSSL.X509.Store
    ( X509Store
    , X509_STORE -- private

    , newX509Store

    , wrapX509Store -- private
    , withX509StorePtr -- private

    , addCertToStore
    , addCRLToStore

    , X509StoreCtx
    , X509_STORE_CTX -- private

    , 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
-- certificate store. The certificate store is usually used for chain
-- verification.
newtype X509Store = X509Store (ForeignPtr X509_STORE)
data X509_STORE


foreign import ccall unsafe "X509_STORE_new"
        _new :: IO (Ptr X509_STORE)

foreign import ccall unsafe "X509_STORE_free"
        _free :: Ptr X509_STORE -> IO ()

foreign import ccall unsafe "X509_STORE_add_cert"
        _add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt

foreign import ccall unsafe "X509_STORE_add_crl"
        _add_crl :: Ptr X509_STORE -> Ptr X509_CRL -> IO CInt

-- |@'newX509Store'@ creates an empty X.509 certificate store.
newX509Store :: IO X509Store
newX509Store = _new
               >>= failIfNull
               >>= \ ptr -> wrapX509Store (_free ptr) ptr

wrapX509Store :: IO () -> Ptr X509_STORE -> IO X509Store
wrapX509Store finaliser ptr
    = do fp <- newForeignPtr_ ptr
         FC.addForeignPtrFinalizer fp finaliser
         return $ X509Store fp

withX509StorePtr :: X509Store -> (Ptr X509_STORE -> IO a) -> IO a
withX509StorePtr (X509Store store)
    = withForeignPtr store

-- |@'addCertToStore' store cert@ adds a certificate to store.
addCertToStore :: X509Store -> X509 -> IO ()
addCertToStore store cert
    = withX509StorePtr store $ \ storePtr ->
      withX509Ptr cert $ \ certPtr ->
      _add_cert storePtr certPtr
           >>= failIf (/= 1)
           >> return ()

-- |@'addCRLToStore' store crl@ adds a revocation list to store.
addCRLToStore :: X509Store -> CRL -> IO ()
addCRLToStore store crl
    = withX509StorePtr store $ \ storePtr ->
      withCRLPtr crl $ \ crlPtr ->
      _add_crl storePtr crlPtr
           >>= failIf (/= 1)
           >> return ()

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 "HsOpenSSL_X509_STORE_CTX_get0_current_issuer"
  _store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_)

foreign import ccall unsafe "HsOpenSSL_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
Something went wrong with that request. Please try again.