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