mongodb/Database/MongoDB/Admin.hs

323 lines
13 KiB
Haskell
Raw Normal View History

2020-04-01 14:53:37 +00:00
-- | Database administrative functions
{-# LANGUAGE CPP, FlexibleContexts, OverloadedStrings, RecordWildCards #-}
module Database.MongoDB.Admin (
2013-12-26 14:57:33 +00:00
-- * Admin
-- ** Collection
CollectionOption(..), createCollection, renameCollection, dropCollection,
2012-06-10 19:47:14 +00:00
validateCollection,
2013-12-26 14:57:33 +00:00
-- ** Index
Index(..), IndexName, index, ensureIndex, createIndex, dropIndex,
2012-06-10 19:47:14 +00:00
getIndexes, dropIndexes,
2013-12-26 14:57:33 +00:00
-- ** 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
2012-06-10 19:47:14 +00:00
import Control.Concurrent (forkIO, threadDelay)
2013-12-27 11:39:22 +00:00
import Control.Monad (forever, unless, liftM)
2012-06-10 19:47:14 +00:00
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
2015-06-19 16:26:38 +00:00
import Data.Maybe (maybeToList)
2012-06-10 19:47:14 +00:00
import Data.Set (Set)
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.HashTable.IO as H
2012-06-10 19:47:14 +00:00
import qualified Data.Set as Set
import Control.Monad.Trans (MonadIO, liftIO)
import Data.Bson (Document, Field(..), at, (=:), (=?), exclude, merge)
2012-05-08 15:13:25 +00:00
import Data.Text (Text)
2012-06-10 19:47:14 +00:00
2012-05-08 15:13:25 +00:00
import qualified Data.Text as T
2012-06-10 19:47:14 +00:00
import Database.MongoDB.Connection (Host, showHostPort)
import Database.MongoDB.Internal.Protocol (pwHash, pwKey)
2013-12-27 11:39:22 +00:00
import Database.MongoDB.Internal.Util ((<.>), true1)
2012-06-10 19:47:14 +00:00
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 (Show, Eq)
coptElem :: CollectionOption -> Field
coptElem Capped = "capped" =: True
coptElem (MaxByteSize n) = "size" =: n
coptElem (MaxItems n) = "max" =: n
2013-12-27 11:39:22 +00:00
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
2013-12-27 11:39:22 +00:00
renameCollection :: (MonadIO m) => Collection -> Collection -> Action m Document
2020-04-01 14:53:37 +00:00
-- ^ Rename first collection to second collection
renameCollection from to = do
2013-12-26 14:57:33 +00:00
db <- thisDatabase
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
2019-10-04 16:10:24 +00:00
dropCollection :: (MonadIO m, MonadFail m) => Collection -> Action m Bool
2020-04-01 13:11:17 +00:00
-- ^ 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
2013-12-26 14:57:33 +00:00
resetIndexCache
r <- runCommand ["drop" =: coll]
if true1 "ok" r then return True else do
if at "errmsg" r == ("ns not found" :: Text) then return False else
fail $ "dropCollection failed: " ++ show r
2013-12-27 11:39:22 +00:00
validateCollection :: (MonadIO m) => Collection -> Action m Document
2020-04-01 13:11:17 +00:00
-- ^ Validate the given collection, scanning the data and indexes for correctness. This operation takes a while.
validateCollection coll = runCommand ["validate" =: coll]
-- ** Index
2012-05-08 15:13:25 +00:00
type IndexName = Text
data Index = Index {
2013-12-26 14:57:33 +00:00
iColl :: Collection,
iKey :: Order,
iName :: IndexName,
iUnique :: Bool,
2015-06-19 16:26:38 +00:00
iDropDups :: Bool,
iExpireAfterSeconds :: Maybe Int
2013-12-26 14:57:33 +00:00
} deriving (Show, Eq)
idxDocument :: Index -> Database -> Document
idxDocument Index{..} db = [
2013-12-26 14:57:33 +00:00
"ns" =: db <.> iColl,
"key" =: iKey,
"name" =: iName,
"unique" =: iUnique,
2015-06-19 16:26:38 +00:00
"dropDups" =: iDropDups ] ++ (maybeToList $ fmap ((=:) "expireAfterSeconds") iExpireAfterSeconds)
index :: Collection -> Order -> Index
2020-04-01 13:11:17 +00:00
-- ^ Spec of index of ordered keys on collection. 'iName' is generated from keys. 'iUnique' and 'iDropDups' are @False@.
2015-06-19 16:26:38 +00:00
index coll keys = Index coll keys (genName keys) False False Nothing
genName :: Order -> IndexName
2012-05-08 15:13:25 +00:00
genName keys = T.intercalate "_" (map f keys) where
2013-12-26 14:57:33 +00:00
f (k := v) = k `T.append` "_" `T.append` T.pack (show v)
2013-12-27 11:39:22 +00:00
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
2013-12-26 14:57:33 +00:00
icache <- fetchIndexCache
set <- liftIO (readIORef icache)
unless (Set.member k set) $ do
accessMode master (createIndex idx)
liftIO $ writeIORef icache (Set.insert k set)
2013-12-27 11:39:22 +00:00
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
2013-12-27 11:39:22 +00:00
dropIndex :: (MonadIO m) => Collection -> IndexName -> Action m Document
2020-04-01 13:11:17 +00:00
-- ^ Remove the index from the given collection.
dropIndex coll idxName = do
2013-12-26 14:57:33 +00:00
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName]
getIndexes :: MonadIO m => Collection -> Action m [Document]
2020-04-01 14:53:37 +00:00
-- ^ Get all indexes on this collection
getIndexes coll = do
2013-12-26 14:57:33 +00:00
db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes")
2013-12-27 11:39:22 +00:00
dropIndexes :: (MonadIO m) => Collection -> Action m Document
2020-04-01 14:53:37 +00:00
-- ^ Drop all indexes on this collection
dropIndexes coll = do
2013-12-26 14:57:33 +00:00
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: ("*" :: 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.
2012-06-10 19:47:14 +00:00
type IndexCache = IORef (Set (Collection, IndexName))
dbIndexCache :: DbIndexCache
-- ^ initialize cache and fork thread that clears it every 15 minutes
dbIndexCache = unsafePerformIO $ do
2013-12-26 14:57:33 +00:00
table <- H.new
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table
{-# NOINLINE dbIndexCache #-}
clearDbIndexCache :: IO ()
clearDbIndexCache = do
2013-12-26 14:57:33 +00:00
keys <- map fst <$> H.toList dbIndexCache
mapM_ (H.delete dbIndexCache) keys
fetchIndexCache :: (MonadIO m) => Action m IndexCache
-- ^ Get index cache for current database
fetchIndexCache = do
2013-12-26 14:57:33 +00:00
db <- thisDatabase
liftIO $ do
mc <- H.lookup dbIndexCache db
maybe (newIdxCache db) return mc
where
2013-12-26 14:57:33 +00:00
newIdxCache db = do
idx <- newIORef Set.empty
H.insert dbIndexCache db idx
return idx
resetIndexCache :: (MonadIO m) => Action m ()
-- ^ reset index cache for current database
resetIndexCache = do
2013-12-26 14:57:33 +00:00
icache <- fetchIndexCache
liftIO (writeIORef icache Set.empty)
-- ** User
allUsers :: MonadIO m => Action m [Document]
2020-04-01 14:53:37 +00:00
-- ^ Fetch all users of this database
allUsers = map (exclude ["_id"]) `liftM` (rest =<< find
2013-12-26 14:57:33 +00:00
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
2016-08-06 22:17:03 +00:00
addUser :: (MonadIO m)
2016-06-08 07:09:33 +00:00
=> Bool -> Username -> Password -> Action m ()
2020-04-03 07:46:07 +00:00
-- ^ Add user with password with read-only access if the boolean argument is @True@, or read-write access if it's @False@
addUser readOnly user pass = do
2013-12-26 14:57:33 +00:00
mu <- findOne (select ["user" =: user] "system.users")
let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu)
save "system.users" usr
2016-08-06 22:17:03 +00:00
removeUser :: (MonadIO m)
2016-06-18 20:33:24 +00:00
=> Username -> Action m ()
removeUser user = delete (select ["user" =: user] "system.users")
-- ** Database
2010-10-27 20:46:11 +00:00
admin :: Database
2020-04-01 13:11:17 +00:00
-- ^ The \"admin\" database, which stores user authorization and authentication data plus other system collections.
admin = "admin"
2013-12-27 11:39:22 +00:00
cloneDatabase :: (MonadIO m) => Database -> Host -> Action m Document
2020-04-01 13:11:17 +00:00
-- ^ 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]
2013-12-27 11:39:22 +00:00
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
2013-12-26 14:57:33 +00:00
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
useDb admin $ case mup of
Nothing -> runCommand c
Just (usr, pss) -> do
2013-12-27 11:39:22 +00:00
n <- at "nonce" `liftM` runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost]
2013-12-26 14:57:33 +00:00
runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
2013-12-27 11:39:22 +00:00
dropDatabase :: (MonadIO m) => Database -> Action m Document
-- ^ Delete the given database!
dropDatabase db = useDb db $ runCommand ["dropDatabase" =: (1 :: Int)]
2013-12-27 11:39:22 +00:00
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
2013-12-27 11:39:22 +00:00
serverBuildInfo :: (MonadIO m) => Action m Document
2020-04-01 13:11:17 +00:00
-- ^ Return a document containing the parameters used to compile the server instance.
serverBuildInfo = useDb admin $ runCommand ["buildinfo" =: (1 :: Int)]
2013-12-27 11:39:22 +00:00
serverVersion :: (MonadIO m) => Action m Text
2020-04-01 13:11:17 +00:00
-- ^ Return the version of the server instance.
2013-12-27 11:39:22 +00:00
serverVersion = at "version" `liftM` serverBuildInfo
-- * Diagnostics
-- ** Collection
2013-12-27 11:39:22 +00:00
collectionStats :: (MonadIO m) => Collection -> Action m Document
2020-04-01 13:11:17 +00:00
-- ^ Return some storage statistics for the given collection.
collectionStats coll = runCommand ["collstats" =: coll]
2013-12-27 11:39:22 +00:00
dataSize :: (MonadIO m) => Collection -> Action m Int
2020-04-01 13:11:17 +00:00
-- ^ Return the total uncompressed size (in bytes) in memory of all records in the given collection. Does not include indexes.
2013-12-27 11:39:22 +00:00
dataSize c = at "size" `liftM` collectionStats c
2013-12-27 11:39:22 +00:00
storageSize :: (MonadIO m) => Collection -> Action m Int
2020-04-01 13:11:17 +00:00
-- ^ Return the total bytes allocated to the given collection. Does not include indexes.
2013-12-27 11:39:22 +00:00
storageSize c = at "storageSize" `liftM` collectionStats c
2013-12-27 11:39:22 +00:00
totalIndexSize :: (MonadIO m) => Collection -> Action m Int
2020-04-01 13:11:17 +00:00
-- ^ The total size in bytes of all indexes in this collection.
2013-12-27 11:39:22 +00:00
totalIndexSize c = at "totalIndexSize" `liftM` collectionStats c
totalSize :: MonadIO m => Collection -> Action m Int
totalSize coll = do
2013-12-26 14:57:33 +00:00
x <- storageSize coll
xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs)
where
2013-12-27 11:39:22 +00:00
isize idx = at "storageSize" `liftM` collectionStats (coll `T.append` ".$" `T.append` at "name" idx)
-- ** Profiling
2020-04-01 13:11:17 +00:00
-- | 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 (Show, Enum, Eq)
2013-12-27 11:39:22 +00:00
getProfilingLevel :: (MonadIO m) => Action m ProfilingLevel
2020-04-01 13:11:17 +00:00
-- ^ Get the profiler level.
2013-12-27 11:39:22 +00:00
getProfilingLevel = (toEnum . at "was") `liftM` runCommand ["profile" =: (-1 :: Int)]
type MilliSec = Int
2013-12-27 11:39:22 +00:00
setProfilingLevel :: (MonadIO m) => ProfilingLevel -> Maybe MilliSec -> Action m ()
2020-04-01 13:11:17 +00:00
-- ^ Set the profiler level, and optionally the slow operation time threshold (in milliseconds).
setProfilingLevel p mSlowMs =
2013-12-26 14:57:33 +00:00
runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return ()
-- ** Database
2013-12-27 11:39:22 +00:00
dbStats :: (MonadIO m) => Action m Document
2020-04-01 13:11:17 +00:00
-- ^ Return some storage statistics for the given database.
dbStats = runCommand ["dbstats" =: (1 :: Int)]
currentOp :: (MonadIO m) => Action m (Maybe Document)
2020-04-01 14:53:37 +00:00
-- ^ See currently running operation on the database, if any
currentOp = findOne (select [] "$cmd.sys.inprog")
2020-04-01 13:11:17 +00:00
-- | An operation indentifier.
type OpNum = Int
killOp :: (MonadIO m) => OpNum -> Action m (Maybe Document)
2020-04-01 13:11:17 +00:00
-- ^ Terminate the operation specified by the given 'OpNum'.
killOp op = findOne (select ["op" =: op] "$cmd.sys.killop")
-- ** Server
2013-12-27 11:39:22 +00:00
serverStatus :: (MonadIO m) => Action m Document
2020-04-01 13:11:17 +00:00
-- ^ Return a document with an overview of the state of the database.
serverStatus = useDb admin $ runCommand ["serverStatus" =: (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. -}