diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs index e948a70..264e4d1 100644 --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -30,7 +30,7 @@ module Database.MongoDB.Admin ( import Prelude hiding (lookup) import Control.Applicative ((<$>)) 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.Set (Set) import System.IO.Unsafe (unsafePerformIO) @@ -47,7 +47,7 @@ import qualified Data.Text as T import Database.MongoDB.Connection (Host, showHostPort) 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, Order, Query(..), accessMode, master, runCommand, useDb, thisDatabase, rest, select, find, findOne, @@ -64,17 +64,17 @@ coptElem Capped = "capped" =: True coptElem (MaxByteSize n) = "size" =: 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. 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 renameCollection from to = do db <- thisDatabase 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). dropCollection coll = do resetIndexCache @@ -83,7 +83,7 @@ dropCollection coll = do if at "errmsg" r == ("ns not found" :: Text) then return False else fail $ "dropCollection failed: " ++ show r -validateCollection :: (MonadIO' m) => Collection -> Action m Document +validateCollection :: (MonadIO m) => Collection -> Action m Document -- ^ This operation takes a while validateCollection coll = runCommand ["validate" =: coll] @@ -115,7 +115,7 @@ genName :: Order -> IndexName genName keys = T.intercalate "_" (map f keys) where 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). ensureIndex idx = let k = (iColl idx, iName idx) in do icache <- fetchIndexCache @@ -124,11 +124,11 @@ ensureIndex idx = let k = (iColl idx, iName idx) in do accessMode master (createIndex idx) 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. 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 dropIndex coll idxName = do resetIndexCache @@ -140,7 +140,7 @@ getIndexes coll = do db <- thisDatabase 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 dropIndexes coll = do resetIndexCache @@ -192,7 +192,7 @@ allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document] allUsers = map (exclude ["_id"]) <$> (rest =<< find (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) -addUser :: (MonadIO' m) => Bool -> Username -> Password -> Action m () +addUser :: (MonadIO m) => Bool -> Username -> Password -> Action m () -- ^ Add user with password with read-only access if bool is True or read-write access if bool is False addUser readOnly user pass = do mu <- findOne (select ["user" =: user] "system.users") @@ -208,76 +208,76 @@ admin :: Database -- ^ \"admin\" database 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). 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. copyDatabase fromDb fromHost mup toDb = do let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb] useDb admin $ case mup of Nothing -> runCommand c 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] -dropDatabase :: (MonadIO' m) => Database -> Action m Document +dropDatabase :: (MonadIO m) => Database -> Action m Document -- ^ Delete the given database! 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. repairDatabase db = useDb db $ runCommand ["repairDatabase" =: (1 :: Int)] -- ** Server -serverBuildInfo :: (MonadIO' m) => Action m Document +serverBuildInfo :: (MonadIO m) => Action m Document serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)] -serverVersion :: (MonadIO' m) => Action m Text -serverVersion = at "version" <$> serverBuildInfo +serverVersion :: (MonadIO m) => Action m Text +serverVersion = at "version" `liftM` serverBuildInfo -- * Diagnostics -- ** Collection -collectionStats :: (MonadIO' m) => Collection -> Action m Document +collectionStats :: (MonadIO m) => Collection -> Action m Document collectionStats coll = runCommand ["collstats" =: coll] -dataSize :: (MonadIO' m) => Collection -> Action m Int -dataSize c = at "size" <$> collectionStats c +dataSize :: (MonadIO m) => Collection -> Action m Int +dataSize c = at "size" `liftM` collectionStats c -storageSize :: (MonadIO' m) => Collection -> Action m Int -storageSize c = at "storageSize" <$> collectionStats c +storageSize :: (MonadIO m) => Collection -> Action m Int +storageSize c = at "storageSize" `liftM` collectionStats c -totalIndexSize :: (MonadIO' m) => Collection -> Action m Int -totalIndexSize c = at "totalIndexSize" <$> collectionStats c +totalIndexSize :: (MonadIO m) => Collection -> Action m Int +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 x <- storageSize coll xs <- mapM isize =<< getIndexes coll return (foldl (+) x xs) 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 data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq) -getProfilingLevel :: (MonadIO' m) => Action m ProfilingLevel -getProfilingLevel = toEnum . at "was" <$> runCommand ["profile" =: (-1 :: Int)] +getProfilingLevel :: (MonadIO m) => Action m ProfilingLevel +getProfilingLevel = (toEnum . at "was") `liftM` runCommand ["profile" =: (-1 :: Int)] type MilliSec = Int -setProfilingLevel :: (MonadIO' m) => ProfilingLevel -> Maybe MilliSec -> Action m () +setProfilingLevel :: (MonadIO m) => ProfilingLevel -> Maybe MilliSec -> Action m () setProfilingLevel p mSlowMs = runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return () -- ** Database -dbStats :: (MonadIO' m) => Action m Document +dbStats :: (MonadIO m) => Action m Document dbStats = runCommand ["dbstats" =: (1 :: Int)] currentOp :: (MonadIO m) => Action m (Maybe Document) @@ -291,7 +291,7 @@ killOp op = findOne (select ["op" =: op] "$cmd.sys.killop") -- ** Server -serverStatus :: (MonadIO' m) => Action m Document +serverStatus :: (MonadIO m) => Action m Document serverStatus = useDb admin $ runCommand ["serverStatus" =: (1 :: Int)] diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs index b1bb7d9..166107c 100644 --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -7,7 +7,7 @@ module Database.MongoDB.Internal.Util where -import Control.Applicative (Applicative(..), (<$>)) +import Control.Applicative ((<$>)) import Control.Exception (assert, handle, throwIO, Exception) import Control.Monad (liftM, liftM2) import Data.Bits (Bits, (.|.)) @@ -35,10 +35,6 @@ deriving instance Eq PortID #endif 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 mergesortM :: Monad m => (a -> a -> m Ordering) -> [a] -> m [a] mergesortM cmp = mergesortM' cmp . map wrap diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index f266562..344b42d 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -44,9 +44,8 @@ module Database.MongoDB.Query ( ) where import Prelude hiding (lookup) -import Control.Applicative (Applicative, (<$>)) import Control.Exception (Exception, throwIO) -import Control.Monad (unless, replicateM) +import Control.Monad (unless, replicateM, liftM) import Data.Int (Int32) import Data.Maybe (listToMaybe, catMaybes) import Data.Word (Word32) @@ -80,7 +79,7 @@ import Database.MongoDB.Internal.Protocol (Reply(..), QueryOption(..), qFullCollection, qBatchSize, qSelector, qProjector), 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 #if !MIN_VERSION_base(4,6,0) @@ -186,9 +185,9 @@ liftDB m = do type Database = Text -allDatabases :: (MonadIO' m) => Action m [Database] +allDatabases :: (MonadIO m) => Action m [Database] -- ^ 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 -- ^ Current database in use @@ -200,18 +199,18 @@ useDb db act = local (\ctx -> ctx {myDatabase = db}) act -- * 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. auth usr pss = do - n <- at "nonce" <$> runCommand ["getnonce" =: (1 :: Int)] - true1 "ok" <$> runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] + n <- at "nonce" `liftM` runCommand ["getnonce" =: (1 :: Int)] + true1 "ok" `liftM` runCommand ["authenticate" =: (1 :: Int), "user" =: usr, "nonce" =: n, "key" =: pwKey n usr pss] -- * Collection type Collection = Text -- ^ 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 allCollections = do db <- thisDatabase @@ -263,11 +262,11 @@ write notice = asks myWriteMode >>= \mode -> case mode of -- ** 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 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 insert_ col doc = insert col doc >> return () @@ -299,11 +298,11 @@ assignId :: Document -> IO Document -- ^ Assign a unique value to _id field if missing assignId doc = if any (("_id" ==) . label) doc then return doc - else (\oid -> ("_id" =: oid) : doc) <$> genObjectId + else (\oid -> ("_id" =: oid) : doc) `liftM` genObjectId -- ** 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 col doc = case look "_id" doc of Nothing -> insert_ col doc @@ -408,7 +407,7 @@ fetch q = findOne q >>= maybe (liftIO $ throwIO $ DocNotFound $ selection q) ret -- | runs the findAndModify command. -- Returns a single updated document (new option is set to true). -- Currently this API does not allow setting the remove option -findAndModify :: (Applicative m, MonadIO m) +findAndModify :: MonadIO m => Query -> Document -- ^ updates -> 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} 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) -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)] ++ ("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 -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) -- ^ 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 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 -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 rest c = loop (next c) @@ -594,7 +593,7 @@ isCursorClosed (Cursor _ _ var) = do type Pipeline = [Document] -- ^ 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 for details. aggregate aColl agg = do response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg] @@ -627,9 +626,9 @@ groupDocument Group{..} = "initial" =: gInitial, "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 -group g = at "retval" <$> runCommand ["group" =: groupDocument g] +group g = at "retval" `liftM` runCommand ["group" =: groupDocument g] -- ** 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 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) runMR mr = do res <- runMR' mr @@ -709,7 +708,7 @@ runMR mr = do Just x -> error $ "unexpected map-reduce result field: " ++ show x 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). runMR' mr = do doc <- runCommand (mrDocument mr) @@ -720,18 +719,18 @@ runMR' mr = do type Command = Document -- ^ A command is a special query or action against the database. See 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 -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 -runCommand1 :: (MonadIO' m) => Text -> Action m Document +runCommand1 :: (MonadIO m) => Text -> Action m Document -- ^ @runCommand1 foo = runCommand [foo =: 1]@ 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 -eval code = at "retval" <$> runCommand ["$eval" =: code] +eval code = at "retval" `liftM` runCommand ["$eval" =: code] {- Authors: Tony Hannan