Refactor getCursorFromResponse
This commit is contained in:
parent
0c7a62fc56
commit
a3e1999287
1 changed files with 22 additions and 20 deletions
|
@ -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
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue