forked from depressed-pho/HsOpenSSL
/
X509.hsc
379 lines (309 loc) · 11.6 KB
/
X509.hsc
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
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
{- -*- haskell -*- -}
{-# OPTIONS_HADDOCK prune #-}
-- |An interface to X.509 certificate.
module OpenSSL.X509
( -- * Type
X509
, X509_
-- * Functions to manipulate certificate
, newX509
, wrapX509 -- private
, withX509Ptr -- private
, withX509Stack -- private
, unsafeX509ToPtr -- private
, touchX509 -- private
, compareX509
, signX509
, verifyX509
, printX509
-- * Accessors
, getVersion
, setVersion
, getSerialNumber
, setSerialNumber
, getIssuerName
, setIssuerName
, getSubjectName
, setSubjectName
, getNotBefore
, setNotBefore
, getNotAfter
, setNotAfter
, getPublicKey
, setPublicKey
, getSubjectEmail
)
where
import Control.Monad
import Data.Time.Clock
import Data.Maybe
import Foreign hiding (unsafeForeignPtrToPtr)
import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr)
import Foreign.C
import OpenSSL.ASN1
import OpenSSL.BIO
import OpenSSL.EVP.Digest hiding (digest)
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Verify
import OpenSSL.EVP.Internal
import OpenSSL.Utils
import OpenSSL.Stack
import OpenSSL.X509.Name
-- |@'X509'@ is an opaque object that represents X.509 certificate.
newtype X509 = X509 (ForeignPtr X509_)
data X509_
foreign import ccall unsafe "X509_new"
_new :: IO (Ptr X509_)
foreign import ccall unsafe "&X509_free"
_free :: FunPtr (Ptr X509_ -> IO ())
foreign import ccall unsafe "X509_print"
_print :: Ptr BIO_ -> Ptr X509_ -> IO CInt
foreign import ccall unsafe "X509_cmp"
_cmp :: Ptr X509_ -> Ptr X509_ -> IO CInt
foreign import ccall unsafe "HsOpenSSL_X509_get_version"
_get_version :: Ptr X509_ -> IO CLong
foreign import ccall unsafe "X509_set_version"
_set_version :: Ptr X509_ -> CLong -> IO CInt
foreign import ccall unsafe "X509_get_serialNumber"
_get_serialNumber :: Ptr X509_ -> IO (Ptr ASN1_INTEGER)
foreign import ccall unsafe "X509_set_serialNumber"
_set_serialNumber :: Ptr X509_ -> Ptr ASN1_INTEGER -> IO CInt
foreign import ccall unsafe "X509_get_issuer_name"
_get_issuer_name :: Ptr X509_ -> IO (Ptr X509_NAME)
foreign import ccall unsafe "X509_set_issuer_name"
_set_issuer_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt
foreign import ccall unsafe "X509_get_subject_name"
_get_subject_name :: Ptr X509_ -> IO (Ptr X509_NAME)
foreign import ccall unsafe "X509_set_subject_name"
_set_subject_name :: Ptr X509_ -> Ptr X509_NAME -> IO CInt
foreign import ccall unsafe "HsOpenSSL_X509_get_notBefore"
_get_notBefore :: Ptr X509_ -> IO (Ptr ASN1_TIME)
foreign import ccall unsafe "X509_set_notBefore"
_set_notBefore :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt
foreign import ccall unsafe "HsOpenSSL_X509_get_notAfter"
_get_notAfter :: Ptr X509_ -> IO (Ptr ASN1_TIME)
foreign import ccall unsafe "X509_set_notAfter"
_set_notAfter :: Ptr X509_ -> Ptr ASN1_TIME -> IO CInt
foreign import ccall unsafe "X509_get_pubkey"
_get_pubkey :: Ptr X509_ -> IO (Ptr EVP_PKEY)
foreign import ccall unsafe "X509_set_pubkey"
_set_pubkey :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt
foreign import ccall unsafe "X509_get1_email"
_get1_email :: Ptr X509_ -> IO (Ptr STACK)
foreign import ccall unsafe "X509_email_free"
_email_free :: Ptr STACK -> IO ()
foreign import ccall unsafe "X509_sign"
_sign :: Ptr X509_ -> Ptr EVP_PKEY -> Ptr EVP_MD -> IO CInt
foreign import ccall unsafe "X509_verify"
_verify :: Ptr X509_ -> Ptr EVP_PKEY -> IO CInt
-- |@'newX509'@ creates an empty certificate. You must set the
-- following properties to and sign it (see 'signX509') to actually
-- use the certificate.
--
-- [/Version/] See 'setVersion'.
--
-- [/Serial number/] See 'setSerialNumber'.
--
-- [/Issuer name/] See 'setIssuerName'.
--
-- [/Subject name/] See 'setSubjectName'.
--
-- [/Validity/] See 'setNotBefore' and 'setNotAfter'.
--
-- [/Public Key/] See 'setPublicKey'.
--
newX509 :: IO X509
newX509 = _new >>= failIfNull >>= wrapX509
wrapX509 :: Ptr X509_ -> IO X509
wrapX509 = fmap X509 . newForeignPtr _free
withX509Ptr :: X509 -> (Ptr X509_ -> IO a) -> IO a
withX509Ptr (X509 x509) = withForeignPtr x509
withX509Stack :: [X509] -> (Ptr STACK -> IO a) -> IO a
withX509Stack = withForeignStack unsafeX509ToPtr touchX509
unsafeX509ToPtr :: X509 -> Ptr X509_
unsafeX509ToPtr (X509 x509) = unsafeForeignPtrToPtr x509
touchX509 :: X509 -> IO ()
touchX509 (X509 x509) = touchForeignPtr x509
-- |@'compareX509' cert1 cert2@ compares two certificates.
compareX509 :: X509 -> X509 -> IO Ordering
compareX509 cert1 cert2
= withX509Ptr cert1 $ \ cert1Ptr ->
withX509Ptr cert2 $ \ cert2Ptr ->
fmap interpret (_cmp cert1Ptr cert2Ptr)
where
interpret :: CInt -> Ordering
interpret n
| n > 0 = GT
| n < 0 = LT
| otherwise = EQ
-- |@'signX509'@ signs a certificate with an issuer private key.
signX509 :: KeyPair key =>
X509 -- ^ The certificate to be signed.
-> key -- ^ The private key to sign with.
-> Maybe Digest -- ^ A hashing algorithm to use. If @Nothing@
-- the most suitable algorithm for the key
-- is automatically used.
-> IO ()
signX509 x509 key mDigest
= withX509Ptr x509 $ \ x509Ptr ->
withPKeyPtr' key $ \ pkeyPtr ->
do digest <- case mDigest of
Just md -> return md
Nothing -> pkeyDefaultMD key
withMDPtr digest $ \ digestPtr ->
_sign x509Ptr pkeyPtr digestPtr
>>= failIf_ (== 0)
return ()
-- |@'verifyX509'@ verifies a signature of certificate with an issuer
-- public key.
verifyX509 :: PublicKey key =>
X509 -- ^ The certificate to be verified.
-> key -- ^ The public key to verify with.
-> IO VerifyStatus
verifyX509 x509 key
= withX509Ptr x509 $ \ x509Ptr ->
withPKeyPtr' key $ \ pkeyPtr ->
_verify x509Ptr pkeyPtr
>>= interpret
where
interpret :: CInt -> IO VerifyStatus
interpret 1 = return VerifySuccess
interpret 0 = return VerifyFailure
interpret _ = raiseOpenSSLError
-- |@'printX509' cert@ translates a certificate into human-readable
-- format.
printX509 :: X509 -> IO String
printX509 x509
= do mem <- newMem
withX509Ptr x509 $ \ x509Ptr ->
withBioPtr mem $ \ memPtr ->
_print memPtr x509Ptr
>>= failIf_ (/= 1)
bioRead mem
-- |@'getVersion' cert@ returns the version number of certificate. It
-- seems the number is 0-origin: version 2 means X.509 v3.
getVersion :: X509 -> IO Int
getVersion x509
= withX509Ptr x509 $ \ x509Ptr ->
liftM fromIntegral $ _get_version x509Ptr
-- |@'setVersion' cert ver@ updates the version number of certificate.
setVersion :: X509 -> Int -> IO ()
setVersion x509 ver
= withX509Ptr x509 $ \ x509Ptr ->
_set_version x509Ptr (fromIntegral ver)
>>= failIf (/= 1)
>> return ()
-- |@'getSerialNumber' cert@ returns the serial number of certificate.
getSerialNumber :: X509 -> IO Integer
getSerialNumber x509
= withX509Ptr x509 $ \ x509Ptr ->
_get_serialNumber x509Ptr
>>= peekASN1Integer
-- |@'setSerialNumber' cert num@ updates the serial number of
-- certificate.
setSerialNumber :: X509 -> Integer -> IO ()
setSerialNumber x509 serial
= withX509Ptr x509 $ \ x509Ptr ->
withASN1Integer serial $ \ serialPtr ->
_set_serialNumber x509Ptr serialPtr
>>= failIf (/= 1)
>> return ()
-- |@'getIssuerName'@ returns the issuer name of certificate.
getIssuerName :: X509 -- ^ The certificate to examine.
-> Bool -- ^ @True@ if you want the keys of each parts
-- to be of long form (e.g. \"commonName\"),
-- or @False@ if you don't (e.g. \"CN\").
-> IO [(String, String)] -- ^ Pairs of key and value,
-- for example \[(\"C\",
-- \"JP\"), (\"ST\",
-- \"Some-State\"), ...\].
getIssuerName x509 wantLongName
= withX509Ptr x509 $ \ x509Ptr ->
do namePtr <- _get_issuer_name x509Ptr
peekX509Name namePtr wantLongName
-- |@'setIssuerName' cert name@ updates the issuer name of
-- certificate. Keys of each parts may be of either long form or short
-- form. See 'getIssuerName'.
setIssuerName :: X509 -> [(String, String)] -> IO ()
setIssuerName x509 issuer
= withX509Ptr x509 $ \ x509Ptr ->
withX509Name issuer $ \ namePtr ->
_set_issuer_name x509Ptr namePtr
>>= failIf (/= 1)
>> return ()
-- |@'getSubjectName' cert wantLongName@ returns the subject name of
-- certificate. See 'getIssuerName'.
getSubjectName :: X509 -> Bool -> IO [(String, String)]
getSubjectName x509 wantLongName
= withX509Ptr x509 $ \ x509Ptr ->
do namePtr <- _get_subject_name x509Ptr
peekX509Name namePtr wantLongName
-- |@'setSubjectName' cert name@ updates the subject name of
-- certificate. See 'setIssuerName'.
setSubjectName :: X509 -> [(String, String)] -> IO ()
setSubjectName x509 subject
= withX509Ptr x509 $ \ x509Ptr ->
withX509Name subject $ \ namePtr ->
_set_subject_name x509Ptr namePtr
>>= failIf (/= 1)
>> return ()
-- |@'getNotBefore' cert@ returns the time when the certificate begins
-- to be valid.
getNotBefore :: X509 -> IO UTCTime
getNotBefore x509
= withX509Ptr x509 $ \ x509Ptr ->
_get_notBefore x509Ptr
>>= peekASN1Time
-- |@'setNotBefore' cert utc@ updates the time when the certificate
-- begins to be valid.
setNotBefore :: X509 -> UTCTime -> IO ()
setNotBefore x509 utc
= withX509Ptr x509 $ \ x509Ptr ->
withASN1Time utc $ \ time ->
_set_notBefore x509Ptr time
>>= failIf (/= 1)
>> return ()
-- |@'getNotAfter' cert@ returns the time when the certificate
-- expires.
getNotAfter :: X509 -> IO UTCTime
getNotAfter x509
= withX509Ptr x509 $ \ x509Ptr ->
_get_notAfter x509Ptr
>>= peekASN1Time
-- |@'setNotAfter' cert utc@ updates the time when the certificate
-- expires.
setNotAfter :: X509 -> UTCTime -> IO ()
setNotAfter x509 utc
= withX509Ptr x509 $ \ x509Ptr ->
withASN1Time utc $ \ time ->
_set_notAfter x509Ptr time
>>= failIf (/= 1)
>> return ()
-- |@'getPublicKey' cert@ returns the public key of the subject of
-- certificate.
getPublicKey :: X509 -> IO SomePublicKey
getPublicKey x509
= withX509Ptr x509 $ \ x509Ptr ->
fmap fromJust ( _get_pubkey x509Ptr
>>= failIfNull
>>= wrapPKeyPtr
>>= fromPKey
)
-- |@'setPublicKey' cert pubkey@ updates the public key of the subject
-- of certificate.
setPublicKey :: PublicKey key => X509 -> key -> IO ()
setPublicKey x509 key
= withX509Ptr x509 $ \ x509Ptr ->
withPKeyPtr' key $ \ pkeyPtr ->
_set_pubkey x509Ptr pkeyPtr
>>= failIf (/= 1)
>> return ()
-- |@'getSubjectEmail' cert@ returns every subject email addresses in
-- the certificate.
getSubjectEmail :: X509 -> IO [String]
getSubjectEmail x509
= withX509Ptr x509 $ \ x509Ptr ->
do st <- _get1_email x509Ptr
list <- mapStack peekCString st
_email_free st
return list