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