Merge pull request #9 from alphaHeavy/monad-control
Updating to monad-control-0.3, with help from Bas van Dijk.
This commit is contained in:
commit
6faad5d866
4 changed files with 51 additions and 30 deletions
|
@ -1,19 +1,18 @@
|
||||||
{- | Lift MVar operations so you can do them within monads stacked on top of IO. Analogous to MonadIO -}
|
{- | Lift MVar operations so you can do them within monads stacked on top of IO. Analogous to MonadIO -}
|
||||||
|
|
||||||
{-# LANGUAGE TupleSections #-}
|
{-# LANGUAGE FlexibleContexts, TupleSections #-}
|
||||||
|
|
||||||
module Control.Monad.MVar (
|
module Control.Monad.MVar (
|
||||||
MVar,
|
MVar,
|
||||||
module Control.Monad.MVar,
|
module Control.Monad.MVar,
|
||||||
liftIO,
|
liftIO,
|
||||||
MonadControlIO
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Control.Concurrent.MVar (MVar)
|
import Control.Concurrent.MVar (MVar)
|
||||||
import qualified Control.Concurrent.MVar as IO
|
import qualified Control.Concurrent.MVar as IO
|
||||||
import Control.Monad.Error (MonadIO (liftIO))
|
import Control.Monad.Error (MonadIO (liftIO))
|
||||||
import Control.Monad.IO.Control (MonadControlIO, controlIO)
|
import Control.Monad.Trans.Control (MonadBaseControl, liftBaseWith)
|
||||||
import Control.Exception.Control (mask, onException)
|
import Control.Exception.Lifted (mask, onException)
|
||||||
|
|
||||||
newEmptyMVar :: (MonadIO m) => m (MVar a)
|
newEmptyMVar :: (MonadIO m) => m (MVar a)
|
||||||
newEmptyMVar = liftIO IO.newEmptyMVar
|
newEmptyMVar = liftIO IO.newEmptyMVar
|
||||||
|
@ -42,7 +41,7 @@ tryPutMVar var = liftIO . IO.tryPutMVar var
|
||||||
isEmptyMVar :: (MonadIO m) => MVar a -> m Bool
|
isEmptyMVar :: (MonadIO m) => MVar a -> m Bool
|
||||||
isEmptyMVar = liftIO . IO.isEmptyMVar
|
isEmptyMVar = liftIO . IO.isEmptyMVar
|
||||||
|
|
||||||
modifyMVar :: MonadControlIO m => MVar a -> (a -> m (a, b)) -> m b
|
modifyMVar :: (MonadIO m, MonadBaseControl IO m) => MVar a -> (a -> m (a, b)) -> m b
|
||||||
modifyMVar m io =
|
modifyMVar m io =
|
||||||
mask $ \restore -> do
|
mask $ \restore -> do
|
||||||
a <- takeMVar m
|
a <- takeMVar m
|
||||||
|
@ -50,16 +49,16 @@ modifyMVar m io =
|
||||||
putMVar m a'
|
putMVar m a'
|
||||||
return b
|
return b
|
||||||
|
|
||||||
addMVarFinalizer :: MonadControlIO m => MVar a -> m () -> m ()
|
addMVarFinalizer :: (MonadIO m, MonadBaseControl IO m) => MVar a -> m () -> m ()
|
||||||
addMVarFinalizer mvar f = controlIO $ \run ->
|
addMVarFinalizer mv f = liftBaseWith $ \run ->
|
||||||
return $ liftIO $ IO.addMVarFinalizer mvar (run f >> return ())
|
IO.addMVarFinalizer mv (run f >> return ())
|
||||||
|
|
||||||
modifyMVar_ :: (MonadControlIO m) => MVar a -> (a -> m a) -> m ()
|
modifyMVar_ :: (MonadIO m, MonadBaseControl IO m) => MVar a -> (a -> m a) -> m ()
|
||||||
modifyMVar_ var act = modifyMVar var $ \a -> do
|
modifyMVar_ var act = modifyMVar var $ \a -> do
|
||||||
a' <- act a
|
a' <- act a
|
||||||
return (a', ())
|
return (a', ())
|
||||||
|
|
||||||
withMVar :: (MonadControlIO m) => MVar a -> (a -> m b) -> m b
|
withMVar :: (MonadIO m, MonadBaseControl IO m) => MVar a -> (a -> m b) -> m b
|
||||||
withMVar var act = modifyMVar var $ \a -> do
|
withMVar var act = modifyMVar var $ \a -> do
|
||||||
b <- act a
|
b <- act a
|
||||||
return (a, b)
|
return (a, b)
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
-- | Database administrative functions
|
-- | Database administrative functions
|
||||||
|
|
||||||
{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
|
{-# LANGUAGE FlexibleContexts, OverloadedStrings, RecordWildCards #-}
|
||||||
|
|
||||||
module Database.MongoDB.Admin (
|
module Database.MongoDB.Admin (
|
||||||
-- * Admin
|
-- * Admin
|
||||||
|
@ -39,7 +39,7 @@ import qualified Data.Set as S
|
||||||
import System.IO.Unsafe (unsafePerformIO)
|
import System.IO.Unsafe (unsafePerformIO)
|
||||||
import Control.Concurrent (forkIO, threadDelay)
|
import Control.Concurrent (forkIO, threadDelay)
|
||||||
import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1)
|
import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1)
|
||||||
import Control.Monad.MVar (MonadControlIO)
|
import Control.Monad.Trans.Control (MonadBaseControl)
|
||||||
|
|
||||||
-- * Admin
|
-- * Admin
|
||||||
|
|
||||||
|
@ -122,7 +122,7 @@ dropIndex coll idxName = do
|
||||||
resetIndexCache
|
resetIndexCache
|
||||||
runCommand ["deleteIndexes" =: coll, "index" =: idxName]
|
runCommand ["deleteIndexes" =: coll, "index" =: idxName]
|
||||||
|
|
||||||
getIndexes :: (MonadControlIO m, Functor m) => Collection -> Action m [Document]
|
getIndexes :: (MonadIO m, MonadBaseControl IO m, Functor m) => Collection -> Action m [Document]
|
||||||
-- ^ Get all indexes on this collection
|
-- ^ Get all indexes on this collection
|
||||||
getIndexes coll = do
|
getIndexes coll = do
|
||||||
db <- thisDatabase
|
db <- thisDatabase
|
||||||
|
@ -175,7 +175,7 @@ resetIndexCache = do
|
||||||
|
|
||||||
-- ** User
|
-- ** User
|
||||||
|
|
||||||
allUsers :: (MonadControlIO m, Functor m) => Action m [Document]
|
allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document]
|
||||||
-- ^ Fetch all users of this database
|
-- ^ Fetch all users of this database
|
||||||
allUsers = map (exclude ["_id"]) <$> (rest =<< find
|
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)]})
|
||||||
|
@ -242,7 +242,7 @@ storageSize c = at "storageSize" <$> collectionStats c
|
||||||
totalIndexSize :: (MonadIO' m) => Collection -> Action m Int
|
totalIndexSize :: (MonadIO' m) => Collection -> Action m Int
|
||||||
totalIndexSize c = at "totalIndexSize" <$> collectionStats c
|
totalIndexSize c = at "totalIndexSize" <$> collectionStats c
|
||||||
|
|
||||||
totalSize :: (MonadControlIO m, MonadIO' m) => Collection -> Action m Int
|
totalSize :: (MonadIO m, MonadBaseControl IO m, MonadIO' m) => Collection -> Action m Int
|
||||||
totalSize coll = do
|
totalSize coll = do
|
||||||
x <- storageSize coll
|
x <- storageSize coll
|
||||||
xs <- mapM isize =<< getIndexes coll
|
xs <- mapM isize =<< getIndexes coll
|
||||||
|
|
|
@ -50,6 +50,8 @@ import Control.Monad.Reader
|
||||||
import Control.Monad.State (StateT)
|
import Control.Monad.State (StateT)
|
||||||
import Control.Monad.Writer (WriterT, Monoid)
|
import Control.Monad.Writer (WriterT, Monoid)
|
||||||
import Control.Monad.RWS (RWST)
|
import Control.Monad.RWS (RWST)
|
||||||
|
import Control.Monad.Base (MonadBase(liftBase))
|
||||||
|
import Control.Monad.Trans.Control (ComposeSt, MonadBaseControl(..), MonadTransControl(..), StM, StT, defaultLiftBaseWith, defaultRestoreM)
|
||||||
import Control.Applicative (Applicative, (<$>))
|
import Control.Applicative (Applicative, (<$>))
|
||||||
import Data.Maybe (listToMaybe, catMaybes)
|
import Data.Maybe (listToMaybe, catMaybes)
|
||||||
import Data.Int (Int32)
|
import Data.Int (Int32)
|
||||||
|
@ -57,11 +59,29 @@ import Data.Word (Word32)
|
||||||
|
|
||||||
-- * Monad
|
-- * Monad
|
||||||
|
|
||||||
newtype Action m a = Action (ErrorT Failure (ReaderT Context m) a)
|
newtype Action m a = Action {unAction :: ErrorT Failure (ReaderT Context m) a}
|
||||||
deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, MonadError Failure)
|
deriving (Functor, Applicative, Monad, MonadIO, MonadError Failure)
|
||||||
-- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'
|
-- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'
|
||||||
|
|
||||||
instance MonadTrans Action where lift = Action . lift . lift
|
instance MonadBase b m => MonadBase b (Action m) where
|
||||||
|
liftBase = Action . liftBase
|
||||||
|
|
||||||
|
instance (MonadIO m, MonadBaseControl b m) => MonadBaseControl b (Action m) where
|
||||||
|
newtype StM (Action m) a = StMT {unStMT :: ComposeSt Action m a}
|
||||||
|
liftBaseWith = defaultLiftBaseWith StMT
|
||||||
|
restoreM = defaultRestoreM unStMT
|
||||||
|
|
||||||
|
instance MonadTrans Action where
|
||||||
|
lift = Action . lift . lift
|
||||||
|
|
||||||
|
instance MonadTransControl Action where
|
||||||
|
newtype StT Action a = StActionT {unStAction :: StT (ReaderT Context) (StT (ErrorT Failure) a)}
|
||||||
|
|
||||||
|
liftWith f = Action $ liftWith $ \runError ->
|
||||||
|
liftWith $ \runReader ->
|
||||||
|
f (liftM StActionT . runReader . runError . unAction)
|
||||||
|
|
||||||
|
restoreT = Action . restoreT . restoreT . liftM unStAction
|
||||||
|
|
||||||
access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m (Either Failure a)
|
access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m (Either Failure a)
|
||||||
-- ^ Run action against database on server at other end of pipe. Use access mode for any reads and writes. Return Left on connection failure or read/write failure.
|
-- ^ Run action against database on server at other end of pipe. Use access mode for any reads and writes. Return Left on connection failure or read/write failure.
|
||||||
|
@ -139,11 +159,11 @@ call ns r = Action $ do
|
||||||
return (liftIOE ConnectionFailure promise)
|
return (liftIOE ConnectionFailure promise)
|
||||||
|
|
||||||
-- | If you stack a monad on top of 'Action' then make it an instance of this class and use 'liftDB' to execute a DB Action within it. Instances already exist for the basic mtl transformers.
|
-- | If you stack a monad on top of 'Action' then make it an instance of this class and use 'liftDB' to execute a DB Action within it. Instances already exist for the basic mtl transformers.
|
||||||
class (Monad m, MonadControlIO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where
|
class (Monad m, MonadBaseControl IO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where
|
||||||
type BaseMonad m :: * -> *
|
type BaseMonad m :: * -> *
|
||||||
liftDB :: Action (BaseMonad m) a -> m a
|
liftDB :: Action (BaseMonad m) a -> m a
|
||||||
|
|
||||||
instance (MonadControlIO m, Applicative m, Functor m) => MonadDB (Action m) where
|
instance (MonadBaseControl IO m, Applicative m, Functor m) => MonadDB (Action m) where
|
||||||
type BaseMonad (Action m) = m
|
type BaseMonad (Action m) = m
|
||||||
liftDB = id
|
liftDB = id
|
||||||
|
|
||||||
|
@ -192,7 +212,7 @@ auth usr pss = do
|
||||||
type Collection = UString
|
type Collection = UString
|
||||||
-- ^ Collection name (not prefixed with database)
|
-- ^ Collection name (not prefixed with database)
|
||||||
|
|
||||||
allCollections :: (MonadControlIO m, Functor m) => Action m [Collection]
|
allCollections :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Collection]
|
||||||
-- ^ List all collections in this database
|
-- ^ List all collections in this database
|
||||||
allCollections = do
|
allCollections = do
|
||||||
db <- thisDatabase
|
db <- thisDatabase
|
||||||
|
@ -369,7 +389,7 @@ query :: Selector -> Collection -> Query
|
||||||
-- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
|
-- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
|
||||||
query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
|
query sel col = Query [] (Select sel col) [] 0 0 [] False 0 []
|
||||||
|
|
||||||
find :: (MonadControlIO m) => Query -> Action m Cursor
|
find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor
|
||||||
-- ^ Fetch documents satisfying query
|
-- ^ Fetch documents satisfying query
|
||||||
find q@Query{selection, batchSize} = do
|
find q@Query{selection, batchSize} = do
|
||||||
db <- thisDatabase
|
db <- thisDatabase
|
||||||
|
@ -464,7 +484,7 @@ fulfill = Action . liftIOE id
|
||||||
data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
|
data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
|
||||||
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
|
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.
|
||||||
|
|
||||||
newCursor :: (MonadControlIO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
|
newCursor :: (MonadIO m, MonadBaseControl IO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
|
||||||
-- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
|
-- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
|
||||||
newCursor db col batchSize dBatch = do
|
newCursor db col batchSize dBatch = do
|
||||||
var <- newMVar dBatch
|
var <- newMVar dBatch
|
||||||
|
@ -472,7 +492,7 @@ newCursor db col batchSize dBatch = do
|
||||||
addMVarFinalizer var (closeCursor cursor)
|
addMVarFinalizer var (closeCursor cursor)
|
||||||
return cursor
|
return cursor
|
||||||
|
|
||||||
nextBatch :: (MonadControlIO m) => Cursor -> Action m [Document]
|
nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document]
|
||||||
-- ^ Return next batch of documents in query result, which will be empty if finished.
|
-- ^ Return next batch of documents in query result, which will be empty if finished.
|
||||||
nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
|
nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
|
||||||
-- Pre-fetch next batch promise from server and return current batch.
|
-- Pre-fetch next batch promise from server and return current batch.
|
||||||
|
@ -483,7 +503,7 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do
|
||||||
nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
|
nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
|
||||||
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
|
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
|
||||||
|
|
||||||
next :: (MonadControlIO m) => Cursor -> Action m (Maybe Document)
|
next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document)
|
||||||
-- ^ Return next document in query result, or Nothing if finished.
|
-- ^ Return next document in query result, or Nothing if finished.
|
||||||
next (Cursor fcol batchSize var) = modifyMVar var nextState where
|
next (Cursor fcol batchSize var) = modifyMVar var nextState where
|
||||||
-- Pre-fetch next batch promise from server when last one in current batch is returned.
|
-- Pre-fetch next batch promise from server when last one in current batch is returned.
|
||||||
|
@ -502,15 +522,15 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where
|
||||||
nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
|
nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit)
|
||||||
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
|
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
|
||||||
|
|
||||||
nextN :: (MonadControlIO m, Functor m) => Int -> Cursor -> Action m [Document]
|
nextN :: (MonadIO m, MonadBaseControl IO m, Functor m) => Int -> Cursor -> Action m [Document]
|
||||||
-- ^ Return next N documents or less if end is reached
|
-- ^ Return next N documents or less if end is reached
|
||||||
nextN n c = catMaybes <$> replicateM n (next c)
|
nextN n c = catMaybes <$> replicateM n (next c)
|
||||||
|
|
||||||
rest :: (MonadControlIO m, Functor m) => Cursor -> Action m [Document]
|
rest :: (MonadIO m, MonadBaseControl IO m, Functor m) => Cursor -> Action m [Document]
|
||||||
-- ^ Return remaining documents in query result
|
-- ^ Return remaining documents in query result
|
||||||
rest c = loop (next c)
|
rest c = loop (next c)
|
||||||
|
|
||||||
closeCursor :: (MonadControlIO m) => Cursor -> Action m ()
|
closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m ()
|
||||||
closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
|
closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do
|
||||||
Batch _ cid _ <- fulfill dBatch
|
Batch _ cid _ <- fulfill dBatch
|
||||||
unless (cid == 0) $ send [KillCursors [cid]]
|
unless (cid == 0) $ send [KillCursors [cid]]
|
||||||
|
@ -618,7 +638,7 @@ mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
|
||||||
-- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
|
-- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
|
||||||
mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
|
mapReduce col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False
|
||||||
|
|
||||||
runMR :: (MonadControlIO m, Applicative m) => MapReduce -> Action m Cursor
|
runMR :: (MonadIO m, MonadBaseControl IO m, Applicative m) => MapReduce -> Action m Cursor
|
||||||
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
|
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
|
||||||
runMR mr = do
|
runMR mr = do
|
||||||
res <- runMR' mr
|
res <- runMR' mr
|
||||||
|
|
|
@ -18,7 +18,9 @@ build-depends:
|
||||||
parsec -any,
|
parsec -any,
|
||||||
random -any,
|
random -any,
|
||||||
random-shuffle -any,
|
random-shuffle -any,
|
||||||
monad-control >= 0.2 && < 0.3
|
monad-control >= 0.3.0.1 && < 0.4,
|
||||||
|
lifted-base >= 0.1.0.1 && < 0.2,
|
||||||
|
transformers-base >= 0.4 && < 0.5
|
||||||
stability: alpha
|
stability: alpha
|
||||||
homepage: http://github.com/TonyGen/mongoDB-haskell
|
homepage: http://github.com/TonyGen/mongoDB-haskell
|
||||||
package-url:
|
package-url:
|
||||||
|
|
Loading…
Reference in a new issue