-- | Database administrative functions

{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards #-}

module Database.MongoDB.Admin (
    -- * Admin
    -- ** Collection
    CollectionOption(..), createCollection, renameCollection, dropCollection,
    validateCollection,
    -- ** Index
    Index(..), IndexName, index, ensureIndex, createIndex, dropIndex,
    getIndexes, dropIndexes,
    -- ** User
    allUsers, addUser, removeUser,
    -- ** Database
    admin, cloneDatabase, copyDatabase, dropDatabase, repairDatabase,
    -- ** Server
    serverBuildInfo, serverVersion,
    -- * Diagnotics
    -- ** Collection
    collectionStats, dataSize, storageSize, totalIndexSize, totalSize,
    -- ** Profiling
    ProfilingLevel(..), getProfilingLevel, MilliSec, setProfilingLevel,
    -- ** Database
    dbStats, OpNum, currentOp, killOp,
    -- ** Server
    serverStatus
) where

import Prelude hiding (lookup)
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Control.Concurrent (forkIO, threadDelay)
import Control.Monad (forever, unless, liftM)
import Control.Monad.Fail(MonadFail)
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Maybe (maybeToList)
import Data.Set (Set)
import System.IO.Unsafe (unsafePerformIO)

import qualified Data.HashTable.IO as H
import qualified Data.Set as Set

import Control.Monad.Trans (MonadIO, liftIO)
import Data.Bson (Document, Field(..), at, (=:), (=?), exclude, merge)
import Data.Text (Text)

import qualified Data.Text as T

import Database.MongoDB.Connection (Host, showHostPort)
import Database.MongoDB.Internal.Protocol (pwHash, pwKey)
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,
                               insert_, save, delete)

-- * Admin

-- ** Collection

data CollectionOption = Capped | MaxByteSize Int | MaxItems Int  deriving (Int -> CollectionOption -> ShowS
[CollectionOption] -> ShowS
CollectionOption -> String
(Int -> CollectionOption -> ShowS)
-> (CollectionOption -> String)
-> ([CollectionOption] -> ShowS)
-> Show CollectionOption
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CollectionOption] -> ShowS
$cshowList :: [CollectionOption] -> ShowS
show :: CollectionOption -> String
$cshow :: CollectionOption -> String
showsPrec :: Int -> CollectionOption -> ShowS
$cshowsPrec :: Int -> CollectionOption -> ShowS
Show, CollectionOption -> CollectionOption -> Bool
(CollectionOption -> CollectionOption -> Bool)
-> (CollectionOption -> CollectionOption -> Bool)
-> Eq CollectionOption
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CollectionOption -> CollectionOption -> Bool
$c/= :: CollectionOption -> CollectionOption -> Bool
== :: CollectionOption -> CollectionOption -> Bool
$c== :: CollectionOption -> CollectionOption -> Bool
Eq)

coptElem :: CollectionOption -> Field
coptElem :: CollectionOption -> Field
coptElem CollectionOption
Capped = Label
"capped" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True
coptElem (MaxByteSize Int
n) = Label
"size" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: Int
n
coptElem (MaxItems Int
n) = Label
"max" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: Int
n

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 :: [CollectionOption] -> Label -> Action m Document
createCollection [CollectionOption]
opts Label
col = Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ [Label
"create" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
col] Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ (CollectionOption -> Field) -> [CollectionOption] -> Document
forall a b. (a -> b) -> [a] -> [b]
map CollectionOption -> Field
coptElem [CollectionOption]
opts

renameCollection :: (MonadIO m) => Collection -> Collection -> Action m Document
-- ^ Rename first collection to second collection
renameCollection :: Label -> Label -> Action m Document
renameCollection Label
from Label
to = do
    Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
    Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
admin (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"renameCollection" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
db Label -> Label -> Label
<.> Label
from, Label
"to" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
db Label -> Label -> Label
<.> Label
to, Label
"dropTarget" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True]

dropCollection :: (MonadIO m, MonadFail m) => Collection -> Action m Bool
-- ^ Delete the given collection! Return @True@ if collection existed (and was deleted); return @False@ if collection did not exist (and no action).
dropCollection :: Label -> Action m Bool
dropCollection Label
coll = do
    Action m ()
forall (m :: * -> *). MonadIO m => Action m ()
resetIndexCache
    Document
r <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"drop" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll]
    if Label -> Document -> Bool
true1 Label
"ok" Document
r then Bool -> Action m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True else do
        if Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"errmsg" Document
r Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== (Label
"ns not found" :: Text) then Bool -> Action m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else
            String -> Action m Bool
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Action m Bool) -> String -> Action m Bool
forall a b. (a -> b) -> a -> b
$ String
"dropCollection failed: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Document -> String
forall a. Show a => a -> String
show Document
r

validateCollection :: (MonadIO m) => Collection -> Action m Document
-- ^ Validate the given collection, scanning the data and indexes for correctness. This operation takes a while.
validateCollection :: Label -> Action m Document
validateCollection Label
coll = Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"validate" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll]

-- ** Index

type IndexName = Text

data Index = Index {
    Index -> Label
iColl :: Collection,
    Index -> Document
iKey :: Order,
    Index -> Label
iName :: IndexName,
    Index -> Bool
iUnique :: Bool,
    Index -> Bool
iDropDups :: Bool,
    Index -> Maybe Int
iExpireAfterSeconds :: Maybe Int
    } deriving (Int -> Index -> ShowS
[Index] -> ShowS
Index -> String
(Int -> Index -> ShowS)
-> (Index -> String) -> ([Index] -> ShowS) -> Show Index
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Index] -> ShowS
$cshowList :: [Index] -> ShowS
show :: Index -> String
$cshow :: Index -> String
showsPrec :: Int -> Index -> ShowS
$cshowsPrec :: Int -> Index -> ShowS
Show, Index -> Index -> Bool
(Index -> Index -> Bool) -> (Index -> Index -> Bool) -> Eq Index
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Index -> Index -> Bool
$c/= :: Index -> Index -> Bool
== :: Index -> Index -> Bool
$c== :: Index -> Index -> Bool
Eq)

idxDocument :: Index -> Database -> Document
idxDocument :: Index -> Label -> Document
idxDocument Index{Bool
Document
Maybe Int
Label
iExpireAfterSeconds :: Maybe Int
iDropDups :: Bool
iUnique :: Bool
iName :: Label
iKey :: Document
iColl :: Label
iExpireAfterSeconds :: Index -> Maybe Int
iDropDups :: Index -> Bool
iUnique :: Index -> Bool
iName :: Index -> Label
iKey :: Index -> Document
iColl :: Index -> Label
..} Label
db = [
    Label
"ns" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
db Label -> Label -> Label
<.> Label
iColl,
    Label
"key" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
iKey,
    Label
"name" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
iName,
    Label
"unique" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
iUnique,
    Label
"dropDups" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
iDropDups ] Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ (Maybe Field -> Document
forall a. Maybe a -> [a]
maybeToList (Maybe Field -> Document) -> Maybe Field -> Document
forall a b. (a -> b) -> a -> b
$ (Int -> Field) -> Maybe Int -> Maybe Field
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Label -> Int -> Field
forall v. Val v => Label -> v -> Field
(=:) Label
"expireAfterSeconds") Maybe Int
iExpireAfterSeconds)

index :: Collection -> Order -> Index
-- ^ Spec of index of ordered keys on collection. 'iName' is generated from keys. 'iUnique' and 'iDropDups' are @False@.
index :: Label -> Document -> Index
index Label
coll Document
keys = Label -> Document -> Label -> Bool -> Bool -> Maybe Int -> Index
Index Label
coll Document
keys (Document -> Label
genName Document
keys) Bool
False Bool
False Maybe Int
forall a. Maybe a
Nothing

genName :: Order -> IndexName
genName :: Document -> Label
genName Document
keys = Label -> [Label] -> Label
T.intercalate Label
"_" ((Field -> Label) -> Document -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Label
f Document
keys)  where
    f :: Field -> Label
f (Label
k := Value
v) = Label
k Label -> Label -> Label
`T.append` Label
"_" Label -> Label -> Label
`T.append` String -> Label
T.pack (Value -> String
forall a. Show a => a -> String
show Value
v)

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 :: Index -> Action m ()
ensureIndex Index
idx = let k :: (Label, Label)
k = (Index -> Label
iColl Index
idx, Index -> Label
iName Index
idx) in do
    IndexCache
icache <- Action m IndexCache
forall (m :: * -> *). MonadIO m => Action m IndexCache
fetchIndexCache
    Set (Label, Label)
set <- IO (Set (Label, Label))
-> ReaderT MongoContext m (Set (Label, Label))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IndexCache -> IO (Set (Label, Label))
forall a. IORef a -> IO a
readIORef IndexCache
icache)
    Bool -> Action m () -> Action m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Label, Label) -> Set (Label, Label) -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member (Label, Label)
k Set (Label, Label)
set) (Action m () -> Action m ()) -> Action m () -> Action m ()
forall a b. (a -> b) -> a -> b
$ do
        AccessMode -> Action m () -> Action m ()
forall (m :: * -> *) a.
Monad m =>
AccessMode -> Action m a -> Action m a
accessMode AccessMode
master (Index -> Action m ()
forall (m :: * -> *). MonadIO m => Index -> Action m ()
createIndex Index
idx)
        IO () -> Action m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Action m ()) -> IO () -> Action m ()
forall a b. (a -> b) -> a -> b
$ IndexCache -> Set (Label, Label) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IndexCache
icache ((Label, Label) -> Set (Label, Label) -> Set (Label, Label)
forall a. Ord a => a -> Set a -> Set a
Set.insert (Label, Label)
k Set (Label, Label)
set)

createIndex :: (MonadIO m) => Index -> Action m ()
-- ^ Create index on the server. This call goes to the server every time.
createIndex :: Index -> Action m ()
createIndex Index
idx = Label -> Document -> Action m ()
forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
insert_ Label
"system.indexes" (Document -> Action m ())
-> (Label -> Document) -> Label -> Action m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index -> Label -> Document
idxDocument Index
idx (Label -> Action m ())
-> ReaderT MongoContext m Label -> Action m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ReaderT MongoContext m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase

dropIndex :: (MonadIO m) => Collection -> IndexName -> Action m Document
-- ^ Remove the index from the given collection.
dropIndex :: Label -> Label -> Action m Document
dropIndex Label
coll Label
idxName = do
    Action m ()
forall (m :: * -> *). MonadIO m => Action m ()
resetIndexCache
    Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"deleteIndexes" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll, Label
"index" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
idxName]

getIndexes :: MonadIO m => Collection -> Action m [Document]
-- ^ Get all indexes on this collection
getIndexes :: Label -> Action m [Document]
getIndexes Label
coll = do
    Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
    Cursor -> Action m [Document]
forall (m :: * -> *). MonadIO m => Cursor -> Action m [Document]
rest (Cursor -> Action m [Document])
-> ReaderT MongoContext m Cursor -> Action m [Document]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Query -> ReaderT MongoContext m Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find (Document -> Label -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select [Label
"ns" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
db Label -> Label -> Label
<.> Label
coll] Label
"system.indexes")

dropIndexes :: (MonadIO m) => Collection -> Action m Document
-- ^ Drop all indexes on this collection
dropIndexes :: Label -> Action m Document
dropIndexes Label
coll = do
    Action m ()
forall (m :: * -> *). MonadIO m => Action m ()
resetIndexCache
    Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"deleteIndexes" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll, Label
"index" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: (Label
"*" :: Text)]

-- *** Index cache

type DbIndexCache = H.BasicHashTable Database IndexCache
-- ^ Cache the indexes we create so repeatedly calling ensureIndex only hits database the first time. Clear cache every once in a while so if someone else deletes index we will recreate it on ensureIndex.

type IndexCache = IORef (Set (Collection, IndexName))

dbIndexCache :: DbIndexCache
-- ^ initialize cache and fork thread that clears it every 15 minutes
dbIndexCache :: DbIndexCache
dbIndexCache = IO (HashTable RealWorld Label IndexCache)
-> HashTable RealWorld Label IndexCache
forall a. IO a -> a
unsafePerformIO (IO (HashTable RealWorld Label IndexCache)
 -> HashTable RealWorld Label IndexCache)
-> IO (HashTable RealWorld Label IndexCache)
-> HashTable RealWorld Label IndexCache
forall a b. (a -> b) -> a -> b
$ do
    HashTable RealWorld Label IndexCache
table <- IO (HashTable RealWorld Label IndexCache)
forall (h :: * -> * -> * -> *) k v.
HashTable h =>
IO (IOHashTable h k v)
H.new
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> (IO () -> IO ()) -> IO () -> IO ThreadId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
900000000 IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
clearDbIndexCache
    HashTable RealWorld Label IndexCache
-> IO (HashTable RealWorld Label IndexCache)
forall (m :: * -> *) a. Monad m => a -> m a
return HashTable RealWorld Label IndexCache
table
{-# NOINLINE dbIndexCache #-}

clearDbIndexCache :: IO ()
clearDbIndexCache :: IO ()
clearDbIndexCache = do
    [Label]
keys <- ((Label, IndexCache) -> Label) -> [(Label, IndexCache)] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label, IndexCache) -> Label
forall a b. (a, b) -> a
fst ([(Label, IndexCache)] -> [Label])
-> IO [(Label, IndexCache)] -> IO [Label]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DbIndexCache -> IO [(Label, IndexCache)]
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> IO [(k, v)]
H.toList DbIndexCache
dbIndexCache
    (Label -> IO ()) -> [Label] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DbIndexCache -> Label -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO ()
H.delete DbIndexCache
dbIndexCache) [Label]
keys

fetchIndexCache :: (MonadIO m) => Action m IndexCache
-- ^ Get index cache for current database
fetchIndexCache :: Action m IndexCache
fetchIndexCache = do
    Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
    IO IndexCache -> Action m IndexCache
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO IndexCache -> Action m IndexCache)
-> IO IndexCache -> Action m IndexCache
forall a b. (a -> b) -> a -> b
$ do
        Maybe IndexCache
mc <- DbIndexCache -> Label -> IO (Maybe IndexCache)
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> IO (Maybe v)
H.lookup DbIndexCache
dbIndexCache Label
db
        IO IndexCache
-> (IndexCache -> IO IndexCache)
-> Maybe IndexCache
-> IO IndexCache
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Label -> IO IndexCache
newIdxCache Label
db) IndexCache -> IO IndexCache
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe IndexCache
mc
 where
    newIdxCache :: Label -> IO IndexCache
newIdxCache Label
db = do
        IndexCache
idx <- Set (Label, Label) -> IO IndexCache
forall a. a -> IO (IORef a)
newIORef Set (Label, Label)
forall a. Set a
Set.empty
        DbIndexCache -> Label -> IndexCache -> IO ()
forall (h :: * -> * -> * -> *) k v.
(HashTable h, Eq k, Hashable k) =>
IOHashTable h k v -> k -> v -> IO ()
H.insert DbIndexCache
dbIndexCache Label
db IndexCache
idx
        IndexCache -> IO IndexCache
forall (m :: * -> *) a. Monad m => a -> m a
return IndexCache
idx

resetIndexCache :: (MonadIO m) => Action m ()
-- ^ reset index cache for current database
resetIndexCache :: Action m ()
resetIndexCache = do
    IndexCache
icache <- Action m IndexCache
forall (m :: * -> *). MonadIO m => Action m IndexCache
fetchIndexCache
    IO () -> Action m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IndexCache -> Set (Label, Label) -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IndexCache
icache Set (Label, Label)
forall a. Set a
Set.empty)

-- ** User

allUsers :: MonadIO m => Action m [Document]
-- ^ Fetch all users of this database
allUsers :: Action m [Document]
allUsers = (Document -> Document) -> [Document] -> [Document]
forall a b. (a -> b) -> [a] -> [b]
map ([Label] -> Document -> Document
exclude [Label
"_id"]) ([Document] -> [Document])
-> Action m [Document] -> Action m [Document]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` (Cursor -> Action m [Document]
forall (m :: * -> *). MonadIO m => Cursor -> Action m [Document]
rest (Cursor -> Action m [Document])
-> ReaderT MongoContext m Cursor -> Action m [Document]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Query -> ReaderT MongoContext m Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find
    (Document -> Label -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select [] Label
"system.users") {sort :: Document
sort = [Label
"user" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)], project :: Document
project = [Label
"user" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"readOnly" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]})

addUser :: (MonadIO m)
        => Bool -> Username -> Password -> Action m ()
-- ^ Add user with password with read-only access if the boolean argument is @True@, or read-write access if it's @False@
addUser :: Bool -> Label -> Label -> Action m ()
addUser Bool
readOnly Label
user Label
pass = do
    Maybe Document
mu <- Query -> Action m (Maybe Document)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne (Document -> Label -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select [Label
"user" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
user] Label
"system.users")
    let usr :: Document
usr = Document -> Document -> Document
merge [Label
"readOnly" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
readOnly, Label
"pwd" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label -> Label -> Label
pwHash Label
user Label
pass] (Document -> (Document -> Document) -> Maybe Document -> Document
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [Label
"user" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
user] Document -> Document
forall a. a -> a
id Maybe Document
mu)
    Label -> Document -> Action m ()
forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
save Label
"system.users" Document
usr

removeUser :: (MonadIO m)
           => Username -> Action m ()
removeUser :: Label -> Action m ()
removeUser Label
user = Selection -> Action m ()
forall (m :: * -> *). MonadIO m => Selection -> Action m ()
delete (Document -> Label -> Selection
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select [Label
"user" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
user] Label
"system.users")

-- ** Database

admin :: Database
-- ^ The \"admin\" database, which stores user authorization and authentication data plus other system collections.
admin :: Label
admin = Label
"admin"

cloneDatabase :: (MonadIO m) => Database -> Host -> Action m Document
-- ^ Copy database from given host to the server I am connected to. Fails and returns @"ok" = 0@ if we don't have permission to read from given server (use 'copyDatabase' in this case).
cloneDatabase :: Label -> Host -> Action m Document
cloneDatabase Label
db Host
fromHost = Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
db (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"clone" Label -> String -> Field
forall v. Val v => Label -> v -> Field
=: Host -> String
showHostPort Host
fromHost]

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 :: Label -> Host -> Maybe (Label, Label) -> Label -> Action m Document
copyDatabase Label
fromDb Host
fromHost Maybe (Label, Label)
mup Label
toDb = do
    let c :: Document
c = [Label
"copydb" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"fromhost" Label -> String -> Field
forall v. Val v => Label -> v -> Field
=: Host -> String
showHostPort Host
fromHost, Label
"fromdb" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
fromDb, Label
"todb" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
toDb]
    Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
admin (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ case Maybe (Label, Label)
mup of
        Maybe (Label, Label)
Nothing -> Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
c
        Just (Label
usr, Label
pss) -> do
            Label
n <- Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"nonce" (Document -> Label)
-> Action m Document -> ReaderT MongoContext m Label
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"copydbgetnonce" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"fromhost" Label -> String -> Field
forall v. Val v => Label -> v -> Field
=: Host -> String
showHostPort Host
fromHost]
            Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document
c Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ [Label
"username" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
usr, Label
"nonce" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
n, Label
"key" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label -> Label -> Label -> Label
pwKey Label
n Label
usr Label
pss]

dropDatabase :: (MonadIO m) => Database -> Action m Document
-- ^ Delete the given database!
dropDatabase :: Label -> Action m Document
dropDatabase Label
db = Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
db (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"dropDatabase" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]

repairDatabase :: (MonadIO m) => Database -> Action m Document
-- ^ Attempt to fix any corrupt records. This operation takes a while.
repairDatabase :: Label -> Action m Document
repairDatabase Label
db = Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
db (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"repairDatabase" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]

-- ** Server

serverBuildInfo :: (MonadIO m) => Action m Document
-- ^ Return a document containing the parameters used to compile the server instance.
serverBuildInfo :: Action m Document
serverBuildInfo = Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
admin (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"buildinfo" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]

serverVersion :: (MonadIO m) => Action m Text
-- ^ Return the version of the server instance.
serverVersion :: Action m Label
serverVersion = Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"version" (Document -> Label)
-> ReaderT MongoContext m Document -> Action m Label
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Action m Document
serverBuildInfo

-- * Diagnostics

-- ** Collection

collectionStats :: (MonadIO m) => Collection -> Action m Document
-- ^ Return some storage statistics for the given collection.
collectionStats :: Label -> Action m Document
collectionStats Label
coll = Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"collstats" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll]

dataSize :: (MonadIO m) => Collection -> Action m Int
-- ^ Return the total uncompressed size (in bytes) in memory of all records in the given collection. Does not include indexes.
dataSize :: Label -> Action m Int
dataSize Label
c = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"size" (Document -> Int)
-> ReaderT MongoContext m Document -> Action m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Label -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
collectionStats Label
c

storageSize :: (MonadIO m) => Collection -> Action m Int
-- ^ Return the total bytes allocated to the given collection. Does not include indexes.
storageSize :: Label -> Action m Int
storageSize Label
c = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"storageSize" (Document -> Int)
-> ReaderT MongoContext m Document -> Action m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Label -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
collectionStats Label
c

totalIndexSize :: (MonadIO m) => Collection -> Action m Int
-- ^ The total size in bytes of all indexes in this collection.
totalIndexSize :: Label -> Action m Int
totalIndexSize Label
c = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"totalIndexSize" (Document -> Int)
-> ReaderT MongoContext m Document -> Action m Int
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Label -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
collectionStats Label
c

totalSize :: MonadIO m => Collection -> Action m Int
totalSize :: Label -> Action m Int
totalSize Label
coll = do
    Int
x <- Label -> Action m Int
forall (m :: * -> *). MonadIO m => Label -> Action m Int
storageSize Label
coll
    [Int]
xs <- (Document -> Action m Int)
-> [Document] -> ReaderT MongoContext m [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Document -> Action m Int
forall (m :: * -> *) r.
(Val r, MonadIO m) =>
Document -> ReaderT MongoContext m r
isize ([Document] -> ReaderT MongoContext m [Int])
-> ReaderT MongoContext m [Document]
-> ReaderT MongoContext m [Int]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Label -> ReaderT MongoContext m [Document]
forall (m :: * -> *). MonadIO m => Label -> Action m [Document]
getIndexes Label
coll
    Int -> Action m Int
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> Int -> Int) -> Int -> [Int] -> Int
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) Int
x [Int]
xs)
 where
    isize :: Document -> ReaderT MongoContext m r
isize Document
idx = Label -> Document -> r
forall v. Val v => Label -> Document -> v
at Label
"storageSize" (Document -> r)
-> ReaderT MongoContext m Document -> ReaderT MongoContext m r
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Label -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
collectionStats (Label
coll Label -> Label -> Label
`T.append` Label
".$" Label -> Label -> Label
`T.append` Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"name" Document
idx)

-- ** Profiling

-- | The available profiler levels.
data ProfilingLevel
    = Off -- ^ No data collection.
    | Slow -- ^ Data collected only for slow operations. The slow operation time threshold is 100ms by default, but can be changed using 'setProfilingLevel'.
    | All -- ^ Data collected for all operations.
    deriving (Int -> ProfilingLevel -> ShowS
[ProfilingLevel] -> ShowS
ProfilingLevel -> String
(Int -> ProfilingLevel -> ShowS)
-> (ProfilingLevel -> String)
-> ([ProfilingLevel] -> ShowS)
-> Show ProfilingLevel
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ProfilingLevel] -> ShowS
$cshowList :: [ProfilingLevel] -> ShowS
show :: ProfilingLevel -> String
$cshow :: ProfilingLevel -> String
showsPrec :: Int -> ProfilingLevel -> ShowS
$cshowsPrec :: Int -> ProfilingLevel -> ShowS
Show, Int -> ProfilingLevel
ProfilingLevel -> Int
ProfilingLevel -> [ProfilingLevel]
ProfilingLevel -> ProfilingLevel
ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
ProfilingLevel
-> ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
(ProfilingLevel -> ProfilingLevel)
-> (ProfilingLevel -> ProfilingLevel)
-> (Int -> ProfilingLevel)
-> (ProfilingLevel -> Int)
-> (ProfilingLevel -> [ProfilingLevel])
-> (ProfilingLevel -> ProfilingLevel -> [ProfilingLevel])
-> (ProfilingLevel -> ProfilingLevel -> [ProfilingLevel])
-> (ProfilingLevel
    -> ProfilingLevel -> ProfilingLevel -> [ProfilingLevel])
-> Enum ProfilingLevel
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: ProfilingLevel
-> ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
$cenumFromThenTo :: ProfilingLevel
-> ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
enumFromTo :: ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
$cenumFromTo :: ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
enumFromThen :: ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
$cenumFromThen :: ProfilingLevel -> ProfilingLevel -> [ProfilingLevel]
enumFrom :: ProfilingLevel -> [ProfilingLevel]
$cenumFrom :: ProfilingLevel -> [ProfilingLevel]
fromEnum :: ProfilingLevel -> Int
$cfromEnum :: ProfilingLevel -> Int
toEnum :: Int -> ProfilingLevel
$ctoEnum :: Int -> ProfilingLevel
pred :: ProfilingLevel -> ProfilingLevel
$cpred :: ProfilingLevel -> ProfilingLevel
succ :: ProfilingLevel -> ProfilingLevel
$csucc :: ProfilingLevel -> ProfilingLevel
Enum, ProfilingLevel -> ProfilingLevel -> Bool
(ProfilingLevel -> ProfilingLevel -> Bool)
-> (ProfilingLevel -> ProfilingLevel -> Bool) -> Eq ProfilingLevel
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ProfilingLevel -> ProfilingLevel -> Bool
$c/= :: ProfilingLevel -> ProfilingLevel -> Bool
== :: ProfilingLevel -> ProfilingLevel -> Bool
$c== :: ProfilingLevel -> ProfilingLevel -> Bool
Eq)

getProfilingLevel :: (MonadIO m) => Action m ProfilingLevel
-- ^ Get the profiler level.
getProfilingLevel :: Action m ProfilingLevel
getProfilingLevel = (Int -> ProfilingLevel
forall a. Enum a => Int -> a
toEnum (Int -> ProfilingLevel)
-> (Document -> Int) -> Document -> ProfilingLevel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"was") (Document -> ProfilingLevel)
-> ReaderT MongoContext m Document -> Action m ProfilingLevel
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Document -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"profile" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (-Int
1 :: Int)]

type MilliSec = Int

setProfilingLevel :: (MonadIO m) => ProfilingLevel -> Maybe MilliSec -> Action m ()
-- ^ Set the profiler level, and optionally the slow operation time threshold (in milliseconds).
setProfilingLevel :: ProfilingLevel -> Maybe Int -> Action m ()
setProfilingLevel ProfilingLevel
p Maybe Int
mSlowMs =
    Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand ([Label
"profile" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: ProfilingLevel -> Int
forall a. Enum a => a -> Int
fromEnum ProfilingLevel
p] Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ (Label
"slowms" Label -> Maybe Int -> Document
forall a. Val a => Label -> Maybe a -> Document
=? Maybe Int
mSlowMs)) Action m Document -> Action m () -> Action m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Action m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- ** Database

dbStats :: (MonadIO m) => Action m Document
-- ^ Return some storage statistics for the given database.
dbStats :: Action m Document
dbStats = Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"dbstats" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]

currentOp :: (MonadIO m) => Action m (Maybe Document)
-- ^ See currently running operation on the database, if any
currentOp :: Action m (Maybe Document)
currentOp = Query -> Action m (Maybe Document)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne (Document -> Label -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select [] Label
"$cmd.sys.inprog")

-- | An operation indentifier.
type OpNum = Int

killOp :: (MonadIO m) => OpNum -> Action m (Maybe Document)
-- ^ Terminate the operation specified by the given 'OpNum'.
killOp :: Int -> Action m (Maybe Document)
killOp Int
op = Query -> Action m (Maybe Document)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne (Document -> Label -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select [Label
"op" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: Int
op] Label
"$cmd.sys.killop")

-- ** Server

serverStatus :: (MonadIO m) => Action m Document
-- ^ Return a document with an overview of the state of the database.
serverStatus :: Action m Document
serverStatus = Label -> Action m Document -> Action m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
admin (Action m Document -> Action m Document)
-> Action m Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"serverStatus" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]


{- Authors: Tony Hannan <tony@10gen.com>
   Copyright 2011 10gen Inc.
   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. -}