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 Data.Binary.Put (runPut)
|
||||
import Data.Bson (Document, Field(..), Label, Val, Value(String, Doc, Bool),
|
||||
Javascript, at, valueAt, lookup, look, genObjectId, merge,
|
||||
(=:), (=?), (!?), Val(..), ObjectId, Value(..))
|
||||
Javascript, at, valueAt, lookup, look, genObjectId, (=:),
|
||||
(=?), (!?), Val(..), ObjectId, Value(..))
|
||||
import Data.Bson.Binary (putDocument)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
|
@ -1038,19 +1038,21 @@ findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor
|
|||
findCommand Query{..} = do
|
||||
let aColl = coll selection
|
||||
response <- runCommand $
|
||||
[ "find" =: aColl
|
||||
, "filter" =: selector selection
|
||||
, "sort" =: sort
|
||||
, "projection" =: project
|
||||
, "hint" =: hint
|
||||
, "skip" =: toInt32 skip
|
||||
]
|
||||
++ mconcat -- optional fields
|
||||
[ "batchSize" =? toMaybe (/= 0) toInt32 batchSize
|
||||
, "limit" =? toMaybe (/= 0) toInt32 limit
|
||||
]
|
||||
[ "find" =: aColl
|
||||
, "filter" =: selector selection
|
||||
, "sort" =: sort
|
||||
, "projection" =: project
|
||||
, "hint" =: hint
|
||||
, "skip" =: toInt32 skip
|
||||
]
|
||||
++ mconcat -- optional fields
|
||||
[ "batchSize" =? toMaybe (/= 0) toInt32 batchSize
|
||||
, "limit" =? toMaybe (/= 0) toInt32 limit
|
||||
]
|
||||
|
||||
getCursorFromResponse aColl response
|
||||
>>= either (liftIO . throwIO . FindFailure) return
|
||||
|
||||
getCursorFromResponse aColl response FindFailure
|
||||
where
|
||||
toInt32 :: Integral a => a -> Int32
|
||||
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.
|
||||
aggregateCursor aColl agg _ = do
|
||||
response <- runCommand ["aggregate" =: aColl, "pipeline" =: agg, "cursor" =: ([] :: Document)]
|
||||
getCursorFromResponse aColl response AggregateFailure
|
||||
getCursorFromResponse aColl response
|
||||
>>= either (liftIO . throwIO . AggregateFailure) return
|
||||
|
||||
getCursorFromResponse
|
||||
:: (MonadIO m, MonadFail m)
|
||||
=> Collection
|
||||
-> Document
|
||||
-> (String -> Failure)
|
||||
-> Action m Cursor
|
||||
getCursorFromResponse aColl response err
|
||||
-> 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
|
||||
newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
|
||||
| otherwise = liftIO . throwIO . err $ at "errmsg" response
|
||||
Right <$> newCursor db aColl 0 (return $ Batch Nothing cursorId firstBatch)
|
||||
| otherwise = return $ Left $ at "errmsg" response
|
||||
|
||||
-- ** Group
|
||||
|
||||
|
|
Loading…
Reference in a new issue