packages feed

mongoDB 1.0.2 → 1.1.0

raw patch · 4 files changed

+42/−55 lines, 4 filesdep +monad-control

Dependencies added: monad-control

Files

Control/Monad/MVar.hs view
@@ -5,14 +5,15 @@ module Control.Monad.MVar ( 	MVar, 	module Control.Monad.MVar,-	liftIO+	liftIO,+	MonadControlIO ) where  import Control.Concurrent.MVar (MVar) import qualified Control.Concurrent.MVar as IO-import Control.Monad.Error-import Control.Monad.Reader-import Control.Monad.State+import Control.Monad.Error (MonadIO (liftIO))+import Control.Monad.IO.Control (MonadControlIO, controlIO)+import Control.Exception.Control (mask, onException)  newEmptyMVar :: (MonadIO m) => m (MVar a) newEmptyMVar = liftIO IO.newEmptyMVar@@ -41,39 +42,24 @@ isEmptyMVar :: (MonadIO m) => MVar a -> m Bool isEmptyMVar = liftIO . IO.isEmptyMVar -class (MonadIO m) => MonadMVar m where-	modifyMVar :: MVar a -> (a -> m (a, b)) -> m b-	addMVarFinalizer :: MVar a -> m () -> m ()+modifyMVar :: MonadControlIO m => MVar a -> (a -> m (a, b)) -> m b+modifyMVar m io =+  mask $ \restore -> do+    a      <- takeMVar m+    (a',b) <- restore (io a) `onException` putMVar m a+    putMVar m a'+    return b -modifyMVar_ :: (MonadMVar m) => MVar a -> (a -> m a) -> m ()+addMVarFinalizer :: MonadControlIO m => MVar a -> m () -> m ()+addMVarFinalizer mvar f = controlIO $ \run ->+    return $ liftIO $ IO.addMVarFinalizer mvar (run f >> return ())++modifyMVar_ :: (MonadControlIO m) => MVar a -> (a -> m a) -> m () modifyMVar_ var act = modifyMVar var $ \a -> do 	a' <- act a 	return (a', ()) -withMVar :: (MonadMVar m) => MVar a -> (a -> m b) -> m b+withMVar :: (MonadControlIO m) => MVar a -> (a -> m b) -> m b withMVar var act = modifyMVar var $ \a -> do 	b <- act a 	return (a, b)--instance MonadMVar IO where-	modifyMVar = IO.modifyMVar-	addMVarFinalizer = IO.addMVarFinalizer--instance (MonadMVar m, Error e) => MonadMVar (ErrorT e m) where-	modifyMVar var f = ErrorT $ modifyMVar var $ \a -> do-		e <- runErrorT (f a)-		return $ either ((a, ) . Left) (fmap Right) e-	addMVarFinalizer var (ErrorT act) = ErrorT $ -		addMVarFinalizer var (act >> return ()) >> return (Right ())-		-- NOTE, error is silently dropped--instance (MonadMVar m) => MonadMVar (ReaderT r m) where-	modifyMVar var f = ReaderT $ \r -> modifyMVar var $ \a -> runReaderT (f a) r-	addMVarFinalizer var (ReaderT act) = ReaderT (addMVarFinalizer var . act)--instance (MonadMVar m) => MonadMVar (StateT s m) where-	modifyMVar var f = StateT $ \s -> modifyMVar var $ \a -> do-		((a', b), s') <- runStateT (f a) s-		return (a', (b, s'))-	addMVarFinalizer var (StateT act) = StateT $ \s ->-		addMVarFinalizer var (act s >> return ()) >> return ((), s)
Database/MongoDB/Admin.hs view
@@ -18,7 +18,7 @@ 	-- ** Collection 	collectionStats, dataSize, storageSize, totalIndexSize, totalSize, 	-- ** Profiling-	ProfilingLevel, getProfilingLevel, MilliSec, setProfilingLevel,+	ProfilingLevel(..), getProfilingLevel, MilliSec, setProfilingLevel, 	-- ** Database 	dbStats, OpNum, currentOp, killOp, 	-- ** Server@@ -39,7 +39,7 @@ import System.IO.Unsafe (unsafePerformIO) import Control.Concurrent (forkIO, threadDelay) import Database.MongoDB.Internal.Util (MonadIO', (<.>), true1)-import Control.Monad.MVar (MonadMVar)+import Control.Monad.MVar (MonadControlIO)  -- * Admin @@ -122,7 +122,7 @@ 	resetIndexCache 	runCommand ["deleteIndexes" =: coll, "index" =: idxName] -getIndexes :: (MonadMVar m, Functor m) => Collection -> Action m [Document]+getIndexes :: (MonadControlIO m, Functor m) => Collection -> Action m [Document] -- ^ Get all indexes on this collection getIndexes coll = do 	db <- thisDatabase@@ -175,7 +175,7 @@  -- ** User -allUsers :: (MonadMVar m, Functor m) => Action m [Document]+allUsers :: (MonadControlIO 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)]})@@ -242,7 +242,7 @@ totalIndexSize :: (MonadIO' m) => Collection -> Action m Int totalIndexSize c = at "totalIndexSize" <$> collectionStats c -totalSize :: (MonadMVar m, MonadIO' m) => Collection -> Action m Int+totalSize :: (MonadControlIO m, MonadIO' m) => Collection -> Action m Int totalSize coll = do 	x <- storageSize coll 	xs <- mapM isize =<< getIndexes coll
Database/MongoDB/Query.hs view
@@ -58,7 +58,7 @@ -- * Monad  newtype Action m a = Action (ErrorT Failure (ReaderT Context m) a)-	deriving (Functor, Applicative, Monad, MonadIO, MonadMVar, MonadError Failure)+	deriving (Functor, Applicative, Monad, MonadIO, MonadControlIO, 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'  instance MonadTrans Action where lift = Action . lift . lift@@ -72,13 +72,13 @@ data Failure = 	 ConnectionFailure IOError  -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe. 	| CursorNotFoundFailure CursorId  -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set)-	| QueryFailure String  -- ^ Query failed for some reason as described in the string+	| QueryFailure ErrorCode String  -- ^ Query failed for some reason as described in the string 	| WriteFailure ErrorCode String  -- ^ Error observed by getLastError after a write, error description is in string 	| DocNotFound Selection  -- ^ 'fetch' found no document matching selection 	deriving (Show, Eq)  type ErrorCode = Int--- ^ Error code from getLastError+-- ^ Error code from getLastError or query failure  instance Error Failure where strMsg = error -- ^ 'fail' is treated the same as a programming 'error'. In other words, don't use it.@@ -139,11 +139,11 @@ 	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.-class (Monad m, MonadMVar (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where+class (Monad m, MonadControlIO (BaseMonad m), Applicative (BaseMonad m), Functor (BaseMonad m)) => MonadDB m where 	type BaseMonad m :: * -> * 	liftDB :: Action (BaseMonad m) a -> m a -instance (MonadMVar m, Applicative m, Functor m) => MonadDB (Action m) where+instance (MonadControlIO m, Applicative m, Functor m) => MonadDB (Action m) where 	type BaseMonad (Action m) = m 	liftDB = id @@ -192,7 +192,7 @@ type Collection = UString -- ^ Collection name (not prefixed with database) -allCollections :: (MonadMVar m, Functor m) => Action m [Collection]+allCollections :: (MonadControlIO m, Functor m) => Action m [Collection] -- ^ List all collections in this database allCollections = do 	db <- thisDatabase@@ -369,7 +369,7 @@ -- ^ 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 [] -find :: (MonadMVar m) => Query -> Action m Cursor+find :: (MonadControlIO m) => Query -> Action m Cursor -- ^ Fetch documents satisfying query find q@Query{selection, batchSize} = do 	db <- thisDatabase@@ -452,8 +452,8 @@ 	-- If response flag indicates failure then throw it, otherwise do nothing 	checkResponseFlag flag = case flag of 		AwaitCapable -> return ()-		CursorNotFound -> throwError (CursorNotFoundFailure rCursorId)-		QueryError -> throwError (QueryFailure $ at "$err" $ head rDocuments)+		CursorNotFound -> throwError $ CursorNotFoundFailure rCursorId+		QueryError -> throwError $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments)  fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch -- ^ Demand and wait for result, raise failure if exception@@ -464,7 +464,7 @@ 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. -newCursor :: (MonadMVar m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor+newCursor :: (MonadControlIO 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. newCursor db col batchSize dBatch = do 	var <- newMVar dBatch@@ -472,7 +472,7 @@ 	addMVarFinalizer var (closeCursor cursor) 	return cursor -nextBatch :: (MonadMVar m) => Cursor -> Action m [Document]+nextBatch :: (MonadControlIO m) => Cursor -> Action m [Document] -- ^ Return next batch of documents in query result, which will be empty if finished. nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do 	-- Pre-fetch next batch promise from server and return current batch.@@ -483,7 +483,7 @@ 	nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit) 		where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit -next :: (MonadMVar m) => Cursor -> Action m (Maybe Document)+next :: (MonadControlIO m) => Cursor -> Action m (Maybe Document) -- ^ Return next document in query result, or Nothing if finished. next (Cursor fcol batchSize var) = modifyMVar var nextState where 	-- Pre-fetch next batch promise from server when last one in current batch is returned.@@ -502,15 +502,15 @@ 	nextBatch' limit cid = request [] (GetMore fcol batchSize' cid, remLimit) 		where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit -nextN :: (MonadMVar m, Functor m) => Int -> Cursor -> Action m [Document]+nextN :: (MonadControlIO m, Functor m) => Int -> Cursor -> Action m [Document] -- ^ Return next N documents or less if end is reached nextN n c = catMaybes <$> replicateM n (next c) -rest :: (MonadMVar m, Functor m) => Cursor -> Action m [Document]+rest :: (MonadControlIO m, Functor m) => Cursor -> Action m [Document] -- ^ Return remaining documents in query result rest c = loop (next c) -closeCursor :: (MonadMVar m) => Cursor -> Action m ()+closeCursor :: (MonadControlIO m) => Cursor -> Action m () closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do 	Batch _ cid _ <- fulfill dBatch 	unless (cid == 0) $ send [KillCursors [cid]]@@ -618,7 +618,7 @@ -- ^ 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 -runMR :: (MonadMVar m, Applicative m) => MapReduce -> Action m Cursor+runMR :: (MonadControlIO m, Applicative m) => MapReduce -> Action m Cursor -- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript) runMR mr = do 	res <- runMR' mr
mongoDB.cabal view
@@ -1,5 +1,5 @@ name: mongoDB-version: 1.0.2+version: 1.1.0 build-type: Simple license: OtherLicense license-file: LICENSE@@ -17,7 +17,8 @@     network -any,     parsec -any,     random -any,-    random-shuffle -any+    random-shuffle -any,+    monad-control >= 0.2 && < 0.3 stability: alpha homepage: http://github.com/TonyGen/mongoDB-haskell package-url: