21cf023854
Add flag imitating bson package PR for network changes. Add stack files for compilation checking. Both ghc86 builds work. Still need to fix ghc84 and under builds with older network code.
99 lines
3.3 KiB
Haskell
99 lines
3.3 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
#if (__GLASGOW_HASKELL__ >= 706)
|
|
{-# LANGUAGE RecursiveDo #-}
|
|
#else
|
|
{-# LANGUAGE DoRec #-}
|
|
#endif
|
|
|
|
{-|
|
|
Module : MongoDB TLS
|
|
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.
|
|
ATTENTION!!! Be aware that this module is highly experimental and is
|
|
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)
|
|
where
|
|
|
|
import Data.IORef
|
|
import Data.Monoid
|
|
import qualified Data.ByteString as ByteString
|
|
import qualified Data.ByteString.Lazy as Lazy.ByteString
|
|
import Data.Default.Class (def)
|
|
import Control.Applicative ((<$>))
|
|
import Control.Exception (bracketOnError)
|
|
import Control.Monad (when, unless)
|
|
import System.IO
|
|
import Database.MongoDB (Pipe)
|
|
import Database.MongoDB.Internal.Protocol (newPipeWith)
|
|
import Database.MongoDB.Transport (Transport(Transport))
|
|
import qualified Database.MongoDB.Transport as T
|
|
import System.IO.Error (mkIOError, eofErrorType)
|
|
import Database.MongoDB.Internal.Network (connectTo, HostName, PortID)
|
|
import qualified Network.TLS as TLS
|
|
import qualified Network.TLS.Extra.Cipher as TLS
|
|
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 "")
|
|
{ TLS.clientSupported = def
|
|
{ TLS.supportedCiphers = TLS.ciphersuite_default}
|
|
, TLS.clientHooks = def
|
|
{ TLS.onServerCertificate = \_ _ _ _ -> return []}
|
|
}
|
|
context <- TLS.contextNew handle params
|
|
TLS.handshake context
|
|
|
|
conn <- tlsConnection context
|
|
rec
|
|
p <- newPipeWith sd conn
|
|
sd <- access p slaveOk "admin" retrieveServerData
|
|
return p
|
|
|
|
tlsConnection :: TLS.Context -> IO Transport
|
|
tlsConnection ctx = do
|
|
restRef <- newIORef mempty
|
|
return Transport
|
|
{ T.read = \count -> let
|
|
readSome = do
|
|
rest <- readIORef restRef
|
|
writeIORef restRef mempty
|
|
if ByteString.null rest
|
|
then TLS.recvData ctx
|
|
else return rest
|
|
unread = \rest ->
|
|
modifyIORef restRef (rest <>)
|
|
go acc n = do
|
|
-- read until get enough bytes
|
|
chunk <- readSome
|
|
when (ByteString.null chunk) $
|
|
ioError eof
|
|
let len = ByteString.length chunk
|
|
if len >= n
|
|
then do
|
|
let (res, rest) = ByteString.splitAt n chunk
|
|
unless (ByteString.null rest) $
|
|
unread rest
|
|
return (acc <> Lazy.ByteString.fromStrict res)
|
|
else go (acc <> Lazy.ByteString.fromStrict chunk) (n - len)
|
|
eof = mkIOError eofErrorType "Database.MongoDB.Transport"
|
|
Nothing Nothing
|
|
in Lazy.ByteString.toStrict <$> go mempty count
|
|
, T.write = TLS.sendData ctx . Lazy.ByteString.fromStrict
|
|
, T.flush = TLS.contextFlush ctx
|
|
, T.close = TLS.contextClose ctx
|
|
}
|