Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Remove MonadIO'

Browse source
This commit is contained in:
Michael Snoyman 2013-12-27 13:39:22 +02:00
parent 3a97c2cbdb
commit a43c94f977
3 changed files with 65 additions and 70 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

66
Database/MongoDB/Admin.hs
View file

@ -30,7 +30,7 @@ module Database.MongoDB.Admin (
import Prelude hiding (lookup) import Prelude hiding (lookup)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forever, unless) import Control.Monad (forever, unless, liftM)
import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Set (Set) import Data.Set (Set)
import System.IO.Unsafe (unsafePerformIO) import System.IO.Unsafe (unsafePerformIO)
@ -47,7 +47,7 @@ import qualified Data.Text as T
import Database.MongoDB.Connection (Host, showHostPort) import Database.MongoDB.Connection (Host, showHostPort)
import Database.MongoDB.Internal.Protocol (pwHash, pwKey) import Database.MongoDB.Internal.Protocol (pwHash, pwKey)
import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1) import Database.MongoDB.Internal.Util ((<.>), true1)
import Database.MongoDB.Query (Action, Database, Collection, Username, Password, import Database.MongoDB.Query (Action, Database, Collection, Username, Password,
Order, Query(..), accessMode, master, runCommand, Order, Query(..), accessMode, master, runCommand,
useDb, thisDatabase, rest, select, find, findOne, useDb, thisDatabase, rest, select, find, findOne,
@ -64,17 +64,17 @@ coptElem Capped = "capped" =: True
coptElem (MaxByteSize n) = "size" =: n coptElem (MaxByteSize n) = "size" =: n
coptElem (MaxItems n) = "max" =: n coptElem (MaxItems n) = "max" =: n
createCollection :: (MonadIO' m) => [CollectionOption] -> Collection -> Action m Document createCollection :: (MonadIO m) => [CollectionOption] -> Collection -> Action m Document
-- ^ Create collection with given options. You only need to call this to set options, otherwise a collection is created automatically on first use with no options. -- ^ Create collection with given options. You only need to call this to set options, otherwise a collection is created automatically on first use with no options.
createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts
renameCollection :: (MonadIO' m) => Collection -> Collection -> Action m Document renameCollection :: (MonadIO m) => Collection -> Collection -> Action m Document
-- ^ Rename first collection to second collection -- ^ Rename first collection to second collection
renameCollection from to = do renameCollection from to = do
db <- thisDatabase db <- thisDatabase
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True] useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
dropCollection :: (MonadIO' m) => Collection -> Action m Bool dropCollection :: (MonadIO 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 dropCollection coll = do
resetIndexCache resetIndexCache
@ -83,7 +83,7 @@ dropCollection coll = do
if at "errmsg" r == ("ns not found" :: Text) then return False else if at "errmsg" r == ("ns not found" :: Text) then return False else
fail $ "dropCollection failed: " ++ show r fail $ "dropCollection failed: " ++ show r
validateCollection :: (MonadIO' m) => Collection -> Action m Document validateCollection :: (MonadIO m) => Collection -> Action m Document
-- ^ This operation takes a while -- ^ This operation takes a while
validateCollection coll = runCommand ["validate" =: coll] validateCollection coll = runCommand ["validate" =: coll]
@ -115,7 +115,7 @@ genName :: Order -> IndexName
genName keys = T.intercalate "_" (map f keys) where genName keys = T.intercalate "_" (map f keys) where
f (k := v) = k `T.append` "_" `T.append` T.pack (show v) f (k := v) = k `T.append` "_" `T.append` T.pack (show v)
ensureIndex :: (MonadIO' m) => Index -> Action m () ensureIndex :: (MonadIO m) => Index -> Action m ()
-- ^ Create index if we did not already create one. May be called repeatedly with practically no performance hit, because we remember if we already called this for the same index (although this memory gets wiped out every 15 minutes, in case another client drops the index and we want to create it again). -- ^ Create index if we did not already create one. May be called repeatedly with practically no performance hit, because we remember if we already called this for the same index (although this memory gets wiped out every 15 minutes, in case another client drops the index and we want to create it again).
ensureIndex idx = let k = (iColl idx, iName idx) in do ensureIndex idx = let k = (iColl idx, iName idx) in do
icache <- fetchIndexCache icache <- fetchIndexCache
@ -124,11 +124,11 @@ ensureIndex idx = let k = (iColl idx, iName idx) in do
accessMode master (createIndex idx) accessMode master (createIndex idx)
liftIO $ writeIORef icache (Set.insert k set) liftIO $ writeIORef icache (Set.insert k set)
createIndex :: (MonadIO' m) => Index -> Action m () createIndex :: (MonadIO m) => Index -> Action m ()
-- ^ Create index on the server. This call goes to the server every time. -- ^ Create index on the server. This call goes to the server every time.
createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase
dropIndex :: (MonadIO' m) => Collection -> IndexName -> Action m Document dropIndex :: (MonadIO m) => Collection -> IndexName -> Action m Document
-- ^ Remove the index -- ^ Remove the index
dropIndex coll idxName = do dropIndex coll idxName = do
resetIndexCache resetIndexCache
@ -140,7 +140,7 @@ getIndexes coll = do
db <- thisDatabase db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes") rest =<< find (select ["ns" =: db <.> coll] "system.indexes")
dropIndexes :: (MonadIO' m) => Collection -> Action m Document dropIndexes :: (MonadIO m) => Collection -> Action m Document
-- ^ Drop all indexes on this collection -- ^ Drop all indexes on this collection
dropIndexes coll = do dropIndexes coll = do
resetIndexCache resetIndexCache
@ -192,7 +192,7 @@ allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document]
allUsers = map (exclude ["_id"]) <$> (rest =<< find allUsers = map (exclude ["_id"]) <$> (rest =<< find
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
addUser :: (MonadIO' m) => Bool -> Username -> Password -> Action m () 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 bool is True or read-write access if bool is False
addUser readOnly user pass = do addUser readOnly user pass = do
mu <- findOne (select ["user" =: user] "system.users") mu <- findOne (select ["user" =: user] "system.users")
@ -208,76 +208,76 @@ admin :: Database
-- ^ \"admin\" database -- ^ \"admin\" database
admin = "admin" admin = "admin"
cloneDatabase :: (MonadIO' m) => Database -> Host -> Action m Document 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] cloneDatabase db fromHost = useDb db $ runCommand ["clone" =: showHostPort fromHost]
copyDatabase :: (MonadIO' m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action m Document copyDatabase :: (MonadIO m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action m Document
-- ^ Copy database from given host to the server I am connected to. If username & password is supplied use them to read from given host. -- ^ Copy database from given host to the server I am connected to. If username & password is supplied use them to read from given host.
copyDatabase fromDb fromHost mup toDb = do copyDatabase fromDb fromHost mup toDb = do
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb] let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
useDb admin $ case mup of useDb admin $ case mup of
Nothing -> runCommand c Nothing -> runCommand c
Just (usr, pss) -> do Just (usr, pss) -> do
n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost] n <- at "nonce" `liftM` runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost]
runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
dropDatabase :: (MonadIO' m) => Database -> Action m Document dropDatabase :: (MonadIO m) => Database -> Action m Document
-- ^ Delete the given database! -- ^ Delete the given database!
dropDatabase db = useDb db $ runCommand ["dropDatabase" =: (1 :: Int)] dropDatabase db = useDb db $ runCommand ["dropDatabase" =: (1 :: Int)]
repairDatabase :: (MonadIO' m) => Database -> Action m Document repairDatabase :: (MonadIO m) => Database -> Action m Document
-- ^ Attempt to fix any corrupt records. This operation takes a while. -- ^ Attempt to fix any corrupt records. This operation takes a while.
repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)] repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)]
-- ** Server -- ** Server
serverBuildInfo :: (MonadIO' m) => Action m Document serverBuildInfo :: (MonadIO m) => Action m Document
serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)] serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)]
serverVersion :: (MonadIO' m) => Action m Text serverVersion :: (MonadIO m) => Action m Text
serverVersion = at "version" <$> serverBuildInfo serverVersion = at "version" `liftM` serverBuildInfo
-- * Diagnostics -- * Diagnostics
-- ** Collection -- ** Collection
collectionStats :: (MonadIO' m) => Collection -> Action m Document collectionStats :: (MonadIO m) => Collection -> Action m Document
collectionStats coll = runCommand ["collstats" =: coll] collectionStats coll = runCommand ["collstats" =: coll]
dataSize :: (MonadIO' m) => Collection -> Action m Int dataSize :: (MonadIO m) => Collection -> Action m Int
dataSize c = at "size" <$> collectionStats c dataSize c = at "size" `liftM` collectionStats c
storageSize :: (MonadIO' m) => Collection -> Action m Int storageSize :: (MonadIO m) => Collection -> Action m Int
storageSize c = at "storageSize" <$> collectionStats c storageSize c = at "storageSize" `liftM` collectionStats c
totalIndexSize :: (MonadIO' m) => Collection -> Action m Int totalIndexSize :: (MonadIO m) => Collection -> Action m Int
totalIndexSize c = at "totalIndexSize" <$> collectionStats c totalIndexSize c = at "totalIndexSize" `liftM` collectionStats c
totalSize :: (MonadIO m, MonadBaseControl IO m, MonadIO' m) => Collection -> Action m Int totalSize :: (MonadIO m, MonadBaseControl IO m) => Collection -> Action m Int
totalSize coll = do totalSize coll = do
x <- storageSize coll x <- storageSize coll
xs <- mapM isize =<< getIndexes coll xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs) return (foldl (+) x xs)
where where
isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx) isize idx = at "storageSize" `liftM` collectionStats (coll `T.append` ".$" `T.append` at "name" idx)
-- ** Profiling -- ** Profiling
data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq) data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq)
getProfilingLevel :: (MonadIO' m) => Action m ProfilingLevel getProfilingLevel :: (MonadIO m) => Action m ProfilingLevel
getProfilingLevel = toEnum . at "was" <$> runCommand ["profile" =: (-1 :: Int)] getProfilingLevel = (toEnum . at "was") `liftM` runCommand ["profile" =: (-1 :: Int)]
type MilliSec = Int type MilliSec = Int
setProfilingLevel :: (MonadIO' m) => ProfilingLevel -> Maybe MilliSec -> Action m () setProfilingLevel :: (MonadIO m) => ProfilingLevel -> Maybe MilliSec -> Action m ()
setProfilingLevel p mSlowMs = setProfilingLevel p mSlowMs =
runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return () runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return ()
-- ** Database -- ** Database
dbStats :: (MonadIO' m) => Action m Document dbStats :: (MonadIO m) => Action m Document
dbStats = runCommand ["dbstats" =: (1 :: Int)] dbStats = runCommand ["dbstats" =: (1 :: Int)]
currentOp :: (MonadIO m) => Action m (Maybe Document) currentOp :: (MonadIO m) => Action m (Maybe Document)
@ -291,7 +291,7 @@ killOp op = findOne (select ["op" =: op] "$cmd.sys.killop")
-- ** Server -- ** Server
serverStatus :: (MonadIO' m) => Action m Document serverStatus :: (MonadIO m) => Action m Document
serverStatus = useDb admin $ runCommand ["serverStatus" =: (1 :: Int)] serverStatus = useDb admin $ runCommand ["serverStatus" =: (1 :: Int)]

6
Database/MongoDB/Internal/Util.hs
View file

@ -7,7 +7,7 @@
module Database.MongoDB.Internal.Util where module Database.MongoDB.Internal.Util where
import Control.Applicative (Applicative(..), (<$>)) import Control.Applicative ((<$>))
import Control.Exception (assert, handle, throwIO, Exception) import Control.Exception (assert, handle, throwIO, Exception)
import Control.Monad (liftM, liftM2) import Control.Monad (liftM, liftM2)
import Data.Bits (Bits, (.|.)) import Data.Bits (Bits, (.|.))
@ -35,10 +35,6 @@ deriving instance Eq PortID
#endif #endif
deriving instance Ord PortID deriving instance Ord PortID
-- | MonadIO with extra Applicative and Functor superclasses
class (MonadIO m, Applicative m, Functor m) => MonadIO' m
instance (MonadIO m, Applicative m, Functor m) => MonadIO' m
-- | A monadic sort implementation derived from the non-monadic one in ghc's Prelude -- | A monadic sort implementation derived from the non-monadic one in ghc's Prelude
mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a] mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a]
mergesortM cmp = mergesortM' cmp . map wrap mergesortM cmp = mergesortM' cmp . map wrap

63
Database/MongoDB/Query.hs
View file

@ -44,9 +44,8 @@ module Database.MongoDB.Query (
) where ) where
import Prelude hiding (lookup) import Prelude hiding (lookup)
import Control.Applicative (Applicative, (<$>))
import Control.Exception (Exception, throwIO) import Control.Exception (Exception, throwIO)
import Control.Monad (unless, replicateM) import Control.Monad (unless, replicateM, liftM)
import Data.Int (Int32) import Data.Int (Int32)
import Data.Maybe (listToMaybe, catMaybes) import Data.Maybe (listToMaybe, catMaybes)
import Data.Word (Word32) import Data.Word (Word32)
@ -80,7 +79,7 @@ import Database.MongoDB.Internal.Protocol (Reply(..), QueryOption(..),
qFullCollection, qBatchSize, qFullCollection, qBatchSize,
qSelector, qProjector), qSelector, qProjector),
pwKey) pwKey)
import Database.MongoDB.Internal.Util (MonadIO', loop, liftIOE, true1, (<.>)) import Database.MongoDB.Internal.Util (loop, liftIOE, true1, (<.>))
import qualified Database.MongoDB.Internal.Protocol as P import qualified Database.MongoDB.Internal.Protocol as P
#if !MIN_VERSION_base(4,6,0) #if !MIN_VERSION_base(4,6,0)
@ -186,9 +185,9 @@ liftDB m = do
type Database = Text type Database = Text
allDatabases :: (MonadIO' m) => Action m [Database] allDatabases :: (MonadIO m) => Action m [Database]
-- ^ List all databases residing on server -- ^ List all databases residing on server
allDatabases = map (at "name") . at "databases" <$> useDb "admin" (runCommand1 "listDatabases") allDatabases = (map (at "name") . at "databases") `liftM` useDb "admin" (runCommand1 "listDatabases")
thisDatabase :: (Monad m) => Action m Database thisDatabase :: (Monad m) => Action m Database
-- ^ Current database in use -- ^ Current database in use
@ -200,18 +199,18 @@ useDb db act = local (\ctx -> ctx {myDatabase = db}) act
-- * Authentication -- * Authentication
auth :: (MonadIO' m) => Username -> Password -> Action m Bool auth :: (MonadIO m) => Username -> Password -> Action m Bool
-- ^ 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. -- ^ 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.
auth usr pss = do auth usr pss = do
n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)] n <- at "nonce" `liftM` runCommand ["getnonce" =: (1 :: Int)]
true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] true1 "ok" `liftM` runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
-- * Collection -- * Collection
type Collection = Text type Collection = Text
-- ^ Collection name (not prefixed with database) -- ^ Collection name (not prefixed with database)
allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection] allCollections :: (MonadIO m, MonadBaseControl IO m) => Action m [Collection]
-- ^ List all collections in this database -- ^ List all collections in this database
allCollections = do allCollections = do
db <- thisDatabase db <- thisDatabase
@ -263,11 +262,11 @@ write notice = asks myWriteMode >>= \mode -> case mode of
-- ** Insert -- ** Insert
insert :: (MonadIO' m) => Collection -> Document -> Action m Value 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 document into collection and return its \"_id\" value, which is created automatically if not supplied
insert col doc = head <$> insertMany col [doc] insert col doc = head `liftM` insertMany col [doc]
insert_ :: (MonadIO' m) => Collection -> Document -> Action m () insert_ :: (MonadIO m) => Collection -> Document -> Action m ()
-- ^ Same as 'insert' except don't return _id -- ^ Same as 'insert' except don't return _id
insert_ col doc = insert col doc >> return () insert_ col doc = insert col doc >> return ()
@ -299,11 +298,11 @@ assignId :: Document -> IO Document
-- ^ Assign a unique value to _id field if missing -- ^ Assign a unique value to _id field if missing
assignId doc = if any (("_id" ==) . label) doc assignId doc = if any (("_id" ==) . label) doc
then return doc then return doc
else (\oid -> ("_id" =: oid) : doc) <$> genObjectId else (\oid -> ("_id" =: oid) : doc) `liftM` genObjectId
-- ** Update -- ** Update
save :: (MonadIO' m) => Collection -> Document -> Action m () save :: (MonadIO m) => Collection -> Document -> Action m ()
-- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or update it if its not new (has \"_id\" field) -- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or update it if its not new (has \"_id\" field)
save col doc = case look "_id" doc of save col doc = case look "_id" doc of
Nothing -> insert_ col doc Nothing -> insert_ col doc
@ -408,7 +407,7 @@ fetch q = findOne q >>= maybe (liftIO $ throwIO $ DocNotFound $ selection q) ret
-- | runs the findAndModify command. -- | runs the findAndModify command.
-- Returns a single updated document (new option is set to true). -- Returns a single updated document (new option is set to true).
-- Currently this API does not allow setting the remove option -- Currently this API does not allow setting the remove option
findAndModify :: (Applicative m, MonadIO m) findAndModify :: MonadIO m
=> Query => Query
-> Document -- ^ updates -> Document -- ^ updates
-> Action m (Either String Document) -> Action m (Either String Document)
@ -450,15 +449,15 @@ explain q = do -- same as findOne but with explain set to true
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1} Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1}
return $ if null docs then error ("no explain: " ++ show q) else head docs return $ if null docs then error ("no explain: " ++ show q) else head docs
count :: (MonadIO' m) => Query -> Action m Int count :: (MonadIO m) => Query -> Action m Int
-- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present) -- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present)
count Query{selection = Select sel col, skip, limit} = at "n" <$> runCommand count Query{selection = Select sel col, skip, limit} = at "n" `liftM` runCommand
(["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)] (["count" =: col, "query" =: sel, "skip" =: (fromIntegral skip :: Int32)]
++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32))) ++ ("limit" =? if limit == 0 then Nothing else Just (fromIntegral limit :: Int32)))
distinct :: (MonadIO' m) => Label -> Selection -> Action m [Value] distinct :: (MonadIO m) => Label -> Selection -> Action m [Value]
-- ^ Fetch distinct values of field in selected documents -- ^ Fetch distinct values of field in selected documents
distinct k (Select sel col) = at "values" <$> runCommand ["distinct" =: col, "key" =: k, "query" =: sel] distinct k (Select sel col) = at "values" `liftM` runCommand ["distinct" =: col, "key" =: k, "query" =: sel]
queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit) queryRequest :: (Monad m) => Bool -> Query -> Action m (Request, Limit)
-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute. -- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
@ -570,11 +569,11 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where
then return (return $ Batch 0 0 [], Nothing) -- finished then return (return $ Batch 0 0 [], Nothing) -- finished
else fmap (,Nothing) $ nextBatch' fcol batchSize limit cid else fmap (,Nothing) $ nextBatch' fcol batchSize limit cid
nextN :: (MonadIO m, MonadBaseControl IO m, Functor m) => Int -> Cursor -> Action m [Document] nextN :: (MonadIO m, MonadBaseControl IO m) => Int -> Cursor -> Action m [Document]
-- ^ Return next N documents or less if end is reached -- ^ Return next N documents or less if end is reached
nextN n c = catMaybes <$> replicateM n (next c) nextN n c = catMaybes `liftM` replicateM n (next c)
rest :: (MonadIO m, MonadBaseControl IO m, Functor m) => Cursor -> Action m [Document] rest :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document]
-- ^ Return remaining documents in query result -- ^ Return remaining documents in query result
rest c = loop (next c) rest c = loop (next c)
@ -594,7 +593,7 @@ isCursorClosed (Cursor _ _ var) = do
type Pipeline = [Document] type Pipeline = [Document]
-- ^ The Aggregate Pipeline -- ^ The Aggregate Pipeline
aggregate :: MonadIO' m => Collection -> Pipeline -> Action m [Document] aggregate :: MonadIO m => Collection -> Pipeline -> Action m [Document]
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details. -- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
aggregate aColl agg = do aggregate aColl agg = do
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg] response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg]
@ -627,9 +626,9 @@ groupDocument Group{..} =
"initial" =: gInitial, "initial" =: gInitial,
"cond" =: gCond ] "cond" =: gCond ]
group :: (MonadIO' m) => Group -> Action m [Document] group :: (MonadIO m) => Group -> Action m [Document]
-- ^ Execute group query and return resulting aggregate value for each distinct key -- ^ Execute group query and return resulting aggregate value for each distinct key
group g = at "retval" <$> runCommand ["group" =: groupDocument g] group g = at "retval" `liftM` runCommand ["group" =: groupDocument g]
-- ** MapReduce -- ** MapReduce
@ -699,7 +698,7 @@ mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
-- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments. -- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
runMR :: (MonadIO m, MonadBaseControl IO m, Applicative m) => MapReduce -> Action m Cursor runMR :: (MonadIO m, MonadBaseControl IO m) => MapReduce -> Action m Cursor
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript) -- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
runMR mr = do runMR mr = do
res <- runMR' mr res <- runMR' mr
@ -709,7 +708,7 @@ runMR mr = do
Just x -> error $ "unexpected map-reduce result field: " ++ show x Just x -> error $ "unexpected map-reduce result field: " ++ show x
Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res) Nothing -> newCursor "" "" 0 $ return $ Batch 0 0 (at "results" res)
runMR' :: (MonadIO' m) => MapReduce -> Action m MRResult runMR' :: (MonadIO m) => MapReduce -> Action m MRResult
-- ^ 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). -- ^ 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).
runMR' mr = do runMR' mr = do
doc <- runCommand (mrDocument mr) doc <- runCommand (mrDocument mr)
@ -720,18 +719,18 @@ runMR' mr = do
type Command = Document type Command = Document
-- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details. -- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details.
runCommand :: (MonadIO' m) => Command -> Action m Document runCommand :: (MonadIO m) => Command -> Action m Document
-- ^ Run command against the database and return its result -- ^ Run command against the database and return its result
runCommand c = maybe err id <$> findOne (query c "$cmd") where runCommand c = maybe err id `liftM` findOne (query c "$cmd") where
err = error $ "Nothing returned for command: " ++ show c err = error $ "Nothing returned for command: " ++ show c
runCommand1 :: (MonadIO' m) => Text -> Action m Document runCommand1 :: (MonadIO m) => Text -> Action m Document
-- ^ @runCommand1 foo = runCommand [foo =: 1]@ -- ^ @runCommand1 foo = runCommand [foo =: 1]@
runCommand1 c = runCommand [c =: (1 :: Int)] runCommand1 c = runCommand [c =: (1 :: Int)]
eval :: (MonadIO' m, Val v) => Javascript -> Action m v eval :: (MonadIO m, Val v) => Javascript -> Action m v
-- ^ Run code on server -- ^ Run code on server
eval code = at "retval" <$> runCommand ["$eval" =: code] eval code = at "retval" `liftM` runCommand ["$eval" =: code]
{- Authors: Tony Hannan <tony@10gen.com> {- Authors: Tony Hannan <tony@10gen.com>