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)
import Control.Applicative ((<$>))
import Database.MongoDB.Internal.Protocol (pwHash, pwKey)
import Database.MongoDB.Connection (Host, showHostPort)
import Database.MongoDB.Query
import Data.Bson
import Data.UString (pack, unpack, append, intercalate)
import Control.Monad.Reader
import qualified Data.HashTable as T
import Data.IORef
import qualified Data.Set as S
import System.IO.Unsafe (unsafePerformIO)
import Control.Concurrent (forkIO, threadDelay)
import Database.MongoDB.Internal.Util ((<.>), true1)
data CollectionOption = Capped | MaxByteSize Int | MaxItems Int deriving (Show, Eq)
coptElem :: CollectionOption -> Field
coptElem Capped = "capped" =: True
coptElem (MaxByteSize n) = "size" =: n
coptElem (MaxItems n) = "max" =: n
createCollection :: (DbAccess m) => [CollectionOption] -> Collection -> m Document
createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts
renameCollection :: (DbAccess m) => Collection -> Collection -> m Document
renameCollection from to = do
Database db <- thisDatabase
use admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
dropCollection :: (DbAccess m) => Collection -> m Bool
dropCollection coll = do
resetIndexCache
r <- runCommand ["drop" =: coll]
if true1 "ok" r then return True else do
if at "errmsg" r == ("ns not found" :: UString) then return False else
fail $ "dropCollection failed: " ++ show r
validateCollection :: (DbAccess m) => Collection -> m Document
validateCollection coll = runCommand ["validate" =: coll]
type IndexName = UString
data Index = Index {
iColl :: Collection,
iKey :: Order,
iName :: IndexName,
iUnique :: Bool,
iDropDups :: Bool
} deriving (Show, Eq)
idxDocument :: Index -> Database -> Document
idxDocument Index{..} (Database db) = [
"ns" =: db <.> iColl,
"key" =: iKey,
"name" =: iName,
"unique" =: iUnique,
"dropDups" =: iDropDups ]
index :: Collection -> Order -> Index
index coll keys = Index coll keys (genName keys) False False
genName :: Order -> IndexName
genName keys = intercalate "_" (map f keys) where
f (k := v) = k `append` "_" `append` pack (show v)
ensureIndex :: (DbAccess m) => Index -> m ()
ensureIndex idx = let k = (iColl idx, iName idx) in do
icache <- fetchIndexCache
set <- liftIO (readIORef icache)
unless (S.member k set) $ do
writeMode (Safe []) (createIndex idx)
liftIO $ writeIORef icache (S.insert k set)
createIndex :: (DbAccess m) => Index -> m ()
createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase
dropIndex :: (DbAccess m) => Collection -> IndexName -> m Document
dropIndex coll idxName = do
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName]
getIndexes :: (DbAccess m) => Collection -> m [Document]
getIndexes coll = do
Database db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes")
dropIndexes :: (DbAccess m) => Collection -> m Document
dropIndexes coll = do
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: UString)]
type DbIndexCache = T.HashTable Database IndexCache
type IndexCache = IORef (S.Set (Collection, IndexName))
dbIndexCache :: DbIndexCache
dbIndexCache = unsafePerformIO $ do
table <- T.new (==) (T.hashString . unpack . databaseName)
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table
clearDbIndexCache :: IO ()
clearDbIndexCache = do
keys <- map fst <$> T.toList dbIndexCache
mapM_ (T.delete dbIndexCache) keys
fetchIndexCache :: (DbAccess m) => m IndexCache
fetchIndexCache = do
db <- thisDatabase
liftIO $ do
mc <- T.lookup dbIndexCache db
maybe (newIdxCache db) return mc
where
newIdxCache db = do
idx <- newIORef S.empty
T.insert dbIndexCache db idx
return idx
resetIndexCache :: (DbAccess m) => m ()
resetIndexCache = do
icache <- fetchIndexCache
liftIO (writeIORef icache S.empty)
allUsers :: (DbAccess m) => m [Document]
allUsers = map (exclude ["_id"]) <$> (rest =<< find
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
addUser :: (DbAccess m) => Bool -> Username -> Password -> m ()
addUser readOnly user pass = do
mu <- findOne (select ["user" =: user] "system.users")
let u = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu)
save "system.users" u
removeUser :: (DbAccess m) => Username -> m ()
removeUser user = delete (select ["user" =: user] "system.users")
admin :: Database
admin = Database "admin"
cloneDatabase :: (Access m) => Database -> Host -> m Document
cloneDatabase db fromHost = use db $ runCommand ["clone" =: showHostPort fromHost]
copyDatabase :: (Access m) => Database -> Host -> Maybe (Username, Password) -> Database -> m Document
copyDatabase (Database fromDb) fromHost mup (Database toDb) = do
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
use admin $ case mup of
Nothing -> runCommand c
Just (u, p) -> do
n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost]
runCommand $ c ++ ["username" =: u, "nonce" =: n, "key" =: pwKey n u p]
dropDatabase :: (Access m) => Database -> m Document
dropDatabase db = use db $ runCommand ["dropDatabase" =: (1 :: Int)]
repairDatabase :: (Access m) => Database -> m Document
repairDatabase db = use db $ runCommand ["repairDatabase" =: (1 :: Int)]
serverBuildInfo :: (Access m) => m Document
serverBuildInfo = use admin $ runCommand ["buildinfo" =: (1 :: Int)]
serverVersion :: (Access m) => m UString
serverVersion = at "version" <$> serverBuildInfo
collectionStats :: (DbAccess m) => Collection -> m Document
collectionStats coll = runCommand ["collstats" =: coll]
dataSize :: (DbAccess m) => Collection -> m Int
dataSize c = at "size" <$> collectionStats c
storageSize :: (DbAccess m) => Collection -> m Int
storageSize c = at "storageSize" <$> collectionStats c
totalIndexSize :: (DbAccess m) => Collection -> m Int
totalIndexSize c = at "totalIndexSize" <$> collectionStats c
totalSize :: (DbAccess m) => Collection -> m Int
totalSize coll = do
x <- storageSize coll
xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs)
where
isize idx = at "storageSize" <$> collectionStats (coll `append` ".$" `append` at "name" idx)
data ProfilingLevel = Off | Slow | All deriving (Show, Enum, Eq)
getProfilingLevel :: (DbAccess m) => m ProfilingLevel
getProfilingLevel = toEnum . at "was" <$> runCommand ["profile" =: (1 :: Int)]
type MilliSec = Int
setProfilingLevel :: (DbAccess m) => ProfilingLevel -> Maybe MilliSec -> m ()
setProfilingLevel p mSlowMs =
runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return ()
dbStats :: (DbAccess m) => m Document
dbStats = runCommand ["dbstats" =: (1 :: Int)]
currentOp :: (DbAccess m) => m (Maybe Document)
currentOp = findOne (select [] "$cmd.sys.inprog")
type OpNum = Int
killOp :: (DbAccess m) => OpNum -> m (Maybe Document)
killOp op = findOne (select ["op" =: op] "$cmd.sys.killop")
serverStatus :: (Access m) => m Document
serverStatus = use admin $ runCommand ["serverStatus" =: (1 :: Int)]