Add tls implementation

This commit is contained in:
Victor Denisov 2016-04-26 23:19:30 -07:00
parent 5ae56f6c49
commit 494bdcbe56

View 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
}