Remove MonadIO'

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

View file

@ -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)]

View file

@ -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

View file

@ -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 <http://docs.mongodb.org/manual/core/aggregation/> 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 <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
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 <tony@10gen.com>