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
148
149
150
151
152
153
|
{-# LANGUAGE EmptyDataDecls #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE CApiFFI #-}
{-# 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
#include "HsOpenSSL.h"
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
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 {-# CTYPE "openssl/x509.h" "X509_STORE" #-} X509_STORE
foreign import capi unsafe "openssl/x509.h X509_STORE_new"
_new :: IO (Ptr X509_STORE)
foreign import capi unsafe "openssl/x509.h X509_STORE_free"
_free :: Ptr X509_STORE -> IO ()
foreign import capi unsafe "openssl/x509.h X509_STORE_add_cert"
_add_cert :: Ptr X509_STORE -> Ptr X509_ -> IO CInt
foreign import capi unsafe "openssl/x509.h 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 {-# CTYPE "openssl/x509.h" "X509_STORE_CTX" #-} X509_STORE_CTX
newtype X509StoreCtx = X509StoreCtx (ForeignPtr X509_STORE_CTX)
foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get_current_cert"
_store_ctx_get_current_cert :: Ptr X509_STORE_CTX -> IO (Ptr X509_)
foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_STORE_CTX_get0_current_issuer"
_store_ctx_get0_current_issuer :: Ptr X509_STORE_CTX -> IO (Ptr X509_)
foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_STORE_CTX_get0_current_crl"
_store_ctx_get0_current_crl :: Ptr X509_STORE_CTX -> IO (Ptr X509_CRL)
#if OPENSSL_VERSION_NUMBER >= 0x10100000L
foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get1_chain"
_store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)
#else
foreign import capi unsafe "openssl/x509.h X509_STORE_CTX_get_chain"
_store_ctx_get_chain :: Ptr X509_STORE_CTX -> IO (Ptr STACK)
#endif
foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_X509_ref"
_x509_ref :: Ptr X509_ -> IO ()
foreign import capi unsafe "HsOpenSSL.h 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
|
