{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards #-}
module Database.MongoDB.Admin (
CollectionOption(..), createCollection, renameCollection, dropCollection,
validateCollection,
Index(..), IndexName, index, ensureIndex, createIndex, dropIndex,
getIndexes, dropIndexes,
allUsers, addUser, removeUser,
admin, cloneDatabase, copyDatabase, dropDatabase, repairDatabase,
serverBuildInfo, serverVersion,
collectionStats, dataSize, storageSize, totalIndexSize, totalSize,
ProfilingLevel(..), getProfilingLevel, MilliSec, setProfilingLevel,
dbStats, OpNum, currentOp, killOp,
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)
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
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
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
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
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]
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
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 ()
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 ()
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
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]
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
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)]
type DbIndexCache = H.BasicHashTable Database IndexCache
type IndexCache = IORef (Set (Collection, IndexName))
dbIndexCache :: DbIndexCache
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
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 ()
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)
allUsers :: MonadIO m => Action m [Document]
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 ()
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")
admin :: Database
admin :: Label
admin = Label
"admin"
cloneDatabase :: (MonadIO m) => Database -> Host -> Action m Document
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
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
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
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)]
serverBuildInfo :: (MonadIO m) => Action m Document
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
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
collectionStats :: (MonadIO m) => Collection -> Action m Document
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
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
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
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)
data ProfilingLevel
= Off
| Slow
| All
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
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 ()
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 ()
dbStats :: (MonadIO m) => Action m Document
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)
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")
type OpNum = Int
killOp :: (MonadIO m) => OpNum -> Action m (Maybe Document)
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")
serverStatus :: (MonadIO m) => Action m Document
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)]