From 419b3c19fb8860ce27d616c3c5671c90aa8444a4 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 4 Aug 2016 22:23:30 -0700 Subject: [PATCH 1/6] Inline call function --- Database/MongoDB/Query.hs | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index eaa68d3..b1d026b 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -191,13 +191,6 @@ send ns = do pipe <- asks mongoPipe liftIOE ConnectionFailure $ P.send pipe ns -call :: (MonadIO m) => [Notice] -> Request -> Action m (IO Reply) --- ^ Send notices and request as a contiguous batch to server and return reply promise, which will block when invoked until reply arrives. This call will throw 'ConnectionFailure' if pipe fails on send, and promise will throw 'ConnectionFailure' if pipe fails on receive. -call ns r = do - pipe <- asks mongoPipe - promise <- liftIOE ConnectionFailure $ P.call pipe ns r - return (liftIOE ConnectionFailure promise) - class HasMongoContext env where mongoContext :: env -> MongoContext instance HasMongoContext MongoContext where @@ -975,8 +968,10 @@ data Batch = Batch (Maybe Limit) CursorId [Document] request :: (MonadIO m) => [Notice] -> (Request, Maybe Limit) -> Action m DelayedBatch -- ^ Send notices and request and return promised batch request ns (req, remainingLimit) = do - promise <- call ns req - return $ fromReply remainingLimit =<< promise + pipe <- asks mongoPipe + promise <- liftIOE ConnectionFailure $ P.call pipe ns req + let protectedPromise = liftIOE ConnectionFailure promise + return $ fromReply remainingLimit =<< protectedPromise fromReply :: Maybe Limit -> Reply -> DelayedBatch -- ^ Convert Reply to Batch or Failure From b34162f0842e3f46adcea4a32a3a63bb6b824d94 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Thu, 4 Aug 2016 22:58:25 -0700 Subject: [PATCH 2/6] Put request function out of Action monad --- Database/MongoDB/Query.hs | 28 ++++++++++++++++++++-------- 1 file changed, 20 insertions(+), 8 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index b1d026b..bc094db 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -384,7 +384,11 @@ write notice = asks mongoWriteMode >>= \mode -> case mode of NoConfirm -> send [notice] Confirm params -> do let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd" - Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1} + pipe <- asks mongoPipe + Batch _ _ [doc] <- do + r <- queryRequest False q {limit = 1} + rr <- liftIO $ request pipe [notice] r + fulfill rr case lookup "err" doc of Nothing -> return () Just err -> liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" doc) err @@ -823,13 +827,18 @@ find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor -- ^ Fetch documents satisfying query find q@Query{selection, batchSize} = do db <- thisDatabase - dBatch <- request [] =<< queryRequest False q + pipe <- asks mongoPipe + qr <- queryRequest False q + dBatch <- liftIO $ request pipe [] qr newCursor db (coll selection) batchSize dBatch findOne :: (MonadIO m) => Query -> Action m (Maybe Document) -- ^ Fetch first document satisfying query or Nothing if none satisfy it findOne q = do - Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1} + pipe <- asks mongoPipe + qr <- queryRequest False q {limit = 1} + rq <- liftIO $ request pipe [] qr + Batch _ _ docs <- fulfill rq return (listToMaybe docs) fetch :: (MonadIO m) => Query -> Action m Document @@ -915,7 +924,10 @@ findAndModifyOpts (Query { explain :: (MonadIO m) => Query -> Action m Document -- ^ Return performance stats of query execution explain q = do -- same as findOne but with explain set to true - Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1} + pipe <- asks mongoPipe + qr <- queryRequest True q {limit = 1} + r <- liftIO $ request pipe [] qr + Batch _ _ docs <- fulfill r return $ if null docs then error ("no explain: " ++ show q) else head docs count :: (MonadIO m) => Query -> Action m Int @@ -965,10 +977,9 @@ type DelayedBatch = IO Batch data Batch = Batch (Maybe Limit) CursorId [Document] -- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is number of documents to return. Nothing means no limit. -request :: (MonadIO m) => [Notice] -> (Request, Maybe Limit) -> Action m DelayedBatch +request :: Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch -- ^ Send notices and request and return promised batch -request ns (req, remainingLimit) = do - pipe <- asks mongoPipe +request pipe ns (req, remainingLimit) = do promise <- liftIOE ConnectionFailure $ P.call pipe ns req let protectedPromise = liftIOE ConnectionFailure promise return $ fromReply remainingLimit =<< protectedPromise @@ -1033,7 +1044,8 @@ fulfill' fcol batchSize dBatch = do nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> (Maybe Limit) -> CursorId -> Action m DelayedBatch nextBatch' fcol batchSize limit cid = do - request [] (GetMore fcol batchSize' cid, remLimit) + pipe <- asks mongoPipe + 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) From 8348045cc581c5f605ffeeb9aa83064f3e0b4a06 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Fri, 5 Aug 2016 20:29:20 -0700 Subject: [PATCH 3/6] Inline send function --- Database/MongoDB/Query.hs | 21 +++++++++++---------- 1 file changed, 11 insertions(+), 10 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index bc094db..e1e25ee 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -185,12 +185,6 @@ mongoReadMode = readMode . mongoAccessMode mongoWriteMode :: MongoContext -> WriteMode mongoWriteMode = writeMode . mongoAccessMode -send :: (MonadIO m) => [Notice] -> Action m () --- ^ Send notices as a contiguous batch to server with no reply. Throw 'ConnectionFailure' if pipe fails. -send ns = do - pipe <- asks mongoPipe - liftIOE ConnectionFailure $ P.send pipe ns - class HasMongoContext env where mongoContext :: env -> MongoContext instance HasMongoContext MongoContext where @@ -381,7 +375,9 @@ data WriteMode = write :: (MonadIO m) => Notice -> Action m () -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error. write notice = asks mongoWriteMode >>= \mode -> case mode of - NoConfirm -> send [notice] + NoConfirm -> do + pipe <- asks mongoPipe + liftIOE ConnectionFailure $ P.send pipe [notice] Confirm params -> do let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd" pipe <- asks mongoPipe @@ -1030,7 +1026,8 @@ nextBatch (Cursor fcol batchSize var) = modifyMVar var $ \dBatch -> do case (cid, newLimit) of (0, _) -> return (emptyBatch, resultDocs) (_, Just 0) -> do - send [KillCursors [cid]] + pipe <- asks mongoPipe + liftIOE ConnectionFailure $ P.send pipe [KillCursors [cid]] return (emptyBatch, resultDocs) (_, _) -> (, resultDocs) <$> getNextBatch @@ -1066,7 +1063,9 @@ next (Cursor fcol batchSize var) = modifyMVar var nextState where dBatch' <- if null docs' && cid /= 0 && ((newLimit > (Just 0)) || (isNothing newLimit)) then nextBatch' fcol batchSize newLimit cid else return $ return (Batch newLimit cid docs') - when (newLimit == (Just 0)) $ unless (cid == 0) $ send [KillCursors [cid]] + when (newLimit == (Just 0)) $ unless (cid == 0) $ do + pipe <- asks mongoPipe + liftIOE ConnectionFailure $ P.send pipe [KillCursors [cid]] return (dBatch', Just doc) [] -> if cid == 0 then return (return $ Batch (Just 0) 0 [], Nothing) -- finished @@ -1083,7 +1082,9 @@ rest c = loop (next c) closeCursor :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m () closeCursor (Cursor _ _ var) = modifyMVar var $ \dBatch -> do Batch _ cid _ <- fulfill dBatch - unless (cid == 0) $ send [KillCursors [cid]] + 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 From b9be757039bdad6a5078485992e23d9a6caeb9a4 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 6 Aug 2016 13:28:36 -0700 Subject: [PATCH 4/6] Restrict type of write function --- Database/MongoDB/Query.hs | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index e1e25ee..a401859 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -372,7 +372,7 @@ data WriteMode = | Confirm GetLastError -- ^ Receive an acknowledgment after every write, and raise exception if one says the write failed. This is acomplished by sending the getLastError command, with given 'GetLastError' parameters, after every write. deriving (Show, Eq) -write :: (MonadIO m) => Notice -> Action m () +write :: Notice -> Action IO () -- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error. write notice = asks mongoWriteMode >>= \mode -> case mode of NoConfirm -> do @@ -457,7 +457,7 @@ insertBlock opts col docs = do let sd = P.serverData p if (maxWireVersion sd < 2) then do - write (Insert (db <.> col) opts docs') + liftDB $ write (Insert (db <.> col) opts docs') return $ map (valueAt "_id") docs' else do mode <- asks mongoWriteMode @@ -628,7 +628,7 @@ updateBlock ordered col docs = do let sel = (at "q" updateDoc) :: Document let upsrt = if at "upsert" updateDoc then [Upsert] else [] let multi = if at "multi" updateDoc then [MultiUpdate] else [] - write (Update (db <.> col) (upsrt ++ multi) sel doc) + liftDB $ write (Update (db <.> col) (upsrt ++ multi) sel doc) return Nothing `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e @@ -747,7 +747,7 @@ deleteBlock ordered col docs = do forM docs $ \deleteDoc -> do let sel = (at "q" deleteDoc) :: Document let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] - write (Delete (db <.> col) opts sel) + liftDB $ write (Delete (db <.> col) opts sel) return Nothing `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e From 482fb570c38d113edb0a23525d76980c2b7356c3 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 6 Aug 2016 15:17:03 -0700 Subject: [PATCH 5/6] Drop MonadBaseControl requirement --- Database/MongoDB/Admin.hs | 4 +-- Database/MongoDB/Query.hs | 57 +++++++++++++++++++++------------------ 2 files changed, 33 insertions(+), 28 deletions(-) diff --git a/Database/MongoDB/Admin.hs b/Database/MongoDB/Admin.hs index 6023f38..ea5e721 100644 --- a/Database/MongoDB/Admin.hs +++ b/Database/MongoDB/Admin.hs @@ -196,7 +196,7 @@ allUsers :: (MonadIO m, MonadBaseControl IO m, Functor m) => Action m [Document] allUsers = map (exclude ["_id"]) <$> (rest =<< find (select [] "system.users") {sort = ["user" =: (1 :: Int)], project = ["user" =: (1 :: Int), "readOnly" =: (1 :: Int)]}) -addUser :: (MonadBaseControl IO m, MonadIO m) +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 @@ -204,7 +204,7 @@ addUser readOnly user pass = do let usr = merge ["readOnly" =: readOnly, "pwd" =: pwHash user pass] (maybe ["user" =: user] id mu) save "system.users" usr -removeUser :: (MonadIO m, MonadBaseControl IO m) +removeUser :: (MonadIO m) => Username -> Action m () removeUser user = delete (select ["user" =: user] "system.users") diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs index a401859..1f580dc 100644 --- a/Database/MongoDB/Query.hs +++ b/Database/MongoDB/Query.hs @@ -48,7 +48,7 @@ module Database.MongoDB.Query ( import Prelude hiding (lookup) import Control.Exception (Exception, throwIO, throw) -import Control.Monad (unless, replicateM, liftM, forM, forM_, void) +import Control.Monad (unless, replicateM, liftM, forM, forM_) import Data.Int (Int32, Int64) import Data.Maybe (listToMaybe, catMaybes, isNothing) import Data.Word (Word32) @@ -65,8 +65,7 @@ import Control.Concurrent.MVar.Lifted (MVar, newMVar, addMVarFinalizer, readMVar, modifyMVar) #endif import Control.Applicative ((<$>)) -import Control.Exception (SomeException) -import Control.Exception.Lifted (catch) +import Control.Exception (SomeException, catch) import Control.Monad (when) import Control.Monad.Base (MonadBase) import Control.Monad.Error (Error(..)) @@ -518,25 +517,25 @@ assignId doc = if any (("_id" ==) . label) doc -- ** Update -save :: (MonadBaseControl IO m, MonadIO m) +save :: (MonadIO m) => Collection -> Document -> Action m () -- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or upsert it if its not new (has \"_id\" field) save col doc = case look "_id" doc of Nothing -> insert_ col doc Just i -> upsert (Select ["_id" := i] col) doc -replace :: (MonadBaseControl IO m, MonadIO m) +replace :: (MonadIO m) => Selection -> Document -> Action m () -- ^ Replace first document in selection with given document replace = update [] -repsert :: (MonadBaseControl IO m, MonadIO m) +repsert :: (MonadIO m) => Selection -> Document -> Action m () -- ^ Replace first document in selection with given document, or insert document if selection is empty repsert = update [Upsert] {-# DEPRECATED repsert "use upsert instead" #-} -upsert :: (MonadBaseControl IO m, MonadIO m) +upsert :: (MonadIO m) => Selection -> Document -> Action m () -- ^ Update first document in selection with given document, or insert document if selection is empty upsert = update [Upsert] @@ -544,15 +543,17 @@ upsert = update [Upsert] type Modifier = Document -- ^ Update operations on fields in a document. See -modify :: (MonadBaseControl IO m, MonadIO m) +modify :: (MonadIO m) => Selection -> Modifier -> Action m () -- ^ Update all documents in selection using given modifier modify = update [MultiUpdate] -update :: (MonadBaseControl IO m, MonadIO m) +update :: (MonadIO m) => [UpdateOption] -> Selection -> Document -> Action m () -- ^ Update first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty. -update opts (Select sel col) up = void $ update' True col [(sel, up, opts)] +update opts (Select sel col) up = do + _ <- update' True col [(sel, up, opts)] + return () updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document updateCommandDocument col ordered updates writeConcern = @@ -567,7 +568,7 @@ updateCommandDocument col ordered updates writeConcern = - before 2.6 it will send update requests one by one. After 2.6 it will use - bulk update feature in mongodb. -} -updateMany :: (MonadBaseControl IO m, MonadIO m) +updateMany :: (MonadIO m) => Collection -> [(Selector, Document, [UpdateOption])] -> Action m UpdateResult @@ -578,13 +579,13 @@ updateMany = update' True - mongodb server before 2.6 it will send update requests one by one. After 2.6 - it will use bulk update feature in mongodb. -} -updateAll :: (MonadBaseControl IO m, MonadIO m) +updateAll :: (MonadIO m) => Collection -> [(Selector, Document, [UpdateOption])] -> Action m UpdateResult updateAll = update' False -update' :: (MonadBaseControl IO m, MonadIO m) +update' :: (MonadIO m) => Bool -> Collection -> [(Selector, Document, [UpdateOption])] @@ -614,7 +615,7 @@ update' ordered col updateDocs = do forM_ chunks (updateBlock ordered col) return UpdateResult -updateBlock :: (MonadIO m, MonadBaseControl IO m) +updateBlock :: (MonadIO m) => Bool -> Collection -> [Document] -> Action m () updateBlock ordered col docs = do p <- asks mongoPipe @@ -622,13 +623,14 @@ updateBlock ordered col docs = do if (maxWireVersion sd < 2) then do db <- thisDatabase + ctx <- ask errors <- - forM docs $ \updateDoc -> do + liftIO $ forM docs $ \updateDoc -> do let doc = (at "u" updateDoc) :: Document let sel = (at "q" updateDoc) :: Document let upsrt = if at "upsert" updateDoc then [Upsert] else [] let multi = if at "multi" updateDoc then [MultiUpdate] else [] - liftDB $ write (Update (db <.> col) (upsrt ++ multi) sel doc) + runReaderT (write (Update (db <.> col) (upsrt ++ multi) sel doc)) ctx return Nothing `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e @@ -660,26 +662,28 @@ updateBlock ordered col docs = do -- ** Delete -delete :: (MonadIO m, MonadBaseControl IO m) +delete :: (MonadIO m) => Selection -> Action m () -- ^ Delete all documents in selection delete = deleteHelper [] -deleteOne :: (MonadIO m, MonadBaseControl IO m) +deleteOne :: (MonadIO m) => Selection -> Action m () -- ^ Delete first document in selection deleteOne = deleteHelper [SingleRemove] -deleteHelper :: (MonadBaseControl IO m, MonadIO m) +deleteHelper :: (MonadIO m) => [DeleteOption] -> Selection -> Action m () -deleteHelper opts (Select sel col) = void $ delete' True col [(sel, opts)] +deleteHelper opts (Select sel col) = do + _ <- delete' True col [(sel, opts)] + return () {-| Bulk delete operation. If one delete fails it will not delete the remaining - documents. Current returned value is only a place holder. With mongodb server - before 2.6 it will send delete requests one by one. After 2.6 it will use - bulk delete feature in mongodb. -} -deleteMany :: (MonadIO m, MonadBaseControl IO m) +deleteMany :: (MonadIO m) => Collection -> [(Selector, [DeleteOption])] -> Action m DeleteResult @@ -690,7 +694,7 @@ deleteMany = delete' True - mongodb server before 2.6 it will send delete requests one by one. After 2.6 - it will use bulk delete feature in mongodb. -} -deleteAll :: (MonadIO m, MonadBaseControl IO m) +deleteAll :: (MonadIO m) => Collection -> [(Selector, [DeleteOption])] -> Action m DeleteResult @@ -704,7 +708,7 @@ deleteCommandDocument col ordered deletes writeConcern = , "writeConcern" =: writeConcern ] -delete' :: (MonadIO m, MonadBaseControl IO m) +delete' :: (MonadIO m) => Bool -> Collection -> [(Selector, [DeleteOption])] @@ -735,7 +739,7 @@ delete' ordered col deleteDocs = do forM_ chunks (deleteBlock ordered col) return DeleteResult -deleteBlock :: (MonadIO m, MonadBaseControl IO m) +deleteBlock :: (MonadIO m) => Bool -> Collection -> [Document] -> Action m () deleteBlock ordered col docs = do p <- asks mongoPipe @@ -743,11 +747,12 @@ deleteBlock ordered col docs = do if (maxWireVersion sd < 2) then do db <- thisDatabase + ctx <- ask errors <- - forM docs $ \deleteDoc -> do + liftIO $ forM docs $ \deleteDoc -> do let sel = (at "q" deleteDoc) :: Document let opts = if at "limit" deleteDoc == (1 :: Int) then [SingleRemove] else [] - liftDB $ write (Delete (db <.> col) opts sel) + runReaderT (write (Delete (db <.> col) opts sel)) ctx return Nothing `catch` \(e :: SomeException) -> do when ordered $ liftIO $ throwIO e From 4997fcde338432a1be0cd6014ad52a5cd9cca8d9 Mon Sep 17 00:00:00 2001 From: Victor Denisov Date: Sat, 6 Aug 2016 17:29:33 -0700 Subject: [PATCH 6/6] Add changelog entry --- CHANGELOG.md | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/CHANGELOG.md b/CHANGELOG.md index c17fba2..59f4e5b 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,12 @@ All notable changes to this project will be documented in this file. This project adheres to [Package Versioning Policy](https://wiki.haskell.org/Package_versioning_policy). +## [2.1.1] - unreleased + +### Changed +- Interfaces of update and delete functions. They don't require MonadBaseControl +anymore. + ## [2.1.0] - 2016-06-21 ### Added