Allow optional TLS params

Merge pull request #129 from darrell-roberts/master

for issue #126.
This commit is contained in:
Victor Denisov 2022-03-21 21:08:47 -07:00 committed by GitHub
commit 2ab662b2de
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23

View file

@ -22,15 +22,16 @@ barely tested. The current implementation doesn't verify server's identity.
It only allows you to connect to a mongodb server using TLS protocol.
-}
module Database.MongoDB.Transport.Tls
(connect)
( connect
, connectWithTlsParams
)
where
import Data.IORef
import Data.Monoid
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as Lazy.ByteString
import Data.Default.Class (def)
import Control.Applicative ((<$>))
import Control.Exception (bracketOnError)
import Control.Monad (when, unless)
import System.IO
@ -45,15 +46,19 @@ import Database.MongoDB.Query (access, slaveOk, retrieveServerData)
-- | Connect to mongodb using TLS
connect :: HostName -> PortID -> IO Pipe
connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do
let params = (TLS.defaultParamsClient host "")
connect host port = connectWithTlsParams params host port
where
params = (TLS.defaultParamsClient host "")
{ TLS.clientSupported = def
{ TLS.supportedCiphers = TLS.ciphersuite_default}
{ TLS.supportedCiphers = TLS.ciphersuite_default }
, TLS.clientHooks = def
{ TLS.onServerCertificate = \_ _ _ _ -> return []}
{ TLS.onServerCertificate = \_ _ _ _ -> return [] }
}
context <- TLS.contextNew handle params
-- | Connect to mongodb using TLS using provided TLS client parameters
connectWithTlsParams :: TLS.ClientParams -> HostName -> PortID -> IO Pipe
connectWithTlsParams clientParams host port = bracketOnError (connectTo host port) hClose $ \handle -> do
context <- TLS.contextNew handle clientParams
TLS.handshake context
conn <- tlsConnection context