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

Put request function out of Action monad

Browse source
This commit is contained in:
Victor Denisov 2016-08-04 22:58:25 -07:00
parent 419b3c19fb
commit b34162f084
1 changed files with 20 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

28
Database/MongoDB/Query.hs
View file

@ -384,7 +384,11 @@ write notice = asks mongoWriteMode >>= \mode -> case mode of
NoConfirm -> send [notice] NoConfirm -> send [notice]
Confirm params -> do Confirm params -> do
let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd" let q = query (("getlasterror" =: (1 :: Int)) : params) "$cmd"
Batch _ _ [doc] <- fulfill =<< request [notice] =<< queryRequest False q {limit = 1} pipe <- asks mongoPipe
Batch _ _ [doc] <- do
r <- queryRequest False q {limit = 1}
rr <- liftIO $ request pipe [notice] r
fulfill rr
case lookup "err" doc of case lookup "err" doc of
Nothing -> return () Nothing -> return ()
Just err -> liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" doc) err Just err -> liftIO $ throwIO $ WriteFailure (maybe 0 id $ lookup "code" doc) err
@ -823,13 +827,18 @@ find :: (MonadIO m, MonadBaseControl IO m) => Query -> Action m Cursor
-- ^ Fetch documents satisfying query -- ^ Fetch documents satisfying query
find q@Query{selection, batchSize} = do find q@Query{selection, batchSize} = do
db <- thisDatabase db <- thisDatabase
dBatch <- request [] =<< queryRequest False q pipe <- asks mongoPipe
qr <- queryRequest False q
dBatch <- liftIO $ request pipe [] qr
newCursor db (coll selection) batchSize dBatch newCursor db (coll selection) batchSize dBatch
findOne :: (MonadIO m) => Query -> Action m (Maybe Document) findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
-- ^ Fetch first document satisfying query or Nothing if none satisfy it -- ^ Fetch first document satisfying query or Nothing if none satisfy it
findOne q = do findOne q = do
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest False q {limit = 1} pipe <- asks mongoPipe
qr <- queryRequest False q {limit = 1}
rq <- liftIO $ request pipe [] qr
Batch _ _ docs <- fulfill rq
return (listToMaybe docs) return (listToMaybe docs)
fetch :: (MonadIO m) => Query -> Action m Document fetch :: (MonadIO m) => Query -> Action m Document
@ -915,7 +924,10 @@ findAndModifyOpts (Query {
explain :: (MonadIO m) => Query -> Action m Document explain :: (MonadIO m) => Query -> Action m Document
-- ^ Return performance stats of query execution -- ^ Return performance stats of query execution
explain q = do -- same as findOne but with explain set to true explain q = do -- same as findOne but with explain set to true
Batch _ _ docs <- fulfill =<< request [] =<< queryRequest True q {limit = 1} pipe <- asks mongoPipe
qr <- queryRequest True q {limit = 1}
r <- liftIO $ request pipe [] qr
Batch _ _ docs <- fulfill r
return $ if null docs then error ("no explain: " ++ show q) else head docs return $ if null docs then error ("no explain: " ++ show q) else head docs
count :: (MonadIO m) => Query -> Action m Int count :: (MonadIO m) => Query -> Action m Int
@ -965,10 +977,9 @@ type DelayedBatch = IO Batch
data Batch = Batch (Maybe Limit) CursorId [Document] data Batch = Batch (Maybe Limit) CursorId [Document]
-- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is number of documents to return. Nothing means no limit. -- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is number of documents to return. Nothing means no limit.
request :: (MonadIO m) => [Notice] -> (Request, Maybe Limit) -> Action m DelayedBatch request :: Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
-- ^ Send notices and request and return promised batch -- ^ Send notices and request and return promised batch
request ns (req, remainingLimit) = do request pipe ns (req, remainingLimit) = do
pipe <- asks mongoPipe
promise <- liftIOE ConnectionFailure $ P.call pipe ns req promise <- liftIOE ConnectionFailure $ P.call pipe ns req
let protectedPromise = liftIOE ConnectionFailure promise let protectedPromise = liftIOE ConnectionFailure promise
return $ fromReply remainingLimit =<< protectedPromise return $ fromReply remainingLimit =<< protectedPromise
@ -1033,7 +1044,8 @@ fulfill' fcol batchSize dBatch = do
nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> (Maybe Limit) -> CursorId -> Action m DelayedBatch nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> (Maybe Limit) -> CursorId -> Action m DelayedBatch
nextBatch' fcol batchSize limit cid = do nextBatch' fcol batchSize limit cid = do
request [] (GetMore fcol batchSize' cid, remLimit) pipe <- asks mongoPipe
liftIO $ request pipe [] (GetMore fcol batchSize' cid, remLimit)
where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit where (batchSize', remLimit) = batchSizeRemainingLimit batchSize limit
next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document) next :: (MonadIO m, MonadBaseControl IO m) => Cursor -> Action m (Maybe Document)