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

Refactor getCursorFromResponse

Browse source
This commit is contained in:
Diego Balseiro 2020-07-30 13:25:19 -05:00
parent 0c7a62fc56
commit a3e1999287
1 changed files with 22 additions and 20 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

42
Database/MongoDB/Query.hs
View file

@ -77,8 +77,8 @@ import Control.Monad.Reader (MonadReader, ReaderT, runReaderT, ask, asks, local)
import Control.Monad.Trans (MonadIO, liftIO) import Control.Monad.Trans (MonadIO, liftIO)
import Data.Binary.Put (runPut) import Data.Binary.Put (runPut)
import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool), import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
Javascript, at, valueAt, lookup, look, genObjectId, merge, Javascript, at, valueAt, lookup, look, genObjectId, (=:),
(=:), (=?), (!?), Val(..), ObjectId, Value(..)) (=?), (!?), Val(..), ObjectId, Value(..))
import Data.Bson.Binary (putDocument) import Data.Bson.Binary (putDocument)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
@ -1038,19 +1038,21 @@ findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor
findCommand Query{..} = do findCommand Query{..} = do
let aColl = coll selection let aColl = coll selection
response <- runCommand $ response <- runCommand $
[ "find" =: aColl [ "find" =: aColl
, "filter" =: selector selection , "filter" =: selector selection
, "sort" =: sort , "sort" =: sort
, "projection" =: project , "projection" =: project
, "hint" =: hint , "hint" =: hint
, "skip" =: toInt32 skip , "skip" =: toInt32 skip
] ]
++ mconcat -- optional fields ++ mconcat -- optional fields
[ "batchSize" =? toMaybe (/= 0) toInt32 batchSize [ "batchSize" =? toMaybe (/= 0) toInt32 batchSize
, "limit" =? toMaybe (/= 0) toInt32 limit , "limit" =? toMaybe (/= 0) toInt32 limit
] ]
getCursorFromResponse aColl response
>>= either (liftIO . throwIO . FindFailure) return
getCursorFromResponse aColl response FindFailure
where where
toInt32 :: Integral a => a -> Int32 toInt32 :: Integral a => a -> Int32
toInt32 = fromIntegral toInt32 = fromIntegral
@ -1347,22 +1349,22 @@ aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Aggrega
-- ^ 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 _ = do aggregateCursor aColl agg _ = do
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)] response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]
getCursorFromResponse aColl response AggregateFailure getCursorFromResponse aColl response
>>= either (liftIO . throwIO . AggregateFailure) return
getCursorFromResponse getCursorFromResponse
:: (MonadIO m, MonadFail m) :: (MonadIO m, MonadFail m)
=> Collection => Collection
-> Document -> Document
-> (String -> Failure) -> Action m (Either String Cursor)
-> Action m Cursor getCursorFromResponse aColl response
getCursorFromResponse aColl response err
| true1 "ok" response = do | true1 "ok" response = do
cursor <- lookup "cursor" response cursor <- lookup "cursor" response
firstBatch <- lookup "firstBatch" cursor firstBatch <- lookup "firstBatch" cursor
cursorId <- lookup "id" cursor cursorId <- lookup "id" cursor
db <- thisDatabase db <- thisDatabase
newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch) Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
| otherwise = liftIO . throwIO . err $ at "errmsg" response | otherwise = return $ Left $ at "errmsg" response
-- ** Group -- ** Group