{-# LINE 1 "OpenSSL/Session.hsc" #-}
{-# LANGUAGE DeriveDataTypeable          #-}
{-# LANGUAGE DeriveFunctor               #-}
{-# LANGUAGE DeriveFoldable              #-}
{-# LANGUAGE DeriveTraversable           #-}
{-# LANGUAGE EmptyDataDecls              #-}
{-# LANGUAGE ExistentialQuantification   #-}
{-# LANGUAGE ForeignFunctionInterface    #-}
{-# LANGUAGE CApiFFI                     #-}
{-# LANGUAGE NamedFieldPuns              #-}
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-- | 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
  , contextAddOption
  , contextRemoveOption
  , contextSetPrivateKey
  , contextSetCertificate
  , contextSetPrivateKeyFile
  , contextSetCertificateFile
  , contextSetCertificateChainFile
  , contextSetCiphers
  , contextSetDefaultCiphers
  , contextCheckPrivateKey
  , VerificationMode(..)
  , contextSetVerificationMode
  , contextSetDefaultVerifyPaths
  , contextSetCAFile
  , contextSetCADirectory
  , contextGetCAStore
  , contextSetSessionIdContext
  , contextSetALPNProtos
  , withContextSetKeylogCallback

    -- * SSL connections
  , SSL
  , SSLResult(..)
  , connection
  , fdConnection
  , addOption
  , removeOption
  , setTlsextHostName
  , enableHostnameValidation
  , accept
  , tryAccept
  , connect
  , tryConnect
  , read
  , tryRead
  , readPtr
  , tryReadPtr
  , write
  , tryWrite
  , writePtr
  , tryWritePtr
  , lazyRead
  , lazyWrite
  , shutdown
  , tryShutdown
  , ShutdownType(..)
  , getPeerCertificate
  , getVerifyResult
  , sslSocket
  , sslFd

    -- * Protocol Options
  , SSLOption(..)

    -- * SSL Exceptions
  , SomeSSLException
  , ConnectionAbruptlyTerminated
  , ProtocolError(..)

    -- * Direct access to OpenSSL objects
  , SSLContext_
  , withContext
  , SSL_
  , withSSL

  ) where



import Prelude hiding (

{-# LINE 91 "OpenSSL/Session.hsc" #-}
  read, ioError, mapM, mapM_)
import Control.Concurrent (threadWaitWrite, threadWaitRead, runInBoundThread)
import Control.Concurrent.MVar
import Control.Exception
import Control.Monad (unless)
import Data.Foldable (mapM_, forM_)
import Data.Traversable (mapM)
import Data.Typeable
import Data.Maybe (fromMaybe)
import Data.IORef
import Foreign
import Foreign.C
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(..))

{-# LINE 111 "OpenSSL/Session.hsc" #-}
import Network.Socket (Socket, withFdSocket)

{-# LINE 115 "OpenSSL/Session.hsc" #-}


{-# LINE 121 "OpenSSL/Session.hsc" #-}

import OpenSSL.ERR
import OpenSSL.EVP.PKey
import OpenSSL.EVP.Internal
import OpenSSL.SSL.Option
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 {-# CTYPE "openssl/ssl.h" "SSL_CTX" #-} 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.
data SSLContext = SSLContext { SSLContext -> MVar (Ptr SSLContext_)
ctxMVar :: MVar (Ptr SSLContext_)
                             , SSLContext -> IORef (Maybe (FunPtr VerifyCb))
ctxVfCb :: IORef (Maybe (FunPtr VerifyCb))
                             }
                deriving Typeable

data {-# CTYPE "openssl/ssl.h" "const SSL_METHOD" #-} SSLMethod_

foreign import capi unsafe "openssl/ssl.h SSL_CTX_new" _ssl_ctx_new :: Ptr SSLMethod_ -> IO (Ptr SSLContext_)
foreign import capi unsafe "openssl/ssl.h SSL_CTX_free" _ssl_ctx_free :: Ptr SSLContext_ -> IO ()

{-# LINE 150 "OpenSSL/Session.hsc" #-}
foreign import capi unsafe "openssl/ssl.h TLS_method" _ssl_method :: IO (Ptr SSLMethod_)

{-# LINE 154 "OpenSSL/Session.hsc" #-}

-- | Create a new SSL context.
context :: IO SSLContext
context :: IO SSLContext
context = IO SSLContext -> IO SSLContext
forall a. IO a -> IO a
mask_ (IO SSLContext -> IO SSLContext) -> IO SSLContext -> IO SSLContext
forall a b. (a -> b) -> a -> b
$ do
  Ptr SSLContext_
ctx   <- IO (Ptr SSLMethod_)
_ssl_method IO (Ptr SSLMethod_)
-> (Ptr SSLMethod_ -> IO (Ptr SSLContext_)) -> IO (Ptr SSLContext_)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr SSLMethod_ -> IO (Ptr SSLContext_)
_ssl_ctx_new IO (Ptr SSLContext_)
-> (Ptr SSLContext_ -> IO (Ptr SSLContext_))
-> IO (Ptr SSLContext_)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr SSLContext_ -> IO (Ptr SSLContext_)
forall a. Ptr a -> IO (Ptr a)
failIfNull
  IORef (Maybe (FunPtr VerifyCb))
cbRef <- Maybe (FunPtr VerifyCb) -> IO (IORef (Maybe (FunPtr VerifyCb)))
forall a. a -> IO (IORef a)
newIORef Maybe (FunPtr VerifyCb)
forall a. Maybe a
Nothing
  MVar (Ptr SSLContext_)
mvar  <- Ptr SSLContext_ -> IO (MVar (Ptr SSLContext_))
forall a. a -> IO (MVar a)
newMVar Ptr SSLContext_
ctx

{-# LINE 162 "OpenSSL/Session.hsc" #-}
  _     <- mkWeakMVar mvar

{-# LINE 166 "OpenSSL/Session.hsc" #-}
           $ do _ssl_ctx_free ctx
                readIORef cbRef >>= mapM_ freeHaskellFunPtr
  SSLContext -> IO SSLContext
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLContext -> IO SSLContext) -> SSLContext -> IO SSLContext
forall a b. (a -> b) -> a -> b
$ SSLContext { ctxMVar :: MVar (Ptr SSLContext_)
ctxMVar = MVar (Ptr SSLContext_)
mvar, ctxVfCb :: IORef (Maybe (FunPtr VerifyCb))
ctxVfCb = IORef (Maybe (FunPtr VerifyCb))
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 :: forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext = MVar (Ptr SSLContext_) -> (Ptr SSLContext_ -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (MVar (Ptr SSLContext_) -> (Ptr SSLContext_ -> IO a) -> IO a)
-> (SSLContext -> MVar (Ptr SSLContext_))
-> SSLContext
-> (Ptr SSLContext_ -> IO a)
-> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSLContext -> MVar (Ptr SSLContext_)
ctxMVar

touchContext :: SSLContext -> IO ()
touchContext :: SSLContext -> IO ()
touchContext = (IO Bool -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO Bool -> IO ())
-> (SSLContext -> IO Bool) -> SSLContext -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MVar (Ptr SSLContext_) -> IO Bool
forall a. MVar a -> IO Bool
isEmptyMVar (MVar (Ptr SSLContext_) -> IO Bool)
-> (SSLContext -> MVar (Ptr SSLContext_)) -> SSLContext -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSLContext -> MVar (Ptr SSLContext_)
ctxMVar

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_CTX_set_options"
    _SSL_CTX_set_options :: Ptr SSLContext_ -> CLong -> IO CLong

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_CTX_clear_options"
    _SSL_CTX_clear_options :: Ptr SSLContext_ -> CLong -> IO CLong

-- | Add a protocol option to the context.
contextAddOption :: SSLContext -> SSLOption -> IO ()
contextAddOption :: SSLContext -> SSLOption -> IO ()
contextAddOption SSLContext
ctx SSLOption
opt =
    SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
ctx ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctxPtr ->
        Ptr SSLContext_ -> CLong -> IO CLong
_SSL_CTX_set_options Ptr SSLContext_
ctxPtr (SSLOption -> CLong
forall a. Integral a => SSLOption -> a
optionToIntegral SSLOption
opt) IO CLong -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Remove a protocol option from the context.
contextRemoveOption :: SSLContext -> SSLOption -> IO ()
contextRemoveOption :: SSLContext -> SSLOption -> IO ()
contextRemoveOption SSLContext
ctx SSLOption
opt =
    SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
ctx ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctxPtr ->
        Ptr SSLContext_ -> CLong -> IO CLong
_SSL_CTX_clear_options Ptr SSLContext_
ctxPtr (SSLOption -> CLong
forall a. Integral a => SSLOption -> a
optionToIntegral SSLOption
opt) IO CLong -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt)
                -> SSLContext -> String -> IO ()
contextLoadFile :: (Ptr SSLContext_ -> CString -> CInt -> IO CInt)
-> SSLContext -> String -> IO ()
contextLoadFile Ptr SSLContext_ -> CString -> CInt -> IO CInt
f SSLContext
context String
path =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cpath -> do
      CInt
result <- Ptr SSLContext_ -> CString -> CInt -> IO CInt
f Ptr SSLContext_
ctx CString
cpath (CInt
1)
{-# LINE 202 "OpenSSL/Session.hsc" #-}
      unless (result == 1)
          $ f ctx cpath (2) >>= failIf_ (/= 1)
{-# LINE 204 "OpenSSL/Session.hsc" #-}

foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_PrivateKey"
    _ssl_ctx_use_privatekey :: Ptr SSLContext_ -> Ptr EVP_PKEY -> IO CInt
foreign import capi unsafe "openssl/ssl.h 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 :: forall k. KeyPair k => SSLContext -> k -> IO ()
contextSetPrivateKey SSLContext
context k
key
    = SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr SSLContext_
ctx    ->
      k -> (Ptr EVP_PKEY -> IO ()) -> IO ()
forall k a. PKey k => k -> (Ptr EVP_PKEY -> IO a) -> IO a
withPKeyPtr' k
key    ((Ptr EVP_PKEY -> IO ()) -> IO ())
-> (Ptr EVP_PKEY -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr EVP_PKEY
keyPtr ->
          Ptr SSLContext_ -> Ptr EVP_PKEY -> IO CInt
_ssl_ctx_use_privatekey Ptr SSLContext_
ctx Ptr EVP_PKEY
keyPtr
               IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

-- | Install a certificate (public key) into a context.
contextSetCertificate :: SSLContext -> X509 -> IO ()
contextSetCertificate :: SSLContext -> X509 -> IO ()
contextSetCertificate SSLContext
context X509
cert
    = SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr SSLContext_
ctx     ->
      X509 -> (Ptr X509_ -> IO ()) -> IO ()
forall a. X509 -> (Ptr X509_ -> IO a) -> IO a
withX509Ptr X509
cert    ((Ptr X509_ -> IO ()) -> IO ()) -> (Ptr X509_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ Ptr X509_
certPtr ->
          Ptr SSLContext_ -> Ptr X509_ -> IO CInt
_ssl_ctx_use_certificate Ptr SSLContext_
ctx Ptr X509_
certPtr
               IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_PrivateKey_file"
   _ssl_ctx_use_privatekey_file :: Ptr SSLContext_ -> CString -> CInt -> IO CInt
foreign import capi unsafe "openssl/ssl.h 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 :: SSLContext -> String -> IO ()
contextSetPrivateKeyFile = (Ptr SSLContext_ -> CString -> CInt -> IO CInt)
-> SSLContext -> String -> IO ()
contextLoadFile Ptr SSLContext_ -> CString -> CInt -> IO CInt
_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 :: SSLContext -> String -> IO ()
contextSetCertificateFile = (Ptr SSLContext_ -> CString -> CInt -> IO CInt)
-> SSLContext -> String -> IO ()
contextLoadFile Ptr SSLContext_ -> CString -> CInt -> IO CInt
_ssl_ctx_use_certificate_file

foreign import capi unsafe "openssl/ssl.h SSL_CTX_use_certificate_chain_file"
   _ssl_ctx_use_certificate_chain_file :: Ptr SSLContext_ -> CString -> IO CInt

-- | Install a certificate chain in a context. The certificates must be in PEM
-- format and must be sorted starting with the subject's certificate (actual
-- client or server certificate), followed by intermediate CA certificates if
-- applicable, and ending at the highest level (root) CA.
contextSetCertificateChainFile :: SSLContext -> FilePath -> IO ()
contextSetCertificateChainFile :: SSLContext -> String -> IO ()
contextSetCertificateChainFile SSLContext
context String
path =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cpath ->
      Ptr SSLContext_ -> CString -> IO CInt
_ssl_ctx_use_certificate_chain_file Ptr SSLContext_
ctx CString
cpath IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

foreign import capi unsafe "openssl/ssl.h 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
--   <https://www.openssl.org/docs/manmaster/man1/openssl-ciphers.html>.
--
--   Unrecognised ciphers are ignored. If no ciphers from the list are
--   recognised, an exception is raised.
contextSetCiphers :: SSLContext -> String -> IO ()
contextSetCiphers :: SSLContext -> String -> IO ()
contextSetCiphers SSLContext
context String
list =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
list ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cpath ->
      Ptr SSLContext_ -> CString -> IO CInt
_ssl_ctx_set_cipher_list Ptr SSLContext_
ctx CString
cpath IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

-- | Set the ciphers to "DEFAULT".
contextSetDefaultCiphers :: SSLContext -> IO ()
contextSetDefaultCiphers :: SSLContext -> IO ()
contextSetDefaultCiphers = (SSLContext -> String -> IO ()) -> String -> SSLContext -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip SSLContext -> String -> IO ()
contextSetCiphers String
"DEFAULT"

foreign import capi unsafe "openssl/ssl.h 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 :: SSLContext -> IO Bool
contextCheckPrivateKey SSLContext
context =
  SSLContext -> (Ptr SSLContext_ -> IO Bool) -> IO Bool
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO Bool) -> IO Bool)
-> (Ptr SSLContext_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    (CInt -> Bool) -> IO CInt -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1) (Ptr SSLContext_ -> IO CInt
_ssl_ctx_check_private_key Ptr SSLContext_
ctx)

-- | See <http://www.openssl.org/docs/ssl/SSL_CTX_set_verify.html>
data VerificationMode = VerifyNone
                      | VerifyPeer {
                          VerificationMode -> Bool
vpFailIfNoPeerCert :: Bool  -- ^ is a certificate required
                        , VerificationMode -> Bool
vpClientOnce       :: Bool  -- ^ only request once per connection
                        , VerificationMode -> Maybe (Bool -> X509StoreCtx -> IO Bool)
vpCallback         :: Maybe (Bool -> X509StoreCtx -> IO Bool) -- ^ optional callback
                        }
                      deriving Typeable

foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_verify"
   _ssl_set_verify_mode :: Ptr SSLContext_ -> CInt -> FunPtr VerifyCb -> IO ()

contextSetVerificationMode :: SSLContext -> VerificationMode -> IO ()
contextSetVerificationMode :: SSLContext -> VerificationMode -> IO ()
contextSetVerificationMode SSLContext
context VerificationMode
VerifyNone =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    Ptr SSLContext_ -> CInt -> FunPtr VerifyCb -> IO ()
_ssl_set_verify_mode Ptr SSLContext_
ctx (CInt
0) FunPtr VerifyCb
forall a. FunPtr a
nullFunPtr IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
{-# LINE 301 "OpenSSL/Session.hsc" #-}

contextSetVerificationMode SSLContext
context (VerifyPeer Bool
reqp Bool
oncep Maybe (Bool -> X509StoreCtx -> IO Bool)
cbp) = do
  let mode :: CInt
mode = (CInt
1) CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|.
{-# LINE 304 "OpenSSL/Session.hsc" #-}
             (if Bool
reqp then (CInt
2) else CInt
0) CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|.
{-# LINE 305 "OpenSSL/Session.hsc" #-}
             (if Bool
oncep then (CInt
4) else CInt
0)
{-# LINE 306 "OpenSSL/Session.hsc" #-}
  withContext context $ \ctx -> mask_ $ 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 capi unsafe "openssl/ssl.h SSL_CTX_set_default_verify_paths"
  _ssl_set_default_verify_paths :: Ptr SSLContext_ -> IO CInt

-- | Specifies that the default locations from which CA certificates are loaded
-- should be used. There is one default directory and one default file.
--
-- The default CA certificates directory is called "certs" in the default OpenSSL
-- directory. Alternatively the SSL_CERT_DIR environment variable can be defined
-- to override this location.
--
-- The default CA certificates file is called "cert.pem" in the default OpenSSL
-- directory. Alternatively the SSL_CERT_FILE environment
-- variable can be defined to override this location.
--
-- See <https://www.openssl.org/docs/manmaster/man3/SSL_CTX_set_default_verify_paths.html> for
-- more information.
contextSetDefaultVerifyPaths :: SSLContext -> IO ()
contextSetDefaultVerifyPaths :: SSLContext -> IO ()
contextSetDefaultVerifyPaths SSLContext
context =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    Ptr SSLContext_ -> IO CInt
_ssl_set_default_verify_paths Ptr SSLContext_
ctx IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

foreign import capi unsafe "openssl/ssl.h 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 :: SSLContext -> String -> IO ()
contextSetCAFile SSLContext
context String
path =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cpath ->
        Ptr SSLContext_ -> CString -> CString -> IO CInt
_ssl_load_verify_locations Ptr SSLContext_
ctx CString
cpath CString
forall a. Ptr a
nullPtr IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
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 :: SSLContext -> String -> IO ()
contextSetCADirectory SSLContext
context String
path =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
path ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \CString
cpath ->
        Ptr SSLContext_ -> CString -> CString -> IO CInt
_ssl_load_verify_locations Ptr SSLContext_
ctx CString
forall a. Ptr a
nullPtr CString
cpath IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

foreign import capi unsafe "openssl/ssl.h 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 :: SSLContext -> IO X509Store
contextGetCAStore SSLContext
context
    = SSLContext -> (Ptr SSLContext_ -> IO X509Store) -> IO X509Store
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO X509Store) -> IO X509Store)
-> (Ptr SSLContext_ -> IO X509Store) -> IO X509Store
forall a b. (a -> b) -> a -> b
$ \ Ptr SSLContext_
ctx ->
      Ptr SSLContext_ -> IO (Ptr X509_STORE)
_ssl_get_cert_store Ptr SSLContext_
ctx
           IO (Ptr X509_STORE)
-> (Ptr X509_STORE -> IO X509Store) -> IO X509Store
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> Ptr X509_STORE -> IO X509Store
wrapX509Store (SSLContext -> IO ()
touchContext SSLContext
context)

foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_session_id_context"
  _ssl_set_session_id_context :: Ptr SSLContext_ -> Ptr CChar -> CUInt -> IO CInt

-- | Set context within which session can be reused (server side only).
--
-- If client certificates are used and the session id context is not set,
-- attempts by the clients to reuse a session will make the handshake fail.
contextSetSessionIdContext :: SSLContext -> B.ByteString -> IO ()
contextSetSessionIdContext :: SSLContext -> ByteString -> IO ()
contextSetSessionIdContext SSLContext
context ByteString
idCtx =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx ->
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
idCtx ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CString
cIdCtx, Int
len) ->
        Ptr SSLContext_ -> CString -> CUInt -> IO CInt
_ssl_set_session_id_context Ptr SSLContext_
ctx CString
cIdCtx (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

foreign import capi unsafe "openssl/ssl.h SSL_CTX_set_alpn_protos"
  _ssl_set_alpn_protos :: Ptr SSLContext_ -> Ptr CChar -> CUInt -> IO CInt

contextSetALPNProtos :: SSLContext -> [B.ByteString] -> IO ()
contextSetALPNProtos :: SSLContext -> [ByteString] -> IO ()
contextSetALPNProtos SSLContext
context [ByteString]
protos =
  SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO ()) -> IO ())
-> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx -> do
    -- Protos need to be wire-format as documented here:
    -- https://www.openssl.org/docs/man1.0.2/man3/SSL_CTX_set_alpn_protos.html#NOTES
    let formattedProtos :: ByteString
formattedProtos = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (\ByteString
p -> Word8 -> ByteString -> ByteString
B.cons (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
p)) ByteString
p) [ByteString]
protos
    ByteString -> (CStringLen -> IO ()) -> IO ()
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
formattedProtos ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CString
cFormattedProtos, Int
len) ->
      -- This function breaks the convention of returning '1' for success:
      -- https://www.openssl.org/docs/man1.0.2/man3/SSL_CTX_set_alpn_protos.html#RETURN-VALUES
      Ptr SSLContext_ -> CString -> CUInt -> IO CInt
_ssl_set_alpn_protos Ptr SSLContext_
ctx CString
cFormattedProtos (Int -> CUInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
0)

type KeylogCb = Ptr SSL_ -> CString -> IO ()

foreign import ccall "wrapper" mkKeylogCb :: KeylogCb -> IO (FunPtr KeylogCb)

foreign import capi "openssl/ssl.h SSL_CTX_set_keylog_callback" _ssl_ctx_set_keylog_callback :: Ptr SSLContext_ -> FunPtr KeylogCb -> IO ()

-- | The key logging callback is called with a String "line". The line is a
-- string containing the key material in the format used by NSS for its
-- SSLKEYLOGFILE debugging output. To recreate that file, the key logging
-- callback should log line, followed by a newline.
--
-- FIXME: Not re-entrant (ignores previous callback and resets it to
-- nullFunPtr on exit)
withContextSetKeylogCallback :: SSLContext -> (String -> IO ()) -> IO a -> IO a
withContextSetKeylogCallback :: forall a. SSLContext -> (String -> IO ()) -> IO a -> IO a
withContextSetKeylogCallback SSLContext
context String -> IO ()
cb IO a
action = do
  -- There doesn't seem to be a way to go from 'Ptr SSL_' to 'SSL', so let's
  -- just ignore it in the haskell callback.
  IO (FunPtr KeylogCb)
-> (FunPtr KeylogCb -> IO ()) -> (FunPtr KeylogCb -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket
    (KeylogCb -> IO (FunPtr KeylogCb)
mkKeylogCb (KeylogCb -> IO (FunPtr KeylogCb))
-> KeylogCb -> IO (FunPtr KeylogCb)
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
_ssl CString
line -> (String -> IO ()
cb (String -> IO ()) -> IO String -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CString -> IO String
peekCString CString
line))
    (\FunPtr KeylogCb
cbPtr -> SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> FunPtr KeylogCb -> IO ())
-> FunPtr KeylogCb -> Ptr SSLContext_ -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr SSLContext_ -> FunPtr KeylogCb -> IO ()
_ssl_ctx_set_keylog_callback FunPtr KeylogCb
forall a. FunPtr a
nullFunPtr) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FunPtr KeylogCb -> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr FunPtr KeylogCb
cbPtr)
    (\FunPtr KeylogCb
cbPtr -> SSLContext -> (Ptr SSLContext_ -> IO ()) -> IO ()
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> FunPtr KeylogCb -> IO ())
-> FunPtr KeylogCb -> Ptr SSLContext_ -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Ptr SSLContext_ -> FunPtr KeylogCb -> IO ()
_ssl_ctx_set_keylog_callback FunPtr KeylogCb
cbPtr) IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO a
action)

data {-# CTYPE "openssl/ssl.h" "SSL" #-} SSL_
-- | This is the type of an SSL connection
--
--   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 { SSL -> SSLContext
sslCtx    :: SSLContext
               , SSL -> MVar (Ptr SSL_)
sslMVar   :: MVar (Ptr SSL_)
               , SSL -> Fd
sslFd     :: Fd -- ^ Get the underlying socket Fd
               , SSL -> Maybe Socket
sslSocket :: Maybe Socket -- ^ Get the socket underlying an SSL connection
               }
           deriving Typeable

foreign import capi unsafe "openssl/ssl.h SSL_new" _ssl_new :: Ptr SSLContext_ -> IO (Ptr SSL_)
foreign import capi unsafe "openssl/ssl.h SSL_free" _ssl_free :: Ptr SSL_ -> IO ()
foreign import capi unsafe "openssl/ssl.h SSL_set_fd" _ssl_set_fd :: Ptr SSL_ -> CInt -> IO ()

connection' :: SSLContext -> Fd -> Maybe Socket -> IO SSL
connection' :: SSLContext -> Fd -> Maybe Socket -> IO SSL
connection' SSLContext
context fd :: Fd
fd@(Fd CInt
fdInt) Maybe Socket
sock = do
  MVar (Ptr SSL_)
mvar <- IO (MVar (Ptr SSL_)) -> IO (MVar (Ptr SSL_))
forall a. IO a -> IO a
mask_ (IO (MVar (Ptr SSL_)) -> IO (MVar (Ptr SSL_)))
-> IO (MVar (Ptr SSL_)) -> IO (MVar (Ptr SSL_))
forall a b. (a -> b) -> a -> b
$ do
    Ptr SSL_
ssl <- SSLContext -> (Ptr SSLContext_ -> IO (Ptr SSL_)) -> IO (Ptr SSL_)
forall a. SSLContext -> (Ptr SSLContext_ -> IO a) -> IO a
withContext SSLContext
context ((Ptr SSLContext_ -> IO (Ptr SSL_)) -> IO (Ptr SSL_))
-> (Ptr SSLContext_ -> IO (Ptr SSL_)) -> IO (Ptr SSL_)
forall a b. (a -> b) -> a -> b
$ \Ptr SSLContext_
ctx -> do
      Ptr SSL_
ssl <- Ptr SSLContext_ -> IO (Ptr SSL_)
_ssl_new Ptr SSLContext_
ctx IO (Ptr SSL_) -> (Ptr SSL_ -> IO (Ptr SSL_)) -> IO (Ptr SSL_)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ptr SSL_ -> IO (Ptr SSL_)
forall a. Ptr a -> IO (Ptr a)
failIfNull
      Ptr SSL_ -> CInt -> IO ()
_ssl_set_fd Ptr SSL_
ssl CInt
fdInt
      Ptr SSL_ -> IO (Ptr SSL_)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Ptr SSL_
ssl
    MVar (Ptr SSL_)
mvar <- Ptr SSL_ -> IO (MVar (Ptr SSL_))
forall a. a -> IO (MVar a)
newMVar Ptr SSL_
ssl

{-# LINE 447 "OpenSSL/Session.hsc" #-}
    _    <- mkWeakMVar mvar $ _ssl_free ssl

{-# LINE 451 "OpenSSL/Session.hsc" #-}
    MVar (Ptr SSL_) -> IO (MVar (Ptr SSL_))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return MVar (Ptr SSL_)
mvar
  SSL -> IO SSL
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSL -> IO SSL) -> SSL -> IO SSL
forall a b. (a -> b) -> a -> b
$ SSL { sslCtx :: SSLContext
sslCtx    = SSLContext
context
               , sslMVar :: MVar (Ptr SSL_)
sslMVar   = MVar (Ptr SSL_)
mvar
               , sslFd :: Fd
sslFd     = Fd
fd
               , sslSocket :: Maybe Socket
sslSocket = Maybe Socket
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 :: SSLContext -> Socket -> IO SSL
connection SSLContext
context Socket
sock = do

{-# LINE 465 "OpenSSL/Session.hsc" #-}
  withFdSocket sock $ \ fd -> connection' context (Fd fd) (Just sock)

{-# LINE 474 "OpenSSL/Session.hsc" #-}

-- | Wrap a socket Fd in an SSL connection.
fdConnection :: SSLContext -> Fd -> IO SSL
fdConnection :: SSLContext -> Fd -> IO SSL
fdConnection SSLContext
context Fd
fd = SSLContext -> Fd -> Maybe Socket -> IO SSL
connection' SSLContext
context Fd
fd Maybe Socket
forall a. Maybe a
Nothing

-- | Run continuation with exclusive access to the underlying SSL object.
withSSL :: SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL :: forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL = MVar (Ptr SSL_) -> (Ptr SSL_ -> IO a) -> IO a
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar (MVar (Ptr SSL_) -> (Ptr SSL_ -> IO a) -> IO a)
-> (SSL -> MVar (Ptr SSL_)) -> SSL -> (Ptr SSL_ -> IO a) -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SSL -> MVar (Ptr SSL_)
sslMVar

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_set_options"
    _SSL_set_options :: Ptr SSL_ -> CLong -> IO CLong

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_clear_options"
    _SSL_clear_options :: Ptr SSL_ -> CLong -> IO CLong

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_SSL_set_tlsext_host_name"
    _SSL_set_tlsext_host_name :: Ptr SSL_ -> CString -> IO CLong

-- | Add a protocol option to the SSL connection.
addOption :: SSL -> SSLOption -> IO ()
addOption :: SSL -> SSLOption -> IO ()
addOption SSL
ssl SSLOption
opt =
    SSL -> (Ptr SSL_ -> IO ()) -> IO ()
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO ()) -> IO ()) -> (Ptr SSL_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
sslPtr ->
        Ptr SSL_ -> CLong -> IO CLong
_SSL_set_options Ptr SSL_
sslPtr (SSLOption -> CLong
forall a. Integral a => SSLOption -> a
optionToIntegral SSLOption
opt) IO CLong -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Remove a protocol option from the SSL connection.
removeOption :: SSL -> SSLOption -> IO ()
removeOption :: SSL -> SSLOption -> IO ()
removeOption SSL
ssl SSLOption
opt =
    SSL -> (Ptr SSL_ -> IO ()) -> IO ()
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO ()) -> IO ()) -> (Ptr SSL_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
sslPtr ->
        Ptr SSL_ -> CLong -> IO CLong
_SSL_clear_options Ptr SSL_
sslPtr (SSLOption -> CLong
forall a. Integral a => SSLOption -> a
optionToIntegral SSLOption
opt) IO CLong -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Set host name for Server Name Indication (SNI)
setTlsextHostName :: SSL -> String -> IO ()
setTlsextHostName :: SSL -> String -> IO ()
setTlsextHostName SSL
ssl String
h =
    SSL -> (Ptr SSL_ -> IO ()) -> IO ()
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO ()) -> IO ()) -> (Ptr SSL_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
sslPtr ->
    String -> (CString -> IO ()) -> IO ()
forall a. String -> (CString -> IO a) -> IO a
withCString String
h ((CString -> IO ()) -> IO ()) -> (CString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \ CString
hPtr ->
        Ptr SSL_ -> CString -> IO CLong
_SSL_set_tlsext_host_name Ptr SSL_
sslPtr CString
hPtr IO CLong -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- Hostname validation, inspired by https://wiki.openssl.org/index.php/Hostname_validation

foreign import capi unsafe "HsOpenSSL.h HsOpenSSL_enable_hostname_validation"
  _enable_hostname_validation :: Ptr SSL_ -> CString -> CSize -> IO CInt

-- | Enable hostname validation. Also see 'setTlsextHostName'.
--
-- This uses the built-in mechanism introduced in 1.0.2/1.1.0, and will
-- fail otherwise.
enableHostnameValidation :: SSL -> String -> IO ()
enableHostnameValidation :: SSL -> String -> IO ()
enableHostnameValidation SSL
ssl String
host =
  SSL -> (Ptr SSL_ -> IO ()) -> IO ()
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO ()) -> IO ()) -> (Ptr SSL_ -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
ssl ->
  String -> (CStringLen -> IO ()) -> IO ()
forall a. String -> (CStringLen -> IO a) -> IO a
withCStringLen String
host ((CStringLen -> IO ()) -> IO ()) -> (CStringLen -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(CString
host, Int
hostLen) ->
    Ptr SSL_ -> CString -> CSize -> IO CInt
_enable_hostname_validation Ptr SSL_
ssl CString
host (Int -> CSize
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hostLen) IO CInt -> (CInt -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (CInt -> Bool) -> CInt -> IO ()
forall a. (a -> Bool) -> a -> IO ()
failIf_ (CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
/= CInt
1)

foreign import capi "openssl/ssl.h SSL_accept" _ssl_accept :: Ptr SSL_ -> IO CInt
foreign import capi "openssl/ssl.h SSL_connect" _ssl_connect :: Ptr SSL_ -> IO CInt
foreign import capi unsafe "openssl/ssl.h SSL_get_error" _ssl_get_error :: Ptr SSL_ -> CInt -> IO CInt

throwSSLException :: String -> CInt -> CInt -> IO a
throwSSLException :: forall a. String -> CInt -> CInt -> IO a
throwSSLException String
loc CInt
sslErr CInt
ret
    = do CULong
e <- IO CULong
getError
         if CULong
e CULong -> CULong -> Bool
forall a. Eq a => a -> a -> Bool
== CULong
0 then
             case CInt
ret of
               CInt
0 ->
                 ConnectionAbruptlyTerminated -> IO a
forall e a. Exception e => e -> IO a
throwIO ConnectionAbruptlyTerminated
ConnectionAbruptlyTerminated
                 -- empty error queue and ret==0 meant EOF in older versions
                 -- of OpenSSL
                 -- https://github.com/openssl/openssl/commit/beacb0f0c1ae7b0542fe053b95307f515b578eb7
               CInt
_ -> do
                 Errno
errno <- IO Errno
getErrno
                 if Errno
errno Errno -> Errno -> Bool
forall a. Eq a => a -> a -> Bool
== Errno
eOK then
                   if CInt
sslErr CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== (CInt
5) then
{-# LINE 544 "OpenSSL/Session.hsc" #-}
                     -- newer OpenSSL versions have bug:
                     -- SSL_ERROR_SYSCALL with errno=0 means unexpected EOF
                     -- from the peer
                     ConnectionAbruptlyTerminated -> IO a
forall e a. Exception e => e -> IO a
throwIO ConnectionAbruptlyTerminated
ConnectionAbruptlyTerminated
                   else
                     ProtocolError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO a) -> ProtocolError -> IO a
forall a b. (a -> b) -> a -> b
$ String -> ProtocolError
ProtocolError (String -> ProtocolError) -> String -> ProtocolError
forall a b. (a -> b) -> a -> b
$ String
loc String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": "
                       String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
sslErrorString CInt
sslErr
                 else
                   String -> IO a
forall a. String -> IO a
throwErrno String
loc
           else
             CULong -> IO String
errorString CULong
e IO String -> (String -> IO a) -> IO a
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ProtocolError -> IO a
forall e a. Exception e => e -> IO a
throwIO (ProtocolError -> IO a)
-> (String -> ProtocolError) -> String -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ProtocolError
ProtocolError

sslErrorString :: CInt -> String
sslErrorString :: CInt -> String
sslErrorString CInt
e = case CInt
e of
  (CInt
0) -> String
"SSL_ERROR_NONE"
{-# LINE 559 "OpenSSL/Session.hsc" #-}
  (6) -> "SSL_ERROR_ZERO_RETURN"
{-# LINE 560 "OpenSSL/Session.hsc" #-}
  (2) -> "SSL_ERROR_WANT_READ"
{-# LINE 561 "OpenSSL/Session.hsc" #-}
  (3) -> "SSL_ERROR_WANT_WRITE"
{-# LINE 562 "OpenSSL/Session.hsc" #-}
  (7) -> "SSL_ERROR_WANT_CONNECT"
{-# LINE 563 "OpenSSL/Session.hsc" #-}
  (8) -> "SSL_ERROR_WANT_ACCEPT"
{-# LINE 564 "OpenSSL/Session.hsc" #-}
  (4) -> "SSL_ERROR_WANT_X509_LOOKUP"
{-# LINE 565 "OpenSSL/Session.hsc" #-}

{-# LINE 566 "OpenSSL/Session.hsc" #-}
  (9) -> "SSL_ERROR_WANT_ASYNC"
{-# LINE 567 "OpenSSL/Session.hsc" #-}

{-# LINE 568 "OpenSSL/Session.hsc" #-}

{-# LINE 569 "OpenSSL/Session.hsc" #-}
  (10) -> "SSL_ERROR_WANT_ASYNC_JOB"
{-# LINE 570 "OpenSSL/Session.hsc" #-}

{-# LINE 571 "OpenSSL/Session.hsc" #-}

{-# LINE 572 "OpenSSL/Session.hsc" #-}
  (11) -> "SSL_ERROR_WANT_CLIENT_HELLO_CB"
{-# LINE 573 "OpenSSL/Session.hsc" #-}

{-# LINE 574 "OpenSSL/Session.hsc" #-}
  (5) -> "SSL_ERROR_SYSCALL"
{-# LINE 575 "OpenSSL/Session.hsc" #-}
  (1) -> "SSL_ERROR_SSL"
{-# LINE 576 "OpenSSL/Session.hsc" #-}
  _ -> "Unknown SSL error: " ++ show e

-- | 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 (SSLResult a -> SSLResult a -> Bool
(SSLResult a -> SSLResult a -> Bool)
-> (SSLResult a -> SSLResult a -> Bool) -> Eq (SSLResult a)
forall a. Eq a => SSLResult a -> SSLResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => SSLResult a -> SSLResult a -> Bool
== :: SSLResult a -> SSLResult a -> Bool
$c/= :: forall a. Eq a => SSLResult a -> SSLResult a -> Bool
/= :: SSLResult a -> SSLResult a -> Bool
Eq, Int -> SSLResult a -> String -> String
[SSLResult a] -> String -> String
SSLResult a -> String
(Int -> SSLResult a -> String -> String)
-> (SSLResult a -> String)
-> ([SSLResult a] -> String -> String)
-> Show (SSLResult a)
forall a. Show a => Int -> SSLResult a -> String -> String
forall a. Show a => [SSLResult a] -> String -> String
forall a. Show a => SSLResult a -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: forall a. Show a => Int -> SSLResult a -> String -> String
showsPrec :: Int -> SSLResult a -> String -> String
$cshow :: forall a. Show a => SSLResult a -> String
show :: SSLResult a -> String
$cshowList :: forall a. Show a => [SSLResult a] -> String -> String
showList :: [SSLResult a] -> String -> String
Show, (forall a b. (a -> b) -> SSLResult a -> SSLResult b)
-> (forall a b. a -> SSLResult b -> SSLResult a)
-> Functor SSLResult
forall a b. a -> SSLResult b -> SSLResult a
forall a b. (a -> b) -> SSLResult a -> SSLResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> SSLResult a -> SSLResult b
fmap :: forall a b. (a -> b) -> SSLResult a -> SSLResult b
$c<$ :: forall a b. a -> SSLResult b -> SSLResult a
<$ :: forall a b. a -> SSLResult b -> SSLResult a
Functor, (forall m. Monoid m => SSLResult m -> m)
-> (forall m a. Monoid m => (a -> m) -> SSLResult a -> m)
-> (forall m a. Monoid m => (a -> m) -> SSLResult a -> m)
-> (forall a b. (a -> b -> b) -> b -> SSLResult a -> b)
-> (forall a b. (a -> b -> b) -> b -> SSLResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> SSLResult a -> b)
-> (forall b a. (b -> a -> b) -> b -> SSLResult a -> b)
-> (forall a. (a -> a -> a) -> SSLResult a -> a)
-> (forall a. (a -> a -> a) -> SSLResult a -> a)
-> (forall a. SSLResult a -> [a])
-> (forall a. SSLResult a -> Bool)
-> (forall a. SSLResult a -> Int)
-> (forall a. Eq a => a -> SSLResult a -> Bool)
-> (forall a. Ord a => SSLResult a -> a)
-> (forall a. Ord a => SSLResult a -> a)
-> (forall a. Num a => SSLResult a -> a)
-> (forall a. Num a => SSLResult a -> a)
-> Foldable SSLResult
forall a. Eq a => a -> SSLResult a -> Bool
forall a. Num a => SSLResult a -> a
forall a. Ord a => SSLResult a -> a
forall m. Monoid m => SSLResult m -> m
forall a. SSLResult a -> Bool
forall a. SSLResult a -> Int
forall a. SSLResult a -> [a]
forall a. (a -> a -> a) -> SSLResult a -> a
forall m a. Monoid m => (a -> m) -> SSLResult a -> m
forall b a. (b -> a -> b) -> b -> SSLResult a -> b
forall a b. (a -> b -> b) -> b -> SSLResult a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => SSLResult m -> m
fold :: forall m. Monoid m => SSLResult m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> SSLResult a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> SSLResult a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> SSLResult a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> SSLResult a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> SSLResult a -> b
foldr :: forall a b. (a -> b -> b) -> b -> SSLResult a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> SSLResult a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> SSLResult a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> SSLResult a -> b
foldl :: forall b a. (b -> a -> b) -> b -> SSLResult a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> SSLResult a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> SSLResult a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> SSLResult a -> a
foldr1 :: forall a. (a -> a -> a) -> SSLResult a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> SSLResult a -> a
foldl1 :: forall a. (a -> a -> a) -> SSLResult a -> a
$ctoList :: forall a. SSLResult a -> [a]
toList :: forall a. SSLResult a -> [a]
$cnull :: forall a. SSLResult a -> Bool
null :: forall a. SSLResult a -> Bool
$clength :: forall a. SSLResult a -> Int
length :: forall a. SSLResult a -> Int
$celem :: forall a. Eq a => a -> SSLResult a -> Bool
elem :: forall a. Eq a => a -> SSLResult a -> Bool
$cmaximum :: forall a. Ord a => SSLResult a -> a
maximum :: forall a. Ord a => SSLResult a -> a
$cminimum :: forall a. Ord a => SSLResult a -> a
minimum :: forall a. Ord a => SSLResult a -> a
$csum :: forall a. Num a => SSLResult a -> a
sum :: forall a. Num a => SSLResult a -> a
$cproduct :: forall a. Num a => SSLResult a -> a
product :: forall a. Num a => SSLResult a -> a
Foldable, Functor SSLResult
Foldable SSLResult
(Functor SSLResult, Foldable SSLResult) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> SSLResult a -> f (SSLResult b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    SSLResult (f a) -> f (SSLResult a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> SSLResult a -> m (SSLResult b))
-> (forall (m :: * -> *) a.
    Monad m =>
    SSLResult (m a) -> m (SSLResult a))
-> Traversable SSLResult
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
SSLResult (m a) -> m (SSLResult a)
forall (f :: * -> *) a.
Applicative f =>
SSLResult (f a) -> f (SSLResult a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SSLResult a -> m (SSLResult b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SSLResult a -> f (SSLResult b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SSLResult a -> f (SSLResult b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> SSLResult a -> f (SSLResult b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
SSLResult (f a) -> f (SSLResult a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
SSLResult (f a) -> f (SSLResult a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SSLResult a -> m (SSLResult b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SSLResult a -> m (SSLResult b)
$csequence :: forall (m :: * -> *) a.
Monad m =>
SSLResult (m a) -> m (SSLResult a)
sequence :: forall (m :: * -> *) a.
Monad m =>
SSLResult (m a) -> m (SSLResult a)
Traversable, Typeable)

-- | Block until the operation is finished.
sslBlock :: (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock :: forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock SSL -> IO (SSLResult a)
action SSL
ssl
    = do SSLResult a
result <- SSL -> IO (SSLResult a)
action SSL
ssl
         case SSLResult a
result of
           SSLDone a
r -> a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r
           SSLResult a
WantRead  -> Fd -> IO ()
threadWaitRead  (SSL -> Fd
sslFd SSL
ssl) IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (SSL -> IO (SSLResult a)) -> SSL -> IO a
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock SSL -> IO (SSLResult a)
action SSL
ssl
           SSLResult a
WantWrite -> Fd -> IO ()
threadWaitWrite (SSL -> Fd
sslFd SSL
ssl) IO () -> IO a -> IO a
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (SSL -> IO (SSLResult a)) -> SSL -> IO a
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock SSL -> IO (SSLResult a)
action SSL
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 :: String -> (Ptr SSL_ -> IO CInt) -> SSL -> IO (SSLResult CInt)
sslTryHandshake String
loc Ptr SSL_ -> IO CInt
action SSL
ssl
    = IO (SSLResult CInt) -> IO (SSLResult CInt)
forall a. IO a -> IO a
runInBoundThread (IO (SSLResult CInt) -> IO (SSLResult CInt))
-> IO (SSLResult CInt) -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$
      SSL -> (Ptr SSL_ -> IO (SSLResult CInt)) -> IO (SSLResult CInt)
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO (SSLResult CInt)) -> IO (SSLResult CInt))
-> (Ptr SSL_ -> IO (SSLResult CInt)) -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
sslPtr ->
      do CInt
n <- Ptr SSL_ -> IO CInt
action Ptr SSL_
sslPtr
         if CInt
n CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
1 then
             SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult CInt -> IO (SSLResult CInt))
-> SSLResult CInt -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$ CInt -> SSLResult CInt
forall a. a -> SSLResult a
SSLDone CInt
n
           else
             do CInt
err <- Ptr SSL_ -> CInt -> IO CInt
_ssl_get_error Ptr SSL_
sslPtr CInt
n
                case CInt
err of
                  (CInt
2) -> SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult CInt
forall a. SSLResult a
WantRead
{-# LINE 612 "OpenSSL/Session.hsc" #-}
                  (CInt
3) -> SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult CInt
forall a. SSLResult a
WantWrite
{-# LINE 613 "OpenSSL/Session.hsc" #-}
                  CInt
_ -> String -> CInt -> CInt -> IO (SSLResult CInt)
forall a. String -> CInt -> CInt -> IO a
throwSSLException String
loc CInt
err CInt
n

-- | Perform an SSL server handshake
accept :: SSL -> IO ()
accept :: SSL -> IO ()
accept = (SSL -> IO (SSLResult ())) -> SSL -> IO ()
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock SSL -> IO (SSLResult ())
tryAccept

-- | Try to perform an SSL server handshake without blocking
tryAccept :: SSL -> IO (SSLResult ())
tryAccept :: SSL -> IO (SSLResult ())
tryAccept SSL
ssl
    = (() () -> SSLResult CInt -> SSLResult ()
forall a b. a -> SSLResult b -> SSLResult a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (SSLResult CInt -> SSLResult ())
-> IO (SSLResult CInt) -> IO (SSLResult ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Ptr SSL_ -> IO CInt) -> SSL -> IO (SSLResult CInt)
sslTryHandshake String
"SSL_accept" Ptr SSL_ -> IO CInt
_ssl_accept SSL
ssl

-- | Perform an SSL client handshake
connect :: SSL -> IO ()
connect :: SSL -> IO ()
connect = (SSL -> IO (SSLResult ())) -> SSL -> IO ()
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock SSL -> IO (SSLResult ())
tryConnect

-- | Try to perform an SSL client handshake without blocking
tryConnect :: SSL -> IO (SSLResult ())
tryConnect :: SSL -> IO (SSLResult ())
tryConnect SSL
ssl
    = (() () -> SSLResult CInt -> SSLResult ()
forall a b. a -> SSLResult b -> SSLResult a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) (SSLResult CInt -> SSLResult ())
-> IO (SSLResult CInt) -> IO (SSLResult ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> (Ptr SSL_ -> IO CInt) -> SSL -> IO (SSLResult CInt)
sslTryHandshake String
"SSL_connect" Ptr SSL_ -> IO CInt
_ssl_connect SSL
ssl

foreign import capi "openssl/ssl.h SSL_read" _ssl_read :: Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
foreign import capi unsafe "openssl/ssl.h 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 :: String
-> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)
-> CString
-> Int
-> SSL
-> IO (SSLResult CInt)
sslIOInner String
loc Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
f CString
ptr Int
nbytes SSL
ssl
    = IO (SSLResult CInt) -> IO (SSLResult CInt)
forall a. IO a -> IO a
runInBoundThread (IO (SSLResult CInt) -> IO (SSLResult CInt))
-> IO (SSLResult CInt) -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$
      SSL -> (Ptr SSL_ -> IO (SSLResult CInt)) -> IO (SSLResult CInt)
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl      ((Ptr SSL_ -> IO (SSLResult CInt)) -> IO (SSLResult CInt))
-> (Ptr SSL_ -> IO (SSLResult CInt)) -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
sslPtr ->
      do CInt
n <- Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
f Ptr SSL_
sslPtr (CString -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr CString
ptr) (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
nbytes
         if CInt
n CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0 then
             SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult CInt -> IO (SSLResult CInt))
-> SSLResult CInt -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$ CInt -> SSLResult CInt
forall a. a -> SSLResult a
SSLDone (CInt -> SSLResult CInt) -> CInt -> SSLResult CInt
forall a b. (a -> b) -> a -> b
$ CInt -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n
           else
             do CInt
err <- Ptr SSL_ -> CInt -> IO CInt
_ssl_get_error Ptr SSL_
sslPtr CInt
n
                case CInt
err of
                  (CInt
6) -> SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult CInt -> IO (SSLResult CInt))
-> SSLResult CInt -> IO (SSLResult CInt)
forall a b. (a -> b) -> a -> b
$ CInt -> SSLResult CInt
forall a. a -> SSLResult a
SSLDone (CInt -> SSLResult CInt) -> CInt -> SSLResult CInt
forall a b. (a -> b) -> a -> b
$ CInt
0
{-# LINE 661 "OpenSSL/Session.hsc" #-}
                  (CInt
2) -> SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult CInt
forall a. SSLResult a
WantRead
{-# LINE 662 "OpenSSL/Session.hsc" #-}
                  (CInt
3) -> SSLResult CInt -> IO (SSLResult CInt)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult CInt
forall a. SSLResult a
WantWrite
{-# LINE 663 "OpenSSL/Session.hsc" #-}
                  CInt
_ -> String -> CInt -> CInt -> IO (SSLResult CInt)
forall a. String -> CInt -> CInt -> IO a
throwSSLException String
loc CInt
err CInt
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.
--
-- NOTE: The returned bytestring could be shorter than the size requested, see:
-- https://www.openssl.org/docs/man3.0/man3/SSL_read.html
read :: SSL -> Int -> IO B.ByteString
read :: SSL -> Int -> IO ByteString
read SSL
ssl Int
nBytes = (SSL -> IO (SSLResult ByteString)) -> SSL -> IO ByteString
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock (SSL -> Int -> IO (SSLResult ByteString)
`tryRead` Int
nBytes) SSL
ssl

-- | Try to read the given number of bytes from an SSL connection
--   without blocking.
--
-- NOTE: The returned bytestring could be shorter than the size requested, see:
-- https://www.openssl.org/docs/man3.0/man3/SSL_read.html
tryRead :: SSL -> Int -> IO (SSLResult B.ByteString)
tryRead :: SSL -> Int -> IO (SSLResult ByteString)
tryRead SSL
ssl Int
nBytes
    = do (ByteString
bs, SSLResult ()
result) <- Int
-> (Ptr Word8 -> IO (Int, Int, SSLResult ()))
-> IO (ByteString, SSLResult ())
forall a.
Int -> (Ptr Word8 -> IO (Int, Int, a)) -> IO (ByteString, a)
B.createAndTrim' Int
nBytes ((Ptr Word8 -> IO (Int, Int, SSLResult ()))
 -> IO (ByteString, SSLResult ()))
-> (Ptr Word8 -> IO (Int, Int, SSLResult ()))
-> IO (ByteString, SSLResult ())
forall a b. (a -> b) -> a -> b
$ \Ptr Word8
bufPtr ->
                         do SSLResult CInt
result <- String
-> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)
-> CString
-> Int
-> SSL
-> IO (SSLResult CInt)
sslIOInner String
"SSL_read" Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
_ssl_read (Ptr Word8 -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
bufPtr) Int
nBytes SSL
ssl
                            case SSLResult CInt
result of
                              SSLDone CInt
n -> (Int, Int, SSLResult ()) -> IO (Int, Int, SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0, CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
n, () -> SSLResult ()
forall a. a -> SSLResult a
SSLDone ())
                              SSLResult CInt
WantRead  -> (Int, Int, SSLResult ()) -> IO (Int, Int, SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0,              Int
0, SSLResult ()
forall a. SSLResult a
WantRead  )
                              SSLResult CInt
WantWrite -> (Int, Int, SSLResult ()) -> IO (Int, Int, SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
0,              Int
0, SSLResult ()
forall a. SSLResult a
WantWrite )
         SSLResult ByteString -> IO (SSLResult ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult ByteString -> IO (SSLResult ByteString))
-> SSLResult ByteString -> IO (SSLResult ByteString)
forall a b. (a -> b) -> a -> b
$ ByteString
bs ByteString -> SSLResult () -> SSLResult ByteString
forall a b. a -> SSLResult b -> SSLResult a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SSLResult ()
result

-- | Read some data into a raw pointer buffer.
-- Retrns the number of bytes read.
readPtr :: SSL -> Ptr a -> Int -> IO Int
readPtr :: forall a. SSL -> Ptr a -> Int -> IO Int
readPtr SSL
ssl Ptr a
ptr Int
len = (SSL -> IO (SSLResult Int)) -> SSL -> IO Int
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock (\SSL
h -> SSL -> Ptr a -> Int -> IO (SSLResult Int)
forall a. SSL -> Ptr a -> Int -> IO (SSLResult Int)
tryReadPtr SSL
h Ptr a
ptr Int
len) SSL
ssl

-- | Try to read some data into a raw pointer buffer, without blocking.
tryReadPtr :: SSL -> Ptr a -> Int -> IO (SSLResult Int)
tryReadPtr :: forall a. SSL -> Ptr a -> Int -> IO (SSLResult Int)
tryReadPtr SSL
ssl Ptr a
bufPtr Int
nBytes =
  (SSLResult CInt -> SSLResult Int)
-> IO (SSLResult CInt) -> IO (SSLResult Int)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CInt -> Int) -> SSLResult CInt -> SSLResult Int
forall a b. (a -> b) -> SSLResult a -> SSLResult b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) (String
-> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)
-> CString
-> Int
-> SSL
-> IO (SSLResult CInt)
sslIOInner String
"SSL_read" Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
_ssl_read (Ptr a -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr a
bufPtr) Int
nBytes SSL
ssl)


foreign import capi "openssl/ssl.h 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 -> ByteString -> IO ()
write SSL
ssl ByteString
bs = (SSL -> IO (SSLResult ())) -> SSL -> IO ()
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock (SSL -> ByteString -> IO (SSLResult ())
`tryWrite` ByteString
bs) SSL
ssl IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Try to write a given ByteString to the SSL connection without blocking.
tryWrite :: SSL -> B.ByteString -> IO (SSLResult ())
tryWrite :: SSL -> ByteString -> IO (SSLResult ())
tryWrite SSL
ssl ByteString
bs
    | ByteString -> Bool
B.null ByteString
bs = SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult () -> IO (SSLResult ()))
-> SSLResult () -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ () -> SSLResult ()
forall a. a -> SSLResult a
SSLDone ()
    | Bool
otherwise
        = ByteString
-> (CStringLen -> IO (SSLResult ())) -> IO (SSLResult ())
forall a. ByteString -> (CStringLen -> IO a) -> IO a
B.unsafeUseAsCStringLen ByteString
bs ((CStringLen -> IO (SSLResult ())) -> IO (SSLResult ()))
-> (CStringLen -> IO (SSLResult ())) -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ \(CString
ptr, Int
len) -> SSL -> CString -> Int -> IO (SSLResult ())
forall a. SSL -> Ptr a -> Int -> IO (SSLResult ())
tryWritePtr SSL
ssl CString
ptr Int
len

-- | Send some data from a raw pointer buffer.
writePtr :: SSL -> Ptr a -> Int -> IO ()
writePtr :: forall a. SSL -> Ptr a -> Int -> IO ()
writePtr SSL
ssl Ptr a
ptr Int
len = (SSL -> IO (SSLResult ())) -> SSL -> IO ()
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock (\SSL
h -> SSL -> Ptr a -> Int -> IO (SSLResult ())
forall a. SSL -> Ptr a -> Int -> IO (SSLResult ())
tryWritePtr SSL
h Ptr a
ptr Int
len) SSL
ssl IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Send some data from a raw pointer buffer, without blocking.
tryWritePtr :: SSL -> Ptr a -> Int -> IO (SSLResult ())
tryWritePtr :: forall a. SSL -> Ptr a -> Int -> IO (SSLResult ())
tryWritePtr SSL
ssl Ptr a
ptr Int
len =
  do SSLResult CInt
result <- String
-> (Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt)
-> CString
-> Int
-> SSL
-> IO (SSLResult CInt)
sslIOInner String
"SSL_write" Ptr SSL_ -> Ptr Word8 -> CInt -> IO CInt
_ssl_write (Ptr a -> CString
forall a b. Ptr a -> Ptr b
castPtr Ptr a
ptr) Int
len SSL
ssl
     case SSLResult CInt
result of
       SSLDone CInt
0 -> IOError -> IO (SSLResult ())
forall a. IOError -> IO a
ioError (IOError -> IO (SSLResult ())) -> IOError -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ String -> Errno -> Maybe Handle -> Maybe String -> IOError
errnoToIOError String
"SSL_write" Errno
ePIPE Maybe Handle
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
       SSLDone CInt
_ -> SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult () -> IO (SSLResult ()))
-> SSLResult () -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ () -> SSLResult ()
forall a. a -> SSLResult a
SSLDone ()
       SSLResult CInt
WantRead  -> SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult ()
forall a. SSLResult a
WantRead
       SSLResult CInt
WantWrite -> SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult ()
forall a. SSLResult a
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 -> IO ByteString
lazyRead SSL
ssl = ([ByteString] -> ByteString) -> IO [ByteString] -> IO ByteString
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ByteString] -> ByteString
L.fromChunks IO [ByteString]
lazyRead'
    where
      chunkSize :: Int
chunkSize = Int
L.defaultChunkSize

      lazyRead' :: IO [ByteString]
lazyRead' = IO [ByteString] -> IO [ByteString]
forall a. IO a -> IO a
unsafeInterleaveIO IO [ByteString]
loop

      loop :: IO [ByteString]
loop = do ByteString
bs <- SSL -> Int -> IO ByteString
read SSL
ssl Int
chunkSize
                if ByteString -> Bool
B.null ByteString
bs then
                    -- got EOF
                    [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                  else
                    do [ByteString]
bss <- IO [ByteString]
lazyRead'
                       [ByteString] -> IO [ByteString]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
bsByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
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 -> ByteString -> IO ()
lazyWrite SSL
ssl ByteString
lbs
    = (ByteString -> IO ()) -> [ByteString] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SSL -> ByteString -> IO ()
write SSL
ssl) ([ByteString] -> IO ()) -> [ByteString] -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
L.toChunks ByteString
lbs

foreign import capi "openssl/ssl.h SSL_shutdown" _ssl_shutdown :: Ptr SSL_ -> IO CInt

data ShutdownType = Bidirectional  -- ^ wait for the peer to also shutdown
                  | Unidirectional  -- ^ only send our shutdown
                  deriving (ShutdownType -> ShutdownType -> Bool
(ShutdownType -> ShutdownType -> Bool)
-> (ShutdownType -> ShutdownType -> Bool) -> Eq ShutdownType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ShutdownType -> ShutdownType -> Bool
== :: ShutdownType -> ShutdownType -> Bool
$c/= :: ShutdownType -> ShutdownType -> Bool
/= :: ShutdownType -> ShutdownType -> Bool
Eq, Int -> ShutdownType -> String -> String
[ShutdownType] -> String -> String
ShutdownType -> String
(Int -> ShutdownType -> String -> String)
-> (ShutdownType -> String)
-> ([ShutdownType] -> String -> String)
-> Show ShutdownType
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ShutdownType -> String -> String
showsPrec :: Int -> ShutdownType -> String -> String
$cshow :: ShutdownType -> String
show :: ShutdownType -> String
$cshowList :: [ShutdownType] -> String -> String
showList :: [ShutdownType] -> String -> String
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 -> ShutdownType -> IO ()
shutdown SSL
ssl ShutdownType
ty = (SSL -> IO (SSLResult ())) -> SSL -> IO ()
forall a. (SSL -> IO (SSLResult a)) -> SSL -> IO a
sslBlock (SSL -> ShutdownType -> IO (SSLResult ())
`tryShutdown` ShutdownType
ty) SSL
ssl

-- | Try to cleanly shutdown an SSL connection without blocking.
tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ())
tryShutdown :: SSL -> ShutdownType -> IO (SSLResult ())
tryShutdown SSL
ssl ShutdownType
ty = IO (SSLResult ()) -> IO (SSLResult ())
forall a. IO a -> IO a
runInBoundThread (IO (SSLResult ()) -> IO (SSLResult ()))
-> IO (SSLResult ()) -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ SSL -> (Ptr SSL_ -> IO (SSLResult ())) -> IO (SSLResult ())
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl Ptr SSL_ -> IO (SSLResult ())
loop
    where
      loop :: Ptr SSL_ -> IO (SSLResult ())
      loop :: Ptr SSL_ -> IO (SSLResult ())
loop Ptr SSL_
sslPtr
          = do CInt
n <- Ptr SSL_ -> IO CInt
_ssl_shutdown Ptr SSL_
sslPtr
               case CInt
n of
                 CInt
0 | ShutdownType
ty ShutdownType -> ShutdownType -> Bool
forall a. Eq a => a -> a -> Bool
== ShutdownType
Bidirectional ->
                       -- We successfully sent a close notify alert to
                       -- the peer but haven't got a reply
                       -- yet. Complete the bidirectional shutdown by
                       -- calling SSL_shutdown(3) again.
                       Ptr SSL_ -> IO (SSLResult ())
loop Ptr SSL_
sslPtr
                   | Bool
otherwise ->
                       -- Unidirection shutdown is enough for us.
                       SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult () -> IO (SSLResult ()))
-> SSLResult () -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ () -> SSLResult ()
forall a. a -> SSLResult a
SSLDone ()
                 CInt
1 ->
                     -- Shutdown has succeeded, either bidirectionally
                     -- or unidirectionally.
                     SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult () -> IO (SSLResult ()))
-> SSLResult () -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ () -> SSLResult ()
forall a. a -> SSLResult a
SSLDone ()
                 CInt
2 ->
                     -- SSL_shutdown(2) can return 2 according to its
                     -- documentation. It says we have to retry
                     -- calling SSL_shutdown(3) in this case.
                     Ptr SSL_ -> IO (SSLResult ())
loop Ptr SSL_
sslPtr
                 CInt
_ -> do CInt
err <- Ptr SSL_ -> CInt -> IO CInt
_ssl_get_error Ptr SSL_
sslPtr CInt
n
                         case CInt
err of
                           (CInt
2) -> SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult ()
forall a. SSLResult a
WantRead
{-# LINE 800 "OpenSSL/Session.hsc" #-}
                           (CInt
3) -> SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return SSLResult ()
forall a. SSLResult a
WantWrite
{-# LINE 801 "OpenSSL/Session.hsc" #-}
                           -- 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.
                           (CInt
5)
{-# LINE 809 "OpenSSL/Session.hsc" #-}
                               -> do CInt
sd <- Ptr SSL_ -> IO CInt
_ssl_get_shutdown Ptr SSL_
sslPtr
                                     if CInt
sd CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.&. (CInt
2) CInt -> CInt -> Bool
forall a. Eq a => a -> a -> Bool
== CInt
0 then
{-# LINE 811 "OpenSSL/Session.hsc" #-}
                                         String -> CInt -> CInt -> IO (SSLResult ())
forall a. String -> CInt -> CInt -> IO a
throwSSLException String
"SSL_shutdown" CInt
err CInt
n
                                       else
                                         SSLResult () -> IO (SSLResult ())
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (SSLResult () -> IO (SSLResult ()))
-> SSLResult () -> IO (SSLResult ())
forall a b. (a -> b) -> a -> b
$ () -> SSLResult ()
forall a. a -> SSLResult a
SSLDone ()
                           CInt
_   -> String -> CInt -> CInt -> IO (SSLResult ())
forall a. String -> CInt -> CInt -> IO a
throwSSLException String
"SSL_shutdown" CInt
err CInt
n

{-# LINE 816 "OpenSSL/Session.hsc" #-}
foreign import capi "openssl/ssl.h SSL_get1_peer_certificate" _ssl_get_peer_cert :: Ptr SSL_ -> IO (Ptr X509_)

{-# LINE 820 "OpenSSL/Session.hsc" #-}

-- | 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 -> IO (Maybe X509)
getPeerCertificate SSL
ssl =
  SSL -> (Ptr SSL_ -> IO (Maybe X509)) -> IO (Maybe X509)
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO (Maybe X509)) -> IO (Maybe X509))
-> (Ptr SSL_ -> IO (Maybe X509)) -> IO (Maybe X509)
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
ssl -> do
    Ptr X509_
cert <- Ptr SSL_ -> IO (Ptr X509_)
_ssl_get_peer_cert Ptr SSL_
ssl
    if Ptr X509_
cert Ptr X509_ -> Ptr X509_ -> Bool
forall a. Eq a => a -> a -> Bool
== Ptr X509_
forall a. Ptr a
nullPtr
       then Maybe X509 -> IO (Maybe X509)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe X509
forall a. Maybe a
Nothing
       else (X509 -> Maybe X509) -> IO X509 -> IO (Maybe X509)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap X509 -> Maybe X509
forall a. a -> Maybe a
Just (Ptr X509_ -> IO X509
wrapX509 Ptr X509_
cert)

foreign import capi "openssl/ssl.h 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 -> IO Bool
getVerifyResult SSL
ssl =
  SSL -> (Ptr SSL_ -> IO Bool) -> IO Bool
forall a. SSL -> (Ptr SSL_ -> IO a) -> IO a
withSSL SSL
ssl ((Ptr SSL_ -> IO Bool) -> IO Bool)
-> (Ptr SSL_ -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \Ptr SSL_
ssl -> do
    CLong
r <- Ptr SSL_ -> IO CLong
_ssl_get_verify_result Ptr SSL_
ssl
    Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ CLong
r CLong -> CLong -> Bool
forall a. Eq a => a -> a -> Bool
== (CLong
0)
{-# LINE 847 "OpenSSL/Session.hsc" #-}

-- | The root exception type for all SSL exceptions.
data SomeSSLException
    = forall e. Exception e => SomeSSLException e
      deriving Typeable

instance Show SomeSSLException where
    show :: SomeSSLException -> String
show (SomeSSLException e
e) = e -> String
forall a. Show a => a -> String
show e
e

instance Exception SomeSSLException

sslExceptionToException :: Exception e => e -> SomeException
sslExceptionToException :: forall e. Exception e => e -> SomeException
sslExceptionToException = SomeSSLException -> SomeException
forall e. Exception e => e -> SomeException
toException (SomeSSLException -> SomeException)
-> (e -> SomeSSLException) -> e -> SomeException
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> SomeSSLException
forall e. Exception e => e -> SomeSSLException
SomeSSLException

sslExceptionFromException :: Exception e => SomeException -> Maybe e
sslExceptionFromException :: forall e. Exception e => SomeException -> Maybe e
sslExceptionFromException SomeException
x
    = do SomeSSLException e
a <- SomeException -> Maybe SomeSSLException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
x
         e -> Maybe e
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast e
a

-- | The peer uncleanly terminated the connection without sending the
-- \"close notify\" alert.
data ConnectionAbruptlyTerminated
    = ConnectionAbruptlyTerminated
      deriving (Typeable, Int -> ConnectionAbruptlyTerminated -> String -> String
[ConnectionAbruptlyTerminated] -> String -> String
ConnectionAbruptlyTerminated -> String
(Int -> ConnectionAbruptlyTerminated -> String -> String)
-> (ConnectionAbruptlyTerminated -> String)
-> ([ConnectionAbruptlyTerminated] -> String -> String)
-> Show ConnectionAbruptlyTerminated
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ConnectionAbruptlyTerminated -> String -> String
showsPrec :: Int -> ConnectionAbruptlyTerminated -> String -> String
$cshow :: ConnectionAbruptlyTerminated -> String
show :: ConnectionAbruptlyTerminated -> String
$cshowList :: [ConnectionAbruptlyTerminated] -> String -> String
showList :: [ConnectionAbruptlyTerminated] -> String -> String
Show, ConnectionAbruptlyTerminated
-> ConnectionAbruptlyTerminated -> Bool
(ConnectionAbruptlyTerminated
 -> ConnectionAbruptlyTerminated -> Bool)
-> (ConnectionAbruptlyTerminated
    -> ConnectionAbruptlyTerminated -> Bool)
-> Eq ConnectionAbruptlyTerminated
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ConnectionAbruptlyTerminated
-> ConnectionAbruptlyTerminated -> Bool
== :: ConnectionAbruptlyTerminated
-> ConnectionAbruptlyTerminated -> Bool
$c/= :: ConnectionAbruptlyTerminated
-> ConnectionAbruptlyTerminated -> Bool
/= :: ConnectionAbruptlyTerminated
-> ConnectionAbruptlyTerminated -> Bool
Eq)

instance Exception ConnectionAbruptlyTerminated where
    toException :: ConnectionAbruptlyTerminated -> SomeException
toException   = ConnectionAbruptlyTerminated -> SomeException
forall e. Exception e => e -> SomeException
sslExceptionToException
    fromException :: SomeException -> Maybe ConnectionAbruptlyTerminated
fromException = SomeException -> Maybe ConnectionAbruptlyTerminated
forall e. Exception e => SomeException -> Maybe e
sslExceptionFromException

-- | A failure in the SSL library occurred, usually a protocol
-- error.
data ProtocolError
    = ProtocolError !String
      deriving (Typeable, Int -> ProtocolError -> String -> String
[ProtocolError] -> String -> String
ProtocolError -> String
(Int -> ProtocolError -> String -> String)
-> (ProtocolError -> String)
-> ([ProtocolError] -> String -> String)
-> Show ProtocolError
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> ProtocolError -> String -> String
showsPrec :: Int -> ProtocolError -> String -> String
$cshow :: ProtocolError -> String
show :: ProtocolError -> String
$cshowList :: [ProtocolError] -> String -> String
showList :: [ProtocolError] -> String -> String
Show, ProtocolError -> ProtocolError -> Bool
(ProtocolError -> ProtocolError -> Bool)
-> (ProtocolError -> ProtocolError -> Bool) -> Eq ProtocolError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ProtocolError -> ProtocolError -> Bool
== :: ProtocolError -> ProtocolError -> Bool
$c/= :: ProtocolError -> ProtocolError -> Bool
/= :: ProtocolError -> ProtocolError -> Bool
Eq)

instance Exception ProtocolError where
    toException :: ProtocolError -> SomeException
toException   = ProtocolError -> SomeException
forall e. Exception e => e -> SomeException
sslExceptionToException
    fromException :: SomeException -> Maybe ProtocolError
fromException = SomeException -> Maybe ProtocolError
forall e. Exception e => SomeException -> Maybe e
sslExceptionFromException