forked from depressed-pho/HsOpenSSL
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Session.hsc
602 lines (524 loc) · 23.8 KB
/
Session.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
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveFoldable #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE NamedFieldPuns #-}
-- | Functions for handling SSL connections. These functions use GHC specific
-- calls to cooperative the with the scheduler so that 'blocking' functions
-- only actually block the Haskell thread, not a whole OS thread.
module OpenSSL.Session
( -- * Contexts
SSLContext
, context
, contextSetPrivateKey
, contextSetCertificate
, contextSetPrivateKeyFile
, contextSetCertificateFile
, contextSetCiphers
, contextSetDefaultCiphers
, contextCheckPrivateKey
, VerificationMode(..)
, contextSetVerificationMode
, contextSetCAFile
, contextSetCADirectory
, contextGetCAStore
-- * SSL connections
, SSL
, SSLResult(..)
, connection
, fdConnection
, accept
, tryAccept
, connect
, tryConnect
, read
, tryRead
, write
, tryWrite
, lazyRead
, lazyWrite
, shutdown
, tryShutdown
, ShutdownType(..)
, getPeerCertificate
, getVerifyResult
, sslSocket
, sslFd
-- * SSL Exceptions
, SomeSSLException
, ConnectionAbruptlyTerminated
, ProtocolError(..)
) where
#include "openssl/ssl.h"
import Prelude hiding (catch, read, ioError, mapM, mapM_)
import Control.Concurrent (threadWaitWrite, threadWaitRead, runInBoundThread)
import Control.Concurrent.QSem
import Control.Exception
import Control.Applicative ((<$>), (<$))
import Control.Monad (unless)
import Data.Typeable
import Data.Foldable (Foldable, mapM_, forM_)
import Data.Traversable (Traversable, mapM)
import Data.Maybe (fromMaybe)
import Data.IORef
import Foreign
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
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L
import System.IO.Unsafe
import System.Posix.Types (Fd(..))
import Network.Socket (Socket(..))
import OpenSSL.ERR
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Internal
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
-- start empty and various options are set on them by the functions in this
-- module. Note that an empty context will pretty much cause any operation to
-- fail since it doesn't even have any ciphers enabled.
--
-- 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.
data SSLContext = SSLContext { ctxSem :: QSem
, ctxPtr :: ForeignPtr SSLContext_
, ctxVfCb :: IORef (Maybe (FunPtr VerifyCb))
}
deriving Typeable
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 :: 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
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 {ctxSem, ctxPtr}) action = do
waitQSem ctxSem
finally (withForeignPtr ctxPtr action) $ signalQSem ctxSem
touchContext :: SSLContext -> IO ()
touchContext = touchForeignPtr . ctxPtr
contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt)
-> SSLContext -> String -> IO ()
contextLoadFile f context path =
withContext context $ \ctx ->
withCString path $ \cpath -> do
result <- f ctx cpath (#const SSL_FILETYPE_PEM)
unless (result == 1)
$ f ctx cpath (#const SSL_FILETYPE_ASN1) >>= failIf_ (/= 1)
foreign import ccall unsafe "SSL_CTX_use_PrivateKey"
_ssl_ctx_use_privatekey :: Ptr SSLContext_ -> Ptr EVP_PKEY -> IO CInt
foreign import ccall unsafe "SSL_CTX_use_certificate"
_ssl_ctx_use_certificate :: Ptr SSLContext_ -> Ptr X509_ -> IO CInt
-- | Install a private key into a context.
contextSetPrivateKey :: KeyPair k => SSLContext -> k -> IO ()
contextSetPrivateKey context key
= withContext context $ \ ctx ->
withPKeyPtr' key $ \ keyPtr ->
_ssl_ctx_use_privatekey ctx keyPtr
>>= failIf_ (/= 1)
-- | Install a certificate (public key) into a context.
contextSetCertificate :: SSLContext -> X509 -> IO ()
contextSetCertificate context cert
= withContext context $ \ ctx ->
withX509Ptr cert $ \ certPtr ->
_ssl_ctx_use_certificate ctx certPtr
>>= failIf_ (/= 1)
foreign import ccall unsafe "SSL_CTX_use_PrivateKey_file"
_ssl_ctx_use_privatekey_file :: Ptr SSLContext_ -> CString -> CInt -> IO CInt
foreign import ccall unsafe "SSL_CTX_use_certificate_file"
_ssl_ctx_use_certificate_file :: Ptr SSLContext_ -> CString -> CInt -> IO CInt
-- | Install a private key file in a context. The key is given as a path to the
-- file which contains the key. The file is parsed first as PEM and, if that
-- fails, as ASN1. If both fail, an exception is raised.
contextSetPrivateKeyFile :: SSLContext -> FilePath -> IO ()
contextSetPrivateKeyFile = contextLoadFile _ssl_ctx_use_privatekey_file
-- | Install a certificate (public key) file in a context. The key is given as
-- a path to the file which contains the key. The file is parsed first as PEM
-- and, if that fails, as ASN1. If both fail, an exception is raised.
contextSetCertificateFile :: SSLContext -> FilePath -> IO ()
contextSetCertificateFile = contextLoadFile _ssl_ctx_use_certificate_file
foreign import ccall unsafe "SSL_CTX_set_cipher_list"
_ssl_ctx_set_cipher_list :: Ptr SSLContext_ -> CString -> IO CInt
-- | Set the ciphers to be used by the given context. The string argument is a
-- list of ciphers, comma separated, as given at
-- http://www.openssl.org/docs/apps/ciphers.html
--
-- Unrecognised ciphers are ignored. If no ciphers from the list are
-- recognised, an exception is raised.
contextSetCiphers :: SSLContext -> String -> IO ()
contextSetCiphers context list =
withContext context $ \ctx ->
withCString list $ \cpath ->
_ssl_ctx_set_cipher_list ctx cpath >>= failIf_ (/= 1)
contextSetDefaultCiphers :: SSLContext -> IO ()
contextSetDefaultCiphers = flip contextSetCiphers "DEFAULT"
foreign import ccall unsafe "SSL_CTX_check_private_key"
_ssl_ctx_check_private_key :: Ptr SSLContext_ -> IO CInt
-- | Return true iff the private key installed in the given context matches the
-- certificate also installed.
contextCheckPrivateKey :: SSLContext -> IO Bool
contextCheckPrivateKey context =
withContext context $ \ctx ->
fmap (== 1) (_ssl_ctx_check_private_key ctx)
-- | See <http://www.openssl.org/docs/ssl/SSL_CTX_set_verify.html>
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
}
deriving Typeable
foreign import ccall unsafe "SSL_CTX_set_verify"
_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) nullFunPtr >> return ()
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
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
_ssl_set_verify_mode ctx mode $ fromMaybe nullFunPtr newCb
return ()
foreign import ccall unsafe "SSL_CTX_load_verify_locations"
_ssl_load_verify_locations :: Ptr SSLContext_ -> Ptr CChar -> Ptr CChar -> IO CInt
-- | Set the location of a PEM encoded list of CA certificates to be used when
-- verifying a server's certificate
contextSetCAFile :: SSLContext -> FilePath -> IO ()
contextSetCAFile context path =
withContext context $ \ctx ->
withCString path $ \cpath ->
_ssl_load_verify_locations ctx cpath nullPtr >>= failIf_ (/= 1)
-- | Set the path to a directory which contains the PEM encoded CA root
-- certificates. This is an alternative to 'contextSetCAFile'. See
-- <http://www.openssl.org/docs/ssl/SSL_CTX_load_verify_locations.html> for
-- details of the file naming scheme
contextSetCADirectory :: SSLContext -> FilePath -> IO ()
contextSetCADirectory context path =
withContext context $ \ctx ->
withCString path $ \cpath ->
_ssl_load_verify_locations ctx nullPtr cpath >>= failIf_ (/= 1)
foreign import ccall unsafe "SSL_CTX_get_cert_store"
_ssl_get_cert_store :: Ptr SSLContext_ -> IO (Ptr X509_STORE)
-- | Get a reference to, not a copy of, the X.509 certificate storage
-- in the SSL context.
contextGetCAStore :: SSLContext -> IO X509Store
contextGetCAStore context
= withContext context $ \ ctx ->
_ssl_get_cert_store ctx
>>= wrapX509Store (touchContext context)
data SSL_
-- | This is the type of an SSL connection
--
-- SSL objects are not thread safe, so they carry a QSem around with them
-- which only lets a single thread work inside them at a time. Thus, one must
-- always use withSSL, rather than withForeignPtr directly.
--
-- IO with SSL objects is non-blocking and many SSL functions return a error
-- code which signifies that it needs to read or write more data. We handle
-- these calls and call threadWaitRead and threadWaitWrite at the correct
-- times. Thus multiple OS threads can be 'blocked' inside IO in the same SSL
-- object at a time, because they aren't really in the SSL object, they are
-- waiting for the RTS to wake the Haskell thread.
data SSL = SSL { sslSem :: QSem
, sslPtr :: ForeignPtr SSL_
, sslFd :: Fd -- ^ Get the underlying socket Fd
, sslSocket :: Maybe Socket -- ^ Get the socket underlying an SSL connection
}
deriving Typeable
foreign import ccall unsafe "SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_)
foreign import ccall unsafe "&SSL_free" _ssl_free :: FunPtr (Ptr SSL_ -> IO ())
foreign import ccall unsafe "SSL_set_fd" _ssl_set_fd :: Ptr SSL_ -> CInt -> IO ()
connection' :: SSLContext -> Fd -> Maybe Socket -> IO SSL
connection' context fd@(Fd fdInt) sock = do
sem <- newQSem 1
ssl <- withContext context $ \ctx -> do
ssl <- _ssl_new ctx >>= failIfNull
_ssl_set_fd ssl fdInt
return ssl
fpssl <- newForeignPtr _ssl_free ssl
return $ SSL { sslSem = sem
, sslPtr = fpssl
, sslFd = fd
, sslSocket = sock
}
-- | Wrap a Socket in an SSL connection. Reading and writing to the Socket
-- after this will cause weird errors in the SSL code. The SSL object
-- carries a handle to the Socket so you need not worry about the garbage
-- collector closing the file descriptor out from under you.
connection :: SSLContext -> Socket -> IO SSL
connection context sock@(MkSocket fd _ _ _ _) =
connection' context (Fd fd) (Just sock)
-- | Wrap a socket Fd in an SSL connection.
fdConnection :: SSLContext -> Fd -> IO SSL
fdConnection context fd = connection' context fd Nothing
withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL (SSL {sslSem, sslPtr}) action = do
waitQSem sslSem
finally (withForeignPtr sslPtr action) $ signalQSem sslSem
foreign import ccall "SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt
foreign import ccall "SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt
foreign import ccall unsafe "SSL_get_error" _ssl_get_error :: Ptr SSL_ -> CInt -> IO CInt
throwSSLException :: String -> CInt -> IO a
throwSSLException loc ret
= do e <- getError
if e == 0 then
case ret of
0 -> throwIO ConnectionAbruptlyTerminated
_ -> throwErrno loc
else
errorString e >>= throwIO . ProtocolError
-- | This is the type of an SSL IO operation. Errors are handled by
-- exceptions while everything else is one of these. Note that reading
-- from an SSL socket can result in WantWrite and vice versa.
data SSLResult a = SSLDone a -- ^ operation finished successfully
| WantRead -- ^ needs more data from the network
| WantWrite -- ^ needs more outgoing buffer space
deriving (Eq, Show, Functor, Foldable, Traversable, Typeable)
-- | Block until the operation is finished.
sslBlock :: (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock action ssl
= do result <- action ssl
case result of
SSLDone r -> return r
WantRead -> threadWaitRead (sslFd ssl) >> sslBlock action ssl
WantWrite -> threadWaitWrite (sslFd ssl) >> sslBlock action ssl
-- | Perform an SSL operation which can return non-blocking error codes, thus
-- requesting that the operation be performed when data or buffer space is
-- availible.
sslTryHandshake :: String
-> (Ptr SSL_ -> IO CInt)
-> SSL
-> IO (SSLResult CInt)
sslTryHandshake loc action ssl
= runInBoundThread $
withSSL ssl $ \sslPtr ->
do n <- action sslPtr
if n == 1 then
return $ SSLDone n
else
do err <- _ssl_get_error sslPtr n
case err of
(#const SSL_ERROR_WANT_READ ) -> return WantRead
(#const SSL_ERROR_WANT_WRITE) -> return WantWrite
_ -> throwSSLException loc n
-- | Perform an SSL server handshake
accept :: SSL -> IO ()
accept = sslBlock tryAccept
-- | Try to perform an SSL server handshake without blocking
tryAccept :: SSL -> IO (SSLResult ())
tryAccept ssl
= (() <$) <$> sslTryHandshake "SSL_accept" _ssl_accept ssl
-- | Perform an SSL client handshake
connect :: SSL -> IO ()
connect = sslBlock tryConnect
-- | Try to perform an SSL client handshake without blocking
tryConnect :: SSL -> IO (SSLResult ())
tryConnect ssl
= (() <$) <$> sslTryHandshake "SSL_connect" _ssl_connect ssl
foreign import ccall "SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
foreign import ccall unsafe "SSL_get_shutdown" _ssl_get_shutdown :: Ptr SSL_ -> IO CInt
-- | Perform an SSL operation which operates of a buffer and can return
-- non-blocking error codes, thus requesting that it be performed again when
-- more data or buffer space is available.
--
-- Note that these SSL functions generally require that the arguments to the
-- repeated call be exactly the same. This presents an issue because multiple
-- threads could try writing at the same time (with different buffers) so the
-- calling function should probably hold the lock on the SSL object over the
-- whole time (include repeated calls)
sslIOInner :: String -- ^ the name of SSL IO function to call
-> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt) -- ^ the SSL IO function to call
-> Ptr CChar -- ^ the buffer to pass
-> Int -- ^ the length to pass
-> SSL
-> IO (SSLResult CInt)
sslIOInner loc f ptr nbytes ssl
= runInBoundThread $
withSSL ssl $ \sslPtr ->
do n <- f sslPtr (castPtr ptr) $ fromIntegral nbytes
if n > 0 then
return $ SSLDone $ fromIntegral n
else
do err <- _ssl_get_error sslPtr n
case err of
(#const SSL_ERROR_ZERO_RETURN) -> return $ SSLDone $ 0
(#const SSL_ERROR_WANT_READ ) -> return WantRead
(#const SSL_ERROR_WANT_WRITE ) -> return WantWrite
_ -> throwSSLException loc n
-- | Try to read the given number of bytes from an SSL connection. On EOF an
-- empty ByteString is returned. If the connection dies without a graceful
-- SSL shutdown, an exception is raised.
read :: SSL -> Int -> IO B.ByteString
read ssl nBytes = sslBlock (`tryRead` nBytes) ssl
-- | Try to read the given number of bytes from an SSL connection
-- without blocking.
tryRead :: SSL -> Int -> IO (SSLResult B.ByteString)
tryRead ssl nBytes
= do (bs, result) <- B.createAndTrim' nBytes $ \bufPtr ->
do result <- sslIOInner "SSL_read" _ssl_read (castPtr bufPtr) nBytes ssl
case result of
SSLDone n -> return (0, fromIntegral n, SSLDone ())
WantRead -> return (0, 0, WantRead )
WantWrite -> return (0, 0, WantWrite )
return $ bs <$ result
foreign import ccall "SSL_write" _ssl_write :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
-- | Write a given ByteString to the SSL connection. Either all the data is
-- written or an exception is raised because of an error.
write :: SSL -> B.ByteString -> IO ()
write ssl bs = sslBlock (`tryWrite` bs) ssl >> return ()
-- | Try to write a given ByteString to the SSL connection without blocking.
tryWrite :: SSL -> B.ByteString -> IO (SSLResult ())
tryWrite ssl bs
| B.null bs = return $ SSLDone ()
| otherwise
= B.unsafeUseAsCStringLen bs $ \(ptr, len) ->
do result <- sslIOInner "SSL_write" _ssl_write ptr len ssl
case result of
SSLDone 0 -> ioError $ errnoToIOError "SSL_write" ePIPE Nothing Nothing
SSLDone _ -> return $ SSLDone ()
WantRead -> return WantRead
WantWrite -> return WantWrite
-- | Lazily read all data until reaching EOF. If the connection dies
-- without a graceful SSL shutdown, an exception is raised.
lazyRead :: SSL -> IO L.ByteString
lazyRead ssl = fmap L.fromChunks lazyRead'
where
chunkSize = L.defaultChunkSize
lazyRead' = unsafeInterleaveIO loop
loop = do bs <- read ssl chunkSize
if B.null bs then
-- got EOF
return []
else
do bss <- lazyRead'
return (bs:bss)
-- | Write a lazy ByteString to the SSL connection. In contrast to
-- 'write', there is a chance that the string is written partway and
-- then an exception is raised for an error. The string doesn't
-- necessarily have to be finite.
lazyWrite :: SSL -> L.ByteString -> IO ()
lazyWrite ssl lbs
= mapM_ (write ssl) $ L.toChunks lbs
foreign import ccall "SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt
data ShutdownType = Bidirectional -- ^ wait for the peer to also shutdown
| Unidirectional -- ^ only send our shutdown
deriving (Eq, Show, Typeable)
-- | Cleanly shutdown an SSL connection. Note that SSL has a concept of a
-- secure shutdown, which is distinct from just closing the TCP connection.
-- This performs the former and should always be preferred.
--
-- This can either just send a shutdown, or can send and wait for the peer's
-- shutdown message.
shutdown :: SSL -> ShutdownType -> IO ()
shutdown ssl ty = sslBlock (`tryShutdown` ty) ssl
-- | Try to cleanly shutdown an SSL connection without blocking.
tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ())
tryShutdown ssl ty
= runInBoundThread $
withSSL ssl $ \sslPtr ->
do n <- _ssl_shutdown sslPtr
case n of
1 -> return $ SSLDone ()
0 -> if ty == Bidirectional then
tryShutdown ssl ty
else
return $ SSLDone ()
_ -> do err <- _ssl_get_error sslPtr n
case err of
(#const SSL_ERROR_WANT_READ ) -> return WantRead
(#const SSL_ERROR_WANT_WRITE) -> return WantWrite
-- SSL_ERROR_SYSCALL/-1 happens when we are
-- trying to send the remote peer a "close
-- notify" alert but the underlying socket was
-- closed at the time. We don't treat this an
-- error /if and only if/ we have already
-- received a "close notify" from the peer.
(#const SSL_ERROR_SYSCALL)
-> do sd <- _ssl_get_shutdown sslPtr
if sd .&. (#const SSL_RECEIVED_SHUTDOWN) == 0 then
throwSSLException "SSL_shutdown" n
else
return $ SSLDone ()
_ -> throwSSLException "SSL_shutdown" n
foreign import ccall "SSL_get_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_)
-- | After a successful connection, get the certificate of the other party. If
-- this is a server connection, you probably won't get a certificate unless
-- you asked for it with contextSetVerificationMode
getPeerCertificate :: SSL -> IO (Maybe X509)
getPeerCertificate ssl =
withSSL ssl $ \ssl -> do
cert <- _ssl_get_peer_cert ssl
if cert == nullPtr
then return Nothing
else fmap Just (wrapX509 cert)
foreign import ccall "SSL_get_verify_result" _ssl_get_verify_result :: Ptr SSL_ -> IO CLong
-- | Get the result of verifing the peer's certificate. This is mostly for
-- clients to verify the certificate of the server that they have connected
-- it. You must set a list of root CA certificates with contextSetCA... for
-- this to make sense.
--
-- Note that this returns True iff the peer's certificate has a valid chain
-- to a root CA. You also need to check that the certificate is correct (i.e.
-- has the correct hostname in it) with getPeerCertificate.
getVerifyResult :: SSL -> IO Bool
getVerifyResult ssl =
withSSL ssl $ \ssl -> do
r <- _ssl_get_verify_result ssl
return $ r == (#const X509_V_OK)
-- | The root exception type for all SSL exceptions.
data SomeSSLException
= forall e. Exception e => SomeSSLException e
deriving Typeable
instance Show SomeSSLException where
show (SomeSSLException e) = show e
instance Exception SomeSSLException
sslExceptionToException :: Exception e => e -> SomeException
sslExceptionToException = toException . SomeSSLException
sslExceptionFromException :: Exception e => SomeException -> Maybe e
sslExceptionFromException x
= do SomeSSLException a <- fromException x
cast a
-- | The peer uncleanly terminated the connection without sending the
-- \"close notify\" alert.
data ConnectionAbruptlyTerminated
= ConnectionAbruptlyTerminated
deriving (Typeable, Show, Eq)
instance Exception ConnectionAbruptlyTerminated where
toException = sslExceptionToException
fromException = sslExceptionFromException
-- | A failure in the SSL library occurred, usually a protocol
-- error.
data ProtocolError
= ProtocolError !String
deriving (Typeable, Show, Eq)
instance Exception ProtocolError where
toException = sslExceptionToException
fromException = sslExceptionFromException