commit
fb0d140aa4
2 changed files with 19 additions and 13 deletions
|
@ -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
|
||||
|
|
|
@ -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 <http://docs.mongodb.org/manual/core/aggregation/> 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 <http://docs.mongodb.org/manual/core/aggregation/> 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
|
||||
|
||||
|
|
Loading…
Reference in a new issue