diff --git a/CHANGELOG.md b/CHANGELOG.md
index 74a052d..44eb7dc 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -2,6 +2,8 @@
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).
+* Get rid of `MonadFail` constraints in `Database.MongoDB.Query`
+
## [2.7.1.2] - 2022-10-26
### Added
diff --git a/Database/MongoDB/Query.hs b/Database/MongoDB/Query.hs
index a8ec1dc..86667aa 100644
--- a/Database/MongoDB/Query.hs
+++ b/Database/MongoDB/Query.hs
@@ -60,7 +60,7 @@ import Control.Monad
when,
)
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)
-import Control.Monad.Trans (MonadIO, liftIO)
+import Control.Monad.Trans (MonadIO, liftIO, lift)
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.MAC.HMAC as HMAC
@@ -131,6 +131,7 @@ import Database.MongoDB.Internal.Protocol
pwKey,
FlagBit (..)
)
+import Control.Monad.Trans.Except
import qualified Database.MongoDB.Internal.Protocol as P
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))
import System.Mem.Weak (Weak)
@@ -1279,7 +1280,7 @@ find q@Query{selection, batchSize} = do
dBatch <- liftIO $ requestOpMsg pipe newQr []
newCursor db (coll selection) batchSize dBatch
-findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor
+findCommand :: (MonadIO m) => Query -> Action m Cursor
-- ^ Fetch documents satisfying query using the command "find"
findCommand q@Query{..} = do
pipe <- asks mongoPipe
@@ -1371,7 +1372,7 @@ defFamUpdateOpts ups = FamUpdate
-- Return a single updated document (@new@ option is set to @True@).
--
-- See 'findAndModifyOpts' for more options.
-findAndModify :: (MonadIO m, MonadFail m)
+findAndModify :: (MonadIO m)
=> Query
-> Document -- ^ updates
-> Action m (Either String Document)
@@ -1386,7 +1387,7 @@ findAndModify q ups = do
-- | Run the @findAndModify@ command
-- (allows more options than 'findAndModify')
-findAndModifyOpts :: (MonadIO m, MonadFail m)
+findAndModifyOpts :: (MonadIO m)
=> Query
-> FindAndModifyOpts
-> Action m (Either String (Maybe Document))
@@ -1666,7 +1667,7 @@ isCursorClosed (Cursor _ _ var) = do
type Pipeline = [Document]
-- ^ The Aggregate Pipeline
-aggregate :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Action m [Document]
+aggregate :: (MonadIO m) => Collection -> Pipeline -> Action m [Document]
-- ^ Runs an aggregate and unpacks the result. See for details.
aggregate aColl agg = do
aggregateCursor aColl agg def >>= rest
@@ -1689,7 +1690,7 @@ aggregateCommand aColl agg AggregateConfig {..} =
, "allowDiskUse" =: allowDiskUse
]
-aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
+aggregateCursor :: (MonadIO m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
-- ^ Runs an aggregate and unpacks the result. See for details.
aggregateCursor aColl agg cfg = do
pipe <- asks mongoPipe
@@ -1708,18 +1709,21 @@ aggregateCursor aColl agg cfg = do
>>= either (liftIO . throwIO . AggregateFailure) return
getCursorFromResponse
- :: (MonadIO m, MonadFail m)
+ :: (MonadIO m)
=> Collection
-> Document
-> Action m (Either String Cursor)
getCursorFromResponse aColl response
- | true1 "ok" response = do
- cursor <- lookup "cursor" response
- firstBatch <- lookup "firstBatch" cursor
- cursorId <- lookup "id" cursor
- db <- thisDatabase
- Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
+ | true1 "ok" response = runExceptT $ do
+ cursor <- lookup "cursor" response ?? "cursor is missing"
+ firstBatch <- lookup "firstBatch" cursor ?? "firstBatch is missing"
+ cursorId <- lookup "id" cursor ?? "id is missing"
+ db <- lift thisDatabase
+ lift $ newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
| otherwise = return $ Left $ at "errmsg" response
+ where
+ Nothing ?? e = throwE e
+ Just a ?? _ = pure a
-- ** Group