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