diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,26 @@ # Change Log 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.7.1.1] - 2021-06-14 + +### Fixed +- Sample code + +### Added +- Clarification to the tutorial + +## [2.7.1.0] - 2020-08-17 + +### Added +- Function findCommand + +## [2.7.0.1] - 2020-04-07 + +### Fixed +- Error reporting for deletion of big messages +- Formatting of docs + ## [2.7.0.0] - 2020-02-08 ### Fixed diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -78,7 +78,7 @@ useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True] dropCollection :: (MonadIO m, MonadFail m) => Collection -> Action m Bool --- ^ Delete the given collection! Return True if collection existed (and was deleted); return False if collection did not exist (and no action). +-- ^ Delete the given collection! Return @True@ if collection existed (and was deleted); return @False@ if collection did not exist (and no action). dropCollection coll = do resetIndexCache r <- runCommand ["drop" =: coll] @@ -87,7 +87,7 @@ fail $ "dropCollection failed: " ++ show r validateCollection :: (MonadIO m) => Collection -> Action m Document --- ^ This operation takes a while +-- ^ Validate the given collection, scanning the data and indexes for correctness. This operation takes a while. validateCollection coll = runCommand ["validate" =: coll] -- ** Index @@ -112,7 +112,7 @@ "dropDups" =: iDropDups ] ++ (maybeToList $ fmap ((=:) "expireAfterSeconds") iExpireAfterSeconds) index :: Collection -> Order -> Index --- ^ Spec of index of ordered keys on collection. Name is generated from keys. Unique and dropDups are False. +-- ^ Spec of index of ordered keys on collection. 'iName' is generated from keys. 'iUnique' and 'iDropDups' are @False@. index coll keys = Index coll keys (genName keys) False False Nothing genName :: Order -> IndexName @@ -133,7 +133,7 @@ createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase dropIndex :: (MonadIO m) => Collection -> IndexName -> Action m Document --- ^ Remove the index +-- ^ Remove the index from the given collection. dropIndex coll idxName = do resetIndexCache runCommand ["deleteIndexes" =: coll, "index" =: idxName] @@ -198,7 +198,7 @@ addUser :: (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 +-- ^ Add user with password with read-only access if the boolean argument is @True@, or read-write access if it's @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) @@ -211,11 +211,11 @@ -- ** Database admin :: Database --- ^ \"admin\" database +-- ^ The \"admin\" database, which stores user authorization and authentication data plus other system collections. admin = "admin" cloneDatabase :: (MonadIO m) => Database -> Host -> Action m Document --- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use copyDatabase in this case). +-- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use 'copyDatabase' in this case). cloneDatabase db fromHost = useDb db $ runCommand ["clone" =: showHostPort fromHost] copyDatabase :: (MonadIO m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action m Document @@ -239,9 +239,11 @@ -- ** Server serverBuildInfo :: (MonadIO m) => Action m Document +-- ^ Return a document containing the parameters used to compile the server instance. serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)] serverVersion :: (MonadIO m) => Action m Text +-- ^ Return the version of the server instance. serverVersion = at "version" `liftM` serverBuildInfo -- * Diagnostics @@ -249,15 +251,19 @@ -- ** Collection collectionStats :: (MonadIO m) => Collection -> Action m Document +-- ^ Return some storage statistics for the given collection. collectionStats coll = runCommand ["collstats" =: coll] dataSize :: (MonadIO m) => Collection -> Action m Int +-- ^ Return the total uncompressed size (in bytes) in memory of all records in the given collection. Does not include indexes. dataSize c = at "size" `liftM` collectionStats c storageSize :: (MonadIO m) => Collection -> Action m Int +-- ^ Return the total bytes allocated to the given collection. Does not include indexes. storageSize c = at "storageSize" `liftM` collectionStats c totalIndexSize :: (MonadIO m) => Collection -> Action m Int +-- ^ The total size in bytes of all indexes in this collection. totalIndexSize c = at "totalIndexSize" `liftM` collectionStats c totalSize :: MonadIO m => Collection -> Action m Int @@ -270,34 +276,45 @@ -- ** Profiling -data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq) +-- | The available profiler levels. +data ProfilingLevel + = Off -- ^ No data collection. + | Slow -- ^ Data collected only for slow operations. The slow operation time threshold is 100ms by default, but can be changed using 'setProfilingLevel'. + | All -- ^ Data collected for all operations. + deriving (Show, Enum, Eq) getProfilingLevel :: (MonadIO m) => Action m ProfilingLevel +-- ^ Get the profiler level. getProfilingLevel = (toEnum . at "was") `liftM` runCommand ["profile" =: (-1 :: Int)] type MilliSec = Int setProfilingLevel :: (MonadIO m) => ProfilingLevel -> Maybe MilliSec -> Action m () +-- ^ Set the profiler level, and optionally the slow operation time threshold (in milliseconds). setProfilingLevel p mSlowMs = runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return () -- ** Database dbStats :: (MonadIO m) => Action m Document +-- ^ Return some storage statistics for the given database. dbStats = runCommand ["dbstats" =: (1 :: Int)] currentOp :: (MonadIO m) => Action m (Maybe Document) -- ^ See currently running operation on the database, if any currentOp = findOne (select [] "$cmd.sys.inprog") +-- | An operation indentifier. type OpNum = Int killOp :: (MonadIO m) => OpNum -> Action m (Maybe Document) +-- ^ Terminate the operation specified by the given 'OpNum'. killOp op = findOne (select ["op" =: op] "$cmd.sys.killop") -- ** Server serverStatus :: (MonadIO m) => Action m Document +-- ^ Return a document with an overview of the state of the database. serverStatus = useDb admin $ runCommand ["serverStatus" =: (1 :: Int)] diff --git a/Database/MongoDB/Connection.hs b/Database/MongoDB/Connection.hs --- a/Database/MongoDB/Connection.hs +++ b/Database/MongoDB/Connection.hs @@ -84,6 +84,7 @@ readHostPortM :: (MonadFail m) => String -> m Host -- ^ Read string \"hostname:port\" as @Host hosthame (PortNumber port)@ or \"hostname\" as @host hostname@ (default port). Fail if string does not match either syntax. + -- TODO: handle Service port readHostPortM = either (fail . show) return . parse parser "readHostPort" where hostname = many1 (letter <|> digit <|> char '-' <|> char '.' <|> char '_') @@ -109,16 +110,16 @@ type Secs = Double globalConnectTimeout :: IORef Secs --- ^ 'connect' (and 'openReplicaSet') fails if it can't connect within this many seconds (default is 6 seconds). Use 'connect\'' (and 'openReplicaSet\'') if you want to ignore this global and specify your own timeout. Note, this timeout only applies to initial connection establishment, not when reading/writing to the connection. +-- ^ 'connect' (and 'openReplicaSet') fails if it can't connect within this many seconds (default is 6 seconds). Use 'connect'' (and 'openReplicaSet'') if you want to ignore this global and specify your own timeout. Note, this timeout only applies to initial connection establishment, not when reading/writing to the connection. globalConnectTimeout = unsafePerformIO (newIORef 6) {-# NOINLINE globalConnectTimeout #-} connect :: Host -> IO Pipe --- ^ Connect to Host returning pipelined TCP connection. Throw IOError if connection refused or no response within 'globalConnectTimeout'. +-- ^ Connect to Host returning pipelined TCP connection. Throw 'IOError' if connection refused or no response within 'globalConnectTimeout'. connect h = readIORef globalConnectTimeout >>= flip connect' h connect' :: Secs -> Host -> IO Pipe --- ^ Connect to Host returning pipelined TCP connection. Throw IOError if connection refused or no response within given number of seconds. +-- ^ Connect to Host returning pipelined TCP connection. Throw 'IOError' if connection refused or no response within given number of seconds. connect' timeoutSecs (Host hostname port) = do mh <- timeout (round $ timeoutSecs * 1000000) (connectTo hostname port) handle <- maybe (ioError $ userError "connect timed out") return mh @@ -137,11 +138,11 @@ data ReplicaSet = ReplicaSet ReplicaSetName (MVar [(Host, Maybe Pipe)]) Secs TransportSecurity replSetName :: ReplicaSet -> Text --- ^ name of connected replica set +-- ^ Get the name of connected replica set. replSetName (ReplicaSet rsName _ _ _) = rsName openReplicaSet :: (ReplicaSetName, [Host]) -> IO ReplicaSet --- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSet\'' instead. +-- ^ Open connections (on demand) to servers in replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSet'' instead. openReplicaSet rsSeed = readIORef globalConnectTimeout >>= flip openReplicaSet' rsSeed openReplicaSet' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet @@ -149,7 +150,7 @@ openReplicaSet' timeoutSecs (rs, hosts) = _openReplicaSet timeoutSecs (rs, hosts, Unsecure) openReplicaSetTLS :: (ReplicaSetName, [Host]) -> IO ReplicaSet --- ^ Open secure connections (on demand) to servers in the replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetTLS\'' instead. +-- ^ Open secure connections (on demand) to servers in the replica set. Supplied hosts is seed list. At least one of them must be a live member of the named replica set, otherwise fail. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetTLS'' instead. openReplicaSetTLS rsSeed = readIORef globalConnectTimeout >>= flip openReplicaSetTLS' rsSeed openReplicaSetTLS' :: Secs -> (ReplicaSetName, [Host]) -> IO ReplicaSet @@ -164,23 +165,23 @@ return rs openReplicaSetSRV :: HostName -> IO ReplicaSet --- ^ Open non-secure connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetSRV\'\'\'' instead. +-- ^ Open /non-secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetSRV''' instead. openReplicaSetSRV hostname = do timeoutSecs <- readIORef globalConnectTimeout _openReplicaSetSRV timeoutSecs Unsecure hostname openReplicaSetSRV' :: HostName -> IO ReplicaSet --- ^ Open secure connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetSRV\'\'\'\'' instead. +-- ^ Open /secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. The value of 'globalConnectTimeout' at the time of this call is the timeout used for future member connect attempts. To use your own value call 'openReplicaSetSRV'''' instead. openReplicaSetSRV' hostname = do timeoutSecs <- readIORef globalConnectTimeout _openReplicaSetSRV timeoutSecs Secure hostname openReplicaSetSRV'' :: Secs -> HostName -> IO ReplicaSet --- ^ Open non-secure connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members. +-- ^ Open /non-secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members. openReplicaSetSRV'' timeoutSecs = _openReplicaSetSRV timeoutSecs Unsecure openReplicaSetSRV''' :: Secs -> HostName -> IO ReplicaSet --- ^ Open secure connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members. +-- ^ Open /secure/ connections (on demand) to servers in a replica set. The seedlist and replica set name is fetched from the SRV and TXT DNS records for the given hostname. Supplied seconds timeout is used for connect attempts to members. openReplicaSetSRV''' timeoutSecs = _openReplicaSetSRV timeoutSecs Secure _openReplicaSetSRV :: Secs -> TransportSecurity -> HostName -> IO ReplicaSet 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 @@ -385,8 +385,8 @@ qFullCollection :: FullCollection, qSkip :: Int32, -- ^ Number of initial matching documents to skip qBatchSize :: Int32, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Negative means close cursor after first batch and use absolute value as batch size. - qSelector :: Document, -- ^ \[\] = return all documents in collection - qProjector :: Document -- ^ \[\] = return whole document + qSelector :: Document, -- ^ @[]@ = return all documents in collection + qProjector :: Document -- ^ @[]@ = return whole document } | GetMore { gFullCollection :: FullCollection, gBatchSize :: Int32, @@ -394,13 +394,15 @@ deriving (Show, Eq) data QueryOption = - TailableCursor -- ^ Tailable means cursor is not closed when the last data is retrieved. Rather, the cursor marks the final object's position. You can resume using the cursor later, from where it was located, if more data were received. Like any "latent cursor", the cursor may become invalid at some point – for example if the final object it references were deleted. Thus, you should be prepared to requery on CursorNotFound exception. + TailableCursor -- ^ Tailable means cursor is not closed when the last data is retrieved. Rather, the cursor marks the final object's position. You can resume using the cursor later, from where it was located, if more data were received. Like any "latent cursor", the cursor may become invalid at some point – for example if the final object it references were deleted. Thus, you should be prepared to requery on @CursorNotFound@ exception. | SlaveOK -- ^ Allow query of replica slave. Normally these return an error except for namespace "local". | NoCursorTimeout -- ^ The server normally times out idle cursors after 10 minutes to prevent a memory leak in case a client forgets to close a cursor. Set this option to allow a cursor to live forever until it is closed. | AwaitData -- ^ Use with TailableCursor. If we are at the end of the data, block for a while rather than returning no data. After a timeout period, we do return as normal. + -- | Exhaust -- ^ Stream the data down full blast in multiple "more" packages, on the assumption that the client will fully read all data queried. Faster when you are pulling a lot of data and know you want to pull it all down. Note: the client is not allowed to not read all the data unless it closes the connection. -- Exhaust commented out because not compatible with current `Pipeline` implementation - | Partial -- ^ Get partial results from a _mongos_ if some shards are down, instead of throwing an error. + + | Partial -- ^ Get partial results from a /mongos/ if some shards are down, instead of throwing an error. deriving (Show, Eq) -- *** Binary format diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -29,7 +29,7 @@ -- ** Query Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Projector, Limit, Order, BatchSize, - explain, find, findOne, fetch, + explain, find, findCommand, findOne, fetch, findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts, count, distinct, -- *** Cursor @@ -136,17 +136,17 @@ instance Exception Failure type ErrorCode = Int --- ^ Error code from getLastError or query failure +-- ^ Error code from @getLastError@ or query failure. --- | Type of reads and writes to perform +-- | Type of reads and writes to perform. data AccessMode = ReadStaleOk -- ^ Read-only action, reading stale data from a slave is OK. | UnconfirmedWrites -- ^ Read-write action, slave not OK, every write is fire & forget. - | ConfirmWrites GetLastError -- ^ Read-write action, slave not OK, every write is confirmed with getLastError. + | ConfirmWrites GetLastError -- ^ Read-write action, slave not OK, every write is confirmed with @getLastError@. deriving Show 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. +-- ^ 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. class Result a where isFailed :: a -> Bool @@ -200,7 +200,8 @@ data MongoContext = MongoContext { mongoPipe :: Pipe, -- ^ operations read/write to this pipelined TCP connection to a MongoDB server mongoAccessMode :: AccessMode, -- ^ read/write operation will use this access mode - mongoDatabase :: Database } -- ^ operations query/update this database + mongoDatabase :: Database -- ^ operations query/update this database +} mongoReadMode :: MongoContext -> ReadMode mongoReadMode = readMode . mongoAccessMode @@ -430,7 +431,7 @@ -- ^ Insert documents into collection and return their \"_id\" values, -- which are created automatically if not supplied. -- If a document fails to be inserted (eg. due to duplicate key) --- then remaining docs are aborted, and LastError is set. +-- then remaining docs are aborted, and @LastError@ is set. -- An exception will be throw if any error occurs. insertMany = insert' [] @@ -632,12 +633,12 @@ ] {-| 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. In order to receive - - error messages in versions under 2.6 you need to user confirmed writes. - - Otherwise even if the errors had place the list of errors will be empty and - - the result will be success. After 2.6 it will use bulk update feature in - - mongodb. + documents. Current returned value is only a place holder. With mongodb server + before 2.6 it will send update requests one by one. In order to receive + error messages in versions under 2.6 you need to user confirmed writes. + Otherwise even if the errors had place the list of errors will be empty and + the result will be success. After 2.6 it will use bulk update feature in + mongodb. -} updateMany :: (MonadIO m) => Collection @@ -646,11 +647,11 @@ updateMany = update' True {-| Bulk update operation. If one update fails it will proceed with the - - remaining documents. With mongodb server before 2.6 it will send update - - requests one by one. In order to receive error messages in versions under - - 2.6 you need to use confirmed writes. Otherwise even if the errors had - - place the list of errors will be empty and the result will be success. - - After 2.6 it will use bulk update feature in mongodb. + remaining documents. With mongodb server before 2.6 it will send update + requests one by one. In order to receive error messages in versions under + 2.6 you need to use confirmed writes. Otherwise even if the errors had + place the list of errors will be empty and the result will be success. + After 2.6 it will use bulk update feature in mongodb. -} updateAll :: (MonadIO m) => Collection @@ -846,9 +847,9 @@ liftIO $ runReaderT (void $ write (Delete (db <.> col) opts sel)) ctx {-| 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. + 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) => Collection @@ -857,9 +858,9 @@ 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. + 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) => Collection @@ -895,25 +896,22 @@ NoConfirm -> ["w" =: (0 :: Int)] Confirm params -> params let docSize = sizeOfDocument $ deleteCommandDocument col ordered [] writeConcern - let preChunks = splitAtLimit + let chunks = splitAtLimit (maxBsonObjectSize sd - docSize) -- size of auxiliary part of delete -- document should be subtracted from -- the overall size (maxWriteBatchSize sd) deletes - let chunks = - if ordered - then takeRightsUpToLeft preChunks - else rights preChunks ctx <- ask - let lens = map length chunks + let lens = map (either (const 1) length) chunks let lSums = 0 : (zipWith (+) lSums lens) - blockResult <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \b -> do - dr <- runReaderT (deleteBlock ordered col b) ctx - return dr - `catch` \(e :: Failure) -> do - return $ WriteResult True 0 Nothing 0 [] [e] [] + let failureResult e = return $ WriteResult True 0 Nothing 0 [] [e] [] + let doChunk b = runReaderT (deleteBlock ordered col b) ctx `catch` failureResult + blockResult <- liftIO $ interruptibleFor ordered (zip lSums chunks) $ \(n, c) -> + case c of + Left e -> failureResult e + Right b -> doChunk (n, b) return $ foldl1' mergeWriteResults blockResult @@ -998,15 +996,15 @@ -- | Use 'select' to create a basic query with defaults, then modify if desired. For example, @(select sel col) {limit = 10}@ data Query = Query { - options :: [QueryOption], -- ^ Default = [] + options :: [QueryOption], -- ^ Default = @[]@ selection :: Selection, - project :: Projector, -- ^ \[\] = all fields. Default = [] + project :: Projector, -- ^ @[]@ = all fields. Default = @[]@ skip :: Word32, -- ^ Number of initial matching documents to skip. Default = 0 limit :: Limit, -- ^ Maximum number of documents to return, 0 = no limit. Default = 0 - sort :: Order, -- ^ Sort results by this order, [] = no sort. Default = [] - snapshot :: Bool, -- ^ If true assures no duplicates are returned, or objects missed, which were present at both the start and end of the query's execution (even if the object were updated). If an object is new during the query, or deleted during the query, it may or may not be returned, even with snapshot mode. Note that short query responses (less than 1MB) are always effectively snapshotted. Default = False + sort :: Order, -- ^ Sort results by this order, @[]@ = no sort. Default = @[]@ + snapshot :: Bool, -- ^ If true assures no duplicates are returned, or objects missed, which were present at both the start and end of the query's execution (even if the object were updated). If an object is new during the query, or deleted during the query, it may or may not be returned, even with snapshot mode. Note that short query responses (less than 1MB) are always effectively snapshotted. Default = @False@ batchSize :: BatchSize, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Default = 0 - hint :: Order -- ^ Force MongoDB to use this index, [] = no hint. Default = [] + hint :: Order -- ^ Force MongoDB to use this index, @[]@ = no hint. Default = @[]@ } deriving (Show, Eq) type Projector = Document @@ -1034,8 +1032,37 @@ dBatch <- liftIO $ request pipe [] qr newCursor db (coll selection) batchSize dBatch +findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor +-- ^ Fetch documents satisfying query using the command "find" +findCommand Query{..} = do + let aColl = coll selection + response <- runCommand $ + [ "find" =: aColl + , "filter" =: selector selection + , "sort" =: sort + , "projection" =: project + , "hint" =: hint + , "skip" =: toInt32 skip + ] + ++ mconcat -- optional fields. They should not be present if set to 0 and mongo will use defaults + [ "batchSize" =? toMaybe (/= 0) toInt32 batchSize + , "limit" =? toMaybe (/= 0) toInt32 limit + ] + + getCursorFromResponse aColl response + >>= either (liftIO . throwIO . QueryFailure (at "code" response)) return + + where + toInt32 :: Integral a => a -> Int32 + toInt32 = fromIntegral + + toMaybe :: (a -> Bool) -> (a -> b) -> a -> Maybe b + toMaybe predicate f a + | predicate a = Just (f a) + | otherwise = Nothing + findOne :: (MonadIO m) => Query -> Action m (Maybe Document) --- ^ Fetch first document satisfying query or Nothing if none satisfy it +-- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it findOne q = do pipe <- asks mongoPipe qr <- queryRequest False q {limit = 1} @@ -1047,14 +1074,17 @@ -- ^ Same as 'findOne' except throw 'DocNotFound' if none match fetch q = findOne q >>= maybe (liftIO $ throwIO $ DocNotFound $ selection q) return -data FindAndModifyOpts = FamRemove Bool - | FamUpdate - { famUpdate :: Document - , famNew :: Bool - , famUpsert :: Bool - } - deriving Show +-- | Options for @findAndModify@ +data FindAndModifyOpts + = FamRemove Bool -- ^ remove the selected document when the boolean is @True@ + | FamUpdate + { famUpdate :: Document -- ^ the update instructions, or a replacement document + , famNew :: Bool -- ^ return the document with the modifications made on the update + , famUpsert :: Bool -- ^ create a new document if no documents match the query + } + deriving Show +-- | Default options used by 'findAndModify'. defFamUpdateOpts :: Document -> FindAndModifyOpts defFamUpdateOpts ups = FamUpdate { famNew = True @@ -1062,10 +1092,10 @@ , famUpdate = ups } --- | runs the findAndModify command as an update without an upsert and new set to true. --- Returns a single updated document (new option is set to true). +-- | Run the @findAndModify@ command as an update without an upsert and new set to @True@. +-- Return a single updated document (@new@ option is set to @True@). -- --- see 'findAndModifyOpts' if you want to use findAndModify in a differnt way +-- See 'findAndModifyOpts' for more options. findAndModify :: (MonadIO m, MonadFail m) => Query -> Document -- ^ updates @@ -1079,11 +1109,11 @@ Nothing -> Left "findAndModify: impossible null result" Just doc -> Right doc --- | runs the findAndModify command, --- allows more options than 'findAndModify' +-- | Run the @findAndModify@ command +-- (allows more options than 'findAndModify') findAndModifyOpts :: (MonadIO m, MonadFail m) => Query - ->FindAndModifyOpts + -> FindAndModifyOpts -> Action m (Either String (Maybe Document)) findAndModifyOpts (Query { selection = Select sel collection @@ -1308,25 +1338,45 @@ aggregate aColl agg = do aggregateCursor aColl agg def >>= rest -data AggregateConfig = AggregateConfig {} - deriving Show +data AggregateConfig = AggregateConfig + { allowDiskUse :: Bool -- ^ Enable writing to temporary files (aggregations have a 100Mb RAM limit) + } + deriving Show instance Default AggregateConfig where - def = AggregateConfig {} + def = AggregateConfig + { allowDiskUse = False + } +aggregateCommand :: Collection -> Pipeline -> AggregateConfig -> Document +aggregateCommand aColl agg AggregateConfig {..} = + [ "aggregate" =: aColl + , "pipeline" =: agg + , "cursor" =: ([] :: Document) + , "allowDiskUse" =: allowDiskUse + ] + aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor -- ^ Runs an aggregate and unpacks the result. See for details. -aggregateCursor aColl agg _ = do - response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)] - case true1 "ok" response of - True -> do - cursor :: Document <- lookup "cursor" response - firstBatch :: [Document] <- lookup "firstBatch" cursor - cursorId :: Int64 <- lookup "id" cursor - db <- thisDatabase - newCursor db aColl 0 $ return $ Batch Nothing cursorId firstBatch - False -> liftIO $ throwIO $ AggregateFailure $ at "errmsg" response +aggregateCursor aColl agg cfg = do + response <- runCommand (aggregateCommand aColl agg cfg) + getCursorFromResponse aColl response + >>= either (liftIO . throwIO . AggregateFailure) return +getCursorFromResponse + :: (MonadIO m, MonadFail m) + => Collection + -> Document + -> Action m (Either String Cursor) +getCursorFromResponse aColl response + | true1 "ok" response = do + cursor <- lookup "cursor" response + firstBatch <- lookup "firstBatch" cursor + cursorId <- lookup "id" cursor + db <- thisDatabase + Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch) + | otherwise = return $ Left $ at "errmsg" response + -- ** Group -- | Groups documents in collection by key then reduces (aggregates) each group @@ -1335,12 +1385,12 @@ gKey :: GroupKey, -- ^ Fields to group by gReduce :: Javascript, -- ^ @(doc, agg) -> ()@. The reduce function reduces (aggregates) the objects iterated. Typical operations of a reduce function include summing and counting. It takes two arguments, the current document being iterated over and the aggregation value, and updates the aggregate value. gInitial :: Document, -- ^ @agg@. Initial aggregation value supplied to reduce - gCond :: Selector, -- ^ Condition that must be true for a row to be considered. [] means always true. - gFinalize :: Maybe Javascript -- ^ @agg -> () | result@. An optional function to be run on each item in the result set just before the item is returned. Can either modify the item (e.g., add an average field given a count and a total) or return a replacement object (returning a new object with just _id and average fields). + gCond :: Selector, -- ^ Condition that must be true for a row to be considered. @[]@ means always true. + gFinalize :: Maybe Javascript -- ^ @agg -> () | result@. An optional function to be run on each item in the result set just before the item is returned. Can either modify the item (e.g., add an average field given a count and a total) or return a replacement object (returning a new object with just @_id@ and average fields). } deriving (Show, Eq) data GroupKey = Key [Label] | KeyF Javascript deriving (Show, Eq) --- ^ Fields to group by, or function (@doc -> key@) returning a "key object" to be used as the grouping key. Use KeyF instead of Key to specify a key that is not an existing member of the object (or, to access embedded members). +-- ^ Fields to group by, or function (@doc -> key@) returning a "key object" to be used as the grouping key. Use 'KeyF' instead of 'Key' to specify a key that is not an existing member of the object (or, to access embedded members). groupDocument :: Group -> Document -- ^ Translate Group data into expected document form @@ -1359,17 +1409,17 @@ -- ** MapReduce -- | Maps every document in collection to a list of (key, value) pairs, then for each unique key reduces all its associated values to a single result. There are additional parameters that may be set to tweak this basic operation. --- This implements the latest version of map-reduce that requires MongoDB 1.7.4 or greater. To map-reduce against an older server use runCommand directly as described in http://www.mongodb.org/display/DOCS/MapReduce. +-- This implements the latest version of map-reduce that requires MongoDB 1.7.4 or greater. To map-reduce against an older server use 'runCommand' directly as described in http://www.mongodb.org/display/DOCS/MapReduce. data MapReduce = MapReduce { rColl :: Collection, rMap :: MapFun, rReduce :: ReduceFun, - rSelect :: Selector, -- ^ Operate on only those documents selected. Default is [] meaning all documents. - rSort :: Order, -- ^ Default is [] meaning no sort + rSelect :: Selector, -- ^ Operate on only those documents selected. Default is @[]@ meaning all documents. + rSort :: Order, -- ^ Default is @[]@ meaning no sort rLimit :: Limit, -- ^ Default is 0 meaning no limit rOut :: MROut, -- ^ Output to a collection with a certain merge policy. Default is no collection ('Inline'). Note, you don't want this default if your result set is large. rFinalize :: Maybe FinalizeFun, -- ^ Function to apply to all the results when finished. Default is Nothing. - rScope :: Document, -- ^ Variables (environment) that can be accessed from map/reduce/finalize. Default is []. + rScope :: Document, -- ^ Variables (environment) that can be accessed from map/reduce/finalize. Default is @[]@. rVerbose :: Bool -- ^ Provide statistics on job execution time. Default is False. } deriving (Show, Eq) diff --git a/mongoDB.cabal b/mongoDB.cabal --- a/mongoDB.cabal +++ b/mongoDB.cabal @@ -1,5 +1,5 @@ Name: mongoDB -Version: 2.7.0.0 +Version: 2.7.1.1 Synopsis: Driver (client) for MongoDB, a free, scalable, fast, document DBMS Description: This package lets you connect to MongoDB servers and diff --git a/test/QuerySpec.hs b/test/QuerySpec.hs --- a/test/QuerySpec.hs +++ b/test/QuerySpec.hs @@ -43,6 +43,21 @@ ] return () +insertUsers :: IO () +insertUsers = db $ + insertAll_ "users" [ ["_id" =: "jane", "joined" =: parseDate "2011-03-02", "likes" =: ["golf", "racquetball"]] + , ["_id" =: "joe", "joined" =: parseDate "2012-07-02", "likes" =: ["tennis", "golf", "swimming"]] + , ["_id" =: "jill", "joined" =: parseDate "2013-11-17", "likes" =: ["cricket", "golf"]] + ] + +pendingIfMongoVersion :: ((Integer, Integer) -> Bool) -> SpecWith () -> Spec +pendingIfMongoVersion invalidVersion = before $ do + version <- db $ extractVersion . T.splitOn "." . at "version" <$> runCommand1 "buildinfo" + when (invalidVersion version) $ pendingWith "This test does not run in the current database version" + where + extractVersion (major:minor:_) = (read $ T.unpack major, read $ T.unpack minor) + extractVersion _ = error "Invalid version specification" + bigDocument :: Document bigDocument = (flip map) [1..10000] $ \i -> (fromString $ "team" ++ (show i)) =: ("team " ++ (show i) ++ " name") @@ -428,13 +443,34 @@ collections <- db $ allCollections liftIO $ (L.sort collections) `shouldContain` ["team1", "team2", "team3"] - describe "aggregate" $ do + describe "aggregate" $ before_ insertUsers $ it "aggregates to normalize and sort documents" $ do - db $ insertAll_ "users" [ ["_id" =: "jane", "joined" =: parseDate "2011-03-02", "likes" =: ["golf", "racquetball"]] - , ["_id" =: "joe", "joined" =: parseDate "2012-07-02", "likes" =: ["tennis", "golf", "swimming"]] - , ["_id" =: "jill", "joined" =: parseDate "2013-11-17", "likes" =: ["cricket", "golf"]] - ] result <- db $ aggregate "users" [ ["$project" =: ["name" =: ["$toUpper" =: "$_id"], "_id" =: 0]] , ["$sort" =: ["name" =: 1]] ] result `shouldBe` [["name" =: "JANE"], ["name" =: "JILL"], ["name" =: "JOE"]] + + -- This feature was introduced in MongoDB version 3.2 + -- https://docs.mongodb.com/manual/reference/command/find/ + describe "findCommand" $ pendingIfMongoVersion (< (3,2)) $ + context "when mongo version is 3.2 or superior" $ before insertUsers $ do + it "fetches all the records" $ do + result <- db $ rest =<< findCommand (select [] "users") + length result `shouldBe` 3 + + it "filters the records" $ do + result <- db $ rest =<< findCommand (select ["_id" =: "joe"] "users") + length result `shouldBe` 1 + + it "projects the records" $ do + result <- db $ rest =<< findCommand + (select [] "users") { project = [ "_id" =: 1 ] } + result `shouldBe` [["_id" =: "jane"], ["_id" =: "joe"], ["_id" =: "jill"]] + + it "sorts the records" $ do + result <- db $ rest =<< findCommand + (select [] "users") { project = [ "_id" =: 1 ] + , sort = [ "_id" =: 1 ] + } + result `shouldBe` [["_id" =: "jane"], ["_id" =: "jill"], ["_id" =: "joe"]] +