Vergara_Tech/mongodb
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity

Get rid of MonadFail constraints in MongoDB.Query

Browse source 
PR #141
This commit is contained in:
Victor Denisov 2023-02-04 21:50:34 -08:00
commit fb0d140aa4
2 changed files with 19 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

2
CHANGELOG.md
View file

@ -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

30
Database/MongoDB/Query.hs
View file

@ -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