Drop io-region dependency

This commit is contained in:
Victor Denisov 2016-05-03 23:02:54 -07:00
parent f18e4ff9f8
commit 5ca93be5e8
2 changed files with 18 additions and 17 deletions

View file

@ -1,12 +1,20 @@
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
-- | TLS connection to mongodb {-|
Module : MongoDB TLS
Description : TLS transport to mongodb
Copyright : (c) Yuras Shumovich, 2016
License : Apache 2.0
Maintainer : Victor Denisov denisovenator@gmail.com
Stability : experimental
Portability : POSIX
This module is for connecting to TLS enabled mongodb servers.
Be aware that this module is highly experimental and is barely tested.
-}
module Database.MongoDB.Transport.Tls module Database.MongoDB.Transport.Tls
( (connect)
connect,
)
where where
import Data.IORef import Data.IORef
@ -26,14 +34,10 @@ import System.IO.Error (mkIOError, eofErrorType)
import Network (connectTo, HostName, PortID) import Network (connectTo, HostName, PortID)
import qualified Network.TLS as TLS import qualified Network.TLS as TLS
import qualified Network.TLS.Extra.Cipher as TLS import qualified Network.TLS.Extra.Cipher as TLS
import qualified Control.IO.Region as Region
-- | Connect to mongodb using TLS -- | Connect to mongodb using TLS
connect :: HostName -> PortID -> IO Pipe connect :: HostName -> PortID -> IO Pipe
connect host port = bracketOnError Region.open Region.close $ \r -> do connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do
handle <- Region.alloc_ r
(connectTo host port)
hClose
let params = (TLS.defaultParamsClient host "") let params = (TLS.defaultParamsClient host "")
{ TLS.clientSupported = def { TLS.clientSupported = def
@ -41,16 +45,14 @@ connect host port = bracketOnError Region.open Region.close $ \r -> do
, TLS.clientHooks = def , TLS.clientHooks = def
{ TLS.onServerCertificate = \_ _ _ _ -> return []} { TLS.onServerCertificate = \_ _ _ _ -> return []}
} }
context <- Region.alloc_ r context <- TLS.contextNew handle params
(TLS.contextNew handle params)
TLS.contextClose
TLS.handshake context TLS.handshake context
conn <- tlsConnection context (Region.close r) conn <- tlsConnection context
newPipeWith conn newPipeWith conn
tlsConnection :: TLS.Context -> IO () -> IO Transport tlsConnection :: TLS.Context -> IO Transport
tlsConnection ctx close = do tlsConnection ctx = do
restRef <- newIORef mempty restRef <- newIORef mempty
return Transport return Transport
{ T.read = \count -> let { T.read = \count -> let
@ -80,5 +82,5 @@ tlsConnection ctx close = do
in Lazy.ByteString.toStrict <$> go mempty count in Lazy.ByteString.toStrict <$> go mempty count
, T.write = TLS.sendData ctx . Lazy.ByteString.fromStrict , T.write = TLS.sendData ctx . Lazy.ByteString.fromStrict
, T.flush = TLS.contextFlush ctx , T.flush = TLS.contextFlush ctx
, T.close = close , T.close = TLS.contextClose ctx
} }

View file

@ -34,7 +34,6 @@ Library
, mtl >= 2 , mtl >= 2
, cryptohash -any , cryptohash -any
, network -any , network -any
, io-region -any
, parsec -any , parsec -any
, random -any , random -any
, random-shuffle -any , random-shuffle -any