diff --git a/Benchmark.hs b/Benchmark.hs --- a/Benchmark.hs +++ b/Benchmark.hs @@ -11,11 +11,11 @@ import qualified Data.Text as T main = defaultMain [ - bgroup "insert" [ bench "100" $ nfIO doInserts ] + bgroup "insert" [ bench "1000" $ nfIO doInserts ] ] doInserts = do - let docs = (flip map) [0..100] $ \i -> + let docs = (flip map) [0..1000] $ \i -> ["name" M.=: (T.pack $ "name " ++ (show i))] pipe <- M.connect (M.host "127.0.0.1") diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,30 @@ All notable changes to this project will be documented in this file. This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy). +## [2.1.0] - 2016-06-21 + +### Added +- TLS implementation. So far it is an experimental feature. +- Insert using command syntax with mongo server >= 2.6 +- UpdateMany and UpdateAll commands. They use bulk operations from mongo + version 2.6 and above. With versions below 2.6 it sends many updates. +- DeleteAll and DeleteMany functions use bulk operations with mongo server + >= 2.6. If mongo server version is below 2.6 then it sends many individual + deletes. + +### Changed +- All messages will be strictly evaluated before sending them to mongodb server. +No more closed handles because of bad arguments. +- Update command is reimplemented in terms of UpdateMany. +- delete and deleteOne functions are now implemented using bulk delete + functions. + +### Removed +- System.IO.Pipeline module + +### Fixed +- allCollections request for mongo versions above 3.0 + ## [2.0.10] - 2015-12-22 ### Fixed diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -196,14 +196,16 @@ allUsers = map (exclude ["_id"]) <$> (rest =<< find (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) -addUser :: (MonadIO m) => Bool -> Username -> Password -> Action m () +addUser :: (MonadBaseControl IO m, MonadIO m) + => Bool -> Username -> Password -> Action m () -- ^ Add user with password with read-only access if bool is True or read-write access if bool is False addUser readOnly user pass = do mu <- findOne (select ["user" =: user] "system.users") let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu) save "system.users" usr -removeUser :: (MonadIO m) => Username -> Action m () +removeUser :: (MonadIO m, MonadBaseControl IO m) + => Username -> Action m () removeUser user = delete (select ["user" =: user] "system.users") -- ** Database diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -2,6 +2,12 @@ {-# LANGUAGE CPP, OverloadedStrings, ScopedTypeVariables, TupleSections #-} +#if (__GLASGOW_HASKELL__ >= 706) +{-# LANGUAGE RecursiveDo #-} +#else +{-# LANGUAGE DoRec #-} +#endif + module Database.MongoDB.Connection ( -- * Util Secs, @@ -42,12 +48,11 @@ import qualified Data.Bson as B import qualified Data.Text as T -import Database.MongoDB.Internal.Protocol (Pipe, newPipe) +import Database.MongoDB.Internal.Protocol (Pipe, newPipe, close, isClosed) import Database.MongoDB.Internal.Util (untilSuccess, liftIOE, updateAssocs, shuffle, mergesortM) import Database.MongoDB.Query (Command, Failure(ConnectionFailure), access, - slaveOk, runCommand) -import System.IO.Pipeline (close, isClosed) + slaveOk, runCommand, retrieveServerData) adminCommand :: Command -> Pipe -> IO Document -- ^ Run command against admin database on server connected to pipe. Fail if connection fails. @@ -114,7 +119,10 @@ connect' timeoutSecs (Host hostname port) = do mh <- timeout (round $ timeoutSecs * 1000000) (connectTo hostname port) handle <- maybe (ioError $ userError "connect timed out") return mh - newPipe handle + rec + p <- newPipe sd handle + sd <- access p slaveOk "admin" retrieveServerData + return p -- * Replica Set diff --git a/Database/MongoDB/Internal/Connection.hs b/Database/MongoDB/Internal/Connection.hs deleted file mode 100644 --- a/Database/MongoDB/Internal/Connection.hs +++ /dev/null @@ -1,72 +0,0 @@ - --- | This module defines a connection interface. It could be a regular --- network connection, TLS connection, a mock or anything else. - -module Database.MongoDB.Internal.Connection ( - Connection(..), - readExactly, - fromHandle, -) where - -import Prelude hiding (read) -import Data.Monoid -import Data.IORef -import Data.ByteString (ByteString) -import qualified Data.ByteString as ByteString -import qualified Data.ByteString.Lazy as Lazy (ByteString) -import qualified Data.ByteString.Lazy as Lazy.ByteString -import Control.Monad -import System.IO -import System.IO.Error (mkIOError, eofErrorType) - --- | Abstract connection interface --- --- `read` should return `ByteString.null` on EOF -data Connection = Connection { - read :: IO ByteString, - unread :: ByteString -> IO (), - write :: ByteString -> IO (), - flush :: IO (), - close :: IO ()} - -readExactly :: Connection -> Int -> IO Lazy.ByteString --- ^ Read specified number of bytes --- --- If EOF is reached before N bytes then raise EOF exception. -readExactly conn count = go mempty count - where - go acc n = do - -- read until get enough bytes - chunk <- read conn - 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 conn rest - return (acc <> Lazy.ByteString.fromStrict res) - else go (acc <> Lazy.ByteString.fromStrict chunk) (n - len) - eof = mkIOError eofErrorType "Database.MongoDB.Internal.Connection" - Nothing Nothing - -fromHandle :: Handle -> IO Connection --- ^ Make connection form handle -fromHandle handle = do - restRef <- newIORef mempty - return Connection - { read = do - rest <- readIORef restRef - writeIORef restRef mempty - if ByteString.null rest - -- 32k corresponds to the default chunk size - -- used in bytestring package - then ByteString.hGetSome handle (32 * 1024) - else return rest - , unread = \rest -> - modifyIORef restRef (rest <>) - , write = ByteString.hPut handle - , flush = hFlush handle - , close = hClose handle - } diff --git a/Database/MongoDB/Internal/Protocol.hs b/Database/MongoDB/Internal/Protocol.hs --- a/Database/MongoDB/Internal/Protocol.hs +++ b/Database/MongoDB/Internal/Protocol.hs @@ -7,7 +7,16 @@ {-# LANGUAGE RecordWildCards, StandaloneDeriving, OverloadedStrings #-} {-# LANGUAGE CPP, FlexibleContexts, TupleSections, TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE NamedFieldPuns, ScopedTypeVariables #-} + +#if (__GLASGOW_HASKELL__ >= 706) +{-# LANGUAGE RecursiveDo #-} +#else +{-# LANGUAGE DoRec #-} +#endif + module Database.MongoDB.Internal.Protocol ( FullCollection, -- * Pipe @@ -19,13 +28,13 @@ -- ** Reply Reply(..), ResponseFlag(..), -- * Authentication - Username, Password, Nonce, pwHash, pwKey + Username, Password, Nonce, pwHash, pwKey, + isClosed, close, ServerData(..), Pipeline(..) ) where #if !MIN_VERSION_base(4,8,0) import Control.Applicative ((<$>)) #endif -import Control.Arrow ((***)) import Control.Monad (forM, replicateM, unless) import Data.Binary.Get (Get, runGet) import Data.Binary.Put (Put, runPut) @@ -35,7 +44,13 @@ import System.IO (Handle) import System.IO.Unsafe (unsafePerformIO) import Data.Maybe (maybeToList) +import GHC.Conc (ThreadStatus(..), threadStatus) +import Control.Monad (forever) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent (ThreadId, forkIO, killThread) +import Control.Exception.Lifted (onException, throwIO, try) + import qualified Data.ByteString.Lazy as L import Control.Monad.Trans (MonadIO, liftIO) @@ -48,38 +63,121 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as TE -import Database.MongoDB.Internal.Util (whenJust, bitOr, byteStringHex) -import System.IO.Pipeline (Pipeline, newPipeline, IOStream(..)) +import Database.MongoDB.Internal.Util (bitOr, byteStringHex) -import qualified System.IO.Pipeline as P +import Database.MongoDB.Transport (Transport) +import qualified Database.MongoDB.Transport as T -import Database.MongoDB.Internal.Connection (Connection) -import qualified Database.MongoDB.Internal.Connection as Connection +#if MIN_VERSION_base(4,6,0) +import Control.Concurrent.MVar.Lifted (MVar, newEmptyMVar, newMVar, withMVar, + putMVar, readMVar, mkWeakMVar) +#else +import Control.Concurrent.MVar.Lifted (MVar, newEmptyMVar, newMVar, withMVar, + putMVar, readMVar, addMVarFinalizer) +#endif +#if !MIN_VERSION_base(4,6,0) +mkWeakMVar :: MVar a -> IO () -> IO () +mkWeakMVar = addMVarFinalizer +#endif + +-- * Pipeline + +-- | Thread-safe and pipelined connection +data Pipeline = Pipeline + { vStream :: MVar Transport -- ^ Mutex on handle, so only one thread at a time can write to it + , responseQueue :: Chan (MVar (Either IOError Response)) -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response. + , listenThread :: ThreadId + , serverData :: ServerData + } + +data ServerData = ServerData + { isMaster :: Bool + , minWireVersion :: Int + , maxWireVersion :: Int + , maxMessageSizeBytes :: Int + , maxBsonObjectSize :: Int + , maxWriteBatchSize :: Int + } + +-- | Create new Pipeline over given handle. You should 'close' pipeline when finished, which will also close handle. If pipeline is not closed but eventually garbage collected, it will be closed along with handle. +newPipeline :: ServerData -> Transport -> IO Pipeline +newPipeline serverData stream = do + vStream <- newMVar stream + responseQueue <- newChan + rec + let pipe = Pipeline{..} + listenThread <- forkIO (listen pipe) + _ <- mkWeakMVar vStream $ do + killThread listenThread + T.close stream + return pipe + +close :: Pipeline -> IO () +-- ^ Close pipe and underlying connection +close Pipeline{..} = do + killThread listenThread + T.close =<< readMVar vStream + +isClosed :: Pipeline -> IO Bool +isClosed Pipeline{listenThread} = do + status <- threadStatus listenThread + return $ case status of + ThreadRunning -> False + ThreadFinished -> True + ThreadBlocked _ -> False + ThreadDied -> True +--isPipeClosed Pipeline{..} = isClosed =<< readMVar vHandle -- isClosed hangs while listen loop is waiting on read + +listen :: Pipeline -> IO () +-- ^ Listen for responses and supply them to waiting threads in order +listen Pipeline{..} = do + stream <- readMVar vStream + forever $ do + e <- try $ readMessage stream + var <- readChan responseQueue + putMVar var e + case e of + Left err -> T.close stream >> ioError err -- close and stop looping + Right _ -> return () + +psend :: Pipeline -> Message -> IO () +-- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own). +-- Throw IOError and close pipeline if send fails +psend p@Pipeline{..} !message = withMVar vStream (flip writeMessage message) `onException` close p + +pcall :: Pipeline -> Message -> IO (IO Response) +-- ^ Send message to destination and return /promise/ of response from one message only. The destination must reply to the message (otherwise promises will have the wrong responses in them). +-- Throw IOError and closes pipeline if send fails, likewise for promised response. +pcall p@Pipeline{..} message = withMVar vStream doCall `onException` close p where + doCall stream = do + writeMessage stream message + var <- newEmptyMVar + liftIO $ writeChan responseQueue var + return $ readMVar var >>= either throwIO return -- return promise + -- * Pipe -type Pipe = Pipeline Response Message +type Pipe = Pipeline -- ^ Thread-safe TCP connection with pipelined requests -newPipe :: Handle -> IO Pipe +newPipe :: ServerData -> Handle -> IO Pipe -- ^ Create pipe over handle -newPipe handle = Connection.fromHandle handle >>= newPipeWith +newPipe sd handle = T.fromHandle handle >>= (newPipeWith sd) -newPipeWith :: Connection -> IO Pipe +newPipeWith :: ServerData -> Transport -> IO Pipe -- ^ Create pipe over connection -newPipeWith conn = newPipeline $ IOStream (writeMessage conn) - (readMessage conn) - (Connection.close conn) +newPipeWith sd conn = newPipeline sd conn send :: Pipe -> [Notice] -> IO () -- ^ Send notices as a contiguous batch to server with no reply. Throw IOError if connection fails. -send pipe notices = P.send pipe (notices, Nothing) +send pipe notices = psend pipe (notices, Nothing) call :: Pipe -> [Notice] -> Request -> IO (IO Reply) -- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call and resulting promise will throw IOError if connection fails. call pipe notices request = do requestId <- genRequestId - promise <- P.call pipe (notices, Just (request, requestId)) + promise <- pcall pipe (notices, Just (request, requestId)) return $ check requestId <$> promise where check requestId (responseTo, reply) = if requestId == responseTo then reply else @@ -91,7 +189,7 @@ -- ^ A write notice(s) with getLastError request, or just query request. -- Note, that requestId will be out of order because request ids will be generated for notices after the request id supplied was generated. This is ok because the mongo server does not care about order just uniqueness. -writeMessage :: Connection -> Message -> IO () +writeMessage :: Transport -> Message -> IO () -- ^ Write message to connection writeMessage conn (notices, mRequest) = do noticeStrings <- forM notices $ \n -> do @@ -104,8 +202,8 @@ let s = runPut $ putRequest request requestId return $ (lenBytes s) `L.append` s - Connection.write conn $ L.toStrict $ L.concat $ noticeStrings ++ (maybeToList requestString) - Connection.flush conn + T.write conn $ L.toStrict $ L.concat $ noticeStrings ++ (maybeToList requestString) + T.flush conn where lenBytes bytes = encodeSize . toEnum . fromEnum $ L.length bytes encodeSize = runPut . putInt32 . (+ 4) @@ -113,12 +211,12 @@ type Response = (ResponseTo, Reply) -- ^ Message received from a Mongo server in response to a Request -readMessage :: Connection -> IO Response +readMessage :: Transport -> IO Response -- ^ read response from a connection readMessage conn = readResp where readResp = do - len <- fromEnum . decodeSize <$> Connection.readExactly conn 4 - runGet getReply <$> Connection.readExactly conn len + len <- fromEnum . decodeSize . L.fromStrict <$> T.read conn 4 + runGet getReply . L.fromStrict <$> T.read conn len decodeSize = subtract 4 . runGet getInt32 type FullCollection = Text diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -1,6 +1,6 @@ -- | Query and update documents -{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP, DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies, CPP, DeriveDataTypeable, ScopedTypeVariables #-} module Database.MongoDB.Query ( -- * Monad @@ -21,9 +21,10 @@ -- ** Insert insert, insert_, insertMany, insertMany_, insertAll, insertAll_, -- ** Update - save, replace, repsert, upsert, Modifier, modify, + save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll, + UpdateResult, UpdateOption(..), -- ** Delete - delete, deleteOne, + delete, deleteOne, deleteMany, deleteAll, DeleteResult, DeleteOption(..), -- * Read -- ** Query Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), @@ -42,13 +43,13 @@ MRResult, mapReduce, runMR, runMR', -- * Command Command, runCommand, runCommand1, - eval, + eval, retrieveServerData ) where import Prelude hiding (lookup) -import Control.Exception (Exception, throwIO) -import Control.Monad (unless, replicateM, liftM) -import Data.Int (Int32) +import Control.Exception (Exception, throwIO, throw) +import Control.Monad (unless, replicateM, liftM, forM, forM_, void) +import Data.Int (Int32, Int64) import Data.Maybe (listToMaybe, catMaybes, isNothing) import Data.Word (Word32) #if !MIN_VERSION_base(4,8,0) @@ -64,15 +65,19 @@ readMVar, modifyMVar) #endif import Control.Applicative ((<$>)) +import Control.Exception (SomeException) +import Control.Exception.Lifted (catch) import Control.Monad (when) import Control.Monad.Base (MonadBase) import Control.Monad.Error (Error(..)) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans.Control (MonadBaseControl(..)) +import Data.Binary.Put (runPut) import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), - (=?)) + (=?), (!?), Val(..)) +import Data.Bson.Binary (putDocument) import Data.Text (Text) import qualified Data.Text as T @@ -84,12 +89,13 @@ Request(GetMore, qOptions, qSkip, qFullCollection, qBatchSize, qSelector, qProjector), - pwKey) + pwKey, ServerData(..)) import Database.MongoDB.Internal.Util (loop, liftIOE, true1, (<.>)) import qualified Database.MongoDB.Internal.Protocol as P import qualified Crypto.Nonce as Nonce import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Base16 as B16 import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Char8 as B @@ -99,6 +105,7 @@ import Data.Bits (xor) import qualified Data.Map as Map import Text.Read (readMaybe) +import Data.Maybe (fromMaybe) #if !MIN_VERSION_base(4,6,0) --mkWeakMVar = addMVarFinalizer @@ -141,6 +148,10 @@ type GetLastError = Document -- ^ Parameters for getLastError command. For example @[\"w\" =: 2]@ tells the server to wait for the write to reach at least two servers in replica set before acknowledging. See for more options. +data UpdateResult = UpdateResult + +data DeleteResult = DeleteResult + master :: AccessMode -- ^ Same as 'ConfirmWrites' [] master = ConfirmWrites [] @@ -277,8 +288,10 @@ if done then return True else do - let client2 = ["saslContinue" =: (1 :: Int), "conversationId" =: (at "conversationId" server1 :: Int), "payload" =: String ""] - server3 <- runCommand client2 + let client2Step2 = [ "saslContinue" =: (1 :: Int) + , "conversationId" =: (at "conversationId" server1 :: Int) + , "payload" =: String ""] + server3 <- runCommand client2Step2 shortcircuit (true1 "ok" server3) $ do return True where @@ -296,6 +309,19 @@ parseSCRAM = Map.fromList . fmap cleanup . (fmap $ T.breakOn "=") . T.splitOn "," . T.pack . B.unpack where cleanup (t1, t2) = (B.pack $ T.unpack t1, B.pack . T.unpack $ T.drop 1 t2) +retrieveServerData :: (MonadIO m) => Action m ServerData +retrieveServerData = do + d <- runCommand1 "isMaster" + let newSd = ServerData + { isMaster = (fromMaybe False $ lookup "ismaster" d) + , minWireVersion = (fromMaybe 0 $ lookup "minWireVersion" d) + , maxWireVersion = (fromMaybe 0 $ lookup "maxWireVersion" d) + , maxMessageSizeBytes = (fromMaybe 48000000 $ lookup "maxMessageSizeBytes" d) + , maxBsonObjectSize = (fromMaybe (16 * 1024 * 1024) $ lookup "maxBsonObjectSize" d) + , maxWriteBatchSize = (fromMaybe 1000 $ lookup "maxWriteBatchSize" d) + } + return newSd + -- * Collection type Collection = Text @@ -304,9 +330,28 @@ allCollections :: (MonadIO m, MonadBaseControl IO m) => Action m [Collection] -- ^ List all collections in this database allCollections = do - db <- thisDatabase - docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]} - return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs + p <- asks mongoPipe + let sd = P.serverData p + if (maxWireVersion sd <= 2) + then do + db <- thisDatabase + docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]} + return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs + else do + r <- runCommand1 "listCollections" + let curData = do + (Doc curDoc) <- r !? "cursor" + (curId :: Int64) <- curDoc !? "id" + (curNs :: Text) <- curDoc !? "ns" + (firstBatch :: [Value]) <- curDoc !? "firstBatch" + return $ (curId, curNs, ((catMaybes (map cast' firstBatch)) :: [Document])) + case curData of + Nothing -> return [] + Just (curId, curNs, firstBatch) -> do + db <- thisDatabase + nc <- newCursor db curNs 0 $ return $ Batch Nothing curId firstBatch + docs <- rest nc + return $ catMaybes $ map (\d -> (d !? "name")) docs where dropDbPrefix = T.tail . T.dropWhile (/= '.') isSpecial db col = T.any (== '$') col && db <.> col /= "local.oplog.$main" @@ -355,7 +400,7 @@ insert :: (MonadIO m) => Collection -> Document -> Action m Value -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied -insert col doc = head `liftM` insertMany col [doc] +insert col doc = head `liftM` insertBlock [] col [doc] insert_ :: (MonadIO m) => Collection -> Document -> Action m () -- ^ Same as 'insert' except don't return _id @@ -377,14 +422,101 @@ -- ^ Same as 'insertAll' except don't return _ids insertAll_ col docs = insertAll col docs >> return () -insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value] +insertCommandDocument :: [InsertOption] -> Collection -> [Document] -> Document -> Document +insertCommandDocument opts col docs writeConcern = + [ "insert" =: col + , "ordered" =: (KeepGoing `notElem` opts) + , "documents" =: docs + , "writeConcern" =: writeConcern + ] + +insert' :: (MonadIO m) + => [InsertOption] -> Collection -> [Document] -> Action m [Value] -- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied insert' opts col docs = do + p <- asks mongoPipe + let sd = P.serverData p + mode <- asks mongoWriteMode + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + let docSize = sizeOfDocument $ insertCommandDocument opts col [] writeConcern + chunks <- forM (splitAtLimit + (not (KeepGoing `elem` opts)) + (maxBsonObjectSize sd - docSize) + -- size of auxiliary part of insert + -- document should be subtracted from + -- the overall size + (maxWriteBatchSize sd) + docs) + (insertBlock opts col) + return $ concat chunks + +insertBlock :: (MonadIO m) + => [InsertOption] -> Collection -> [Document] -> Action m [Value] +-- ^ This will fail if the list of documents is bigger than restrictions +insertBlock _ _ [] = return [] +insertBlock opts col docs = do db <- thisDatabase docs' <- liftIO $ mapM assignId docs - write (Insert (db <.> col) opts docs') - return $ map (valueAt "_id") docs' + p <- asks mongoPipe + let sd = P.serverData p + if (maxWireVersion sd < 2) + then do + write (Insert (db <.> col) opts docs') + return $ map (valueAt "_id") docs' + else do + mode <- asks mongoWriteMode + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + doc <- runCommand $ insertCommandDocument opts col docs' writeConcern + case (look "writeErrors" doc, look "writeConcernError" doc) of + (Nothing, Nothing) -> return $ map (valueAt "_id") docs' + (Just err, Nothing) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err) + (Nothing, Just err) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err) + (Just err, Just writeConcernErr) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err ++ show writeConcernErr) + +splitAtLimit :: Bool -> Int -> Int -> [Document] -> [[Document]] +splitAtLimit ordered maxSize maxCount list = chop (go 0 0 []) list + where + go :: Int -> Int -> [Document] -> [Document] -> ([Document], [Document]) + go _ _ res [] = (reverse res, []) + go curSize curCount [] (x:xs) | + ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize) = + if (not ordered) + then + go curSize curCount [] xs -- Skip this document and insert the other documents. + else + throw $ WriteFailure 0 "One document is too big for the message" + go curSize curCount res (x:xs) = + if ( ((curSize + (sizeOfDocument x) + 2 + curCount) > maxSize) + -- we have ^ 2 brackets and curCount commas in + -- the document that we need to take into + -- account + || ((curCount + 1) > maxCount)) + then + (reverse res, x:xs) + else + go (curSize + (sizeOfDocument x)) (curCount + 1) (x:res) xs + + chop :: ([a] -> (b, [a])) -> [a] -> [b] + chop _ [] = [] + chop f as = let (b, as') = f as in b : chop f as' + +sizeOfDocument :: Document -> Int +sizeOfDocument d = fromIntegral $ LBS.length $ runPut $ putDocument d + assignId :: Document -> IO Document -- ^ Assign a unique value to _id field if missing assignId doc = if any (("_id" ==) . label) doc @@ -393,53 +525,264 @@ -- ** Update -save :: (MonadIO m) => Collection -> Document -> Action m () +save :: (MonadBaseControl IO m, MonadIO m) + => Collection -> Document -> Action m () -- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or upsert it if its not new (has \"_id\" field) save col doc = case look "_id" doc of Nothing -> insert_ col doc Just i -> upsert (Select ["_id" := i] col) doc -replace :: (MonadIO m) => Selection -> Document -> Action m () +replace :: (MonadBaseControl IO m, MonadIO m) + => Selection -> Document -> Action m () -- ^ Replace first document in selection with given document replace = update [] -repsert :: (MonadIO m) => Selection -> Document -> Action m () +repsert :: (MonadBaseControl IO m, MonadIO m) + => Selection -> Document -> Action m () -- ^ Replace first document in selection with given document, or insert document if selection is empty repsert = update [Upsert] {-# DEPRECATED repsert "use upsert instead" #-} -upsert :: (MonadIO m) => Selection -> Document -> Action m () +upsert :: (MonadBaseControl IO m, MonadIO m) + => Selection -> Document -> Action m () -- ^ Update first document in selection with given document, or insert document if selection is empty upsert = update [Upsert] type Modifier = Document -- ^ Update operations on fields in a document. See -modify :: (MonadIO m) => Selection -> Modifier -> Action m () +modify :: (MonadBaseControl IO m, MonadIO m) + => Selection -> Modifier -> Action m () -- ^ Update all documents in selection using given modifier modify = update [MultiUpdate] -update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m () +update :: (MonadBaseControl IO m, MonadIO m) + => [UpdateOption] -> Selection -> Document -> Action m () -- ^ Update first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty. -update opts (Select sel col) up = do - db <- thisDatabase - write (Update (db <.> col) opts sel up) +update opts (Select sel col) up = void $ update' True col [(sel, up, opts)] +updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document +updateCommandDocument col ordered updates writeConcern = + [ "update" =: col + , "ordered" =: ordered + , "updates" =: updates + , "writeConcern" =: writeConcern + ] + +{-| Bulk update operation. If one update fails it will not update the remaining + - documents. Current returned value is only a place holder. With mongodb server + - before 2.6 it will send update requests one by one. After 2.6 it will use + - bulk update feature in mongodb. + -} +updateMany :: (MonadBaseControl IO m, MonadIO m) + => Collection + -> [(Selector, Document, [UpdateOption])] + -> Action m UpdateResult +updateMany = update' True + +{-| Bulk update operation. If one update fails it will proceed with the + - remaining documents. Current returned value is only a place holder. With + - mongodb server before 2.6 it will send update requests one by one. After 2.6 + - it will use bulk update feature in mongodb. + -} +updateAll :: (MonadBaseControl IO m, MonadIO m) + => Collection + -> [(Selector, Document, [UpdateOption])] + -> Action m UpdateResult +updateAll = update' False + +update' :: (MonadBaseControl IO m, MonadIO m) + => Bool + -> Collection + -> [(Selector, Document, [UpdateOption])] + -> Action m UpdateResult +update' ordered col updateDocs = do + p <- asks mongoPipe + let sd = P.serverData p + let updates = map (\(s, d, os) -> [ "q" =: s + , "u" =: d + , "upsert" =: (Upsert `elem` os) + , "multi" =: (MultiUpdate `elem` os)]) + updateDocs + + mode <- asks mongoWriteMode + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + let docSize = sizeOfDocument $ updateCommandDocument col ordered [] writeConcern + let chunks = splitAtLimit + ordered + (maxBsonObjectSize sd - docSize) + -- size of auxiliary part of update + -- document should be subtracted from + -- the overall size + (maxWriteBatchSize sd) + updates + forM_ chunks (updateBlock ordered col) + return UpdateResult + +updateBlock :: (MonadIO m, MonadBaseControl IO m) + => Bool -> Collection -> [Document] -> Action m () +updateBlock ordered col docs = do + p <- asks mongoPipe + let sd = P.serverData p + if (maxWireVersion sd < 2) + then do + db <- thisDatabase + errors <- + forM docs $ \updateDoc -> do + let doc = (at "u" updateDoc) :: Document + let sel = (at "q" updateDoc) :: Document + let upsrt = if at "upsert" updateDoc then [Upsert] else [] + let multi = if at "multi" updateDoc then [MultiUpdate] else [] + write (Update (db <.> col) (upsrt ++ multi) sel doc) + return Nothing + `catch` \(e :: SomeException) -> do + when ordered $ liftIO $ throwIO e + return $ Just e + let onlyErrors = catMaybes errors + if not $ null onlyErrors + then liftIO $ throwIO $ WriteFailure 0 (show onlyErrors) + else return () + else do + mode <- asks mongoWriteMode + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + doc <- runCommand $ updateCommandDocument col ordered docs writeConcern + case (look "writeErrors" doc, look "writeConcernError" doc) of + (Nothing, Nothing) -> return () + (Just err, Nothing) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err) + (Nothing, Just err) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err) + (Just err, Just writeConcernErr) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err ++ show writeConcernErr) + -- ** Delete -delete :: (MonadIO m) => Selection -> Action m () +delete :: (MonadIO m, MonadBaseControl IO m) + => Selection -> Action m () -- ^ Delete all documents in selection -delete = delete' [] +delete = deleteHelper [] -deleteOne :: (MonadIO m) => Selection -> Action m () +deleteOne :: (MonadIO m, MonadBaseControl IO m) + => Selection -> Action m () -- ^ Delete first document in selection -deleteOne = delete' [SingleRemove] +deleteOne = deleteHelper [SingleRemove] -delete' :: (MonadIO m) => [DeleteOption] -> Selection -> Action m () --- ^ Delete all documents in selection unless 'SingleRemove' option is given then only delete first document in selection -delete' opts (Select sel col) = do - db <- thisDatabase - write (Delete (db <.> col) opts sel) +deleteHelper :: (MonadBaseControl IO m, MonadIO m) + => [DeleteOption] -> Selection -> Action m () +deleteHelper opts (Select sel col) = void $ delete' True col [(sel, opts)] + +{-| Bulk delete operation. If one delete fails it will not delete the remaining + - documents. Current returned value is only a place holder. With mongodb server + - before 2.6 it will send delete requests one by one. After 2.6 it will use + - bulk delete feature in mongodb. + -} +deleteMany :: (MonadIO m, MonadBaseControl IO m) + => Collection + -> [(Selector, [DeleteOption])] + -> Action m DeleteResult +deleteMany = delete' True + +{-| Bulk delete operation. If one delete fails it will proceed with the + - remaining documents. Current returned value is only a place holder. With + - mongodb server before 2.6 it will send delete requests one by one. After 2.6 + - it will use bulk delete feature in mongodb. + -} +deleteAll :: (MonadIO m, MonadBaseControl IO m) + => Collection + -> [(Selector, [DeleteOption])] + -> Action m DeleteResult +deleteAll = delete' False + +deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document +deleteCommandDocument col ordered deletes writeConcern = + [ "delete" =: col + , "ordered" =: ordered + , "deletes" =: deletes + , "writeConcern" =: writeConcern + ] + +delete' :: (MonadIO m, MonadBaseControl IO m) + => Bool + -> Collection + -> [(Selector, [DeleteOption])] + -> Action m DeleteResult +delete' ordered col deleteDocs = do + p <- asks mongoPipe + let sd = P.serverData p + let deletes = map (\(s, os) -> [ "q" =: s + , "limit" =: if SingleRemove `elem` os + then (1 :: Int) -- Remove only one matching + else (0 :: Int) -- Remove all matching + ]) + deleteDocs + + mode <- asks mongoWriteMode + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + let docSize = sizeOfDocument $ deleteCommandDocument col ordered [] writeConcern + let chunks = splitAtLimit + ordered + (maxBsonObjectSize sd - docSize) + -- size of auxiliary part of delete + -- document should be subtracted from + -- the overall size + (maxWriteBatchSize sd) + deletes + forM_ chunks (deleteBlock ordered col) + return DeleteResult + +deleteBlock :: (MonadIO m, MonadBaseControl IO m) + => Bool -> Collection -> [Document] -> Action m () +deleteBlock ordered col docs = do + p <- asks mongoPipe + let sd = P.serverData p + if (maxWireVersion sd < 2) + then do + db <- thisDatabase + errors <- + forM docs $ \deleteDoc -> do + let sel = (at "q" deleteDoc) :: Document + let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] + write (Delete (db <.> col) opts sel) + return Nothing + `catch` \(e :: SomeException) -> do + when ordered $ liftIO $ throwIO e + return $ Just e + let onlyErrors = catMaybes errors + if not $ null onlyErrors + then liftIO $ throwIO $ WriteFailure 0 (show onlyErrors) + else return () + else do + mode <- asks mongoWriteMode + let writeConcern = case mode of + NoConfirm -> ["w" =: (0 :: Int)] + Confirm params -> params + doc <- runCommand $ deleteCommandDocument col ordered docs writeConcern + case (look "writeErrors" doc, look "writeConcernError" doc) of + (Nothing, Nothing) -> return () + (Just err, Nothing) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err) + (Nothing, Just err) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err) + (Just err, Just writeConcernErr) -> do + liftIO $ throwIO $ WriteFailure + (maybe 0 id $ lookup "ok" doc) + (show err ++ show writeConcernErr) -- * Read diff --git a/Database/MongoDB/Transport.hs b/Database/MongoDB/Transport.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Transport.hs @@ -0,0 +1,40 @@ +{-| +Module : MongoDB TLS +Copyright : (c) Victor Denisov, 2016 +License : Apache 2.0 +Maintainer : Victor Denisov denisovenator@gmail.com +Stability : alpha +Portability : POSIX + +This module defines a connection interface. It could be a regular +network connection, TLS connection, a mock or anything else. +-} + +module Database.MongoDB.Transport ( + Transport(..), + fromHandle, +) where + +import Prelude hiding (read) +import Data.ByteString (ByteString) +import qualified Data.ByteString as ByteString +import System.IO + +-- | Abstract transport interface +-- +-- `read` should return `ByteString.null` on EOF +data Transport = Transport { + read :: Int -> IO ByteString, + write :: ByteString -> IO (), + flush :: IO (), + close :: IO ()} + +fromHandle :: Handle -> IO Transport +-- ^ Make connection from handle +fromHandle handle = do + return Transport + { read = ByteString.hGet handle + , write = ByteString.hPut handle + , flush = hFlush handle + , close = hClose handle + } diff --git a/Database/MongoDB/Transport/Tls.hs b/Database/MongoDB/Transport/Tls.hs new file mode 100644 --- /dev/null +++ b/Database/MongoDB/Transport/Tls.hs @@ -0,0 +1,98 @@ +{-# 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 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_all} + , 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 + } diff --git a/System/IO/Pipeline.hs b/System/IO/Pipeline.hs deleted file mode 100644 --- a/System/IO/Pipeline.hs +++ /dev/null @@ -1,118 +0,0 @@ -{- | Pipelining is sending multiple requests over a socket and receiving the responses later in the same order (a' la HTTP pipelining). This is faster than sending one request, waiting for the response, then sending the next request, and so on. This implementation returns a /promise (future)/ response for each request that when invoked waits for the response if not already arrived. Multiple threads can send on the same pipeline (and get promises back); it will send each thread's request right away without waiting. - -A pipeline closes itself when a read or write causes an error, so you can detect a broken pipeline by checking isClosed. It also closes itself when garbage collected, or you can close it explicitly. -} - -{-# LANGUAGE RecordWildCards, NamedFieldPuns, ScopedTypeVariables #-} -{-# LANGUAGE CPP, FlexibleContexts #-} - -#if (__GLASGOW_HASKELL__ >= 706) -{-# LANGUAGE RecursiveDo #-} -#else -{-# LANGUAGE DoRec #-} -#endif - -module System.IO.Pipeline ( - -- * IOStream - IOStream(..), - -- * Pipeline - Pipeline, newPipeline, send, call, close, isClosed -) where - -import Prelude hiding (length) -import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Monad (forever) -import GHC.Conc (ThreadStatus(..), threadStatus) - -import Control.Monad.Trans (liftIO) -#if MIN_VERSION_base(4,6,0) -import Control.Concurrent.MVar.Lifted (MVar, newEmptyMVar, newMVar, withMVar, - putMVar, readMVar, mkWeakMVar) -#else -import Control.Concurrent.MVar.Lifted (MVar, newEmptyMVar, newMVar, withMVar, - putMVar, readMVar, addMVarFinalizer) -#endif -import Control.Exception.Lifted (onException, throwIO, try) - -#if !MIN_VERSION_base(4,6,0) -mkWeakMVar :: MVar a -> IO () -> IO () -mkWeakMVar = addMVarFinalizer -#endif - --- * IOStream - --- | An IO sink and source where value of type @o@ are sent and values of type @i@ are received. -data IOStream i o = IOStream { - writeStream :: o -> IO (), - readStream :: IO i, - closeStream :: IO () } - --- * Pipeline - --- | Thread-safe and pipelined connection -data Pipeline i o = Pipeline { - vStream :: MVar (IOStream i o), -- ^ Mutex on handle, so only one thread at a time can write to it - responseQueue :: Chan (MVar (Either IOError i)), -- ^ Queue of threads waiting for responses. Every time a response arrive we pop the next thread and give it the response. - listenThread :: ThreadId - } - --- | Create new Pipeline over given handle. You should 'close' pipeline when finished, which will also close handle. If pipeline is not closed but eventually garbage collected, it will be closed along with handle. -newPipeline :: IOStream i o -> IO (Pipeline i o) -newPipeline stream = do - vStream <- newMVar stream - responseQueue <- newChan - rec - let pipe = Pipeline{..} - listenThread <- forkIO (listen pipe) - _ <- mkWeakMVar vStream $ do - killThread listenThread - closeStream stream - return pipe - -close :: Pipeline i o -> IO () --- ^ Close pipe and underlying connection -close Pipeline{..} = do - killThread listenThread - closeStream =<< readMVar vStream - -isClosed :: Pipeline i o -> IO Bool -isClosed Pipeline{listenThread} = do - status <- threadStatus listenThread - return $ case status of - ThreadRunning -> False - ThreadFinished -> True - ThreadBlocked _ -> False - ThreadDied -> True ---isPipeClosed Pipeline{..} = isClosed =<< readMVar vHandle -- isClosed hangs while listen loop is waiting on read - -listen :: Pipeline i o -> IO () --- ^ Listen for responses and supply them to waiting threads in order -listen Pipeline{..} = do - stream <- readMVar vStream - forever $ do - e <- try $ readStream stream - var <- readChan responseQueue - putMVar var e - case e of - Left err -> closeStream stream >> ioError err -- close and stop looping - Right _ -> return () - -send :: Pipeline i o -> o -> IO () --- ^ Send message to destination; the destination must not response (otherwise future 'call's will get these responses instead of their own). --- Throw IOError and close pipeline if send fails -send p@Pipeline{..} message = withMVar vStream (flip writeStream message) `onException` close p - -call :: Pipeline i o -> o -> IO (IO i) --- ^ Send message to destination and return /promise/ of response from one message only. The destination must reply to the message (otherwise promises will have the wrong responses in them). --- Throw IOError and closes pipeline if send fails, likewise for promised response. -call p@Pipeline{..} message = withMVar vStream doCall `onException` close p where - doCall stream = do - writeStream stream message - var <- newEmptyMVar - liftIO $ writeChan responseQueue var - return $ readMVar var >>= either throwIO return -- return promise - - -{- Authors: Tony Hannan - Copyright 2011 10gen Inc. - Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -} diff --git a/mongoDB.cabal b/mongoDB.cabal --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -1,5 +1,5 @@ Name: mongoDB -Version: 2.0.10 +Version: 2.1.0 Synopsis: Driver (client) for MongoDB, a free, scalable, fast, document DBMS Description: This package lets you connect to MongoDB servers and @@ -21,7 +21,7 @@ Library GHC-options: -Wall - GHC-prof-options: -auto-all + GHC-prof-options: -auto-all-exported default-language: Haskell2010 Build-depends: array -any @@ -39,6 +39,8 @@ , random-shuffle -any , monad-control >= 0.3.1 , lifted-base >= 0.1.0.3 + , tls >= 1.2.0 + , data-default-class -any , transformers-base >= 0.4.1 , hashtables >= 1.1.2.0 , base16-bytestring >= 0.1.1.6 @@ -48,11 +50,11 @@ Exposed-modules: Database.MongoDB Database.MongoDB.Admin Database.MongoDB.Connection - Database.MongoDB.Internal.Connection - Database.MongoDB.Internal.Protocol - Database.MongoDB.Internal.Util Database.MongoDB.Query - System.IO.Pipeline + Database.MongoDB.Transport + Database.MongoDB.Transport.Tls + Other-modules: Database.MongoDB.Internal.Protocol + Database.MongoDB.Internal.Util Source-repository head Type: git @@ -60,8 +62,8 @@ test-suite test hs-source-dirs: test - main-is: Spec.hs - ghc-options: -Wall -with-rtsopts "-K32m" + main-is: Main.hs + ghc-options: -Wall -with-rtsopts "-K64m" type: exitcode-stdio-1.0 build-depends: mongoDB , base @@ -82,6 +84,8 @@ type: exitcode-stdio-1.0 Build-depends: array -any , base < 5 + , base64-bytestring + , base16-bytestring , binary -any , bson >= 0.3 && < 0.4 , text @@ -90,6 +94,7 @@ , mtl >= 2 , cryptohash -any , network -any + , nonce , parsec -any , random -any , random-shuffle -any diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,15 @@ +module Main where + +import Database.MongoDB.Admin (serverVersion) +import Database.MongoDB.Connection (connect, host) +import Database.MongoDB.Query (access, slaveOk) +import Data.Text (unpack) +import Test.Hspec.Runner +import qualified Spec + +main :: IO () +main = do + p <- connect $ host "localhost" + version <- access p slaveOk "admin" serverVersion + putStrLn $ "Running tests with mongodb version: " ++ (unpack version) + hspecWith defaultConfig Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover #-}