{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, CPP, DeriveDataTypeable, ScopedTypeVariables, BangPatterns #-}
module Database.MongoDB.Query (
Action, access, Failure(..), ErrorCode,
AccessMode(..), GetLastError, master, slaveOk, accessMode,
liftDB,
MongoContext(..), HasMongoContext(..),
Database, allDatabases, useDb, thisDatabase,
Username, Password, auth, authMongoCR, authSCRAMSHA1,
Collection, allCollections,
Selection(..), Selector, whereJS,
Select(select),
insert, insert_, insertMany, insertMany_, insertAll, insertAll_,
save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll,
WriteResult(..), UpdateOption(..), Upserted(..),
delete, deleteOne, deleteMany, deleteAll, DeleteOption(..),
Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial),
Projector, Limit, Order, BatchSize,
explain, find, findCommand, findOne, fetch,
findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts,
count, distinct,
Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed,
Pipeline, AggregateConfig(..), aggregate, aggregateCursor,
Group(..), GroupKey(..), group,
MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..),
MRResult, mapReduce, runMR, runMR',
Command, runCommand, runCommand1,
eval, retrieveServerData, ServerData(..)
) where
import qualified Control.Concurrent.MVar as MV
import Control.Concurrent.MVar.Lifted
( MVar,
readMVar,
)
import Control.Exception (Exception, catch, throwIO)
import Control.Monad
( liftM2,
replicateM,
unless,
void,
when,
)
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)
import Control.Monad.Trans (MonadIO, liftIO)
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.MAC.HMAC as HMAC
import qualified Crypto.Nonce as Nonce
import Data.Binary.Put (runPut)
import Data.Bits (xor)
import Data.Bson
( Document,
Field (..),
Javascript,
Label,
ObjectId,
Val (..),
Value (..),
at,
genObjectId,
look,
lookup,
valueAt,
(!?),
(=:),
(=?),
merge,
cast
)
import Data.Bson.Binary (putDocument)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LBS
import Data.Default.Class (Default (..))
import Data.Either (lefts, rights)
import qualified Data.Either as E
import Data.Functor ((<&>))
import Data.Int (Int32, Int64)
import Data.List (foldl1')
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe, isNothing, listToMaybe, mapMaybe, maybeToList, fromJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.MongoDB.Internal.Protocol
( CursorId,
DeleteOption (..),
FullCollection,
InsertOption (..),
Notice (..),
Password,
Pipe,
QueryOption (..),
Reply (..),
Request
( GetMore,
qBatchSize,
qFullCollection,
qOptions,
qProjector,
qSelector,
qSkip
),
ResponseFlag (..),
ServerData (..),
UpdateOption (..),
Username,
Cmd (..),
pwKey,
FlagBit (..)
)
import qualified Database.MongoDB.Internal.Protocol as P
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>))
import System.Mem.Weak (Weak)
import Text.Read (readMaybe)
import Prelude hiding (lookup)
type Action = ReaderT MongoContext
access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m a
access :: forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Label -> Action m a -> m a
access Pipe
mongoPipe AccessMode
mongoAccessMode Label
mongoDatabase Action m a
action = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Action m a
action MongoContext{Label
Pipe
AccessMode
mongoDatabase :: Label
mongoAccessMode :: AccessMode
mongoPipe :: Pipe
mongoDatabase :: Label
mongoAccessMode :: AccessMode
mongoPipe :: Pipe
..}
data Failure =
ConnectionFailure IOError
| CursorNotFoundFailure CursorId
| QueryFailure ErrorCode String
| WriteFailure Int ErrorCode String
| WriteConcernFailure Int String
| DocNotFound Selection
| AggregateFailure String
| CompoundFailure [Failure]
| ProtocolFailure Int String
deriving (Int -> Failure -> ShowS
[Failure] -> ShowS
Failure -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Failure] -> ShowS
$cshowList :: [Failure] -> ShowS
show :: Failure -> String
$cshow :: Failure -> String
showsPrec :: Int -> Failure -> ShowS
$cshowsPrec :: Int -> Failure -> ShowS
Show, Failure -> Failure -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c== :: Failure -> Failure -> Bool
Eq, Typeable)
instance Exception Failure
type ErrorCode = Int
data AccessMode =
ReadStaleOk
| UnconfirmedWrites
| ConfirmWrites GetLastError
deriving Int -> AccessMode -> ShowS
[AccessMode] -> ShowS
AccessMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccessMode] -> ShowS
$cshowList :: [AccessMode] -> ShowS
show :: AccessMode -> String
$cshow :: AccessMode -> String
showsPrec :: Int -> AccessMode -> ShowS
$cshowsPrec :: Int -> AccessMode -> ShowS
Show
type GetLastError = Document
class Result a where
isFailed :: a -> Bool
data WriteResult = WriteResult
{ WriteResult -> Bool
failed :: Bool
, WriteResult -> Int
nMatched :: Int
, WriteResult -> Maybe Int
nModified :: Maybe Int
, WriteResult -> Int
nRemoved :: Int
, WriteResult -> [Upserted]
upserted :: [Upserted]
, WriteResult -> [Failure]
writeErrors :: [Failure]
, WriteResult -> [Failure]
writeConcernErrors :: [Failure]
} deriving Int -> WriteResult -> ShowS
[WriteResult] -> ShowS
WriteResult -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteResult] -> ShowS
$cshowList :: [WriteResult] -> ShowS
show :: WriteResult -> String
$cshow :: WriteResult -> String
showsPrec :: Int -> WriteResult -> ShowS
$cshowsPrec :: Int -> WriteResult -> ShowS
Show
instance Result WriteResult where
isFailed :: WriteResult -> Bool
isFailed = WriteResult -> Bool
failed
instance Result (Either a b) where
isFailed :: Either a b -> Bool
isFailed (Left a
_) = Bool
True
isFailed Either a b
_ = Bool
False
data Upserted = Upserted
{ Upserted -> Int
upsertedIndex :: Int
, Upserted -> ObjectId
upsertedId :: ObjectId
} deriving Int -> Upserted -> ShowS
[Upserted] -> ShowS
Upserted -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Upserted] -> ShowS
$cshowList :: [Upserted] -> ShowS
show :: Upserted -> String
$cshow :: Upserted -> String
showsPrec :: Int -> Upserted -> ShowS
$cshowsPrec :: Int -> Upserted -> ShowS
Show
master :: AccessMode
master :: AccessMode
master = Document -> AccessMode
ConfirmWrites []
slaveOk :: AccessMode
slaveOk :: AccessMode
slaveOk = AccessMode
ReadStaleOk
accessMode :: (Monad m) => AccessMode -> Action m a -> Action m a
accessMode :: forall (m :: * -> *) a.
Monad m =>
AccessMode -> Action m a -> Action m a
accessMode AccessMode
mode = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\MongoContext
ctx -> MongoContext
ctx {mongoAccessMode :: AccessMode
mongoAccessMode = AccessMode
mode})
readMode :: AccessMode -> ReadMode
readMode :: AccessMode -> ReadMode
readMode AccessMode
ReadStaleOk = ReadMode
StaleOk
readMode AccessMode
_ = ReadMode
Fresh
writeMode :: AccessMode -> WriteMode
writeMode :: AccessMode -> WriteMode
writeMode AccessMode
ReadStaleOk = Document -> WriteMode
Confirm []
writeMode AccessMode
UnconfirmedWrites = WriteMode
NoConfirm
writeMode (ConfirmWrites Document
z) = Document -> WriteMode
Confirm Document
z
data MongoContext = MongoContext {
MongoContext -> Pipe
mongoPipe :: Pipe,
MongoContext -> AccessMode
mongoAccessMode :: AccessMode,
MongoContext -> Label
mongoDatabase :: Database
}
mongoReadMode :: MongoContext -> ReadMode
mongoReadMode :: MongoContext -> ReadMode
mongoReadMode = AccessMode -> ReadMode
readMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. MongoContext -> AccessMode
mongoAccessMode
mongoWriteMode :: MongoContext -> WriteMode
mongoWriteMode :: MongoContext -> WriteMode
mongoWriteMode = AccessMode -> WriteMode
writeMode forall b c a. (b -> c) -> (a -> b) -> a -> c
. MongoContext -> AccessMode
mongoAccessMode
class HasMongoContext env where
mongoContext :: env -> MongoContext
instance HasMongoContext MongoContext where
mongoContext :: MongoContext -> MongoContext
mongoContext = forall a. a -> a
id
liftDB :: (MonadReader env m, HasMongoContext env, MonadIO m)
=> Action IO a
-> m a
liftDB :: forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB Action IO a
m = do
env
env <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Action IO a
m (forall env. HasMongoContext env => env -> MongoContext
mongoContext env
env)
type Database = Text
allDatabases :: (MonadIO m) => Action m [Database]
allDatabases :: forall (m :: * -> *). MonadIO m => Action m [Label]
allDatabases = forall a b. (a -> b) -> [a] -> [b]
map (forall v. Val v => Label -> Document -> v
at Label
"name") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. Val v => Label -> Document -> v
at Label
"databases" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
"admin" (forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
"listDatabases")
thisDatabase :: (Monad m) => Action m Database
thisDatabase :: forall (m :: * -> *). Monad m => Action m Label
thisDatabase = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Label
mongoDatabase
useDb :: (Monad m) => Database -> Action m a -> Action m a
useDb :: forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
db = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\MongoContext
ctx -> MongoContext
ctx {mongoDatabase :: Label
mongoDatabase = Label
db})
auth :: MonadIO m => Username -> Password -> Action m Bool
auth :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
auth Label
un Label
pw = do
let serverVersion :: ReaderT MongoContext m Label
serverVersion = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall v. Val v => Label -> Document -> v
at Label
"version") forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
"admin" forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"buildinfo" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
Maybe Int
mmv <- forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> [Label]
T.splitOn Label
"." forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT MongoContext m Label
serverVersion
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Int -> Action m Bool
performAuth Maybe Int
mmv
where
performAuth :: Int -> Action m Bool
performAuth Int
majorVersion =
if Int
majorVersion forall a. Ord a => a -> a -> Bool
>= (Int
3 :: Int)
then forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authSCRAMSHA1 Label
un Label
pw
else forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authMongoCR Label
un Label
pw
authMongoCR :: (MonadIO m) => Username -> Password -> Action m Bool
authMongoCR :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authMongoCR Label
usr Label
pss = do
Label
n <- forall v. Val v => Label -> Document -> v
at Label
"nonce" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"getnonce" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
Label -> Document -> Bool
true1 Label
"ok" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"authenticate" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"user" forall v. Val v => Label -> v -> Field
=: Label
usr, Label
"nonce" forall v. Val v => Label -> v -> Field
=: Label
n, Label
"key" forall v. Val v => Label -> v -> Field
=: Label -> Label -> Label -> Label
pwKey Label
n Label
usr Label
pss]
authSCRAMSHA1 :: MonadIO m => Username -> Password -> Action m Bool
authSCRAMSHA1 :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authSCRAMSHA1 Label
un Label
pw = do
let hmac :: ByteString -> ByteString -> ByteString
hmac = (ByteString -> ByteString)
-> Int -> ByteString -> ByteString -> ByteString
HMAC.hmac ByteString -> ByteString
SHA1.hash Int
64
ByteString
nonce <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
MonadUnliftIO m =>
(Generator -> m a) -> m a
Nonce.withGenerator forall (m :: * -> *). MonadIO m => Generator -> m ByteString
Nonce.nonce128 forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> ByteString
B64.encode)
let firstBare :: ByteString
firstBare = [ByteString] -> ByteString
B.concat [String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ String
"n=" forall a. [a] -> [a] -> [a]
++ Label -> String
T.unpack Label
un forall a. [a] -> [a] -> [a]
++ String
",r=", ByteString
nonce]
let client1 :: Document
client1 = [Label
"saslStart" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"mechanism" forall v. Val v => Label -> v -> Field
=: (String
"SCRAM-SHA-1" :: String), Label
"payload" forall v. Val v => Label -> v -> Field
=: (ByteString -> String
B.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
B64.encode forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
B.concat [String -> ByteString
B.pack String
"n,,", ByteString
firstBare]), Label
"autoAuthorize" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
Document
server1 <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
client1
forall {m :: * -> *}. Monad m => Bool -> m Bool -> m Bool
shortcircuit (Label -> Document -> Bool
true1 Label
"ok" Document
server1) forall a b. (a -> b) -> a -> b
$ do
let serverPayload1 :: ByteString
serverPayload1 = ByteString -> ByteString
B64.decodeLenient forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. Val v => Label -> Document -> v
at Label
"payload" forall a b. (a -> b) -> a -> b
$ Document
server1
let serverData1 :: Map ByteString ByteString
serverData1 = ByteString -> Map ByteString ByteString
parseSCRAM ByteString
serverPayload1
let iterations :: Int
iterations = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
"1" ByteString
"i" Map ByteString ByteString
serverData1
let salt :: ByteString
salt = ByteString -> ByteString
B64.decodeLenient forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
"" ByteString
"s" Map ByteString ByteString
serverData1
let snonce :: ByteString
snonce = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
"" ByteString
"r" Map ByteString ByteString
serverData1
forall {m :: * -> *}. Monad m => Bool -> m Bool -> m Bool
shortcircuit (ByteString -> ByteString -> Bool
B.isInfixOf ByteString
nonce ByteString
snonce) forall a b. (a -> b) -> a -> b
$ do
let withoutProof :: ByteString
withoutProof = [ByteString] -> ByteString
B.concat [String -> ByteString
B.pack String
"c=biws,r=", ByteString
snonce]
let digestS :: ByteString
digestS = String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ Label -> String
T.unpack Label
un forall a. [a] -> [a] -> [a]
++ String
":mongo:" forall a. [a] -> [a] -> [a]
++ Label -> String
T.unpack Label
pw
let digest :: ByteString
digest = ByteString -> ByteString
B16.encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hash ByteString
digestS
let saltedPass :: ByteString
saltedPass = ByteString -> ByteString -> Int -> ByteString
scramHI ByteString
digest ByteString
salt Int
iterations
let clientKey :: ByteString
clientKey = ByteString -> ByteString -> ByteString
hmac ByteString
saltedPass (String -> ByteString
B.pack String
"Client Key")
let storedKey :: ByteString
storedKey = ByteString -> ByteString
SHA1.hash ByteString
clientKey
let authMsg :: ByteString
authMsg = [ByteString] -> ByteString
B.concat [ByteString
firstBare, String -> ByteString
B.pack String
",", ByteString
serverPayload1, String -> ByteString
B.pack String
",", ByteString
withoutProof]
let clientSig :: ByteString
clientSig = ByteString -> ByteString -> ByteString
hmac ByteString
storedKey ByteString
authMsg
let pval :: ByteString
pval = ByteString -> ByteString
B64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a. (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
BS.zipWith forall a. Bits a => a -> a -> a
xor ByteString
clientKey ByteString
clientSig
let clientFinal :: ByteString
clientFinal = [ByteString] -> ByteString
B.concat [ByteString
withoutProof, String -> ByteString
B.pack String
",p=", ByteString
pval]
let serverKey :: ByteString
serverKey = ByteString -> ByteString -> ByteString
hmac ByteString
saltedPass (String -> ByteString
B.pack String
"Server Key")
let serverSig :: ByteString
serverSig = ByteString -> ByteString
B64.encode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
hmac ByteString
serverKey ByteString
authMsg
let client2 :: Document
client2 = [Label
"saslContinue" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"conversationId" forall v. Val v => Label -> v -> Field
=: (forall v. Val v => Label -> Document -> v
at Label
"conversationId" Document
server1 :: Int), Label
"payload" forall v. Val v => Label -> v -> Field
=: ByteString -> String
B.unpack (ByteString -> ByteString
B64.encode ByteString
clientFinal)]
Document
server2 <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
client2
forall {m :: * -> *}. Monad m => Bool -> m Bool -> m Bool
shortcircuit (Label -> Document -> Bool
true1 Label
"ok" Document
server2) forall a b. (a -> b) -> a -> b
$ do
let serverPayload2 :: ByteString
serverPayload2 = ByteString -> ByteString
B64.decodeLenient forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall v. Val v => Label -> Document -> v
at Label
"payload" Document
server2
let serverData2 :: Map ByteString ByteString
serverData2 = ByteString -> Map ByteString ByteString
parseSCRAM ByteString
serverPayload2
let serverSigComp :: ByteString
serverSigComp = forall k a. Ord k => a -> k -> Map k a -> a
Map.findWithDefault ByteString
"" ByteString
"v" Map ByteString ByteString
serverData2
forall {m :: * -> *}. Monad m => Bool -> m Bool -> m Bool
shortcircuit (ByteString
serverSig forall a. Eq a => a -> a -> Bool
== ByteString
serverSigComp) forall a b. (a -> b) -> a -> b
$ do
let done :: Bool
done = Label -> Document -> Bool
true1 Label
"done" Document
server2
if Bool
done
then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
else do
let client2Step2 :: Document
client2Step2 = [ Label
"saslContinue" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)
, Label
"conversationId" forall v. Val v => Label -> v -> Field
=: (forall v. Val v => Label -> Document -> v
at Label
"conversationId" Document
server1 :: Int)
, Label
"payload" forall v. Val v => Label -> v -> Field
=: Label -> Value
String Label
""]
Document
server3 <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
client2Step2
forall {m :: * -> *}. Monad m => Bool -> m Bool -> m Bool
shortcircuit (Label -> Document -> Bool
true1 Label
"ok" Document
server3) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
where
shortcircuit :: Bool -> m Bool -> m Bool
shortcircuit Bool
True m Bool
f = m Bool
f
shortcircuit Bool
False m Bool
_ = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
scramHI :: B.ByteString -> B.ByteString -> Int -> B.ByteString
scramHI :: ByteString -> ByteString -> Int -> ByteString
scramHI ByteString
digest ByteString
salt Int
iters = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ByteString, ByteString) -> Int -> (ByteString, ByteString)
com (ByteString
u1, ByteString
u1) [Int
1..(Int
itersforall a. Num a => a -> a -> a
-Int
1)]
where
hmacd :: ByteString -> ByteString
hmacd = (ByteString -> ByteString)
-> Int -> ByteString -> ByteString -> ByteString
HMAC.hmac ByteString -> ByteString
SHA1.hash Int
64 ByteString
digest
u1 :: ByteString
u1 = ByteString -> ByteString
hmacd ([ByteString] -> ByteString
B.concat [ByteString
salt, [Word8] -> ByteString
BS.pack [Word8
0, Word8
0, Word8
0, Word8
1]])
com :: (ByteString, ByteString) -> Int -> (ByteString, ByteString)
com (ByteString
u,ByteString
uc) Int
_ = let u' :: ByteString
u' = ByteString -> ByteString
hmacd ByteString
u in (ByteString
u', [Word8] -> ByteString
BS.pack forall a b. (a -> b) -> a -> b
$ forall a. (Word8 -> Word8 -> a) -> ByteString -> ByteString -> [a]
BS.zipWith forall a. Bits a => a -> a -> a
xor ByteString
uc ByteString
u')
parseSCRAM :: B.ByteString -> Map.Map B.ByteString B.ByteString
parseSCRAM :: ByteString -> Map ByteString ByteString
parseSCRAM = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Label, Label) -> (ByteString, ByteString)
cleanup forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> (Label, Label)
T.breakOn Label
"=") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> [Label]
T.splitOn Label
"," forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Label
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack
where cleanup :: (Label, Label) -> (ByteString, ByteString)
cleanup (Label
t1, Label
t2) = (String -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ Label -> String
T.unpack Label
t1, String -> ByteString
B.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Int -> Label -> Label
T.drop Int
1 Label
t2)
retrieveServerData :: (MonadIO m) => Action m ServerData
retrieveServerData :: forall (m :: * -> *). MonadIO m => Action m ServerData
retrieveServerData = do
Document
d <- forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
"isMaster"
let newSd :: ServerData
newSd = ServerData
{ isMaster :: Bool
isMaster = forall a. a -> Maybe a -> a
fromMaybe Bool
False forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"isMaster" Document
d
, minWireVersion :: Int
minWireVersion = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"minWireVersion" Document
d
, maxWireVersion :: Int
maxWireVersion = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxWireVersion" Document
d
, maxMessageSizeBytes :: Int
maxMessageSizeBytes = forall a. a -> Maybe a -> a
fromMaybe Int
48000000 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxMessageSizeBytes" Document
d
, maxBsonObjectSize :: Int
maxBsonObjectSize = forall a. a -> Maybe a -> a
fromMaybe (Int
16 forall a. Num a => a -> a -> a
* Int
1024 forall a. Num a => a -> a -> a
* Int
1024) forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxBsonObjectSize" Document
d
, maxWriteBatchSize :: Int
maxWriteBatchSize = forall a. a -> Maybe a -> a
fromMaybe Int
1000 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxWriteBatchSize" Document
d
}
forall (m :: * -> *) a. Monad m => a -> m a
return ServerData
newSd
type Collection = Text
allCollections :: MonadIO m => Action m [Collection]
allCollections :: forall (m :: * -> *). MonadIO m => Action m [Label]
allCollections = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
<= Int
2
then do
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Pipeline
docs <- forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find (Document -> Label -> Query
query [] Label
"system.namespaces") {sort :: Document
sort = [Label
"name" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]}
(forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> Bool
isSpecial Label
db)) (forall a b. (a -> b) -> [a] -> [b]
map (Label -> Label
dropDbPrefix forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall v. Val v => Label -> Document -> v
at Label
"name") Pipeline
docs)
else
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then do
Document
r <- forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
"listCollections"
let curData :: Maybe (CursorId, Label, Pipeline)
curData = do
(Doc Document
curDoc) <- Document
r forall a. Val a => Document -> Label -> Maybe a
!? Label
"cursor"
(CursorId
curId :: Int64) <- Document
curDoc forall a. Val a => Document -> Label -> Maybe a
!? Label
"id"
(Label
curNs :: Text) <- Document
curDoc forall a. Val a => Document -> Label -> Maybe a
!? Label
"ns"
([Value]
firstBatch :: [Value]) <- Document
curDoc forall a. Val a => Document -> Label -> Maybe a
!? Label
"firstBatch"
forall (m :: * -> *) a. Monad m => a -> m a
return (CursorId
curId, Label
curNs, forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. Val a => Value -> Maybe a
cast' [Value]
firstBatch :: [Document])
case Maybe (CursorId, Label, Pipeline)
curData of
Maybe (CursorId, Label, Pipeline)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (CursorId
curId, Label
curNs, Pipeline
firstBatch) -> do
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Cursor
nc <- forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
curNs Limit
0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch forall a. Maybe a
Nothing CursorId
curId Pipeline
firstBatch
Pipeline
docs <- forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest Cursor
nc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Document
d -> Document
d forall a. Val a => Document -> Label -> Maybe a
!? Label
"name") Pipeline
docs
else do
let q :: Query
q = [QueryOption]
-> Selection
-> Document
-> Limit
-> Limit
-> Document
-> Bool
-> Limit
-> Document
-> Query
Query [] (Document -> Label -> Selection
Select [Label
"listCollections" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)] Label
"$cmd") [] Limit
0 Limit
0 [] Bool
False Limit
0 []
(Cmd, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q
DelayedBatch
dBatch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
p (Cmd, Maybe Limit)
qr []
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Cursor
nc <- forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
"$cmd" Limit
0 DelayedBatch
dBatch
Pipeline
docs <- forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest Cursor
nc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Document
d -> Document
d forall a. Val a => Document -> Label -> Maybe a
!? Label
"name") Pipeline
docs
where
dropDbPrefix :: Label -> Label
dropDbPrefix = Label -> Label
T.tail forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Label -> Label
T.dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.')
isSpecial :: Label -> Label -> Bool
isSpecial Label
db Label
col = (Char -> Bool) -> Label -> Bool
T.any (forall a. Eq a => a -> a -> Bool
== Char
'$') Label
col Bool -> Bool -> Bool
&& Label
db Label -> Label -> Label
<.> Label
col forall a. Eq a => a -> a -> Bool
/= Label
"local.oplog.$main"
data Selection = Select {Selection -> Document
selector :: Selector, Selection -> Label
coll :: Collection} deriving (Int -> Selection -> ShowS
[Selection] -> ShowS
Selection -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Selection] -> ShowS
$cshowList :: [Selection] -> ShowS
show :: Selection -> String
$cshow :: Selection -> String
showsPrec :: Int -> Selection -> ShowS
$cshowsPrec :: Int -> Selection -> ShowS
Show, Selection -> Selection -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Selection -> Selection -> Bool
$c/= :: Selection -> Selection -> Bool
== :: Selection -> Selection -> Bool
$c== :: Selection -> Selection -> Bool
Eq)
type Selector = Document
whereJS :: Selector -> Javascript -> Selector
whereJS :: Document -> FinalizeFun -> Document
whereJS Document
sel FinalizeFun
js = (Label
"$where" forall v. Val v => Label -> v -> Field
=: FinalizeFun
js) forall a. a -> [a] -> [a]
: Document
sel
class Select aQueryOrSelection where
select :: Selector -> Collection -> aQueryOrSelection
instance Select Selection where
select :: Document -> Label -> Selection
select = Document -> Label -> Selection
Select
instance Select Query where
select :: Document -> Label -> Query
select = Document -> Label -> Query
query
data WriteMode =
NoConfirm
| Confirm GetLastError
deriving (Int -> WriteMode -> ShowS
[WriteMode] -> ShowS
WriteMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WriteMode] -> ShowS
$cshowList :: [WriteMode] -> ShowS
show :: WriteMode -> String
$cshow :: WriteMode -> String
showsPrec :: Int -> WriteMode -> ShowS
$cshowsPrec :: Int -> WriteMode -> ShowS
Show, WriteMode -> WriteMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WriteMode -> WriteMode -> Bool
$c/= :: WriteMode -> WriteMode -> Bool
== :: WriteMode -> WriteMode -> Bool
$c== :: WriteMode -> WriteMode -> Bool
Eq)
write :: Notice -> Action IO (Maybe Document)
write :: Notice -> Action IO (Maybe Document)
write Notice
notice = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \WriteMode
mode -> case WriteMode
mode of
WriteMode
NoConfirm -> do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> IO ()
P.send Pipe
pipe [Notice
notice]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Confirm Document
params -> do
let q :: Query
q = Document -> Label -> Query
query ((Label
"getlasterror" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)) forall a. a -> [a] -> [a]
: Document
params) Label
"$cmd"
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
Batch Maybe Limit
_ CursorId
_ [Document
doc] <- do
(Request, Maybe Limit)
r <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
False Query
q {limit :: Limit
limit = Limit
1}
DelayedBatch
rr <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [Notice
notice] (Request, Maybe Limit)
r
DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
rr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Document
doc
insert :: (MonadIO m) => Collection -> Document -> Action m Value
insert :: forall (m :: * -> *).
MonadIO m =>
Label -> Document -> Action m Value
insert Label
col Document
doc = do
Document
doc' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Document -> IO Document
assignId Document
doc
Either Failure [Value]
res <- forall (m :: * -> *).
MonadIO m =>
[InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
insertBlock [] Label
col (Int
0, [Document
doc'])
case Either Failure [Value]
res of
Left Failure
failure -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO Failure
failure
Right [Value]
r -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Value]
r
insert_ :: (MonadIO m) => Collection -> Document -> Action m ()
insert_ :: forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
insert_ Label
col Document
doc = forall (m :: * -> *).
MonadIO m =>
Label -> Document -> Action m Value
insert Label
col Document
doc forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertMany :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
insertMany :: forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertMany = forall (m :: * -> *).
MonadIO m =>
[InsertOption] -> Label -> Pipeline -> Action m [Value]
insert' []
insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
insertMany_ :: forall (m :: * -> *). MonadIO m => Label -> Pipeline -> Action m ()
insertMany_ Label
col Pipeline
docs = forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertMany Label
col Pipeline
docs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertAll :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
insertAll :: forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertAll = forall (m :: * -> *).
MonadIO m =>
[InsertOption] -> Label -> Pipeline -> Action m [Value]
insert' [InsertOption
KeepGoing]
insertAll_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
insertAll_ :: forall (m :: * -> *). MonadIO m => Label -> Pipeline -> Action m ()
insertAll_ Label
col Pipeline
docs = forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertAll Label
col Pipeline
docs forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertCommandDocument :: [InsertOption] -> Collection -> [Document] -> Document -> Document
insertCommandDocument :: [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col Pipeline
docs Document
writeConcern =
[ Label
"insert" forall v. Val v => Label -> v -> Field
=: Label
col
, Label
"ordered" forall v. Val v => Label -> v -> Field
=: (InsertOption
KeepGoing forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [InsertOption]
opts)
, Label
"documents" forall v. Val v => Label -> v -> Field
=: Pipeline
docs
, Label
"writeConcern" forall v. Val v => Label -> v -> Field
=: Document
writeConcern
]
takeRightsUpToLeft :: [Either a b] -> [b]
takeRightsUpToLeft :: forall a b. [Either a b] -> [b]
takeRightsUpToLeft [Either a b]
l = forall a b. [Either a b] -> [b]
E.rights forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile forall a b. Either a b -> Bool
E.isRight [Either a b]
l
insert' :: (MonadIO m)
=> [InsertOption] -> Collection -> [Document] -> Action m [Value]
insert' :: forall (m :: * -> *).
MonadIO m =>
[InsertOption] -> Label -> Pipeline -> Action m [Value]
insert' [InsertOption]
opts Label
col Pipeline
docs = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
Pipeline
docs' <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Document -> IO Document
assignId Pipeline
docs
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
let docSize :: Int
docSize = Document -> Int
sizeOfDocument forall a b. (a -> b) -> a -> b
$ [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col [] Document
writeConcern
let ordered :: Bool
ordered = InsertOption
KeepGoing forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [InsertOption]
opts
let preChunks :: [Either Failure Pipeline]
preChunks = Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit
(ServerData -> Int
maxBsonObjectSize ServerData
sd forall a. Num a => a -> a -> a
- Int
docSize)
(ServerData -> Int
maxWriteBatchSize ServerData
sd)
Pipeline
docs'
let chunks :: [Pipeline]
chunks =
if Bool
ordered
then forall a b. [Either a b] -> [b]
takeRightsUpToLeft [Either Failure Pipeline]
preChunks
else forall a b. [Either a b] -> [b]
rights [Either Failure Pipeline]
preChunks
let lens :: [Int]
lens = forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pipeline]
chunks
let lSums :: [Int]
lSums = Int
0 forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Int]
lSums [Int]
lens
[Either Failure [Value]]
chunkResults <- forall (m :: * -> *) b a.
(Monad m, Result b) =>
Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor Bool
ordered (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lSums [Pipeline]
chunks) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadIO m =>
[InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
insertBlock [InsertOption]
opts Label
col
let lchunks :: [Failure]
lchunks = forall a b. [Either a b] -> [a]
lefts [Either Failure Pipeline]
preChunks
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Failure]
lchunks) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Failure]
lchunks
let lresults :: [Failure]
lresults = forall a b. [Either a b] -> [a]
lefts [Either Failure [Value]]
chunkResults
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Failure]
lresults) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [Failure]
lresults
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a b. [Either a b] -> [b]
rights [Either Failure [Value]]
chunkResults
insertBlock :: (MonadIO m)
=> [InsertOption] -> Collection -> (Int, [Document]) -> Action m (Either Failure [Value])
insertBlock :: forall (m :: * -> *).
MonadIO m =>
[InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
insertBlock [InsertOption]
_ Label
_ (Int
_, []) = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right []
insertBlock [InsertOption]
opts Label
col (Int
prevCount, Pipeline
docs) = do
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
2
then do
Maybe Document
res <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ Notice -> Action IO (Maybe Document)
write (Label -> [InsertOption] -> Pipeline -> Notice
Insert (Label
db Label -> Label -> Label
<.> Label
col) [InsertOption]
opts Pipeline
docs)
let errorMessage :: Maybe Failure
errorMessage = do
Document
jRes <- Maybe Document
res
String
em <- forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"err" Document
jRes
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure Int
prevCount (forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"code" Document
jRes) String
em
case Maybe Failure
errorMessage of
Just Failure
failure -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left Failure
failure
Maybe Failure
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Value
valueAt Label
"_id") Pipeline
docs
else if ServerData -> Int
maxWireVersion ServerData
sd forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17 then do
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$ [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col Pipeline
docs Document
writeConcern
case (forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc, forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc) of
(Maybe Value
Nothing, Maybe Value
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Value
valueAt Label
"_id") Pipeline
docs
(Just (Array [Value]
errs), Maybe Value
Nothing) -> do
let writeErrors :: [Failure]
writeErrors = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
errs
let errorsWithFailureIndex :: [Failure]
errorsWithFailureIndex = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Failure -> Failure
addFailureIndex Int
prevCount) [Failure]
writeErrors
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Failure] -> Failure
CompoundFailure [Failure]
errorsWithFailureIndex
(Maybe Value
Nothing, Just Value
err) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure
Int
prevCount
(forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc)
(forall a. Show a => a -> String
show Value
err)
(Just (Array [Value]
errs), Just Value
writeConcernErr) -> do
let writeErrors :: [Failure]
writeErrors = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
errs
let errorsWithFailureIndex :: [Failure]
errorsWithFailureIndex = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Failure -> Failure
addFailureIndex Int
prevCount) [Failure]
writeErrors
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Failure] -> Failure
CompoundFailure forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure
Int
prevCount
(forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc)
(forall a. Show a => a -> String
show Value
writeConcernErr) forall a. a -> [a] -> [a]
: [Failure]
errorsWithFailureIndex
(Just Value
unknownValue, Maybe Value
Nothing) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> String -> Failure
ProtocolFailure Int
prevCount forall a b. (a -> b) -> a -> b
$ String
"Expected array of errors. Received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownValue
(Just Value
unknownValue, Just Value
writeConcernErr) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Failure] -> Failure
CompoundFailure [ Int -> String -> Failure
ProtocolFailure Int
prevCount forall a b. (a -> b) -> a -> b
$ String
"Expected array of errors. Received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownValue
, Int -> Int -> String -> Failure
WriteFailure Int
prevCount (forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc) forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Value
writeConcernErr]
else do
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document -> Document -> Document
merge Document
params [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$ [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col Pipeline
docs Document
writeConcern
case (forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc, forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc) of
(Maybe Value
Nothing, Maybe Value
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Value
valueAt Label
"_id") Pipeline
docs
(Just (Array [Value]
errs), Maybe Value
Nothing) -> do
let writeErrors :: [Failure]
writeErrors = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
errs
let errorsWithFailureIndex :: [Failure]
errorsWithFailureIndex = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Failure -> Failure
addFailureIndex Int
prevCount) [Failure]
writeErrors
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Failure] -> Failure
CompoundFailure [Failure]
errorsWithFailureIndex
(Maybe Value
Nothing, Just Value
err) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure
Int
prevCount
(forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc)
(forall a. Show a => a -> String
show Value
err)
(Just (Array [Value]
errs), Just Value
writeConcernErr) -> do
let writeErrors :: [Failure]
writeErrors = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
errs
let errorsWithFailureIndex :: [Failure]
errorsWithFailureIndex = forall a b. (a -> b) -> [a] -> [b]
map (Int -> Failure -> Failure
addFailureIndex Int
prevCount) [Failure]
writeErrors
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Failure] -> Failure
CompoundFailure forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure
Int
prevCount
(forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc)
(forall a. Show a => a -> String
show Value
writeConcernErr) forall a. a -> [a] -> [a]
: [Failure]
errorsWithFailureIndex
(Just Value
unknownValue, Maybe Value
Nothing) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> String -> Failure
ProtocolFailure Int
prevCount forall a b. (a -> b) -> a -> b
$ String
"Expected array of errors. Received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownValue
(Just Value
unknownValue, Just Value
writeConcernErr) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Failure] -> Failure
CompoundFailure [ Int -> String -> Failure
ProtocolFailure Int
prevCount forall a b. (a -> b) -> a -> b
$ String
"Expected array of errors. Received: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownValue
, Int -> Int -> String -> Failure
WriteFailure Int
prevCount (forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc) forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Value
writeConcernErr]
splitAtLimit :: Int -> Int -> [Document] -> [Either Failure [Document]]
splitAtLimit :: Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit Int
maxSize Int
maxCount Pipeline
list = forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chop (Int
-> Int
-> Pipeline
-> Pipeline
-> (Either Failure Pipeline, Pipeline)
go Int
0 Int
0 []) Pipeline
list
where
go :: Int -> Int -> [Document] -> [Document] -> (Either Failure [Document], [Document])
go :: Int
-> Int
-> Pipeline
-> Pipeline
-> (Either Failure Pipeline, Pipeline)
go Int
_ Int
_ Pipeline
res [] = (forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse Pipeline
res, [])
go Int
curSize Int
curCount [] (Document
x:Pipeline
xs) |
(Int
curSize forall a. Num a => a -> a -> a
+ Document -> Int
sizeOfDocument Document
x forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ Int
curCount) forall a. Ord a => a -> a -> Bool
> Int
maxSize =
(forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure Int
0 Int
0 String
"One document is too big for the message", Pipeline
xs)
go Int
curSize Int
curCount Pipeline
res (Document
x:Pipeline
xs) =
if ((Int
curSize forall a. Num a => a -> a -> a
+ Document -> Int
sizeOfDocument Document
x forall a. Num a => a -> a -> a
+ Int
2 forall a. Num a => a -> a -> a
+ Int
curCount) forall a. Ord a => a -> a -> Bool
> Int
maxSize)
Bool -> Bool -> Bool
|| ((Int
curCount forall a. Num a => a -> a -> a
+ Int
1) forall a. Ord a => a -> a -> Bool
> Int
maxCount)
then
(forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse Pipeline
res, Document
xforall a. a -> [a] -> [a]
:Pipeline
xs)
else
Int
-> Int
-> Pipeline
-> Pipeline
-> (Either Failure Pipeline, Pipeline)
go (Int
curSize forall a. Num a => a -> a -> a
+ Document -> Int
sizeOfDocument Document
x) (Int
curCount forall a. Num a => a -> a -> a
+ Int
1) (Document
xforall a. a -> [a] -> [a]
:Pipeline
res) Pipeline
xs
chop :: ([a] -> (b, [a])) -> [a] -> [b]
chop :: forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chop [a] -> (b, [a])
_ [] = []
chop [a] -> (b, [a])
f [a]
as = let (b
b, [a]
as') = [a] -> (b, [a])
f [a]
as in b
b forall a. a -> [a] -> [a]
: forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chop [a] -> (b, [a])
f [a]
as'
sizeOfDocument :: Document -> Int
sizeOfDocument :: Document -> Int
sizeOfDocument Document
d = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> CursorId
LBS.length forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut forall a b. (a -> b) -> a -> b
$ Document -> Put
putDocument Document
d
assignId :: Document -> IO Document
assignId :: Document -> IO Document
assignId Document
doc = if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Label
"_id" forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Label
label) Document
doc
then forall (m :: * -> *) a. Monad m => a -> m a
return Document
doc
else (\ObjectId
oid -> (Label
"_id" forall v. Val v => Label -> v -> Field
=: ObjectId
oid) forall a. a -> [a] -> [a]
: Document
doc) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ObjectId
genObjectId
save :: (MonadIO m)
=> Collection -> Document -> Action m ()
save :: forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
save Label
col Document
doc = case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"_id" Document
doc of
Maybe Value
Nothing -> forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
insert_ Label
col Document
doc
Just Value
i -> forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
upsert (Document -> Label -> Selection
Select [Label
"_id" Label -> Value -> Field
:= Value
i] Label
col) Document
doc
replace :: (MonadIO m)
=> Selection -> Document -> Action m ()
replace :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
replace = forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update []
repsert :: (MonadIO m)
=> Selection -> Document -> Action m ()
repsert :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
repsert = forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption
Upsert]
{-# DEPRECATED repsert "use upsert instead" #-}
upsert :: (MonadIO m)
=> Selection -> Document -> Action m ()
upsert :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
upsert = forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption
Upsert]
type Modifier = Document
modify :: (MonadIO m)
=> Selection -> Modifier -> Action m ()
modify :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
modify = forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption
MultiUpdate]
update :: (MonadIO m)
=> [UpdateOption] -> Selection -> Document -> Action m ()
update :: forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption]
opts (Select Document
sel Label
col) Document
up = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then do
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Notice -> Action IO (Maybe Document)
write (Label -> [UpdateOption] -> Document -> Document -> Notice
Update (Label
db Label -> Label -> Label
<.> Label
col) [UpdateOption]
opts Document
sel Document
up)) MongoContext
ctx
else do
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$
Pipe -> [Cmd] -> Maybe FlagBit -> Document -> IO ()
P.sendOpMsg
Pipe
pipe
[Notice -> Cmd
Nc (Label -> [UpdateOption] -> Document -> Document -> Notice
Update (Label
db Label -> Label -> Label
<.> Label
col) [UpdateOption]
opts Document
sel Document
up)]
(forall a. a -> Maybe a
Just FlagBit
P.MoreToCome)
[Label
"writeConcern" forall v. Val v => Label -> v -> Field
=: [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]]
updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
updateCommandDocument :: Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument Label
col Bool
ordered Pipeline
updates Document
writeConcern =
[ Label
"update" forall v. Val v => Label -> v -> Field
=: Label
col
, Label
"ordered" forall v. Val v => Label -> v -> Field
=: Bool
ordered
, Label
"updates" forall v. Val v => Label -> v -> Field
=: Pipeline
updates
, Label
"writeConcern" forall v. Val v => Label -> v -> Field
=: Document
writeConcern
]
updateMany :: (MonadIO m)
=> Collection
-> [(Selector, Document, [UpdateOption])]
-> Action m WriteResult
updateMany :: forall (m :: * -> *).
MonadIO m =>
Label
-> [(Document, Document, [UpdateOption])] -> Action m WriteResult
updateMany = forall (m :: * -> *).
MonadIO m =>
Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
update' Bool
True
updateAll :: (MonadIO m)
=> Collection
-> [(Selector, Document, [UpdateOption])]
-> Action m WriteResult
updateAll :: forall (m :: * -> *).
MonadIO m =>
Label
-> [(Document, Document, [UpdateOption])] -> Action m WriteResult
updateAll = forall (m :: * -> *).
MonadIO m =>
Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
update' Bool
False
update' :: (MonadIO m)
=> Bool
-> Collection
-> [(Selector, Document, [UpdateOption])]
-> Action m WriteResult
update' :: forall (m :: * -> *).
MonadIO m =>
Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
update' Bool
ordered Label
col [(Document, Document, [UpdateOption])]
updateDocs = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
let updates :: Pipeline
updates = forall a b. (a -> b) -> [a] -> [b]
map (\(Document
s, Document
d, [UpdateOption]
os) -> [ Label
"q" forall v. Val v => Label -> v -> Field
=: Document
s
, Label
"u" forall v. Val v => Label -> v -> Field
=: Document
d
, Label
"upsert" forall v. Val v => Label -> v -> Field
=: (UpdateOption
Upsert forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpdateOption]
os)
, Label
"multi" forall v. Val v => Label -> v -> Field
=: (UpdateOption
MultiUpdate forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpdateOption]
os)])
[(Document, Document, [UpdateOption])]
updateDocs
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
let docSize :: Int
docSize = Document -> Int
sizeOfDocument forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument
Label
col
Bool
ordered
[]
Document
writeConcern
let preChunks :: [Either Failure Pipeline]
preChunks = Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit
(ServerData -> Int
maxBsonObjectSize ServerData
sd forall a. Num a => a -> a -> a
- Int
docSize)
(ServerData -> Int
maxWriteBatchSize ServerData
sd)
Pipeline
updates
let chunks :: [Pipeline]
chunks =
if Bool
ordered
then forall a b. [Either a b] -> [b]
takeRightsUpToLeft [Either Failure Pipeline]
preChunks
else forall a b. [Either a b] -> [b]
rights [Either Failure Pipeline]
preChunks
let lens :: [Int]
lens = forall a b. (a -> b) -> [a] -> [b]
map forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pipeline]
chunks
let lSums :: [Int]
lSums = Int
0 forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Int]
lSums [Int]
lens
[WriteResult]
blocks <- forall (m :: * -> *) b a.
(Monad m, Result b) =>
Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor Bool
ordered (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lSums [Pipeline]
chunks) forall a b. (a -> b) -> a -> b
$ \(Int, Pipeline)
b -> do
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
updateBlock Bool
ordered Label
col (Int, Pipeline)
b) MongoContext
ctx
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(Failure
e :: Failure) -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 forall a. Maybe a
Nothing Int
0 [] [Failure
e] []
let failedTotal :: Bool
failedTotal = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WriteResult -> Bool
failed [WriteResult]
blocks
let updatedTotal :: Int
updatedTotal = forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map WriteResult -> Int
nMatched [WriteResult]
blocks
let modifiedTotal :: Maybe Int
modifiedTotal =
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a. Maybe a -> Bool
isNothing forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriteResult -> Maybe Int
nModified) [WriteResult]
blocks
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WriteResult -> Maybe Int
nModified [WriteResult]
blocks
let totalWriteErrors :: [Failure]
totalWriteErrors = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteResult -> [Failure]
writeErrors [WriteResult]
blocks
let totalWriteConcernErrors :: [Failure]
totalWriteConcernErrors = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteResult -> [Failure]
writeConcernErrors [WriteResult]
blocks
let upsertedTotal :: [Upserted]
upsertedTotal = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteResult -> [Upserted]
upserted [WriteResult]
blocks
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
failedTotal
Int
updatedTotal
Maybe Int
modifiedTotal
Int
0
[Upserted]
upsertedTotal
[Failure]
totalWriteErrors
[Failure]
totalWriteConcernErrors
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(Failure
e :: Failure) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 forall a. Maybe a
Nothing Int
0 [] [Failure
e] []
updateBlock :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m WriteResult
updateBlock :: forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
updateBlock Bool
ordered Label
col (Int
prevCount, Pipeline
docs) = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
2
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"updateMany doesn't support mongodb older than 2.6"
else if ServerData -> Int
maxWireVersion ServerData
sd forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17 then do
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let writeErrorsResults :: WriteResult
writeErrorsResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (forall a. a -> Maybe a
Just Int
0) Int
0 [] [] []
Just (Array [Value]
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 (forall a. a -> Maybe a
Just Int
0) Int
0 [] (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
err) []
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(forall a. a -> Maybe a
Just Int
0)
Int
0
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected array of error docs, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
[]
let writeConcernResults :: WriteResult
writeConcernResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (forall a. a -> Maybe a
Just Int
0) Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(forall a. a -> Maybe a
Just Int
0)
Int
0
[]
[]
[ Int -> String -> Failure
WriteConcernFailure
(forall a. a -> Maybe a -> a
fromMaybe (-Int
1) forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"code")
(forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(forall a. a -> Maybe a
Just Int
0)
Int
0
[]
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected doc in writeConcernError, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
let upsertedList :: [Upserted]
upsertedList = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map Document -> Upserted
docToUpserted) (Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"upserted")
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
n (Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"nModified") Int
0 [Upserted]
upsertedList [] []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
writeErrorsResults, WriteResult
writeConcernResults, WriteResult
successResults]
else do
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document -> Document -> Document
merge Document
params [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let writeErrorsResults :: WriteResult
writeErrorsResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (forall a. a -> Maybe a
Just Int
0) Int
0 [] [] []
Just (Array [Value]
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 (forall a. a -> Maybe a
Just Int
0) Int
0 [] (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
err) []
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(forall a. a -> Maybe a
Just Int
0)
Int
0
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected array of error docs, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
[]
let writeConcernResults :: WriteResult
writeConcernResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (forall a. a -> Maybe a
Just Int
0) Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(forall a. a -> Maybe a
Just Int
0)
Int
0
[]
[]
[ Int -> String -> Failure
WriteConcernFailure
(forall a. a -> Maybe a -> a
fromMaybe (-Int
1) forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"code")
(forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(forall a. a -> Maybe a
Just Int
0)
Int
0
[]
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected doc in writeConcernError, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
let upsertedList :: [Upserted]
upsertedList = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (forall a b. (a -> b) -> [a] -> [b]
map Document -> Upserted
docToUpserted) (Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"upserted")
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
n (Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"nModified") Int
0 [Upserted]
upsertedList [] []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
writeErrorsResults, WriteResult
writeConcernResults, WriteResult
successResults]
interruptibleFor :: (Monad m, Result b) => Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor :: forall (m :: * -> *) b a.
(Monad m, Result b) =>
Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor Bool
ordered = [b] -> [a] -> (a -> m b) -> m [b]
go []
where
go :: [b] -> [a] -> (a -> m b) -> m [b]
go ![b]
res [] a -> m b
_ = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [b]
res
go ![b]
res (a
x:[a]
xs) a -> m b
f = do
b
y <- a -> m b
f a
x
if forall a. Result a => a -> Bool
isFailed b
y Bool -> Bool -> Bool
&& Bool
ordered
then forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse (b
yforall a. a -> [a] -> [a]
:[b]
res)
else [b] -> [a] -> (a -> m b) -> m [b]
go (b
yforall a. a -> [a] -> [a]
:[b]
res) [a]
xs a -> m b
f
mergeWriteResults :: WriteResult -> WriteResult -> WriteResult
mergeWriteResults :: WriteResult -> WriteResult -> WriteResult
mergeWriteResults
(WriteResult Bool
failed1 Int
nMatched1 Maybe Int
nModified1 Int
nDeleted1 [Upserted]
upserted1 [Failure]
writeErrors1 [Failure]
writeConcernErrors1)
(WriteResult Bool
failed2 Int
nMatched2 Maybe Int
nModified2 Int
nDeleted2 [Upserted]
upserted2 [Failure]
writeErrors2 [Failure]
writeConcernErrors2) =
Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
(Bool
failed1 Bool -> Bool -> Bool
|| Bool
failed2)
(Int
nMatched1 forall a. Num a => a -> a -> a
+ Int
nMatched2)
(forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall a. Num a => a -> a -> a
(+) Maybe Int
nModified1 Maybe Int
nModified2)
(Int
nDeleted1 forall a. Num a => a -> a -> a
+ Int
nDeleted2)
([Upserted]
upserted2 forall a. [a] -> [a] -> [a]
++ [Upserted]
upserted1)
([Failure]
writeErrors2 forall a. [a] -> [a] -> [a]
++ [Failure]
writeErrors1)
([Failure]
writeConcernErrors2 forall a. [a] -> [a] -> [a]
++ [Failure]
writeConcernErrors1)
docToUpserted :: Document -> Upserted
docToUpserted :: Document -> Upserted
docToUpserted Document
doc = Int -> ObjectId -> Upserted
Upserted Int
ind ObjectId
uid
where
ind :: Int
ind = forall v. Val v => Label -> Document -> v
at Label
"index" Document
doc
uid :: ObjectId
uid = forall v. Val v => Label -> Document -> v
at Label
"_id" Document
doc
docToWriteError :: Document -> Failure
docToWriteError :: Document -> Failure
docToWriteError Document
doc = Int -> Int -> String -> Failure
WriteFailure Int
ind Int
code String
msg
where
ind :: Int
ind = forall v. Val v => Label -> Document -> v
at Label
"index" Document
doc
code :: Int
code = forall v. Val v => Label -> Document -> v
at Label
"code" Document
doc
msg :: String
msg = forall v. Val v => Label -> Document -> v
at Label
"errmsg" Document
doc
delete :: (MonadIO m)
=> Selection -> Action m ()
delete :: forall (m :: * -> *). MonadIO m => Selection -> Action m ()
delete Selection
s = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then forall (m :: * -> *).
MonadIO m =>
[DeleteOption] -> Selection -> Action m ()
deleteHelper [] Selection
s
else forall (m :: * -> *).
MonadIO m =>
Label -> [(Document, [DeleteOption])] -> Action m WriteResult
deleteMany (Selection -> Label
coll Selection
s) [([], [])] forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return ()
deleteOne :: (MonadIO m)
=> Selection -> Action m ()
deleteOne :: forall (m :: * -> *). MonadIO m => Selection -> Action m ()
deleteOne sel :: Selection
sel@((Select Document
sel' Label
col)) = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then forall (m :: * -> *).
MonadIO m =>
[DeleteOption] -> Selection -> Action m ()
deleteHelper [DeleteOption
SingleRemove] Selection
sel
else do
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$
Pipe -> [Cmd] -> Maybe FlagBit -> Document -> IO ()
P.sendOpMsg
Pipe
pipe
[Notice -> Cmd
Nc (Label -> [DeleteOption] -> Document -> Notice
Delete (Label
db Label -> Label -> Label
<.> Label
col) [] Document
sel')]
(forall a. a -> Maybe a
Just FlagBit
P.MoreToCome)
[Label
"writeConcern" forall v. Val v => Label -> v -> Field
=: [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]]
deleteHelper :: (MonadIO m)
=> [DeleteOption] -> Selection -> Action m ()
deleteHelper :: forall (m :: * -> *).
MonadIO m =>
[DeleteOption] -> Selection -> Action m ()
deleteHelper [DeleteOption]
opts (Select Document
sel Label
col) = do
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Notice -> Action IO (Maybe Document)
write (Label -> [DeleteOption] -> Document -> Notice
Delete (Label
db Label -> Label -> Label
<.> Label
col) [DeleteOption]
opts Document
sel)) MongoContext
ctx
deleteMany :: (MonadIO m)
=> Collection
-> [(Selector, [DeleteOption])]
-> Action m WriteResult
deleteMany :: forall (m :: * -> *).
MonadIO m =>
Label -> [(Document, [DeleteOption])] -> Action m WriteResult
deleteMany = forall (m :: * -> *).
MonadIO m =>
Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
delete' Bool
True
deleteAll :: (MonadIO m)
=> Collection
-> [(Selector, [DeleteOption])]
-> Action m WriteResult
deleteAll :: forall (m :: * -> *).
MonadIO m =>
Label -> [(Document, [DeleteOption])] -> Action m WriteResult
deleteAll = forall (m :: * -> *).
MonadIO m =>
Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
delete' Bool
False
deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
deleteCommandDocument :: Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered Pipeline
deletes Document
writeConcern =
[ Label
"delete" forall v. Val v => Label -> v -> Field
=: Label
col
, Label
"ordered" forall v. Val v => Label -> v -> Field
=: Bool
ordered
, Label
"deletes" forall v. Val v => Label -> v -> Field
=: Pipeline
deletes
, Label
"writeConcern" forall v. Val v => Label -> v -> Field
=: Document
writeConcern
]
delete' :: (MonadIO m)
=> Bool
-> Collection
-> [(Selector, [DeleteOption])]
-> Action m WriteResult
delete' :: forall (m :: * -> *).
MonadIO m =>
Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
delete' Bool
ordered Label
col [(Document, [DeleteOption])]
deleteDocs = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
let deletes :: Pipeline
deletes = forall a b. (a -> b) -> [a] -> [b]
map (\(Document
s, [DeleteOption]
os) -> [ Label
"q" forall v. Val v => Label -> v -> Field
=: Document
s
, Label
"limit" forall v. Val v => Label -> v -> Field
=: if DeleteOption
SingleRemove forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeleteOption]
os
then (Int
1 :: Int)
else (Int
0 :: Int)
])
[(Document, [DeleteOption])]
deleteDocs
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
let docSize :: Int
docSize = Document -> Int
sizeOfDocument forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered [] Document
writeConcern
let chunks :: [Either Failure Pipeline]
chunks = Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit
(ServerData -> Int
maxBsonObjectSize ServerData
sd forall a. Num a => a -> a -> a
- Int
docSize)
(ServerData -> Int
maxWriteBatchSize ServerData
sd)
Pipeline
deletes
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
let lens :: [Int]
lens = forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const Int
1) forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Either Failure Pipeline]
chunks
let lSums :: [Int]
lSums = Int
0 forall a. a -> [a] -> [a]
: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. Num a => a -> a -> a
(+) [Int]
lSums [Int]
lens
let failureResult :: Failure -> m WriteResult
failureResult Failure
e = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 forall a. Maybe a
Nothing Int
0 [] [Failure
e] []
let doChunk :: (Int, Pipeline) -> IO WriteResult
doChunk (Int, Pipeline)
b = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
deleteBlock Bool
ordered Label
col (Int, Pipeline)
b) MongoContext
ctx forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` forall {m :: * -> *}. Monad m => Failure -> m WriteResult
failureResult
[WriteResult]
blockResult <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b a.
(Monad m, Result b) =>
Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor Bool
ordered (forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lSums [Either Failure Pipeline]
chunks) forall a b. (a -> b) -> a -> b
$ \(Int
n, Either Failure Pipeline
c) ->
case Either Failure Pipeline
c of
Left Failure
e -> forall {m :: * -> *}. Monad m => Failure -> m WriteResult
failureResult Failure
e
Right Pipeline
b -> (Int, Pipeline) -> IO WriteResult
doChunk (Int
n, Pipeline
b)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult]
blockResult
addFailureIndex :: Int -> Failure -> Failure
addFailureIndex :: Int -> Failure -> Failure
addFailureIndex Int
i (WriteFailure Int
ind Int
code String
s) = Int -> Int -> String -> Failure
WriteFailure (Int
ind forall a. Num a => a -> a -> a
+ Int
i) Int
code String
s
addFailureIndex Int
_ Failure
f = Failure
f
deleteBlock :: (MonadIO m)
=> Bool -> Collection -> (Int, [Document]) -> Action m WriteResult
deleteBlock :: forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
deleteBlock Bool
ordered Label
col (Int
prevCount, Pipeline
docs) = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
2
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IOError -> IO a
ioError forall a b. (a -> b) -> a -> b
$ String -> IOError
userError String
"deleteMany doesn't support mongodb older than 2.6"
else if ServerData -> Int
maxWireVersion ServerData
sd forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17 then do
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 forall a. Maybe a
Nothing Int
n [] [] []
let writeErrorsResults :: WriteResult
writeErrorsResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 forall a. Maybe a
Nothing Int
0 [] [] []
Just (Array [Value]
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 forall a. Maybe a
Nothing Int
0 [] (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
err) []
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
forall a. Maybe a
Nothing
Int
0
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected array of error docs, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
[]
let writeConcernResults :: WriteResult
writeConcernResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 forall a. Maybe a
Nothing Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
forall a. Maybe a
Nothing
Int
0
[]
[]
[ Int -> String -> Failure
WriteConcernFailure
(forall a. a -> Maybe a -> a
fromMaybe (-Int
1) forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"code")
(forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
forall a. Maybe a
Nothing
Int
0
[]
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected doc in writeConcernError, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
successResults, WriteResult
writeErrorsResults, WriteResult
writeConcernResults]
else do
WriteMode
mode <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document -> Document -> Document
merge Document
params [Label
"w" forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = forall a. a -> Maybe a -> a
fromMaybe Int
0 forall a b. (a -> b) -> a -> b
$ Document
doc forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 forall a. Maybe a
Nothing Int
n [] [] []
let writeErrorsResults :: WriteResult
writeErrorsResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 forall a. Maybe a
Nothing Int
0 [] [] []
Just (Array [Value]
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
True Int
0 forall a. Maybe a
Nothing Int
0 [] (forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [Value]
err) []
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
forall a. Maybe a
Nothing
Int
0
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected array of error docs, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
[]
let writeConcernResults :: WriteResult
writeConcernResults =
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 forall a. Maybe a
Nothing Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
forall a. Maybe a
Nothing
Int
0
[]
[]
[ Int -> String -> Failure
WriteConcernFailure
(forall a. a -> Maybe a -> a
fromMaybe (-Int
1) forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"code")
(forall a. a -> Maybe a -> a
fromMaybe String
"" forall a b. (a -> b) -> a -> b
$ Document
err forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
forall a. Maybe a
Nothing
Int
0
[]
[]
[ Int -> String -> Failure
ProtocolFailure
Int
prevCount
forall a b. (a -> b) -> a -> b
$ String
"Expected doc in writeConcernError, but received: "
forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
unknownErr]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
successResults, WriteResult
writeErrorsResults, WriteResult
writeConcernResults]
anyToWriteError :: Int -> Value -> Failure
anyToWriteError :: Int -> Value -> Failure
anyToWriteError Int
_ (Doc Document
d) = Document -> Failure
docToWriteError Document
d
anyToWriteError Int
ind Value
_ = Int -> String -> Failure
ProtocolFailure Int
ind String
"Unknown bson value"
data ReadMode =
Fresh
| StaleOk
deriving (Int -> ReadMode -> ShowS
[ReadMode] -> ShowS
ReadMode -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ReadMode] -> ShowS
$cshowList :: [ReadMode] -> ShowS
show :: ReadMode -> String
$cshow :: ReadMode -> String
showsPrec :: Int -> ReadMode -> ShowS
$cshowsPrec :: Int -> ReadMode -> ShowS
Show, ReadMode -> ReadMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ReadMode -> ReadMode -> Bool
$c/= :: ReadMode -> ReadMode -> Bool
== :: ReadMode -> ReadMode -> Bool
$c== :: ReadMode -> ReadMode -> Bool
Eq)
readModeOption :: ReadMode -> [QueryOption]
readModeOption :: ReadMode -> [QueryOption]
readModeOption ReadMode
Fresh = []
readModeOption ReadMode
StaleOk = [QueryOption
SlaveOK]
data Query = Query {
Query -> [QueryOption]
options :: [QueryOption],
Query -> Selection
selection :: Selection,
Query -> Document
project :: Projector,
Query -> Limit
skip :: Word32,
Query -> Limit
limit :: Limit,
Query -> Document
sort :: Order,
Query -> Bool
snapshot :: Bool,
Query -> Limit
batchSize :: BatchSize,
Query -> Document
hint :: Order
} deriving (Int -> Query -> ShowS
[Query] -> ShowS
Query -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Query] -> ShowS
$cshowList :: [Query] -> ShowS
show :: Query -> String
$cshow :: Query -> String
showsPrec :: Int -> Query -> ShowS
$cshowsPrec :: Int -> Query -> ShowS
Show, Query -> Query -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Query -> Query -> Bool
$c/= :: Query -> Query -> Bool
== :: Query -> Query -> Bool
$c== :: Query -> Query -> Bool
Eq)
type Projector = Document
type Limit = Word32
type Order = Document
type BatchSize = Word32
noticeCommands :: [Text]
noticeCommands :: [Label]
noticeCommands = [ Label
"aggregate"
, Label
"count"
, Label
"delete"
, Label
"findAndModify"
, Label
"insert"
, Label
"listCollections"
, Label
"update"
]
adminCommands :: [Text]
adminCommands :: [Label]
adminCommands = [ Label
"buildinfo"
, Label
"clone"
, Label
"collstats"
, Label
"copydb"
, Label
"copydbgetnonce"
, Label
"create"
, Label
"dbstats"
, Label
"deleteIndexes"
, Label
"drop"
, Label
"dropDatabase"
, Label
"renameCollection"
, Label
"repairDatabase"
, Label
"serverStatus"
, Label
"validate"
]
query :: Selector -> Collection -> Query
query :: Document -> Label -> Query
query Document
sel Label
col = [QueryOption]
-> Selection
-> Document
-> Limit
-> Limit
-> Document
-> Bool
-> Limit
-> Document
-> Query
Query [] (Document -> Label -> Selection
Select Document
sel Label
col) [] Limit
0 Limit
0 [] Bool
False Limit
0 []
find :: MonadIO m => Query -> Action m Cursor
find :: forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find q :: Query
q@Query{Selection
selection :: Selection
selection :: Query -> Selection
selection, Limit
batchSize :: Limit
batchSize :: Query -> Limit
batchSize} = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then do
(Request, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
False Query
q
DelayedBatch
dBatch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [] (Request, Maybe Limit)
qr
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db (Selection -> Label
coll Selection
selection) Limit
batchSize DelayedBatch
dBatch
else do
(Cmd, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q
let newQr :: (Cmd, Maybe Limit)
newQr =
case forall a b. (a, b) -> a
fst (Cmd, Maybe Limit)
qr of
Req Request
qry ->
let coll :: Label
coll = forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ Label -> Label -> [Label]
T.splitOn Label
"." (Request -> Label
qFullCollection Request
qry)
in (Request -> Cmd
Req forall a b. (a -> b) -> a -> b
$ Request
qry {qSelector :: Document
qSelector = Document -> Document -> Document
merge (Request -> Document
qSelector Request
qry) [ Label
"find" forall v. Val v => Label -> v -> Field
=: Label
coll ]}, forall a b. (a, b) -> b
snd (Cmd, Maybe Limit)
qr)
Cmd
_ -> forall a. HasCallStack => String -> a
error String
"impossible"
DelayedBatch
dBatch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Cmd, Maybe Limit)
newQr []
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db (Selection -> Label
coll Selection
selection) Limit
batchSize DelayedBatch
dBatch
findCommand :: (MonadIO m, MonadFail m) => Query -> Action m Cursor
findCommand :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Query -> Action m Cursor
findCommand q :: Query
q@Query{Bool
Document
[QueryOption]
Limit
Selection
hint :: Document
batchSize :: Limit
snapshot :: Bool
sort :: Document
limit :: Limit
skip :: Limit
project :: Document
selection :: Selection
options :: [QueryOption]
hint :: Query -> Document
batchSize :: Query -> Limit
snapshot :: Query -> Bool
skip :: Query -> Limit
project :: Query -> Document
selection :: Query -> Selection
options :: Query -> [QueryOption]
limit :: Query -> Limit
sort :: Query -> Document
..} = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then do
let aColl :: Label
aColl = Selection -> Label
coll Selection
selection
Document
response <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand forall a b. (a -> b) -> a -> b
$
[ Label
"find" forall v. Val v => Label -> v -> Field
=: Label
aColl
, Label
"filter" forall v. Val v => Label -> v -> Field
=: Selection -> Document
selector Selection
selection
, Label
"sort" forall v. Val v => Label -> v -> Field
=: Document
sort
, Label
"projection" forall v. Val v => Label -> v -> Field
=: Document
project
, Label
"hint" forall v. Val v => Label -> v -> Field
=: Document
hint
, Label
"skip" forall v. Val v => Label -> v -> Field
=: forall a. Integral a => a -> Int32
toInt32 Limit
skip
]
forall a. [a] -> [a] -> [a]
++ forall a. Monoid a => [a] -> a
mconcat
[ Label
"batchSize" forall a. Val a => Label -> Maybe a -> Document
=? forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe (forall a. Eq a => a -> a -> Bool
/= Limit
0) forall a. Integral a => a -> Int32
toInt32 Limit
batchSize
, Label
"limit" forall a. Val a => Label -> Maybe a -> Document
=? forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe (forall a. Eq a => a -> a -> Bool
/= Limit
0) forall a. Integral a => a -> Int32
toInt32 Limit
limit
]
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Label -> Document -> Action m (Either String Cursor)
getCursorFromResponse Label
aColl Document
response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String -> Failure
QueryFailure (forall v. Val v => Label -> Document -> v
at Label
"code" Document
response)) forall (m :: * -> *) a. Monad m => a -> m a
return
else forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find Query
q
where
toInt32 :: Integral a => a -> Int32
toInt32 :: forall a. Integral a => a -> Int32
toInt32 = forall a b. (Integral a, Num b) => a -> b
fromIntegral
toMaybe :: (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe :: forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe a -> Bool
predicate a -> b
f a
a
| a -> Bool
predicate a
a = forall a. a -> Maybe a
Just (a -> b
f a
a)
| Bool
otherwise = forall a. Maybe a
Nothing
findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
findOne :: forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne Query
q = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let legacyQuery :: Action m (Maybe Document)
legacyQuery = do
(Request, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
False Query
q {limit :: Limit
limit = Limit
1}
DelayedBatch
rq <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [] (Request, Maybe Limit)
qr
Batch Maybe Limit
_ CursorId
_ Pipeline
docs <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
rq
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Maybe a
listToMaybe Pipeline
docs)
isHandshake :: Bool
isHandshake = (forall a. Eq a => a -> a -> Bool
== [Label
"isMaster" forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]) forall a b. (a -> b) -> a -> b
$ Selection -> Document
selector forall a b. (a -> b) -> a -> b
$ Query -> Selection
selection Query
q :: Bool
if Bool
isHandshake
then Action m (Maybe Document)
legacyQuery
else do
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if (ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17)
then Action m (Maybe Document)
legacyQuery
else do
(Cmd, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q {limit :: Limit
limit = Limit
1}
let newQr :: (Cmd, Maybe Limit)
newQr =
case forall a b. (a, b) -> a
fst (Cmd, Maybe Limit)
qr of
Req Request
qry ->
let coll :: Label
coll = forall a. [a] -> a
last forall a b. (a -> b) -> a -> b
$ Label -> Label -> [Label]
T.splitOn Label
"." (Request -> Label
qFullCollection Request
qry)
labels :: [Value]
labels = forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Label
f -> forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
f forall a b. (a -> b) -> a -> b
$ Request -> Document
qSelector Request
qry) ([Label]
noticeCommands forall a. [a] -> [a] -> [a]
++ [Label]
adminCommands) :: [Value]
in if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
labels
then (Request -> Cmd
Req forall a b. (a -> b) -> a -> b
$ Request
qry {qSelector :: Document
qSelector = Document -> Document -> Document
merge (Request -> Document
qSelector Request
qry) [ Label
"find" forall v. Val v => Label -> v -> Field
=: Label
coll ]}, forall a b. (a, b) -> b
snd (Cmd, Maybe Limit)
qr)
else (Cmd, Maybe Limit)
qr
Cmd
_ -> forall a. HasCallStack => String -> a
error String
"impossible"
DelayedBatch
rq <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Cmd, Maybe Limit)
newQr []
Batch Maybe Limit
_ CursorId
_ Pipeline
docs <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
rq
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> Maybe a
listToMaybe Pipeline
docs)
fetch :: (MonadIO m) => Query -> Action m Document
fetch :: forall (m :: * -> *). MonadIO m => Query -> Action m Document
fetch Query
q = forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne Query
q forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Selection -> Failure
DocNotFound forall a b. (a -> b) -> a -> b
$ Query -> Selection
selection Query
q) forall (m :: * -> *) a. Monad m => a -> m a
return
data FindAndModifyOpts
= FamRemove Bool
| FamUpdate
{ FindAndModifyOpts -> Document
famUpdate :: Document
, FindAndModifyOpts -> Bool
famNew :: Bool
, FindAndModifyOpts -> Bool
famUpsert :: Bool
}
deriving Int -> FindAndModifyOpts -> ShowS
[FindAndModifyOpts] -> ShowS
FindAndModifyOpts -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FindAndModifyOpts] -> ShowS
$cshowList :: [FindAndModifyOpts] -> ShowS
show :: FindAndModifyOpts -> String
$cshow :: FindAndModifyOpts -> String
showsPrec :: Int -> FindAndModifyOpts -> ShowS
$cshowsPrec :: Int -> FindAndModifyOpts -> ShowS
Show
defFamUpdateOpts :: Document -> FindAndModifyOpts
defFamUpdateOpts :: Document -> FindAndModifyOpts
defFamUpdateOpts Document
ups = FamUpdate
{ famNew :: Bool
famNew = Bool
True
, famUpsert :: Bool
famUpsert = Bool
False
, famUpdate :: Document
famUpdate = Document
ups
}
findAndModify :: (MonadIO m, MonadFail m)
=> Query
-> Document
-> Action m (Either String Document)
findAndModify :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Query -> Document -> Action m (Either String Document)
findAndModify Query
q Document
ups = do
Either String (Maybe Document)
eres <- forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Query
-> FindAndModifyOpts -> Action m (Either String (Maybe Document))
findAndModifyOpts Query
q (Document -> FindAndModifyOpts
defFamUpdateOpts Document
ups)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either String (Maybe Document)
eres of
Left String
l -> forall a b. a -> Either a b
Left String
l
Right Maybe Document
r -> case Maybe Document
r of
Maybe Document
Nothing -> forall a b. a -> Either a b
Left String
"findAndModify: impossible null result"
Just Document
doc -> forall a b. b -> Either a b
Right Document
doc
findAndModifyOpts :: (MonadIO m, MonadFail m)
=> Query
-> FindAndModifyOpts
-> Action m (Either String (Maybe Document))
findAndModifyOpts :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Query
-> FindAndModifyOpts -> Action m (Either String (Maybe Document))
findAndModifyOpts Query {
selection :: Query -> Selection
selection = Select Document
sel Label
collection
, project :: Query -> Document
project = Document
project
, sort :: Query -> Document
sort = Document
sort
} FindAndModifyOpts
famOpts = do
Document
result <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand
([ Label
"findAndModify" Label -> Value -> Field
:= Label -> Value
String Label
collection
, Label
"query" Label -> Value -> Field
:= Document -> Value
Doc Document
sel
, Label
"fields" Label -> Value -> Field
:= Document -> Value
Doc Document
project
, Label
"sort" Label -> Value -> Field
:= Document -> Value
Doc Document
sort
] forall a. [a] -> [a] -> [a]
++
case FindAndModifyOpts
famOpts of
FamRemove Bool
shouldRemove -> [ Label
"remove" Label -> Value -> Field
:= Bool -> Value
Bool Bool
shouldRemove ]
FamUpdate {Bool
Document
famUpsert :: Bool
famNew :: Bool
famUpdate :: Document
famUpsert :: FindAndModifyOpts -> Bool
famNew :: FindAndModifyOpts -> Bool
famUpdate :: FindAndModifyOpts -> Document
..} ->
[ Label
"update" Label -> Value -> Field
:= Document -> Value
Doc Document
famUpdate
, Label
"new" Label -> Value -> Field
:= Bool -> Value
Bool Bool
famNew
, Label
"upsert" Label -> Value -> Field
:= Bool -> Value
Bool Bool
famUpsert
])
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Document -> Maybe String
lookupErr Document
result of
Just String
e -> String -> Either String (Maybe Document)
leftErr String
e
Maybe String
Nothing -> case forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"value" Document
result of
Maybe (Maybe Document)
Nothing -> String -> Either String (Maybe Document)
leftErr String
"no document found"
Just Maybe Document
mdoc -> case Maybe Document
mdoc of
Just doc :: Document
doc@(Field
_:Document
_) -> forall a b. b -> Either a b
Right (forall a. a -> Maybe a
Just Document
doc)
Just [] -> case FindAndModifyOpts
famOpts of
FamUpdate { famUpsert :: FindAndModifyOpts -> Bool
famUpsert = Bool
True, famNew :: FindAndModifyOpts -> Bool
famNew = Bool
False } -> forall a b. b -> Either a b
Right forall a. Maybe a
Nothing
FindAndModifyOpts
_ -> String -> Either String (Maybe Document)
leftErr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Document
result
Maybe Document
_ -> String -> Either String (Maybe Document)
leftErr forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Document
result
where
leftErr :: String -> Either String (Maybe Document)
leftErr String
err = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"findAndModify " forall a. Monoid a => a -> a -> a
`mappend` forall a. Show a => a -> String
show Label
collection
forall a. Monoid a => a -> a -> a
`mappend` String
"\nfrom query: " forall a. Monoid a => a -> a -> a
`mappend` forall a. Show a => a -> String
show Document
sel
forall a. Monoid a => a -> a -> a
`mappend` String
"\nerror: " forall a. Monoid a => a -> a -> a
`mappend` String
err
lookupErr :: Document -> Maybe String
lookupErr :: Document -> Maybe String
lookupErr Document
result = do
Document
errObject <- forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"lastErrorObject" Document
result
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"err" Document
errObject
explain :: (MonadIO m) => Query -> Action m Document
explain :: forall (m :: * -> *). MonadIO m => Query -> Action m Document
explain Query
q = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
(Request, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
True Query
q {limit :: Limit
limit = Limit
1}
DelayedBatch
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [] (Request, Maybe Limit)
qr
Batch Maybe Limit
_ CursorId
_ Pipeline
docs <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
r
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs then forall a. HasCallStack => String -> a
error (String
"no explain: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Query
q) else forall a. [a] -> a
head Pipeline
docs
count :: (MonadIO m) => Query -> Action m Int
count :: forall (m :: * -> *). MonadIO m => Query -> Action m Int
count Query{selection :: Query -> Selection
selection = Select Document
sel Label
col, Limit
skip :: Limit
skip :: Query -> Limit
skip, Limit
limit :: Limit
limit :: Query -> Limit
limit} = forall v. Val v => Label -> Document -> v
at Label
"n" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand
([Label
"count" forall v. Val v => Label -> v -> Field
=: Label
col, Label
"query" forall v. Val v => Label -> v -> Field
=: Document
sel, Label
"skip" forall v. Val v => Label -> v -> Field
=: (forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
skip :: Int32)]
forall a. [a] -> [a] -> [a]
++ (Label
"limit" forall a. Val a => Label -> Maybe a -> Document
=? if Limit
limit forall a. Eq a => a -> a -> Bool
== Limit
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
limit :: Int32)))
distinct :: (MonadIO m) => Label -> Selection -> Action m [Value]
distinct :: forall (m :: * -> *).
MonadIO m =>
Label -> Selection -> Action m [Value]
distinct Label
k (Select Document
sel Label
col) = forall v. Val v => Label -> Document -> v
at Label
"values" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"distinct" forall v. Val v => Label -> v -> Field
=: Label
col, Label
"key" forall v. Val v => Label -> v -> Field
=: Label
k, Label
"query" forall v. Val v => Label -> v -> Field
=: Document
sel]
queryRequest :: (Monad m, MonadIO m) => Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest :: forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
isExplain Query{Bool
Document
[QueryOption]
Limit
Selection
hint :: Document
batchSize :: Limit
snapshot :: Bool
sort :: Document
limit :: Limit
skip :: Limit
project :: Document
selection :: Selection
options :: [QueryOption]
hint :: Query -> Document
batchSize :: Query -> Limit
snapshot :: Query -> Bool
skip :: Query -> Limit
project :: Query -> Document
selection :: Query -> Selection
options :: Query -> [QueryOption]
limit :: Query -> Limit
sort :: Query -> Document
..} = do
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ReadMode -> Label -> (Request, Maybe Limit)
queryRequest' (MongoContext -> ReadMode
mongoReadMode MongoContext
ctx) (MongoContext -> Label
mongoDatabase MongoContext
ctx)
where
queryRequest' :: ReadMode -> Label -> (Request, Maybe Limit)
queryRequest' ReadMode
rm Label
db = (P.Query{Int32
Document
[QueryOption]
Label
qSelector :: Document
qProjector :: Document
qBatchSize :: Int32
qSkip :: Int32
qFullCollection :: Label
qOptions :: [QueryOption]
qSkip :: Int32
qSelector :: Document
qProjector :: Document
qOptions :: [QueryOption]
qFullCollection :: Label
qBatchSize :: Int32
..}, Maybe Limit
remainingLimit) where
qOptions :: [QueryOption]
qOptions = ReadMode -> [QueryOption]
readModeOption ReadMode
rm forall a. [a] -> [a] -> [a]
++ [QueryOption]
options
qFullCollection :: Label
qFullCollection = Label
db Label -> Label -> Label
<.> Selection -> Label
coll Selection
selection
qSkip :: Int32
qSkip = forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
skip
(Int32
qBatchSize, Maybe Limit
remainingLimit) = Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize (if Limit
limit forall a. Eq a => a -> a -> Bool
== Limit
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Limit
limit)
qProjector :: Document
qProjector = Document
project
mOrder :: Maybe Field
mOrder = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
sort then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Label
"$orderby" forall v. Val v => Label -> v -> Field
=: Document
sort)
mSnapshot :: Maybe Field
mSnapshot = if Bool
snapshot then forall a. a -> Maybe a
Just (Label
"$snapshot" forall v. Val v => Label -> v -> Field
=: Bool
True) else forall a. Maybe a
Nothing
mHint :: Maybe Field
mHint = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
hint then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Label
"$hint" forall v. Val v => Label -> v -> Field
=: Document
hint)
mExplain :: Maybe Field
mExplain = if Bool
isExplain then forall a. a -> Maybe a
Just (Label
"$explain" forall v. Val v => Label -> v -> Field
=: Bool
True) else forall a. Maybe a
Nothing
special :: Document
special = forall a. [Maybe a] -> [a]
catMaybes [Maybe Field
mOrder, Maybe Field
mSnapshot, Maybe Field
mHint, Maybe Field
mExplain]
qSelector :: Document
qSelector = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
special then Document
s else (Label
"$query" forall v. Val v => Label -> v -> Field
=: Document
s) forall a. a -> [a] -> [a]
: Document
special where s :: Document
s = Selection -> Document
selector Selection
selection
queryRequestOpMsg :: (Monad m, MonadIO m) => Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg :: forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
isExplain Query{Bool
Document
[QueryOption]
Limit
Selection
hint :: Document
batchSize :: Limit
snapshot :: Bool
sort :: Document
limit :: Limit
skip :: Limit
project :: Document
selection :: Selection
options :: [QueryOption]
hint :: Query -> Document
batchSize :: Query -> Limit
snapshot :: Query -> Bool
skip :: Query -> Limit
project :: Query -> Document
selection :: Query -> Selection
options :: Query -> [QueryOption]
limit :: Query -> Limit
sort :: Query -> Document
..} = do
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ReadMode -> Label -> (Cmd, Maybe Limit)
queryRequest' (MongoContext -> ReadMode
mongoReadMode MongoContext
ctx) (MongoContext -> Label
mongoDatabase MongoContext
ctx)
where
queryRequest' :: ReadMode -> Label -> (Cmd, Maybe Limit)
queryRequest' ReadMode
rm Label
db = (Request -> Cmd
Req P.Query{Int32
Document
[QueryOption]
Label
qSelector :: Document
qProjector :: Document
qBatchSize :: Int32
qSkip :: Int32
qFullCollection :: Label
qOptions :: [QueryOption]
qSkip :: Int32
qSelector :: Document
qProjector :: Document
qOptions :: [QueryOption]
qFullCollection :: Label
qBatchSize :: Int32
..}, Maybe Limit
remainingLimit) where
qOptions :: [QueryOption]
qOptions = ReadMode -> [QueryOption]
readModeOption ReadMode
rm forall a. [a] -> [a] -> [a]
++ [QueryOption]
options
qFullCollection :: Label
qFullCollection = Label
db Label -> Label -> Label
<.> Selection -> Label
coll Selection
selection
qSkip :: Int32
qSkip = forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
skip
(Int32
qBatchSize, Maybe Limit
remainingLimit) = Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize (if Limit
limit forall a. Eq a => a -> a -> Bool
== Limit
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just Limit
limit)
isNotCommand :: Bool
isNotCommand = forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\Label
l -> forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
l (Selection -> Document
selector Selection
selection)) ([Label]
noticeCommands forall a. [a] -> [a] -> [a]
++ [Label]
adminCommands)
mOrder :: Maybe Field
mOrder = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
sort then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Label
"sort" forall v. Val v => Label -> v -> Field
=: Document
sort)
mSnapshot :: Maybe Field
mSnapshot = if Bool
snapshot then forall a. a -> Maybe a
Just (Label
"snapshot" forall v. Val v => Label -> v -> Field
=: Bool
True) else forall a. Maybe a
Nothing
mHint :: Maybe Field
mHint = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
hint then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Label
"hint" forall v. Val v => Label -> v -> Field
=: Document
hint)
mExplain :: Maybe Field
mExplain = if Bool
isExplain then forall a. a -> Maybe a
Just (Label
"$explain" forall v. Val v => Label -> v -> Field
=: Bool
True) else forall a. Maybe a
Nothing
special :: Document
special = forall a. [Maybe a] -> [a]
catMaybes [Maybe Field
mOrder, Maybe Field
mSnapshot, Maybe Field
mHint, Maybe Field
mExplain]
qProjector :: Document
qProjector = if Bool
isNotCommand then [Label
"projection" forall v. Val v => Label -> v -> Field
=: Document
project] else Document
project
qSelector :: Document
qSelector = if Bool
isNotCommand then Document
c else Document
s
where s :: Document
s = Selection -> Document
selector Selection
selection
bSize :: Maybe Field
bSize = if Int32
qBatchSize forall a. Eq a => a -> a -> Bool
== Int32
0 then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just (Label
"batchSize" forall v. Val v => Label -> v -> Field
=: Int32
qBatchSize)
mLimit :: Maybe Field
mLimit = if Limit
limit forall a. Eq a => a -> a -> Bool
== Limit
0 then forall a. Maybe a
Nothing else forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing (\Limit
rL -> forall a. a -> Maybe a
Just (Label
"limit" forall v. Val v => Label -> v -> Field
=: (forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
rL :: Int32))) Maybe Limit
remainingLimit
c :: Document
c = (Label
"filter" forall v. Val v => Label -> v -> Field
=: Document
s) forall a. a -> [a] -> [a]
: Document
special forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe Field
bSize forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe Field
mLimit
batchSizeRemainingLimit :: BatchSize -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit :: Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize Maybe Limit
mLimit =
let remaining :: Limit
remaining =
case Maybe Limit
mLimit of
Maybe Limit
Nothing -> Limit
batchSize
Just Limit
limit ->
if Limit
0 forall a. Ord a => a -> a -> Bool
< Limit
batchSize Bool -> Bool -> Bool
&& Limit
batchSize forall a. Ord a => a -> a -> Bool
< Limit
limit
then Limit
batchSize
else Limit
limit
in (forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
remaining, Maybe Limit
mLimit)
type DelayedBatch = IO Batch
data Batch = Batch (Maybe Limit) CursorId [Document]
request :: Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request :: Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [Notice]
ns (Request
req, Maybe Limit
remainingLimit) = do
IO Reply
promise <- forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> Request -> IO (IO Reply)
P.call Pipe
pipe [Notice]
ns Request
req
let protectedPromise :: IO Reply
protectedPromise = forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure IO Reply
promise
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> Reply -> DelayedBatch
fromReply Maybe Limit
remainingLimit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Reply
protectedPromise
requestOpMsg :: Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg :: Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Req Request
r, Maybe Limit
remainingLimit) Document
params = do
IO Reply
promise <- forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> Request -> Maybe FlagBit -> Document -> IO (IO Reply)
P.callOpMsg Pipe
pipe Request
r forall a. Maybe a
Nothing Document
params
let protectedPromise :: IO Reply
protectedPromise = forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure IO Reply
promise
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> Reply -> DelayedBatch
fromReply Maybe Limit
remainingLimit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Reply
protectedPromise
requestOpMsg Pipe
_ (Nc Notice
_, Maybe Limit
_) Document
_ = forall a. HasCallStack => String -> a
error String
"requestOpMsg: Only messages of type Query are supported"
fromReply :: Maybe Limit -> Reply -> DelayedBatch
fromReply :: Maybe Limit -> Reply -> DelayedBatch
fromReply Maybe Limit
limit Reply{Int32
CursorId
Pipeline
[ResponseFlag]
rDocuments :: Reply -> Pipeline
rStartingFrom :: Reply -> Int32
rCursorId :: Reply -> CursorId
rResponseFlags :: Reply -> [ResponseFlag]
rDocuments :: Pipeline
rStartingFrom :: Int32
rCursorId :: CursorId
rResponseFlags :: [ResponseFlag]
..} = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ResponseFlag -> IO ()
checkResponseFlag [ResponseFlag]
rResponseFlags
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
rCursorId Pipeline
rDocuments)
where
checkResponseFlag :: ResponseFlag -> IO ()
checkResponseFlag ResponseFlag
flag = case ResponseFlag
flag of
ResponseFlag
AwaitCapable -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
ResponseFlag
CursorNotFound -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ CursorId -> Failure
CursorNotFoundFailure CursorId
rCursorId
ResponseFlag
QueryError -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ Int -> String -> Failure
QueryFailure (forall v. Val v => Label -> Document -> v
at Label
"code" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head Pipeline
rDocuments) (forall v. Val v => Label -> Document -> v
at Label
"$err" forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head Pipeline
rDocuments)
fromReply Maybe Limit
limit ReplyOpMsg{Pipeline
[FlagBit]
Maybe Int32
checksum :: Reply -> Maybe Int32
sections :: Reply -> Pipeline
flagBits :: Reply -> [FlagBit]
checksum :: Maybe Int32
sections :: Pipeline
flagBits :: [FlagBit]
..} = do
let section :: Document
section = forall a. [a] -> a
head Pipeline
sections
cur :: Maybe Document
cur = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Maybe a
Nothing forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"cursor" Document
section
case Maybe Document
cur of
Maybe Document
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
0 Pipeline
sections)
Just Document
doc ->
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"firstBatch" Document
doc of
Just Value
ar -> do
let docs :: Pipeline
docs = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast Value
ar
id' :: CursorId
id' = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast forall a b. (a -> b) -> a -> b
$ Label -> Document -> Value
valueAt Label
"id" Document
doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
id' Pipeline
docs)
Maybe Value
Nothing -> do
let docs :: Pipeline
docs = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast forall a b. (a -> b) -> a -> b
$ Label -> Document -> Value
valueAt Label
"nextBatch" Document
doc
id' :: CursorId
id' = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast forall a b. (a -> b) -> a -> b
$ Label -> Document -> Value
valueAt Label
"id" Document
doc
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
id' Pipeline
docs)
fulfill :: DelayedBatch -> Action IO Batch
fulfill :: DelayedBatch -> ReaderT MongoContext IO Batch
fulfill = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
newCursor :: MonadIO m => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
newCursor :: forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
col Limit
batchSize DelayedBatch
dBatch = do
MVar DelayedBatch
var <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
MV.newMVar DelayedBatch
dBatch
let cursor :: Cursor
cursor = Label -> Limit -> MVar DelayedBatch -> Cursor
Cursor (Label
db Label -> Label -> Label
<.> Label
col) Limit
batchSize MVar DelayedBatch
var
Weak (MVar DelayedBatch)
_ <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ forall a.
MVar a -> ReaderT MongoContext IO () -> Action IO (Weak (MVar a))
mkWeakMVar MVar DelayedBatch
var (forall (m :: * -> *). MonadIO m => Cursor -> Action m ()
closeCursor Cursor
cursor)
forall (m :: * -> *) a. Monad m => a -> m a
return Cursor
cursor
nextBatch :: MonadIO m => Cursor -> Action m [Document]
nextBatch :: forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
nextBatch (Cursor Label
fcol Limit
batchSize MVar DelayedBatch
var) = forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar DelayedBatch
var forall a b. (a -> b) -> a -> b
$ \DelayedBatch
dBatch -> do
Batch Maybe Limit
mLimit CursorId
cid Pipeline
docs <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ Label -> Limit -> DelayedBatch -> ReaderT MongoContext IO Batch
fulfill' Label
fcol Limit
batchSize DelayedBatch
dBatch
let newLimit :: Maybe Limit
newLimit = do
Limit
limit <- Maybe Limit
mLimit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Limit
limit forall a. Num a => a -> a -> a
- forall a. Ord a => a -> a -> a
min Limit
limit (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Int
length Pipeline
docs)
let emptyBatch :: DelayedBatch
emptyBatch = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch (forall a. a -> Maybe a
Just Limit
0) CursorId
0 []
let getNextBatch :: ReaderT MongoContext IO DelayedBatch
getNextBatch = forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
newLimit CursorId
cid
let resultDocs :: Pipeline
resultDocs = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a. Int -> [a] -> [a]
take forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Limit
mLimit Pipeline
docs
case (CursorId
cid, Maybe Limit
newLimit) of
(CursorId
0, Maybe Limit
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
emptyBatch, Pipeline
resultDocs)
(CursorId
_, Just Limit
0) -> do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> IO ()
P.send Pipe
pipe [[CursorId] -> Notice
KillCursors [CursorId
cid]]
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
emptyBatch, Pipeline
resultDocs)
(CursorId
_, Maybe Limit
_) -> (, Pipeline
resultDocs) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT MongoContext IO DelayedBatch
getNextBatch
fulfill' :: FullCollection -> BatchSize -> DelayedBatch -> Action IO Batch
fulfill' :: Label -> Limit -> DelayedBatch -> ReaderT MongoContext IO Batch
fulfill' Label
fcol Limit
batchSize DelayedBatch
dBatch = do
b :: Batch
b@(Batch Maybe Limit
limit CursorId
cid Pipeline
docs) <- DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
dBatch
if CursorId
cid forall a. Eq a => a -> a -> Bool
/= CursorId
0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs Bool -> Bool -> Bool
&& (Maybe Limit
limit forall a. Ord a => a -> a -> Bool
> forall a. a -> Maybe a
Just Limit
0)
then forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
limit CursorId
cid forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= DelayedBatch -> ReaderT MongoContext IO Batch
fulfill
else forall (m :: * -> *) a. Monad m => a -> m a
return Batch
b
nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' :: forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
limit CursorId
cid = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [] (Label -> Int32 -> CursorId -> Request
GetMore Label
fcol Int32
batchSize' CursorId
cid, Maybe Limit
remLimit)
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Request -> Cmd
Req forall a b. (a -> b) -> a -> b
$ Label -> Int32 -> CursorId -> Request
GetMore Label
fcol Int32
batchSize' CursorId
cid, Maybe Limit
remLimit) []
where (Int32
batchSize', Maybe Limit
remLimit) = Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize Maybe Limit
limit
next :: MonadIO m => Cursor -> Action m (Maybe Document)
next :: forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Document)
next (Cursor Label
fcol Limit
batchSize MVar DelayedBatch
var) = forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar DelayedBatch
var DelayedBatch
-> ReaderT MongoContext IO (DelayedBatch, Maybe Document)
nextState where
nextState :: DelayedBatch
-> ReaderT MongoContext IO (DelayedBatch, Maybe Document)
nextState DelayedBatch
dBatch = do
Batch Maybe Limit
mLimit CursorId
cid Pipeline
docs <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ Label -> Limit -> DelayedBatch -> ReaderT MongoContext IO Batch
fulfill' Label
fcol Limit
batchSize DelayedBatch
dBatch
if Maybe Limit
mLimit forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Limit
0
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch (forall a. a -> Maybe a
Just Limit
0) CursorId
0 [], forall a. Maybe a
Nothing)
else
case Pipeline
docs of
Document
doc : Pipeline
docs' -> do
let newLimit :: Maybe Limit
newLimit = do
Limit
limit <- Maybe Limit
mLimit
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Limit
limit forall a. Num a => a -> a -> a
- Limit
1
DelayedBatch
dBatch' <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs' Bool -> Bool -> Bool
&& CursorId
cid forall a. Eq a => a -> a -> Bool
/= CursorId
0 Bool -> Bool -> Bool
&& ((Maybe Limit
newLimit forall a. Ord a => a -> a -> Bool
> forall a. a -> Maybe a
Just Limit
0) Bool -> Bool -> Bool
|| forall a. Maybe a -> Bool
isNothing Maybe Limit
newLimit)
then forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
newLimit CursorId
cid
else forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
newLimit CursorId
cid Pipeline
docs')
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Limit
newLimit forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Limit
0) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CursorId
cid forall a. Eq a => a -> a -> Bool
== CursorId
0) forall a b. (a -> b) -> a -> b
$ do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> IO ()
P.send Pipe
pipe [[CursorId] -> Notice
KillCursors [CursorId
cid]]
else forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> [Cmd] -> Maybe FlagBit -> Document -> IO ()
P.sendOpMsg Pipe
pipe [KillC -> Cmd
Kc (Notice -> Label -> KillC
P.KillC ([CursorId] -> Notice
KillCursors [CursorId
cid]) Label
fcol)] (forall a. a -> Maybe a
Just FlagBit
MoreToCome) []
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
dBatch', forall a. a -> Maybe a
Just Document
doc)
[] -> if CursorId
cid forall a. Eq a => a -> a -> Bool
== CursorId
0
then forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch (forall a. a -> Maybe a
Just Limit
0) CursorId
0 [], forall a. Maybe a
Nothing)
else do
DelayedBatch
nb <- forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
mLimit CursorId
cid
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
nb, forall a. Maybe a
Nothing)
nextN :: MonadIO m => Int -> Cursor -> Action m [Document]
nextN :: forall (m :: * -> *).
MonadIO m =>
Int -> Cursor -> Action m Pipeline
nextN Int
n Cursor
c = forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Document)
next Cursor
c)
rest :: MonadIO m => Cursor -> Action m [Document]
rest :: forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest Cursor
c = forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
loop (forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Document)
next Cursor
c)
closeCursor :: MonadIO m => Cursor -> Action m ()
closeCursor :: forall (m :: * -> *). MonadIO m => Cursor -> Action m ()
closeCursor (Cursor Label
_ Limit
_ MVar DelayedBatch
var) = forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar DelayedBatch
var forall a b. (a -> b) -> a -> b
$ \DelayedBatch
dBatch -> do
Batch Maybe Limit
_ CursorId
cid Pipeline
_ <- DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
dBatch
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CursorId
cid forall a. Eq a => a -> a -> Bool
== CursorId
0) forall a b. (a -> b) -> a -> b
$ do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> IO ()
P.send Pipe
pipe [[CursorId] -> Notice
KillCursors [CursorId
cid]]
forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch (forall a. a -> Maybe a
Just Limit
0) CursorId
0 [], ())
isCursorClosed :: MonadIO m => Cursor -> Action m Bool
isCursorClosed :: forall (m :: * -> *). MonadIO m => Cursor -> Action m Bool
isCursorClosed (Cursor Label
_ Limit
_ MVar DelayedBatch
var) = do
Batch Maybe Limit
_ CursorId
cid Pipeline
docs <- forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB forall a b. (a -> b) -> a -> b
$ DelayedBatch -> ReaderT MongoContext IO Batch
fulfill forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar DelayedBatch
var
forall (m :: * -> *) a. Monad m => a -> m a
return (CursorId
cid forall a. Eq a => a -> a -> Bool
== CursorId
0 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs)
type Pipeline = [Document]
aggregate :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> Action m [Document]
aggregate :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Label -> Pipeline -> Action m Pipeline
aggregate Label
aColl Pipeline
agg = do
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Label -> Pipeline -> AggregateConfig -> Action m Cursor
aggregateCursor Label
aColl Pipeline
agg forall a. Default a => a
def forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest
data AggregateConfig = AggregateConfig
{ AggregateConfig -> Bool
allowDiskUse :: Bool
}
deriving Int -> AggregateConfig -> ShowS
[AggregateConfig] -> ShowS
AggregateConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AggregateConfig] -> ShowS
$cshowList :: [AggregateConfig] -> ShowS
show :: AggregateConfig -> String
$cshow :: AggregateConfig -> String
showsPrec :: Int -> AggregateConfig -> ShowS
$cshowsPrec :: Int -> AggregateConfig -> ShowS
Show
instance Default AggregateConfig where
def :: AggregateConfig
def = AggregateConfig
{ allowDiskUse :: Bool
allowDiskUse = Bool
False
}
aggregateCommand :: Collection -> Pipeline -> AggregateConfig -> Document
aggregateCommand :: Label -> Pipeline -> AggregateConfig -> Document
aggregateCommand Label
aColl Pipeline
agg AggregateConfig {Bool
allowDiskUse :: Bool
allowDiskUse :: AggregateConfig -> Bool
..} =
[ Label
"aggregate" forall v. Val v => Label -> v -> Field
=: Label
aColl
, Label
"pipeline" forall v. Val v => Label -> v -> Field
=: Pipeline
agg
, Label
"cursor" forall v. Val v => Label -> v -> Field
=: ([] :: Document)
, Label
"allowDiskUse" forall v. Val v => Label -> v -> Field
=: Bool
allowDiskUse
]
aggregateCursor :: (MonadIO m, MonadFail m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
aggregateCursor :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Label -> Pipeline -> AggregateConfig -> Action m Cursor
aggregateCursor Label
aColl Pipeline
agg AggregateConfig
cfg = do
Pipe
pipe <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
< Int
17
then do
Document
response <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Label -> Pipeline -> AggregateConfig -> Document
aggregateCommand Label
aColl Pipeline
agg AggregateConfig
cfg)
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Label -> Document -> Action m (Either String Cursor)
getCursorFromResponse Label
aColl Document
response
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Failure
AggregateFailure) forall (m :: * -> *) a. Monad m => a -> m a
return
else do
let q :: Query
q = forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select (Label -> Pipeline -> AggregateConfig -> Document
aggregateCommand Label
aColl Pipeline
agg AggregateConfig
cfg) Label
aColl
(Cmd, Maybe Limit)
qr <- forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q
DelayedBatch
dBatch <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Cmd, Maybe Limit)
qr []
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
aColl Limit
0 DelayedBatch
dBatch
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Failure
AggregateFailure) forall (m :: * -> *) a. Monad m => a -> m a
return
getCursorFromResponse
:: (MonadIO m, MonadFail m)
=> Collection
-> Document
-> Action m (Either String Cursor)
getCursorFromResponse :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Label -> Document -> Action m (Either String Cursor)
getCursorFromResponse Label
aColl Document
response
| Label -> Document -> Bool
true1 Label
"ok" Document
response = do
Document
cursor <- forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"cursor" Document
response
Pipeline
firstBatch <- forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"firstBatch" Document
cursor
CursorId
cursorId <- forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"id" Document
cursor
Label
db <- forall (m :: * -> *). Monad m => Action m Label
thisDatabase
forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
aColl Limit
0 (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch forall a. Maybe a
Nothing CursorId
cursorId Pipeline
firstBatch)
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall v. Val v => Label -> Document -> v
at Label
"errmsg" Document
response
data Group = Group {
Group -> Label
gColl :: Collection,
Group -> GroupKey
gKey :: GroupKey,
Group -> FinalizeFun
gReduce :: Javascript,
Group -> Document
gInitial :: Document,
Group -> Document
gCond :: Selector,
Group -> Maybe FinalizeFun
gFinalize :: Maybe Javascript
} deriving (Int -> Group -> ShowS
[Group] -> ShowS
Group -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Group] -> ShowS
$cshowList :: [Group] -> ShowS
show :: Group -> String
$cshow :: Group -> String
showsPrec :: Int -> Group -> ShowS
$cshowsPrec :: Int -> Group -> ShowS
Show, Group -> Group -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Group -> Group -> Bool
$c/= :: Group -> Group -> Bool
== :: Group -> Group -> Bool
$c== :: Group -> Group -> Bool
Eq)
data GroupKey = Key [Label] | KeyF Javascript deriving (Int -> GroupKey -> ShowS
[GroupKey] -> ShowS
GroupKey -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GroupKey] -> ShowS
$cshowList :: [GroupKey] -> ShowS
show :: GroupKey -> String
$cshow :: GroupKey -> String
showsPrec :: Int -> GroupKey -> ShowS
$cshowsPrec :: Int -> GroupKey -> ShowS
Show, GroupKey -> GroupKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GroupKey -> GroupKey -> Bool
$c/= :: GroupKey -> GroupKey -> Bool
== :: GroupKey -> GroupKey -> Bool
$c== :: GroupKey -> GroupKey -> Bool
Eq)
groupDocument :: Group -> Document
groupDocument :: Group -> Document
groupDocument Group{Document
Maybe FinalizeFun
Label
FinalizeFun
GroupKey
gFinalize :: Maybe FinalizeFun
gCond :: Document
gInitial :: Document
gReduce :: FinalizeFun
gKey :: GroupKey
gColl :: Label
gFinalize :: Group -> Maybe FinalizeFun
gCond :: Group -> Document
gInitial :: Group -> Document
gReduce :: Group -> FinalizeFun
gKey :: Group -> GroupKey
gColl :: Group -> Label
..} =
(Label
"finalize" forall a. Val a => Label -> Maybe a -> Document
=? Maybe FinalizeFun
gFinalize) forall a. [a] -> [a] -> [a]
++ [
Label
"ns" forall v. Val v => Label -> v -> Field
=: Label
gColl,
case GroupKey
gKey of Key [Label]
k -> Label
"key" forall v. Val v => Label -> v -> Field
=: forall a b. (a -> b) -> [a] -> [b]
map (forall v. Val v => Label -> v -> Field
=: Bool
True) [Label]
k; KeyF FinalizeFun
f -> Label
"$keyf" forall v. Val v => Label -> v -> Field
=: FinalizeFun
f,
Label
"$reduce" forall v. Val v => Label -> v -> Field
=: FinalizeFun
gReduce,
Label
"initial" forall v. Val v => Label -> v -> Field
=: Document
gInitial,
Label
"cond" forall v. Val v => Label -> v -> Field
=: Document
gCond ]
group :: (MonadIO m) => Group -> Action m [Document]
group :: forall (m :: * -> *). MonadIO m => Group -> Action m Pipeline
group Group
g = forall v. Val v => Label -> Document -> v
at Label
"retval" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"group" forall v. Val v => Label -> v -> Field
=: Group -> Document
groupDocument Group
g]
data MapReduce = MapReduce {
MapReduce -> Label
rColl :: Collection,
MapReduce -> FinalizeFun
rMap :: MapFun,
MapReduce -> FinalizeFun
rReduce :: ReduceFun,
MapReduce -> Document
rSelect :: Selector,
MapReduce -> Document
rSort :: Order,
MapReduce -> Limit
rLimit :: Limit,
MapReduce -> MROut
rOut :: MROut,
MapReduce -> Maybe FinalizeFun
rFinalize :: Maybe FinalizeFun,
MapReduce -> Document
rScope :: Document,
MapReduce -> Bool
rVerbose :: Bool
} deriving (Int -> MapReduce -> ShowS
[MapReduce] -> ShowS
MapReduce -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MapReduce] -> ShowS
$cshowList :: [MapReduce] -> ShowS
show :: MapReduce -> String
$cshow :: MapReduce -> String
showsPrec :: Int -> MapReduce -> ShowS
$cshowsPrec :: Int -> MapReduce -> ShowS
Show, MapReduce -> MapReduce -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MapReduce -> MapReduce -> Bool
$c/= :: MapReduce -> MapReduce -> Bool
== :: MapReduce -> MapReduce -> Bool
$c== :: MapReduce -> MapReduce -> Bool
Eq)
type MapFun = Javascript
type ReduceFun = Javascript
type FinalizeFun = Javascript
data MROut =
Inline
| Output MRMerge Collection (Maybe Database)
deriving (Int -> MROut -> ShowS
[MROut] -> ShowS
MROut -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MROut] -> ShowS
$cshowList :: [MROut] -> ShowS
show :: MROut -> String
$cshow :: MROut -> String
showsPrec :: Int -> MROut -> ShowS
$cshowsPrec :: Int -> MROut -> ShowS
Show, MROut -> MROut -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MROut -> MROut -> Bool
$c/= :: MROut -> MROut -> Bool
== :: MROut -> MROut -> Bool
$c== :: MROut -> MROut -> Bool
Eq)
data MRMerge =
Replace
| Merge
| Reduce
deriving (Int -> MRMerge -> ShowS
[MRMerge] -> ShowS
MRMerge -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MRMerge] -> ShowS
$cshowList :: [MRMerge] -> ShowS
show :: MRMerge -> String
$cshow :: MRMerge -> String
showsPrec :: Int -> MRMerge -> ShowS
$cshowsPrec :: Int -> MRMerge -> ShowS
Show, MRMerge -> MRMerge -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MRMerge -> MRMerge -> Bool
$c/= :: MRMerge -> MRMerge -> Bool
== :: MRMerge -> MRMerge -> Bool
$c== :: MRMerge -> MRMerge -> Bool
Eq)
type MRResult = Document
mrDocument :: MapReduce -> Document
mrDocument :: MapReduce -> Document
mrDocument MapReduce{Bool
Document
Maybe FinalizeFun
Limit
Label
FinalizeFun
MROut
rVerbose :: Bool
rScope :: Document
rFinalize :: Maybe FinalizeFun
rOut :: MROut
rLimit :: Limit
rSort :: Document
rSelect :: Document
rReduce :: FinalizeFun
rMap :: FinalizeFun
rColl :: Label
rVerbose :: MapReduce -> Bool
rScope :: MapReduce -> Document
rFinalize :: MapReduce -> Maybe FinalizeFun
rOut :: MapReduce -> MROut
rLimit :: MapReduce -> Limit
rSort :: MapReduce -> Document
rSelect :: MapReduce -> Document
rReduce :: MapReduce -> FinalizeFun
rMap :: MapReduce -> FinalizeFun
rColl :: MapReduce -> Label
..} =
(Label
"mapreduce" forall v. Val v => Label -> v -> Field
=: Label
rColl) forall a. a -> [a] -> [a]
:
(Label
"out" forall v. Val v => Label -> v -> Field
=: MROut -> Document
mrOutDoc MROut
rOut) forall a. a -> [a] -> [a]
:
(Label
"finalize" forall a. Val a => Label -> Maybe a -> Document
=? Maybe FinalizeFun
rFinalize) forall a. [a] -> [a] -> [a]
++ [
Label
"map" forall v. Val v => Label -> v -> Field
=: FinalizeFun
rMap,
Label
"reduce" forall v. Val v => Label -> v -> Field
=: FinalizeFun
rReduce,
Label
"query" forall v. Val v => Label -> v -> Field
=: Document
rSelect,
Label
"sort" forall v. Val v => Label -> v -> Field
=: Document
rSort,
Label
"limit" forall v. Val v => Label -> v -> Field
=: (forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
rLimit :: Int),
Label
"scope" forall v. Val v => Label -> v -> Field
=: Document
rScope,
Label
"verbose" forall v. Val v => Label -> v -> Field
=: Bool
rVerbose ]
mrOutDoc :: MROut -> Document
mrOutDoc :: MROut -> Document
mrOutDoc MROut
Inline = [Label
"inline" forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
mrOutDoc (Output MRMerge
mrMerge Label
coll Maybe Label
mDB) = (forall {a}. IsString a => MRMerge -> a
mergeName MRMerge
mrMerge forall v. Val v => Label -> v -> Field
=: Label
coll) forall a. a -> [a] -> [a]
: forall {v}. Val v => Maybe v -> Document
mdb Maybe Label
mDB where
mergeName :: MRMerge -> a
mergeName MRMerge
Replace = a
"replace"
mergeName MRMerge
Merge = a
"merge"
mergeName MRMerge
Reduce = a
"reduce"
mdb :: Maybe v -> Document
mdb Maybe v
Nothing = []
mdb (Just v
db) = [Label
"db" forall v. Val v => Label -> v -> Field
=: v
db]
mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
mapReduce :: Label -> FinalizeFun -> FinalizeFun -> MapReduce
mapReduce Label
col FinalizeFun
map' FinalizeFun
red = Label
-> FinalizeFun
-> FinalizeFun
-> Document
-> Document
-> Limit
-> MROut
-> Maybe FinalizeFun
-> Document
-> Bool
-> MapReduce
MapReduce Label
col FinalizeFun
map' FinalizeFun
red [] [] Limit
0 MROut
Inline forall a. Maybe a
Nothing [] Bool
False
runMR :: MonadIO m => MapReduce -> Action m Cursor
runMR :: forall (m :: * -> *). MonadIO m => MapReduce -> Action m Cursor
runMR MapReduce
mr = do
Document
res <- forall (m :: * -> *). MonadIO m => MapReduce -> Action m Document
runMR' MapReduce
mr
case forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"result" Document
res of
Just (String Label
coll) -> forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find forall a b. (a -> b) -> a -> b
$ Document -> Label -> Query
query [] Label
coll
Just (Doc Document
doc) -> forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb (forall v. Val v => Label -> Document -> v
at Label
"db" Document
doc) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find forall a b. (a -> b) -> a -> b
$ Document -> Label -> Query
query [] (forall v. Val v => Label -> Document -> v
at Label
"collection" Document
doc)
Just Value
x -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"unexpected map-reduce result field: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Value
x
Maybe Value
Nothing -> forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
"" Label
"" Limit
0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch (forall a. a -> Maybe a
Just Limit
0) CursorId
0 (forall v. Val v => Label -> Document -> v
at Label
"results" Document
res)
runMR' :: (MonadIO m) => MapReduce -> Action m MRResult
runMR' :: forall (m :: * -> *). MonadIO m => MapReduce -> Action m Document
runMR' MapReduce
mr = do
Document
doc <- forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (MapReduce -> Document
mrDocument MapReduce
mr)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Label -> Document -> Bool
true1 Label
"ok" Document
doc then Document
doc else forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"mapReduce error:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Document
doc forall a. [a] -> [a] -> [a]
++ String
"\nin:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show MapReduce
mr
type Command = Document
runCommand :: (MonadIO m) => Command -> Action m Document
runCommand :: forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
c = forall a. a -> Maybe a -> a
fromMaybe Document
err forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne (Document -> Label -> Query
query Document
c Label
"$cmd") where
err :: Document
err = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Nothing returned for command: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Document
c
runCommand1 :: (MonadIO m) => Text -> Action m Document
runCommand1 :: forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
c = forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
c forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
eval :: (MonadIO m, Val v) => Javascript -> Action m v
eval :: forall (m :: * -> *) v.
(MonadIO m, Val v) =>
FinalizeFun -> Action m v
eval FinalizeFun
code = do
Pipe
p <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
p
if ServerData -> Int
maxWireVersion ServerData
sd forall a. Ord a => a -> a -> Bool
<= Int
7
then forall v. Val v => Label -> Document -> v
at Label
"retval" forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"$eval" forall v. Val v => Label -> v -> Field
=: FinalizeFun
code]
else forall a. HasCallStack => String -> a
error String
"The command db.eval() has been removed since MongoDB 4.2"
modifyMVar :: MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar :: forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar a
v a -> Action IO (a, b)
f = do
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar a
v (\a
x -> forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> Action IO (a, b)
f a
x) MongoContext
ctx)
mkWeakMVar :: MVar a -> Action IO () -> Action IO (Weak (MVar a))
mkWeakMVar :: forall a.
MVar a -> ReaderT MongoContext IO () -> Action IO (Weak (MVar a))
mkWeakMVar MVar a
m ReaderT MongoContext IO ()
closing = do
MongoContext
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
#if MIN_VERSION_base(4,6,0)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO () -> IO (Weak (MVar a))
MV.mkWeakMVar MVar a
m forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT MongoContext IO ()
closing MongoContext
ctx
#else
liftIO $ MV.addMVarFinalizer m $ runReaderT closing ctx
#endif