From dd6c5057f572ae074d363c956f390fc11fcc16a1 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 8 May 2017 22:47:47 -0700 Subject: [PATCH 1/4] Add modifyMVar for Action monad --- Database/MongoDB/Internal/Util.hs | 4 +-- Database/MongoDB/Query.hs | 47 ++++++++++++++++++------------- 2 files changed, 29 insertions(+), 22 deletions(-) diff --git a/Database/MongoDB/Internal/Util.hs b/Database/MongoDB/Internal/Util.hs index ac21356..2c05138 100644 --- a/Database/MongoDB/Internal/Util.hs +++ b/Database/MongoDB/Internal/Util.hs @@ -65,9 +65,9 @@ shuffle :: [a] -> IO [a] -- ^ Randomly shuffle items in list shuffle list = shuffle' list (length list) <$> newStdGen -loop :: (Functor m, Monad m) => m (Maybe a) -> m [a] +loop :: Monad m => m (Maybe a) -> m [a] -- ^ Repeatedy execute action, collecting results, until it returns Nothing -loop act = act >>= maybe (return []) (\a -> (a :) <$> loop act) +loop act = act >>= maybe (return []) (\a -> (a :) `liftM` loop act) untilSuccess :: (MonadError e m, Error e) => (a -> m b) -> [a] -> m b -- ^ Apply action to elements one at a time until one succeeds. Throw last error if all fail. Throw 'strMsg' error if list is empty. diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 4dec503..2b5840b 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -57,17 +57,17 @@ import Data.Monoid (mappend) #endif import Data.Typeable (Typeable) +import qualified Control.Concurrent.MVar as MV #if MIN_VERSION_base(4,6,0) import Control.Concurrent.MVar.Lifted (MVar, newMVar, mkWeakMVar, - readMVar, modifyMVar) + readMVar) #else import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, - readMVar, modifyMVar) + readMVar) #endif import Control.Applicative ((<$>)) import Control.Exception (SomeException, catch) import Control.Monad (when) -import Control.Monad.Base (MonadBase) import Control.Monad.Error (Error(..)) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Trans (MonadIO, liftIO) @@ -840,7 +840,7 @@ findOne q = do pipe <- asks mongoPipe qr <- queryRequest False q {limit = 1} rq <- liftIO $ request pipe [] qr - Batch _ _ docs <- fulfill rq + Batch _ _ docs <- liftDB $ fulfill rq return (listToMaybe docs) fetch :: (MonadIO m) => Query -> Action m Document @@ -929,7 +929,7 @@ explain q = do -- same as findOne but with explain set to true pipe <- asks mongoPipe qr <- queryRequest True q {limit = 1} r <- liftIO $ request pipe [] qr - Batch _ _ docs <- fulfill r + Batch _ _ docs <- liftDB $ fulfill r return $ if null docs then error ("no explain: " ++ show q) else head docs count :: (MonadIO m) => Query -> Action m Int @@ -998,7 +998,7 @@ fromReply limit Reply{..} = do CursorNotFound -> throwIO $ CursorNotFoundFailure rCursorId QueryError -> throwIO $ QueryFailure (at "code" $ head rDocuments) (at "$err" $ head rDocuments) -fulfill :: (MonadIO m) => DelayedBatch -> Action m Batch +fulfill :: DelayedBatch -> Action IO Batch -- ^ Demand and wait for result, raise failure if exception fulfill = liftIO @@ -1018,11 +1018,11 @@ newCursor db col batchSize dBatch = do where mkWeakMVar = addMVarFinalizer #endif -nextBatch :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document] +nextBatch :: MonadIO 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 +nextBatch (Cursor fcol batchSize var) = liftDB $ modifyMVar var $ \dBatch -> do -- Pre-fetch next batch promise from server and return current batch. - Batch mLimit cid docs <- fulfill' fcol batchSize dBatch + Batch mLimit cid docs <- liftDB $ fulfill' fcol batchSize dBatch let newLimit = do limit <- mLimit return $ limit - (min limit $ fromIntegral $ length docs) @@ -1037,7 +1037,7 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do return (emptyBatch, resultDocs) (_, _) -> (, resultDocs) <$> getNextBatch -fulfill' :: (MonadIO m) => FullCollection -> BatchSize -> DelayedBatch -> Action m Batch +fulfill' :: FullCollection -> BatchSize -> DelayedBatch -> Action IO Batch -- Discard pre-fetched batch if empty with nonzero cid. fulfill' fcol batchSize dBatch = do b@(Batch limit cid docs) <- fulfill dBatch @@ -1051,13 +1051,13 @@ nextBatch' fcol batchSize limit cid = do liftIO $ request pipe [] (GetMore fcol batchSize' cid, remLimit) where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit -next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document) +next :: MonadIO 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 +next (Cursor fcol batchSize var) = liftDB $ modifyMVar var nextState where -- Pre-fetch next batch promise from server when last one in current batch is returned. -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document) nextState dBatch = do - Batch mLimit cid docs <- fulfill' fcol batchSize dBatch + Batch mLimit cid docs <- liftDB $ fulfill' fcol batchSize dBatch if mLimit == (Just 0) then return (return $ Batch (Just 0) 0 [], Nothing) else @@ -1075,27 +1075,29 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where return (dBatch', Just doc) [] -> if cid == 0 then return (return $ Batch (Just 0) 0 [], Nothing) -- finished - else fmap (,Nothing) $ nextBatch' fcol batchSize mLimit cid + else do + nb <- nextBatch' fcol batchSize mLimit cid + return (nb, Nothing) -nextN :: (MonadIO m, MonadBaseControl IO m) => Int -> Cursor -> Action m [Document] +nextN :: MonadIO m => Int -> Cursor -> Action m [Document] -- ^ Return next N documents or less if end is reached nextN n c = catMaybes `liftM` replicateM n (next c) -rest :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m [Document] +rest :: MonadIO m => Cursor -> Action m [Document] -- ^ Return remaining documents in query result rest c = loop (next c) -closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m () -closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do +closeCursor :: MonadIO m => Cursor -> Action m () +closeCursor (Cursor _ _ var) = liftDB $ modifyMVar var $ \dBatch -> do Batch _ cid _ <- fulfill dBatch unless (cid == 0) $ do pipe <- asks mongoPipe liftIOE ConnectionFailure $ P.send pipe [KillCursors [cid]] return $ (return $ Batch (Just 0) 0 [], ()) -isCursorClosed :: (MonadIO m, MonadBase IO m) => Cursor -> Action m Bool +isCursorClosed :: MonadIO m => Cursor -> Action m Bool isCursorClosed (Cursor _ _ var) = do - Batch _ cid docs <- fulfill =<< readMVar var + Batch _ cid docs <- liftDB $ fulfill =<< readMVar var return (cid == 0 && null docs) -- ** Aggregate @@ -1242,6 +1244,11 @@ eval :: (MonadIO m, Val v) => Javascript -> Action m v -- ^ Run code on server eval code = at "retval" `liftM` runCommand ["$eval" =: code] +modifyMVar :: MVar a -> (a -> Action IO (a, b)) -> Action IO b +modifyMVar v f = do + ctx <- ask + liftIO $ MV.modifyMVar v (\x -> runReaderT (f x) ctx) + {- Authors: Tony Hannan Copyright 2011 10gen Inc. From a1568d9dbf6b7e9ed6f97a6daf1d716772f9a86d Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Mon, 8 May 2017 23:12:26 -0700 Subject: [PATCH 2/4] Add mkWeakMVar for Action monad --- Database/MongoDB/Query.hs | 34 ++++++++++++++++++---------------- 1 file changed, 18 insertions(+), 16 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index 2b5840b..6a18436 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -56,13 +56,14 @@ import Data.Word (Word32) import Data.Monoid (mappend) #endif import Data.Typeable (Typeable) +import System.Mem.Weak (Weak) import qualified Control.Concurrent.MVar as MV #if MIN_VERSION_base(4,6,0) -import Control.Concurrent.MVar.Lifted (MVar, newMVar, mkWeakMVar, +import Control.Concurrent.MVar.Lifted (MVar, readMVar) #else -import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, +import Control.Concurrent.MVar.Lifted (MVar, addMVarFinalizer, readMVar) #endif import Control.Applicative ((<$>)) @@ -71,7 +72,6 @@ import Control.Monad (when) import Control.Monad.Error (Error(..)) import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local) import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl(..)) import Data.Binary.Put (runPut) import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), Javascript, at, valueAt, lookup, look, genObjectId, (=:), @@ -106,10 +106,6 @@ import qualified Data.Map as Map import Text.Read (readMaybe) import Data.Maybe (fromMaybe) -#if !MIN_VERSION_base(4,6,0) ---mkWeakMVar = addMVarFinalizer -#endif - -- * Monad type Action = ReaderT MongoContext @@ -314,7 +310,7 @@ retrieveServerData = do type Collection = Text -- ^ Collection name (not prefixed with database) -allCollections :: (MonadIO m, MonadBaseControl IO m) => Action m [Collection] +allCollections :: MonadIO m => Action m [Collection] -- ^ List all collections in this database allCollections = do p <- asks mongoPipe @@ -825,7 +821,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. query sel col = Query [] (Select sel col) [] 0 0 [] False 0 [] -find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor +find :: MonadIO m => Query -> Action m Cursor -- ^ Fetch documents satisfying query find q@Query{selection, batchSize} = do db <- thisDatabase @@ -1007,16 +1003,13 @@ fulfill = liftIO 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 :: (MonadIO m, MonadBaseControl IO m) => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor +newCursor :: MonadIO 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 + var <- liftIO $ MV.newMVar dBatch let cursor = Cursor (db <.> col) batchSize var - _ <- mkWeakMVar var (closeCursor cursor) + _ <- liftDB $ mkWeakMVar var (closeCursor cursor) return cursor -#if !MIN_VERSION_base(4,6,0) - where mkWeakMVar = addMVarFinalizer -#endif nextBatch :: MonadIO m => Cursor -> Action m [Document] -- ^ Return next batch of documents in query result, which will be empty if finished. @@ -1210,7 +1203,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 col map' red = MapReduce col map' red [] [] 0 Inline Nothing [] False -runMR :: (MonadIO m, MonadBaseControl IO m) => MapReduce -> Action m Cursor +runMR :: MonadIO 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 @@ -1249,6 +1242,15 @@ modifyMVar v f = do ctx <- ask liftIO $ MV.modifyMVar v (\x -> runReaderT (f x) ctx) +mkWeakMVar :: MVar a -> Action IO () -> Action IO (Weak (MVar a)) +mkWeakMVar m closing = do + ctx <- ask +#if MIN_VERSION_base(4,6,0) + liftIO $ MV.mkWeakMVar m $ runReaderT closing ctx +#else + liftIO $ MV.addMVarFinalizer m $ runReaderT closing ctx +#endif + {- Authors: Tony Hannan Copyright 2011 10gen Inc. From 282d228ff2f7e4e0055109954254e2d6d629dc7c Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 11 May 2017 20:38:54 -0700 Subject: [PATCH 3/4] Add changelog entry --- CHANGELOG.md | 1 + 1 file changed, 1 insertion(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index 3ec5386..f1123ab 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,7 @@ This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Pac ### Changed - Description of access function +- Lift MonadBaseControl restriction ## [2.2.0] - 2017-04-08 From 77c7ee3ee99808b88eb38087b869cf1962fe63e3 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 11 May 2017 21:35:41 -0700 Subject: [PATCH 4/4] Drop MonadBaseControl from two more modules --- Database/MongoDB/Admin.hs | 9 ++++----- Database/MongoDB/GridFS.hs | 3 +-- 2 files changed, 5 insertions(+), 7 deletions(-) diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs index ea5e721..1a07eab 100644 --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -42,7 +42,6 @@ import qualified Data.HashTable.IO as H import qualified Data.Set as Set import Control.Monad.Trans (MonadIO, liftIO) -import Control.Monad.Trans.Control (MonadBaseControl) import Data.Bson (Document, Field(..), at, (=:), (=?), exclude, merge) import Data.Text (Text) @@ -138,7 +137,7 @@ dropIndex coll idxName = do resetIndexCache runCommand ["deleteIndexes" =: coll, "index" =: idxName] -getIndexes :: (MonadIO m, MonadBaseControl IO m, Functor m) => Collection -> Action m [Document] +getIndexes :: MonadIO m => Collection -> Action m [Document] -- ^ Get all indexes on this collection getIndexes coll = do db <- thisDatabase @@ -191,9 +190,9 @@ resetIndexCache = do -- ** User -allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document] +allUsers :: MonadIO m => Action m [Document] -- ^ Fetch all users of this database -allUsers = map (exclude ["_id"]) <$> (rest =<< find +allUsers = map (exclude ["_id"]) `liftM` (rest =<< find (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) addUser :: (MonadIO m) @@ -260,7 +259,7 @@ storageSize c = at "storageSize" `liftM` collectionStats c totalIndexSize :: (MonadIO m) => Collection -> Action m Int totalIndexSize c = at "totalIndexSize" `liftM` collectionStats c -totalSize :: (MonadIO m, MonadBaseControl IO m) => Collection -> Action m Int +totalSize :: MonadIO m => Collection -> Action m Int totalSize coll = do x <- storageSize coll xs <- mapM isize =<< getIndexes coll diff --git a/Database/MongoDB/GridFS.hs b/Database/MongoDB/GridFS.hs index bc425e7..c1d03d0 100644 --- a/Database/MongoDB/GridFS.hs +++ b/Database/MongoDB/GridFS.hs @@ -28,7 +28,6 @@ import Control.Concurrent(forkIO) import Control.Monad(when) import Control.Monad.IO.Class import Control.Monad.Trans(MonadTrans, lift) -import Control.Monad.Trans.Control(MonadBaseControl) import Control.Monad.Trans.Resource(MonadResource(..)) import Data.Conduit import Data.Digest.Pure.MD5 @@ -76,7 +75,7 @@ getChunk (File bucket doc) i = do Just (Binary b) -> return (Just b) _ -> return Nothing -findFile :: (MonadIO m, MonadBaseControl IO m) => Bucket -> Selector -> Action m [File] +findFile :: MonadIO m => Bucket -> Selector -> Action m [File] -- ^ Find files in the bucket findFile bucket sel = do cursor <- find $ select sel $ files bucket