PageRenderTime 51ms CodeModel.GetById 17ms RepoModel.GetById 0ms app.codeStats 1ms

/Database/MongoDB/Query.hs

http://github.com/TonyGen/mongoDB-haskell
Haskell | 684 lines | 429 code | 127 blank | 128 comment | 44 complexity | 2ad9ea5b58d78190c45853b51a9696ed MD5 | raw file
Possible License(s): Apache-2.0
  1. -- | Query and update documents
  2. {-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, StandaloneDeriving, TypeSynonymInstances, TypeFamilies #-}
  3. module Database.MongoDB.Query (
  4. -- * Monad
  5. Action, access, Failure(..), ErrorCode,
  6. AccessMode(..), GetLastError, master, slaveOk, accessMode,
  7. MonadDB(..),
  8. -- * Database
  9. Database, allDatabases, useDb, thisDatabase,
  10. -- ** Authentication
  11. Username, Password, auth,
  12. -- * Collection
  13. Collection, allCollections,
  14. -- ** Selection
  15. Selection(..), Selector, whereJS,
  16. Select(select),
  17. -- * Write
  18. -- ** Insert
  19. insert, insert_, insertMany, insertMany_, insertAll, insertAll_,
  20. -- ** Update
  21. save, replace, repsert, Modifier, modify,
  22. -- ** Delete
  23. delete, deleteOne,
  24. -- * Read
  25. -- ** Query
  26. Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial), Projector, Limit, Order, BatchSize,
  27. explain, find, findOne, fetch, count, distinct,
  28. -- *** Cursor
  29. Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed,
  30. -- ** Group
  31. Group(..), GroupKey(..), group,
  32. -- ** MapReduce
  33. MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..), MRResult, mapReduce, runMR, runMR',
  34. -- * Command
  35. Command, runCommand, runCommand1,
  36. eval,
  37. ) where
  38. import Prelude as X hiding (lookup)
  39. import Data.UString as U (UString, dropWhile, any, tail)
  40. import Data.Bson (Document, at, valueAt, lookup, look, Field(..), (=:), (=?), Label, Value(String,Doc), Javascript, genObjectId)
  41. import Database.MongoDB.Internal.Protocol (Pipe, Notice(..), Request(GetMore, qOptions, qFullCollection, qSkip, qBatchSize, qSelector, qProjector), Reply(..), QueryOption(..), ResponseFlag(..), InsertOption(..), UpdateOption(..), DeleteOption(..), CursorId, FullCollection, Username, Password, pwKey)
  42. import qualified Database.MongoDB.Internal.Protocol as P (send, call, Request(Query))
  43. import Database.MongoDB.Internal.Util (MonadIO', loop, liftIOE, true1, (<.>))
  44. import Control.Concurrent.MVar.Lifted
  45. import Control.Monad.Error
  46. import Control.Monad.Reader
  47. import Control.Monad.State (StateT)
  48. import Control.Monad.Writer (WriterT, Monoid)
  49. import Control.Monad.RWS (RWST)
  50. import Control.Monad.Base (MonadBase(liftBase))
  51. import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..), MonadTransControl(..), StM, StT, defaultLiftBaseWith, defaultRestoreM)
  52. import Control.Applicative (Applicative, (<$>))
  53. import Data.Maybe (listToMaybe, catMaybes)
  54. import Data.Int (Int32)
  55. import Data.Word (Word32)
  56. -- * Monad
  57. newtype Action m a = Action {unAction :: ErrorT Failure (ReaderT Context m) a}
  58. deriving (Functor, Applicative, Monad, MonadIO, MonadError Failure)
  59. -- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'
  60. instance MonadBase b m => MonadBase b (Action m) where
  61. liftBase = Action . liftBase
  62. instance (MonadIO m, MonadBaseControl b m) => MonadBaseControl b (Action m) where
  63. newtype StM (Action m) a = StMT {unStMT :: ComposeSt Action m a}
  64. liftBaseWith = defaultLiftBaseWith StMT
  65. restoreM = defaultRestoreM unStMT
  66. instance MonadTrans Action where
  67. lift = Action . lift . lift
  68. instance MonadTransControl Action where
  69. newtype StT Action a = StActionT {unStAction :: StT (ReaderT Context) (StT (ErrorT Failure) a)}
  70. liftWith f = Action $ liftWith $ \runError ->
  71. liftWith $ \runReader' ->
  72. f (liftM StActionT . runReader' . runError . unAction)
  73. restoreT = Action . restoreT . restoreT . liftM unStAction
  74. access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m (Either Failure a)
  75. -- ^ Run action against database on server at other end of pipe. Use access mode for any reads and writes. Return Left on connection failure or read/write failure.
  76. access myPipe myAccessMode myDatabase (Action action) = runReaderT (runErrorT action) Context{..}
  77. -- | A connection failure, or a read or write exception like cursor expired or inserting a duplicate key.
  78. -- Note, unexpected data from the server is not a Failure, rather it is a programming error (you should call 'error' in this case) because the client and server are incompatible and requires a programming change.
  79. data Failure =
  80. ConnectionFailure IOError -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe.
  81. | CursorNotFoundFailure CursorId -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set)
  82. | QueryFailure ErrorCode String -- ^ Query failed for some reason as described in the string
  83. | WriteFailure ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string
  84. | DocNotFound Selection -- ^ 'fetch' found no document matching selection
  85. deriving (Show, Eq)
  86. type ErrorCode = Int
  87. -- ^ Error code from getLastError or query failure
  88. instance Error Failure where strMsg = error
  89. -- ^ 'fail' is treated the same as a programming 'error'. In other words, don't use it.
  90. -- | Type of reads and writes to perform
  91. data AccessMode =
  92. ReadStaleOk -- ^ Read-only action, reading stale data from a slave is OK.
  93. | UnconfirmedWrites -- ^ Read-write action, slave not OK, every write is fire & forget.
  94. | ConfirmWrites GetLastError -- ^ Read-write action, slave not OK, every write is confirmed with getLastError.
  95. deriving Show
  96. type GetLastError = Document
  97. -- ^ 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 <http://www.mongodb.org/display/DOCS/Last+Error+Commands> for more options.
  98. master :: AccessMode
  99. -- ^ Same as 'ConfirmWrites' []
  100. master = ConfirmWrites []
  101. slaveOk :: AccessMode
  102. -- ^ Same as 'ReadStaleOk'
  103. slaveOk = ReadStaleOk
  104. accessMode :: (Monad m) => AccessMode -> Action m a -> Action m a
  105. -- ^ Run action with given 'AccessMode'
  106. accessMode mode (Action act) = Action $ local (\ctx -> ctx {myAccessMode = mode}) act
  107. readMode :: AccessMode -> ReadMode
  108. readMode ReadStaleOk = StaleOk
  109. readMode _ = Fresh
  110. writeMode :: AccessMode -> WriteMode
  111. writeMode ReadStaleOk = Confirm []
  112. writeMode UnconfirmedWrites = NoConfirm
  113. writeMode (ConfirmWrites z) = Confirm z
  114. -- | Values needed when executing a db operation
  115. data Context = Context {
  116. myPipe :: Pipe, -- ^ operations read/write to this pipelined TCP connection to a MongoDB server
  117. myAccessMode :: AccessMode, -- ^ read/write operation will use this access mode
  118. myDatabase :: Database } -- ^ operations query/update this database
  119. myReadMode :: Context -> ReadMode
  120. myReadMode = readMode . myAccessMode
  121. myWriteMode :: Context -> WriteMode
  122. myWriteMode = writeMode . myAccessMode
  123. send :: (MonadIO m) => [Notice] -> Action m ()
  124. -- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails.
  125. send ns = Action $ do
  126. pipe <- asks myPipe
  127. liftIOE ConnectionFailure $ P.send pipe ns
  128. call :: (MonadIO m) => [Notice] -> Request -> Action m (ErrorT Failure IO Reply)
  129. -- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive.
  130. call ns r = Action $ do
  131. pipe <- asks myPipe
  132. promise <- liftIOE ConnectionFailure $ P.call pipe ns r
  133. return (liftIOE ConnectionFailure promise)
  134. -- | If you stack a monad on top of 'Action' then make it an instance of this class and use 'liftDB' to execute a DB Action within it. Instances already exist for the basic mtl transformers.
  135. class (Monad m, MonadBaseControl IO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where
  136. type BaseMonad m :: * -> *
  137. liftDB :: Action (BaseMonad m) a -> m a
  138. instance (MonadBaseControl IO m, Applicative m, Functor m) => MonadDB (Action m) where
  139. type BaseMonad (Action m) = m
  140. liftDB = id
  141. instance (MonadDB m, Error e) => MonadDB (ErrorT e m) where
  142. type BaseMonad (ErrorT e m) = BaseMonad m
  143. liftDB = lift . liftDB
  144. instance (MonadDB m) => MonadDB (ReaderT r m) where
  145. type BaseMonad (ReaderT r m) = BaseMonad m
  146. liftDB = lift . liftDB
  147. instance (MonadDB m) => MonadDB (StateT s m) where
  148. type BaseMonad (StateT s m) = BaseMonad m
  149. liftDB = lift . liftDB
  150. instance (MonadDB m, Monoid w) => MonadDB (WriterT w m) where
  151. type BaseMonad (WriterT w m) = BaseMonad m
  152. liftDB = lift . liftDB
  153. instance (MonadDB m, Monoid w) => MonadDB (RWST r w s m) where
  154. type BaseMonad (RWST r w s m) = BaseMonad m
  155. liftDB = lift . liftDB
  156. -- * Database
  157. type Database = UString
  158. allDatabases :: (MonadIO' m) => Action m [Database]
  159. -- ^ List all databases residing on server
  160. allDatabases = map (at "name") . at "databases" <$> useDb "admin" (runCommand1 "listDatabases")
  161. thisDatabase :: (Monad m) => Action m Database
  162. -- ^ Current database in use
  163. thisDatabase = Action $ asks myDatabase
  164. useDb :: (Monad m) => Database -> Action m a -> Action m a
  165. -- ^ Run action against given database
  166. useDb db (Action act) = Action $ local (\ctx -> ctx {myDatabase = db}) act
  167. -- * Authentication
  168. auth :: (MonadIO' m) => Username -> Password -> Action m Bool
  169. -- ^ Authenticate with the current database (if server is running in secure mode). Return whether authentication was successful or not. Reauthentication is required for every new pipe.
  170. auth usr pss = do
  171. n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)]
  172. true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
  173. -- * Collection
  174. type Collection = UString
  175. -- ^ Collection name (not prefixed with database)
  176. allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection]
  177. -- ^ List all collections in this database
  178. allCollections = do
  179. db <- thisDatabase
  180. docs <- rest =<< find (query [] "system.namespaces") {sort = ["name" =: (1 :: Int)]}
  181. return . filter (not . isSpecial db) . map dropDbPrefix $ map (at "name") docs
  182. where
  183. dropDbPrefix = U.tail . U.dropWhile (/= '.')
  184. isSpecial db col = U.any (== '$') col && db <.> col /= "local.oplog.$main"
  185. -- * Selection
  186. data Selection = Select {selector :: Selector, coll :: Collection} deriving (Show, Eq)
  187. -- ^ Selects documents in collection that match selector
  188. type Selector = Document
  189. -- ^ Filter for a query, analogous to the where clause in SQL. @[]@ matches all documents in collection. @[\"x\" =: a, \"y\" =: b]@ is analogous to @where x = a and y = b@ in SQL. See <http://www.mongodb.org/display/DOCS/Querying> for full selector syntax.
  190. whereJS :: Selector -> Javascript -> Selector
  191. -- ^ Add Javascript predicate to selector, in which case a document must match both selector and predicate
  192. whereJS sel js = ("$where" =: js) : sel
  193. class Select aQueryOrSelection where
  194. select :: Selector -> Collection -> aQueryOrSelection
  195. -- ^ 'Query' or 'Selection' that selects documents in collection that match selector. The choice of type depends on use, for example, in @find (select sel col)@ it is a Query, and in @delete (select sel col)@ it is a Selection.
  196. instance Select Selection where
  197. select = Select
  198. instance Select Query where
  199. select = query
  200. -- * Write
  201. data WriteMode =
  202. NoConfirm -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not.
  203. | Confirm GetLastError -- ^ Receive an acknowledgment after every write, and raise exception if one says the write failed. This is acomplished by sending the getLastError command, with given 'GetLastError' parameters, after every write.
  204. deriving (Show, Eq)
  205. write :: (MonadIO m) => Notice -> Action m ()
  206. -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error.
  207. write notice = Action (asks myWriteMode) >>= \mode -> case mode of
  208. NoConfirm -> send [notice]
  209. Confirm params -> do
  210. let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd"
  211. Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1}
  212. case lookup "err" doc of
  213. Nothing -> return ()
  214. Just err -> throwError $ WriteFailure (maybe 0 id $ lookup "code" doc) err
  215. -- ** Insert
  216. insert :: (MonadIO' m) => Collection -> Document -> Action m Value
  217. -- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied
  218. insert col doc = head <$> insertMany col [doc]
  219. insert_ :: (MonadIO' m) => Collection -> Document -> Action m ()
  220. -- ^ Same as 'insert' except don't return _id
  221. insert_ col doc = insert col doc >> return ()
  222. insertMany :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
  223. -- ^ 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.
  224. insertMany = insert' []
  225. insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
  226. -- ^ Same as 'insertMany' except don't return _ids
  227. insertMany_ col docs = insertMany col docs >> return ()
  228. insertAll :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
  229. -- ^ 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 still inserted. LastError is set if any doc fails, not just last one.
  230. insertAll = insert' [KeepGoing]
  231. insertAll_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
  232. -- ^ Same as 'insertAll' except don't return _ids
  233. insertAll_ col docs = insertAll col docs >> return ()
  234. insert' :: (MonadIO m) => [InsertOption] -> Collection -> [Document] -> Action m [Value]
  235. -- ^ Insert documents into collection and return their \"_id\" values, which are created automatically if not supplied
  236. insert' opts col docs = do
  237. db <- thisDatabase
  238. docs' <- liftIO $ mapM assignId docs
  239. write (Insert (db <.> col) opts docs')
  240. return $ map (valueAt "_id") docs'
  241. assignId :: Document -> IO Document
  242. -- ^ Assign a unique value to _id field if missing
  243. assignId doc = if X.any (("_id" ==) . label) doc
  244. then return doc
  245. else (\oid -> ("_id" =: oid) : doc) <$> genObjectId
  246. -- ** Update
  247. save :: (MonadIO' m) => Collection -> Document -> Action m ()
  248. -- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or update it if its not new (has \"_id\" field)
  249. save col doc = case look "_id" doc of
  250. Nothing -> insert_ col doc
  251. Just i -> repsert (Select ["_id" := i] col) doc
  252. replace :: (MonadIO m) => Selection -> Document -> Action m ()
  253. -- ^ Replace first document in selection with given document
  254. replace = update []
  255. repsert :: (MonadIO m) => Selection -> Document -> Action m ()
  256. -- ^ Replace first document in selection with given document, or insert document if selection is empty
  257. repsert = update [Upsert]
  258. type Modifier = Document
  259. -- ^ Update operations on fields in a document. See <http://www.mongodb.org/display/DOCS/Updating#Updating-ModifierOperations>
  260. modify :: (MonadIO m) => Selection -> Modifier -> Action m ()
  261. -- ^ Update all documents in selection using given modifier
  262. modify = update [MultiUpdate]
  263. update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m ()
  264. -- ^ 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.
  265. update opts (Select sel col) up = do
  266. db <- thisDatabase
  267. write (Update (db <.> col) opts sel up)
  268. -- ** Delete
  269. delete :: (MonadIO m) => Selection -> Action m ()
  270. -- ^ Delete all documents in selection
  271. delete = delete' []
  272. deleteOne :: (MonadIO m) => Selection -> Action m ()
  273. -- ^ Delete first document in selection
  274. deleteOne = delete' [SingleRemove]
  275. delete' :: (MonadIO m) => [DeleteOption] -> Selection -> Action m ()
  276. -- ^ Delete all documents in selection unless 'SingleRemove' option is given then only delete first document in selection
  277. delete' opts (Select sel col) = do
  278. db <- thisDatabase
  279. write (Delete (db <.> col) opts sel)
  280. -- * Read
  281. data ReadMode =
  282. Fresh -- ^ read from master only
  283. | StaleOk -- ^ read from slave ok
  284. deriving (Show, Eq)
  285. readModeOption :: ReadMode -> [QueryOption]
  286. readModeOption Fresh = []
  287. readModeOption StaleOk = [SlaveOK]
  288. -- ** Query
  289. -- | Use 'select' to create a basic query with defaults, then modify if desired. For example, @(select sel col) {limit = 10}@
  290. data Query = Query {
  291. options :: [QueryOption], -- ^ Default = []
  292. selection :: Selection,
  293. project :: Projector, -- ^ \[\] = all fields. Default = []
  294. skip :: Word32, -- ^ Number of initial matching documents to skip. Default = 0
  295. limit :: Limit, -- ^ Maximum number of documents to return, 0 = no limit. Default = 0
  296. sort :: Order, -- ^ Sort results by this order, [] = no sort. Default = []
  297. 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
  298. batchSize :: BatchSize, -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Default = 0
  299. hint :: Order -- ^ Force MongoDB to use this index, [] = no hint. Default = []
  300. } deriving (Show, Eq)
  301. type Projector = Document
  302. -- ^ Fields to return, analogous to the select clause in SQL. @[]@ means return whole document (analogous to * in SQL). @[\"x\" =: 1, \"y\" =: 1]@ means return only @x@ and @y@ fields of each document. @[\"x\" =: 0]@ means return all fields except @x@.
  303. type Limit = Word32
  304. -- ^ Maximum number of documents to return, i.e. cursor will close after iterating over this number of documents. 0 means no limit.
  305. type Order = Document
  306. -- ^ Fields to sort by. Each one is associated with 1 or -1. Eg. @[\"x\" =: 1, \"y\" =: -1]@ means sort by @x@ ascending then @y@ descending
  307. type BatchSize = Word32
  308. -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default.
  309. query :: Selector -> Collection -> Query
  310. -- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
  311. query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
  312. find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor
  313. -- ^ Fetch documents satisfying query
  314. find q@Query{selection, batchSize} = do
  315. db <- thisDatabase
  316. dBatch <- request [] =<< queryRequest False q
  317. newCursor db (coll selection) batchSize dBatch
  318. findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
  319. -- ^ Fetch first document satisfying query or Nothing if none satisfy it
  320. findOne q = do
  321. Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1}
  322. return (listToMaybe docs)
  323. fetch :: (MonadIO m) => Query -> Action m Document
  324. -- ^ Same as 'findOne' except throw 'DocNotFound' if none match
  325. fetch q = findOne q >>= maybe (throwError $ DocNotFound $ selection q) return
  326. explain :: (MonadIO m) => Query -> Action m Document
  327. -- ^ Return performance stats of query execution
  328. explain q = do -- same as findOne but with explain set to true
  329. Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1}
  330. return $ if null docs then error ("no explain: " ++ show q) else head docs
  331. count :: (MonadIO' m) => Query -> Action m Int
  332. -- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present)
  333. count Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand
  334. (["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)]
  335. ++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32)))
  336. distinct :: (MonadIO' m) => Label -> Selection -> Action m [Value]
  337. -- ^ Fetch distinct values of field in selected documents
  338. distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "key" =: k, "query" =: sel]
  339. queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit)
  340. -- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
  341. queryRequest isExplain Query{..} = do
  342. ctx <- Action ask
  343. return $ queryRequest' (myReadMode ctx) (myDatabase ctx)
  344. where
  345. queryRequest' rm db = (P.Query{..}, remainingLimit) where
  346. qOptions = readModeOption rm ++ options
  347. qFullCollection = db <.> coll selection
  348. qSkip = fromIntegral skip
  349. (qBatchSize, remainingLimit) = batchSizeRemainingLimit batchSize limit
  350. qProjector = project
  351. mOrder = if null sort then Nothing else Just ("$orderby" =: sort)
  352. mSnapshot = if snapshot then Just ("$snapshot" =: True) else Nothing
  353. mHint = if null hint then Nothing else Just ("$hint" =: hint)
  354. mExplain = if isExplain then Just ("$explain" =: True) else Nothing
  355. special = catMaybes [mOrder, mSnapshot, mHint, mExplain]
  356. qSelector = if null special then s else ("$query" =: s) : special where s = selector selection
  357. batchSizeRemainingLimit :: BatchSize -> Limit -> (Int32, Limit)
  358. -- ^ Given batchSize and limit return P.qBatchSize and remaining limit
  359. batchSizeRemainingLimit batchSize limit = if limit == 0
  360. then (fromIntegral batchSize', 0) -- no limit
  361. else if 0 < batchSize' && batchSize' < limit
  362. then (fromIntegral batchSize', limit - batchSize')
  363. else (- fromIntegral limit, 1)
  364. where batchSize' = if batchSize == 1 then 2 else batchSize
  365. -- batchSize 1 is broken because server converts 1 to -1 meaning limit 1
  366. type DelayedBatch = ErrorT Failure IO Batch
  367. -- ^ A promised batch which may fail
  368. data Batch = Batch Limit CursorId [Document]
  369. -- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is remaining limit for next fetch.
  370. request :: (MonadIO m) => [Notice] -> (Request, Limit) -> Action m DelayedBatch
  371. -- ^ Send notices and request and return promised batch
  372. request ns (req, remainingLimit) = do
  373. promise <- call ns req
  374. return $ fromReply remainingLimit =<< promise
  375. fromReply :: Limit -> Reply -> DelayedBatch
  376. -- ^ Convert Reply to Batch or Failure
  377. fromReply limit Reply{..} = do
  378. mapM_ checkResponseFlag rResponseFlags
  379. return (Batch limit rCursorId rDocuments)
  380. where
  381. -- If response flag indicates failure then throw it, otherwise do nothing
  382. checkResponseFlag flag = case flag of
  383. AwaitCapable -> return ()
  384. CursorNotFound -> throwError $ CursorNotFoundFailure rCursorId
  385. QueryError -> throwError $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments)
  386. fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch
  387. -- ^ Demand and wait for result, raise failure if exception
  388. fulfill = Action . liftIOE id
  389. -- *** Cursor
  390. data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
  391. -- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
  392. newCursor :: (MonadIO m, MonadBaseControl IO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
  393. -- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
  394. newCursor db col batchSize dBatch = do
  395. var <- newMVar dBatch
  396. let cursor = Cursor (db <.> col) batchSize var
  397. addMVarFinalizer var (closeCursor cursor)
  398. return cursor
  399. nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document]
  400. -- ^ Return next batch of documents in query result, which will be empty if finished.
  401. nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
  402. -- Pre-fetch next batch promise from server and return current batch.
  403. Batch limit cid docs <- fulfill' fcol batchSize dBatch
  404. dBatch' <- if cid /= 0 then nextBatch' fcol batchSize limit cid else return $ return (Batch 0 0 [])
  405. return (dBatch', docs)
  406. fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch
  407. -- Discard pre-fetched batch if empty with nonzero cid.
  408. fulfill' fcol batchSize dBatch = do
  409. b@(Batch limit cid docs) <- fulfill dBatch
  410. if cid /= 0 && null docs
  411. then nextBatch' fcol batchSize limit cid >>= fulfill
  412. else return b
  413. nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> Limit -> CursorId -> Action m DelayedBatch
  414. nextBatch' fcol batchSize limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
  415. where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
  416. next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document)
  417. -- ^ Return next document in query result, or Nothing if finished.
  418. next (Cursor fcol batchSize var) = modifyMVar var nextState where
  419. -- Pre-fetch next batch promise from server when last one in current batch is returned.
  420. -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document)
  421. nextState dBatch = do
  422. Batch limit cid docs <- fulfill' fcol batchSize dBatch
  423. case docs of
  424. doc : docs' -> do
  425. dBatch' <- if null docs' && cid /= 0
  426. then nextBatch' fcol batchSize limit cid
  427. else return $ return (Batch limit cid docs')
  428. return (dBatch', Just doc)
  429. [] -> if cid == 0
  430. then return (return $ Batch 0 0 [], Nothing) -- finished
  431. else fmap (,Nothing) $ nextBatch' fcol batchSize limit cid
  432. nextN :: (MonadIO m, MonadBaseControl IO m, Functor m) => Int -> Cursor -> Action m [Document]
  433. -- ^ Return next N documents or less if end is reached
  434. nextN n c = catMaybes <$> replicateM n (next c)
  435. rest :: (MonadIO m, MonadBaseControl IO m, Functor m) => Cursor -> Action m [Document]
  436. -- ^ Return remaining documents in query result
  437. rest c = loop (next c)
  438. closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m ()
  439. closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
  440. Batch _ cid _ <- fulfill dBatch
  441. unless (cid == 0) $ send [KillCursors [cid]]
  442. return $ (return $ Batch 0 0 [], ())
  443. isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool
  444. isCursorClosed (Cursor _ _ var) = do
  445. Batch _ cid docs <- fulfill =<< readMVar var
  446. return (cid == 0 && null docs)
  447. -- ** Group
  448. -- | Groups documents in collection by key then reduces (aggregates) each group
  449. data Group = Group {
  450. gColl :: Collection,
  451. gKey :: GroupKey, -- ^ Fields to group by
  452. 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.
  453. gInitial :: Document, -- ^ @agg@. Initial aggregation value supplied to reduce
  454. gCond :: Selector, -- ^ Condition that must be true for a row to be considered. [] means always true.
  455. 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).
  456. } deriving (Show, Eq)
  457. data GroupKey = Key [Label] | KeyF Javascript deriving (Show, Eq)
  458. -- ^ 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).
  459. groupDocument :: Group -> Document
  460. -- ^ Translate Group data into expected document form
  461. groupDocument Group{..} =
  462. ("finalize" =? gFinalize) ++ [
  463. "ns" =: gColl,
  464. case gKey of Key k -> "key" =: map (=: True) k; KeyF f -> "$keyf" =: f,
  465. "$reduce" =: gReduce,
  466. "initial" =: gInitial,
  467. "cond" =: gCond ]
  468. group :: (MonadIO' m) => Group -> Action m [Document]
  469. -- ^ Execute group query and return resulting aggregate value for each distinct key
  470. group g = at "retval" <$> runCommand ["group" =: groupDocument g]
  471. -- ** MapReduce
  472. -- | 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.
  473. -- 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.
  474. data MapReduce = MapReduce {
  475. rColl :: Collection,
  476. rMap :: MapFun,
  477. rReduce :: ReduceFun,
  478. rSelect :: Selector, -- ^ Operate on only those documents selected. Default is [] meaning all documents.
  479. rSort :: Order, -- ^ Default is [] meaning no sort
  480. rLimit :: Limit, -- ^ Default is 0 meaning no limit
  481. 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.
  482. rFinalize :: Maybe FinalizeFun, -- ^ Function to apply to all the results when finished. Default is Nothing.
  483. rScope :: Document, -- ^ Variables (environment) that can be accessed from map/reduce/finalize. Default is [].
  484. rVerbose :: Bool -- ^ Provide statistics on job execution time. Default is False.
  485. } deriving (Show, Eq)
  486. type MapFun = Javascript
  487. -- ^ @() -> void@. The map function references the variable @this@ to inspect the current object under consideration. The function must call @emit(key,value)@ at least once, but may be invoked any number of times, as may be appropriate.
  488. type ReduceFun = Javascript
  489. -- ^ @(key, [value]) -> value@. The reduce function receives a key and an array of values and returns an aggregate result value. The MapReduce engine may invoke reduce functions iteratively; thus, these functions must be idempotent. That is, the following must hold for your reduce function: @reduce(k, [reduce(k,vs)]) == reduce(k,vs)@. If you need to perform an operation only once, use a finalize function. The output of emit (the 2nd param) and reduce should be the same format to make iterative reduce possible.
  490. type FinalizeFun = Javascript
  491. -- ^ @(key, value) -> final_value@. A finalize function may be run after reduction. Such a function is optional and is not necessary for many map/reduce cases. The finalize function takes a key and a value, and returns a finalized value.
  492. data MROut =
  493. Inline -- ^ Return results directly instead of writing them to an output collection. Results must fit within 16MB limit of a single document
  494. | Output MRMerge Collection (Maybe Database) -- ^ Write results to given collection, in other database if specified. Follow merge policy when entry already exists
  495. deriving (Show, Eq)
  496. data MRMerge =
  497. Replace -- ^ Clear all old data and replace it with new data
  498. | Merge -- ^ Leave old data but overwrite entries with the same key with new data
  499. | Reduce -- ^ Leave old data but combine entries with the same key via MR's reduce function
  500. deriving (Show, Eq)
  501. type MRResult = Document
  502. -- ^ Result of running a MapReduce has some stats besides the output. See http://www.mongodb.org/display/DOCS/MapReduce#MapReduce-Resultobject
  503. mrDocument :: MapReduce -> Document
  504. -- ^ Translate MapReduce data into expected document form
  505. mrDocument MapReduce{..} =
  506. ("mapreduce" =: rColl) :
  507. ("out" =: mrOutDoc rOut) :
  508. ("finalize" =? rFinalize) ++ [
  509. "map" =: rMap,
  510. "reduce" =: rReduce,
  511. "query" =: rSelect,
  512. "sort" =: rSort,
  513. "limit" =: (fromIntegral rLimit :: Int),
  514. "scope" =: rScope,
  515. "verbose" =: rVerbose ]
  516. mrOutDoc :: MROut -> Document
  517. -- ^ Translate MROut into expected document form
  518. mrOutDoc Inline = ["inline" =: (1 :: Int)]
  519. mrOutDoc (Output mrMerge coll mDB) = (mergeName mrMerge =: coll) : mdb mDB where
  520. mergeName Replace = "replace"
  521. mergeName Merge = "merge"
  522. mergeName Reduce = "reduce"
  523. mdb Nothing = []
  524. mdb (Just db) = ["db" =: db]
  525. mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
  526. -- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
  527. mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
  528. runMR :: (MonadIO m, MonadBaseControl IO m, Applicative m) => MapReduce -> Action m Cursor
  529. -- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
  530. runMR mr = do
  531. res <- runMR' mr
  532. case look "result" res of
  533. Just (String coll) -> find $ query [] coll
  534. Just (Doc doc) -> useDb (at "db" doc) $ find $ query [] (at "collection" doc)
  535. Just x -> error $ "unexpected map-reduce result field: " ++ show x
  536. Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res)
  537. runMR' :: (MonadIO' m) => MapReduce -> Action m MRResult
  538. -- ^ Run MapReduce and return a MR result document containing stats and the results if Inlined. Error if the map/reduce failed (because of bad Javascript).
  539. runMR' mr = do
  540. doc <- runCommand (mrDocument mr)
  541. return $ if true1 "ok" doc then doc else error $ "mapReduce error:\n" ++ show doc ++ "\nin:\n" ++ show mr
  542. -- * Command
  543. type Command = Document
  544. -- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details.
  545. runCommand :: (MonadIO' m) => Command -> Action m Document
  546. -- ^ Run command against the database and return its result
  547. runCommand c = maybe err id <$> findOne (query c "$cmd") where
  548. err = error $ "Nothing returned for command: " ++ show c
  549. runCommand1 :: (MonadIO' m) => UString -> Action m Document
  550. -- ^ @runCommand1 foo = runCommand [foo =: 1]@
  551. runCommand1 c = runCommand [c =: (1 :: Int)]
  552. eval :: (MonadIO' m) => Javascript -> Action m Document
  553. -- ^ Run code on server
  554. eval code = at "retval" <$> runCommand ["$eval" =: code]
  555. {- Authors: Tony Hannan <tony@10gen.com>
  556. Copyright 2011 10gen Inc.
  557. 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. -}