for issue #126. Allow optional TLS params
This commit is contained in:
parent
5980bc18b2
commit
408cc267f5
1 changed files with 15 additions and 7 deletions
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue