Skip to content

Commit

Permalink
Replace hard tabs with spaces
Browse files Browse the repository at this point in the history
  • Loading branch information
@snoyberg
snoyberg committed Dec 26, 2013
1 parent b128bc7 commit 756c918
Show file tree
Hide file tree
Showing 7 changed files with 575 additions and 575 deletions.
8 changes: 4 additions & 4 deletions Database/MongoDB.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -40,10 +40,10 @@ Simple example below. Use with language extensions /OvererloadedStrings/ & /Exte
-}

module Database.MongoDB (
module Data.Bson,
module Database.MongoDB.Connection,
module Database.MongoDB.Query,
module Database.MongoDB.Admin
module Data.Bson,
module Database.MongoDB.Connection,
module Database.MongoDB.Query,
module Database.MongoDB.Admin
) where

import Data.Bson
Expand Down
160 changes: 80 additions & 80 deletions Database/MongoDB/Admin.hs
View file
Original file line number Diff line number Diff line change
Expand Up @@ -3,28 +3,28 @@
{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-}

module Database.MongoDB.Admin (
-- * Admin
-- ** Collection
CollectionOption(..), createCollection, renameCollection, dropCollection,
-- * Admin
-- ** Collection
CollectionOption(..), createCollection, renameCollection, dropCollection,
validateCollection,
-- ** Index
Index(..), IndexName, index, ensureIndex, createIndex, dropIndex,
-- ** 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
-- ** 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)
Expand Down Expand Up @@ -71,17 +71,17 @@ createCollection opts col = runCommand $ ["create" =: col] ++ map coptElem opts
renameCollection :: (MonadIO' m) => Collection -> Collection -> Action m Document
-- ^ Rename first collection to second collection
renameCollection from to = do
db <- thisDatabase
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]
db <- thisDatabase
useDb admin $ runCommand ["renameCollection" =: db <.> from, "to" =: db <.> to, "dropTarget" =: True]

dropCollection :: (MonadIO' m) => Collection -> Action m Bool
-- ^ Delete the given collection! Return True if collection existed (and was deleted); return False if collection did not exist (and no action).
dropCollection coll = do
resetIndexCache
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
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

validateCollection :: (MonadIO' m) => Collection -> Action m Document
-- ^ This operation takes a while
Expand All @@ -92,37 +92,37 @@ validateCollection coll = runCommand ["validate" =: coll]
type IndexName = Text

data Index = Index {
iColl :: Collection,
iKey :: Order,
iName :: IndexName,
iUnique :: Bool,
iDropDups :: Bool
} deriving (Show, Eq)
iColl :: Collection,
iKey :: Order,
iName :: IndexName,
iUnique :: Bool,
iDropDups :: Bool
} deriving (Show, Eq)

idxDocument :: Index -> Database -> Document
idxDocument Index{..} db = [
"ns" =: db <.> iColl,
"key" =: iKey,
"name" =: iName,
"unique" =: iUnique,
"dropDups" =: iDropDups ]
"ns" =: db <.> iColl,
"key" =: iKey,
"name" =: iName,
"unique" =: iUnique,
"dropDups" =: iDropDups ]

index :: Collection -> Order -> Index
-- ^ Spec of index of ordered keys on collection. Name is generated from keys. Unique and dropDups are False.
index coll keys = Index coll keys (genName keys) False False

genName :: Order -> IndexName
genName keys = T.intercalate "_" (map f keys) where
f (k := v) = k `T.append` "_" `T.append` T.pack (show v)
f (k := v) = k `T.append` "_" `T.append` T.pack (show 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 idx = let k = (iColl idx, iName idx) in do
icache <- fetchIndexCache
set <- liftIO (readIORef icache)
unless (Set.member k set) $ do
accessMode master (createIndex idx)
liftIO $ writeIORef icache (Set.insert k set)
icache <- fetchIndexCache
set <- liftIO (readIORef icache)
unless (Set.member k set) $ do
accessMode master (createIndex idx)
liftIO $ writeIORef icache (Set.insert k set)

createIndex :: (MonadIO' m) => Index -> Action m ()
-- ^ Create index on the server. This call goes to the server every time.
Expand All @@ -131,20 +131,20 @@ createIndex idx = insert_ "system.indexes" . idxDocument idx =<< thisDatabase
dropIndex :: (MonadIO' m) => Collection -> IndexName -> Action m Document
-- ^ Remove the index
dropIndex coll idxName = do
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName]
resetIndexCache
runCommand ["deleteIndexes" =: coll, "index" =: idxName]

getIndexes :: (MonadIO m, MonadBaseControl IO m, Functor m) => Collection -> Action m [Document]
-- ^ Get all indexes on this collection
getIndexes coll = do
db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes")
db <- thisDatabase
rest =<< find (select ["ns" =: db <.> coll] "system.indexes")

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

-- *** Index cache

Expand All @@ -156,48 +156,48 @@ type IndexCache = IORef (Set (Collection, IndexName))
dbIndexCache :: DbIndexCache
-- ^ initialize cache and fork thread that clears it every 15 minutes
dbIndexCache = unsafePerformIO $ do
table <- H.new
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table
table <- H.new
_ <- forkIO . forever $ threadDelay 900000000 >> clearDbIndexCache
return table
{-# NOINLINE dbIndexCache #-}

clearDbIndexCache :: IO ()
clearDbIndexCache = do
keys <- map fst <$> H.toList dbIndexCache
mapM_ (H.delete dbIndexCache) keys
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
db <- thisDatabase
liftIO $ do
mc <- H.lookup dbIndexCache db
maybe (newIdxCache db) return mc
db <- thisDatabase
liftIO $ do
mc <- H.lookup dbIndexCache db
maybe (newIdxCache db) return mc
where
newIdxCache db = do
idx <- newIORef Set.empty
H.insert dbIndexCache db idx
return idx
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
icache <- fetchIndexCache
liftIO (writeIORef icache Set.empty)
icache <- fetchIndexCache
liftIO (writeIORef icache Set.empty)

-- ** User

allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document]
-- ^ Fetch all users of this database
allUsers = map (exclude ["_id"]) <$> (rest =<< find
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})
(select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]})

addUser :: (MonadIO' m) => Bool -> Username -> Password -> Action m ()
-- ^ Add user with password with read-only access if bool is True or read-write access if bool is False
addUser readOnly user pass = do
mu <- findOne (select ["user" =: user] "system.users")
let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu)
save "system.users" usr
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

removeUser :: (MonadIO m) => Username -> Action m ()
removeUser user = delete (select ["user" =: user] "system.users")
Expand All @@ -215,12 +215,12 @@ cloneDatabase db fromHost = useDb db $ runCommand ["clone" =: showHostPort fromH
copyDatabase :: (MonadIO' m) => Database -> Host -> Maybe (Username, Password) -> Database -> Action m Document
-- ^ Copy database from given host to the server I am connected to. If username & password is supplied use them to read from given host.
copyDatabase fromDb fromHost mup toDb = do
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
useDb admin $ case mup of
Nothing -> runCommand c
Just (usr, pss) -> do
n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost]
runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]
let c = ["copydb" =: (1 :: Int), "fromhost" =: showHostPort fromHost, "fromdb" =: fromDb, "todb" =: toDb]
useDb admin $ case mup of
Nothing -> runCommand c
Just (usr, pss) -> do
n <- at "nonce" <$> runCommand ["copydbgetnonce" =: (1 :: Int), "fromhost" =: showHostPort fromHost]
runCommand $ c ++ ["username" =: usr, "nonce" =: n, "key" =: pwKey n usr pss]

dropDatabase :: (MonadIO' m) => Database -> Action m Document
-- ^ Delete the given database!
Expand Down Expand Up @@ -256,11 +256,11 @@ totalIndexSize c = at "totalIndexSize" <$> collectionStats c

totalSize :: (MonadIO m, MonadBaseControl IO m, MonadIO' m) => Collection -> Action m Int
totalSize coll = do
x <- storageSize coll
xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs)
x <- storageSize coll
xs <- mapM isize =<< getIndexes coll
return (foldl (+) x xs)
where
isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx)
isize idx = at "storageSize" <$> collectionStats (coll `T.append` ".$" `T.append` at "name" idx)

-- ** Profiling

Expand All @@ -273,7 +273,7 @@ type MilliSec = Int

setProfilingLevel :: (MonadIO' m) => ProfilingLevel -> Maybe MilliSec -> Action m ()
setProfilingLevel p mSlowMs =
runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return ()
runCommand (["profile" =: fromEnum p] ++ ("slowms" =? mSlowMs)) >> return ()

-- ** Database

Expand Down
Loading

0 comments on commit 756c918

Please sign in to comment.