Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

for issue #126. Allow optional TLS params

Browse source
This commit is contained in:
Darrell Roberts 2022-03-07 08:50:11 -05:00
parent 5980bc18b2
commit 408cc267f5
1 changed files with 15 additions and 7 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
Database/MongoDB/Transport/Tls.hs
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. It only allows you to connect to a mongodb server using TLS protocol.
-} -}
module Database.MongoDB.Transport.Tls module Database.MongoDB.Transport.Tls
(connect) ( connect
, connectWithTlsParams
)
where where
import Data.IORef import Data.IORef
import Data.Monoid import Data.Monoid
import Data.Maybe(fromMaybe)
import qualified Data.ByteString as ByteString import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Lazy as Lazy.ByteString import qualified Data.ByteString.Lazy as Lazy.ByteString
import Data.Default.Class (def) import Data.Default.Class (def)
@ -45,15 +48,19 @@ import Database.MongoDB.Query (access, slaveOk, retrieveServerData)
-- | Connect to mongodb using TLS -- | Connect to mongodb using TLS
connect :: HostName -> PortID -> IO Pipe connect :: HostName -> PortID -> IO Pipe
connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do connect host port = connectWithTlsParams params host port
where
let params = (TLS.defaultParamsClient host "") params = (TLS.defaultParamsClient host "")
{ TLS.clientSupported = def { TLS.clientSupported = def
{ TLS.supportedCiphers = TLS.ciphersuite_default} { TLS.supportedCiphers = TLS.ciphersuite_default }
, TLS.clientHooks = def , 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 TLS.handshake context
conn <- tlsConnection context conn <- tlsConnection context
@ -62,6 +69,7 @@ connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do
sd <- access p slaveOk "admin" retrieveServerData sd <- access p slaveOk "admin" retrieveServerData
return p return p
tlsConnection :: TLS.Context -> IO Transport tlsConnection :: TLS.Context -> IO Transport
tlsConnection ctx = do tlsConnection ctx = do
restRef <- newIORef mempty restRef <- newIORef mempty