Add tls implementation
This commit is contained in:
parent
5ae56f6c49
commit
494bdcbe56
1 changed files with 67 additions and 0 deletions
67
Database/MongoDB/Internal/Tls.hs
Normal file
67
Database/MongoDB/Internal/Tls.hs
Normal file
|
@ -0,0 +1,67 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
-- | TLS connection to mongodb
|
||||
|
||||
module Bend.Database.Mongo.Tls
|
||||
(
|
||||
connect,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.IORef
|
||||
import Data.Monoid
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
||||
import Data.Default.Class (def)
|
||||
import Control.Exception (bracketOnError)
|
||||
import System.IO
|
||||
import Database.MongoDB (Pipe)
|
||||
import Database.MongoDB.Internal.Protocol (newPipeWith)
|
||||
import Database.MongoDB.Internal.Connection (Connection(Connection))
|
||||
import qualified Database.MongoDB.Internal.Connection as Connection
|
||||
import qualified Network
|
||||
import qualified Network.TLS as TLS
|
||||
import qualified Network.TLS.Extra.Cipher as TLS
|
||||
import qualified Control.IO.Region as Region
|
||||
|
||||
-- | Connect to mongodb using TLS
|
||||
connect :: Text -> Int -> IO Pipe
|
||||
connect host port = bracketOnError Region.open Region.close $ \r -> do
|
||||
handle <- Region.alloc_ r
|
||||
(Network.connectTo (Text.unpack host)
|
||||
(Network.PortNumber $ fromIntegral port))
|
||||
hClose
|
||||
|
||||
let params = (TLS.defaultParamsClient (Text.unpack host) "")
|
||||
{ TLS.clientSupported = def
|
||||
{ TLS.supportedCiphers = TLS.ciphersuite_all}
|
||||
, TLS.clientHooks = def
|
||||
{ TLS.onServerCertificate = \_ _ _ _ -> return []}
|
||||
}
|
||||
context <- Region.alloc_ r
|
||||
(TLS.contextNew handle params)
|
||||
TLS.contextClose
|
||||
TLS.handshake context
|
||||
|
||||
conn <- tlsConnection context (Region.close r)
|
||||
newPipeWith conn
|
||||
|
||||
tlsConnection :: TLS.Context -> IO () -> IO Connection
|
||||
tlsConnection ctx close = do
|
||||
restRef <- newIORef mempty
|
||||
return Connection
|
||||
{ Connection.read = do
|
||||
rest <- readIORef restRef
|
||||
writeIORef restRef mempty
|
||||
if ByteString.null rest
|
||||
then TLS.recvData ctx
|
||||
else return rest
|
||||
, Connection.unread = \rest ->
|
||||
modifyIORef restRef (rest <>)
|
||||
, Connection.write = TLS.sendData ctx . Lazy.ByteString.fromStrict
|
||||
, Connection.flush = TLS.contextFlush ctx
|
||||
, Connection.close = close
|
||||
}
|
Loading…
Reference in a new issue