mongodb/Database/MongoDB/Transport/Tls.hs

89 lines
3 KiB
Haskell
Raw Normal View History

2016-04-27 06:19:30 +00:00
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
2016-05-04 06:02:54 +00:00
{-|
Module : MongoDB TLS
Description : TLS transport for mongodb
2016-05-04 06:02:54 +00:00
Copyright : (c) Yuras Shumovich, 2016
License : Apache 2.0
Maintainer : Victor Denisov denisovenator@gmail.com
Stability : experimental
Portability : POSIX
2016-04-27 06:19:30 +00:00
2016-05-04 06:02:54 +00:00
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.
2016-05-04 06:02:54 +00:00
-}
2016-05-03 05:05:02 +00:00
module Database.MongoDB.Transport.Tls
2016-05-04 06:02:54 +00:00
(connect)
2016-04-27 06:19:30 +00:00
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)
2016-05-01 03:11:44 +00:00
import Control.Applicative ((<$>))
2016-04-27 06:19:30 +00:00
import Control.Exception (bracketOnError)
2016-05-01 03:11:44 +00:00
import Control.Monad (when, unless)
2016-04-27 06:19:30 +00:00
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
2016-05-01 03:11:44 +00:00
import System.IO.Error (mkIOError, eofErrorType)
2016-05-02 02:23:30 +00:00
import Network (connectTo, HostName, PortID)
2016-04-27 06:19:30 +00:00
import qualified Network.TLS as TLS
import qualified Network.TLS.Extra.Cipher as TLS
-- | Connect to mongodb using TLS
2016-05-02 02:23:30 +00:00
connect :: HostName -> PortID -> IO Pipe
2016-05-04 06:02:54 +00:00
connect host port = bracketOnError (connectTo host port) hClose $ \handle -> do
2016-04-27 06:19:30 +00:00
2016-05-02 02:23:30 +00:00
let params = (TLS.defaultParamsClient host "")
2016-04-27 06:19:30 +00:00
{ TLS.clientSupported = def
{ TLS.supportedCiphers = TLS.ciphersuite_all}
, TLS.clientHooks = def
{ TLS.onServerCertificate = \_ _ _ _ -> return []}
}
2016-05-04 06:02:54 +00:00
context <- TLS.contextNew handle params
2016-04-27 06:19:30 +00:00
TLS.handshake context
2016-05-04 06:02:54 +00:00
conn <- tlsConnection context
2016-04-27 06:19:30 +00:00
newPipeWith conn
2016-05-04 06:02:54 +00:00
tlsConnection :: TLS.Context -> IO Transport
tlsConnection ctx = do
2016-04-27 06:19:30 +00:00
restRef <- newIORef mempty
return Transport
{ T.read = \count -> let
2016-05-01 03:11:44 +00:00
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"
2016-05-01 03:11:44 +00:00
Nothing Nothing
in Lazy.ByteString.toStrict <$> go mempty count
, T.write = TLS.sendData ctx . Lazy.ByteString.fromStrict
, T.flush = TLS.contextFlush ctx
2016-05-04 06:02:54 +00:00
, T.close = TLS.contextClose ctx
2016-04-27 06:19:30 +00:00
}