for issue #126. Allow optional TLS params

This commit is contained in:
Darrell Roberts 2022-03-07 08:50:11 -05:00
parent 5980bc18b2
commit 408cc267f5

View file

@ -22,11 +22,14 @@ 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 Data.Maybe(fromMaybe)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as Lazy.ByteString
import Data.Default.Class (def)
@ -45,15 +48,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
@ -62,6 +69,7 @@ connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do
sd <- access p slaveOk "admin" retrieveServerData
return p
tlsConnection :: TLS.Context -> IO Transport
tlsConnection ctx = do
restRef <- newIORef mempty