{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, CPP, DeriveDataTypeable, ScopedTypeVariables, BangPatterns #-}
module Database.MongoDB.Query (
Action, access, Failure(..), ErrorCode,
AccessMode(..), GetLastError, master, slaveOk, accessMode,
liftDB,
MongoContext(..), HasMongoContext(..),
Database, allDatabases, useDb, thisDatabase,
Username, Password, auth, authMongoCR, authSCRAMSHA1, authSCRAMSHA256,
Collection, allCollections,
Selection(..), Selector, whereJS,
Select(select),
insert, insert_, insertMany, insertMany_, insertAll, insertAll_,
save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll,
WriteResult(..), UpdateOption(..), Upserted(..),
delete, deleteOne, deleteMany, deleteAll, DeleteOption(..),
Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial),
Projector, Limit, Order, BatchSize,
explain, find, findCommand, findOne, fetch,
findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts,
count, distinct,
Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed,
Pipeline, AggregateConfig(..), aggregate, aggregateCursor,
Group(..), GroupKey(..), group,
MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..),
MRResult, mapReduce, runMR, runMR',
Command, runCommand, runCommand1,
eval, retrieveServerData, ServerData(..)
) where
import qualified Control.Concurrent.MVar as MV
import Control.Concurrent.MVar.Lifted
( MVar,
readMVar,
)
import Control.Exception (Exception, catch, throwIO)
import Control.Monad
( liftM2,
replicateM,
unless,
void,
when,
)
import Control.Monad.Reader (MonadReader, ReaderT, ask, asks, local, runReaderT)
import Control.Monad.Trans (MonadIO, liftIO, lift)
import Control.Monad.Trans.Except
import qualified Crypto.Hash.MD5 as MD5
import qualified Crypto.Hash.SHA1 as SHA1
import qualified Crypto.Hash.SHA256 as SHA256
import qualified Crypto.MAC.HMAC as HMAC
import qualified Crypto.Nonce as Nonce
import Data.Binary.Put (runPut)
import Data.Bits (xor)
import Data.Bson
( Document,
Field (..),
Javascript,
Label,
ObjectId,
Val (..),
Value (..),
at,
genObjectId,
look,
lookup,
valueAt,
(!?),
(=:),
(=?),
merge,
cast
)
import Data.Bson.Binary (putDocument)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base16 as B16
import qualified Data.ByteString.Base64 as B64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy as LBS
import Data.Default.Class (Default (..))
import Data.Either (lefts, rights)
import qualified Data.Either as E
import Data.Functor ((<&>))
import Data.Int (Int32, Int64)
import Data.List (foldl1')
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromMaybe, isNothing, listToMaybe, mapMaybe, maybeToList, fromJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Data.Word (Word32)
import Database.MongoDB.Internal.Protocol
( CursorId,
DeleteOption (..),
FullCollection,
InsertOption (..),
Notice (..),
Password,
Pipe,
QueryOption (..),
Reply (..),
Request
( GetMore,
qBatchSize,
qFullCollection,
qOptions,
qProjector,
qSelector,
qSkip
),
ResponseFlag (..),
ServerData (..),
UpdateOption (..),
Username,
Cmd (..),
pwKey,
FlagBit (..)
)
import Control.Monad.Trans.Except
import qualified Database.MongoDB.Internal.Protocol as P
import Database.MongoDB.Internal.Util (liftIOE, loop, true1, (<.>), splitDot)
import System.Mem.Weak (Weak)
import Text.Read (readMaybe)
import Prelude hiding (lookup)
type Action = ReaderT MongoContext
access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m a
access :: forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Label -> Action m a -> m a
access Pipe
mongoPipe AccessMode
mongoAccessMode Label
mongoDatabase Action m a
action = Action m a -> MongoContext -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Action m a
action MongoContext{Label
Pipe
AccessMode
mongoPipe :: Pipe
mongoAccessMode :: AccessMode
mongoDatabase :: Label
mongoPipe :: Pipe
mongoAccessMode :: AccessMode
mongoDatabase :: Label
..}
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
$cshowsPrec :: Int -> Failure -> ShowS
showsPrec :: Int -> Failure -> ShowS
$cshow :: Failure -> String
show :: Failure -> String
$cshowList :: [Failure] -> ShowS
showList :: [Failure] -> ShowS
Show, Failure -> Failure -> Bool
(Failure -> Failure -> Bool)
-> (Failure -> Failure -> Bool) -> Eq Failure
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Failure -> Failure -> Bool
== :: Failure -> Failure -> Bool
$c/= :: Failure -> Failure -> Bool
/= :: 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
$cshowsPrec :: Int -> AccessMode -> ShowS
showsPrec :: Int -> AccessMode -> ShowS
$cshow :: AccessMode -> String
show :: AccessMode -> String
$cshowList :: [AccessMode] -> ShowS
showList :: [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
$cshowsPrec :: Int -> WriteResult -> ShowS
showsPrec :: Int -> WriteResult -> ShowS
$cshow :: WriteResult -> String
show :: WriteResult -> String
$cshowList :: [WriteResult] -> ShowS
showList :: [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
$cshowsPrec :: Int -> Upserted -> ShowS
showsPrec :: Int -> Upserted -> ShowS
$cshow :: Upserted -> String
show :: Upserted -> String
$cshowList :: [Upserted] -> ShowS
showList :: [Upserted] -> ShowS
Show
master :: AccessMode
master :: AccessMode
master = Document -> AccessMode
ConfirmWrites []
slaveOk :: AccessMode
slaveOk :: AccessMode
slaveOk = AccessMode
ReadStaleOk
accessMode :: (Monad m) => AccessMode -> Action m a -> Action m a
accessMode :: forall (m :: * -> *) a.
Monad m =>
AccessMode -> Action m a -> Action m a
accessMode AccessMode
mode = (MongoContext -> MongoContext)
-> ReaderT MongoContext m a -> ReaderT MongoContext m a
forall a.
(MongoContext -> MongoContext)
-> ReaderT MongoContext m a -> ReaderT MongoContext m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\MongoContext
ctx -> MongoContext
ctx {mongoAccessMode = mode})
readMode :: AccessMode -> ReadMode
readMode :: AccessMode -> ReadMode
readMode AccessMode
ReadStaleOk = ReadMode
StaleOk
readMode AccessMode
_ = ReadMode
Fresh
writeMode :: AccessMode -> WriteMode
writeMode :: AccessMode -> WriteMode
writeMode AccessMode
ReadStaleOk = Document -> WriteMode
Confirm []
writeMode AccessMode
UnconfirmedWrites = WriteMode
NoConfirm
writeMode (ConfirmWrites Document
z) = Document -> WriteMode
Confirm Document
z
data MongoContext = MongoContext {
MongoContext -> Pipe
mongoPipe :: Pipe,
MongoContext -> AccessMode
mongoAccessMode :: AccessMode,
MongoContext -> Label
mongoDatabase :: Database
}
mongoReadMode :: MongoContext -> ReadMode
mongoReadMode :: MongoContext -> ReadMode
mongoReadMode = AccessMode -> ReadMode
readMode (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 :: forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
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 a. 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 :: forall (m :: * -> *). MonadIO m => Action m [Label]
allDatabases = (Document -> Label) -> Pipeline -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"name") (Pipeline -> [Label])
-> (Document -> Pipeline) -> Document -> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Document -> Pipeline
forall v. Val v => Label -> Document -> v
at Label
"databases" (Document -> [Label])
-> ReaderT MongoContext m Document
-> ReaderT MongoContext m [Label]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label
-> ReaderT MongoContext m Document
-> ReaderT MongoContext m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
"admin" (Label -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
"listDatabases")
thisDatabase :: (Monad m) => Action m Database
thisDatabase :: forall (m :: * -> *). Monad m => Action m Label
thisDatabase = (MongoContext -> Label) -> ReaderT MongoContext m Label
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Label
mongoDatabase
useDb :: (Monad m) => Database -> Action m a -> Action m a
useDb :: forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
db = (MongoContext -> MongoContext)
-> ReaderT MongoContext m a -> ReaderT MongoContext m a
forall a.
(MongoContext -> MongoContext)
-> ReaderT MongoContext m a -> ReaderT MongoContext m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\MongoContext
ctx -> MongoContext
ctx {mongoDatabase = db})
auth :: MonadIO m => Username -> Password -> Action m Bool
auth :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
auth Label
un Label
pw = do
let serverVersion :: ReaderT MongoContext m Label
serverVersion = (Document -> Label)
-> ReaderT MongoContext m Document -> ReaderT MongoContext m Label
forall a b.
(a -> b) -> ReaderT MongoContext m a -> ReaderT MongoContext m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"version") (ReaderT MongoContext m Document -> ReaderT MongoContext m Label)
-> ReaderT MongoContext m Document -> ReaderT MongoContext m Label
forall a b. (a -> b) -> a -> b
$ Label
-> ReaderT MongoContext m Document
-> ReaderT MongoContext m Document
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb Label
"admin" (ReaderT MongoContext m Document
-> ReaderT MongoContext m Document)
-> ReaderT MongoContext m Document
-> ReaderT MongoContext m Document
forall a b. (a -> b) -> a -> b
$ Document -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"buildinfo" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
Maybe Int
mmv <- String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Label -> String) -> Label -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
T.unpack (Label -> String) -> (Label -> Label) -> Label -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Label] -> Label
forall a. HasCallStack => [a] -> a
head ([Label] -> Label) -> (Label -> [Label]) -> Label -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Label -> Label -> [Label]
Label -> Label -> [Label]
T.splitOn Label
"." (Label -> Maybe Int)
-> ReaderT MongoContext m Label
-> ReaderT MongoContext m (Maybe Int)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT MongoContext m Label
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 a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) Int -> Action m Bool
performAuth Maybe Int
mmv
where
performAuth :: Int -> Action m Bool
performAuth Int
majorVersion =
if Int
majorVersion Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= (Int
3 :: Int)
then Label -> Label -> Action m Bool
forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authSCRAMSHA1 Label
un Label
pw
else Label -> Label -> Action m Bool
forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authMongoCR Label
un Label
pw
authMongoCR :: (MonadIO m) => Username -> Password -> Action m Bool
authMongoCR :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authMongoCR Label
usr Label
pss = do
Label
n <- Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"nonce" (Document -> Label)
-> ReaderT MongoContext m Document -> ReaderT MongoContext m Label
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"getnonce" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
Label -> Document -> Bool
true1 Label
"ok" (Document -> Bool)
-> ReaderT MongoContext m Document -> Action m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"authenticate" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int), Label
"user" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
usr, Label
"nonce" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
n, Label
"key" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label -> Label -> Label -> Label
pwKey Label
n Label
usr Label
pss]
data HashAlgorithm = SHA1 | SHA256 deriving Int -> HashAlgorithm -> ShowS
[HashAlgorithm] -> ShowS
HashAlgorithm -> String
(Int -> HashAlgorithm -> ShowS)
-> (HashAlgorithm -> String)
-> ([HashAlgorithm] -> ShowS)
-> Show HashAlgorithm
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> HashAlgorithm -> ShowS
showsPrec :: Int -> HashAlgorithm -> ShowS
$cshow :: HashAlgorithm -> String
show :: HashAlgorithm -> String
$cshowList :: [HashAlgorithm] -> ShowS
showList :: [HashAlgorithm] -> ShowS
Show
hash :: HashAlgorithm -> B.ByteString -> B.ByteString
hash :: HashAlgorithm -> ByteString -> ByteString
hash HashAlgorithm
SHA1 = ByteString -> ByteString
SHA1.hash
hash HashAlgorithm
SHA256 = ByteString -> ByteString
SHA256.hash
authSCRAMSHA1 :: MonadIO m => Username -> Password -> Action m Bool
authSCRAMSHA1 :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authSCRAMSHA1 = HashAlgorithm -> Label -> Label -> Action m Bool
forall (m :: * -> *).
MonadIO m =>
HashAlgorithm -> Label -> Label -> Action m Bool
authSCRAMWith HashAlgorithm
SHA1
authSCRAMSHA256 :: MonadIO m => Username -> Password -> Action m Bool
authSCRAMSHA256 :: forall (m :: * -> *). MonadIO m => Label -> Label -> Action m Bool
authSCRAMSHA256 = HashAlgorithm -> Label -> Label -> Action m Bool
forall (m :: * -> *).
MonadIO m =>
HashAlgorithm -> Label -> Label -> Action m Bool
authSCRAMWith HashAlgorithm
SHA256
toAuthResult :: Functor m => ExceptT String (Action m) () -> Action m Bool
toAuthResult :: forall (m :: * -> *).
Functor m =>
ExceptT String (Action m) () -> Action m Bool
toAuthResult = (Either String () -> Bool)
-> ReaderT MongoContext m (Either String ())
-> ReaderT MongoContext m Bool
forall a b.
(a -> b) -> ReaderT MongoContext m a -> ReaderT MongoContext m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((String -> Bool) -> (() -> Bool) -> Either String () -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> () -> Bool
forall a b. a -> b -> a
const Bool
True)) (ReaderT MongoContext m (Either String ())
-> ReaderT MongoContext m Bool)
-> (ExceptT String (ReaderT MongoContext m) ()
-> ReaderT MongoContext m (Either String ()))
-> ExceptT String (ReaderT MongoContext m) ()
-> ReaderT MongoContext m Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String (ReaderT MongoContext m) ()
-> ReaderT MongoContext m (Either String ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT
saslprep :: Text -> Text
saslprep :: Label -> Label
saslprep = Label -> Label
forall a. a -> a
id
authSCRAMWith :: MonadIO m => HashAlgorithm -> Username -> Password -> Action m Bool
authSCRAMWith :: forall (m :: * -> *).
MonadIO m =>
HashAlgorithm -> Label -> Label -> Action m Bool
authSCRAMWith HashAlgorithm
algo Label
un Label
pw = ExceptT String (Action m) () -> Action m Bool
forall (m :: * -> *).
Functor m =>
ExceptT String (Action m) () -> Action m Bool
toAuthResult (ExceptT String (Action m) () -> Action m Bool)
-> ExceptT String (Action m) () -> Action m Bool
forall a b. (a -> b) -> a -> b
$ do
let hmac :: ByteString -> ByteString -> ByteString
hmac = (ByteString -> ByteString)
-> Int -> ByteString -> ByteString -> ByteString
HMAC.hmac (HashAlgorithm -> ByteString -> ByteString
hash HashAlgorithm
algo) Int
64
ByteString
nonce <- IO ByteString -> ExceptT String (Action m) ByteString
forall a. IO a -> ExceptT String (Action m) a
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 -> ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ByteString -> ByteString
B64.encode)
let firstBare :: ByteString
firstBare = [ByteString] -> ByteString
B.concat [String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"n=" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Label -> String
T.unpack Label
un String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
",r=", ByteString
nonce]
let client1 :: Document
client1 =
[ Label
"saslStart" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)
, Label
"mechanism" Label -> String -> Field
forall v. Val v => Label -> v -> Field
=: case HashAlgorithm
algo of
HashAlgorithm
SHA1 -> String
"SCRAM-SHA-1" :: String
HashAlgorithm
SHA256 -> String
"SCRAM-SHA-256"
, Label
"payload" Label -> String -> Field
forall v. Val v => Label -> 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])
, Label
"autoAuthorize" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)
]
Document
server1 <- Action m Document -> ExceptT String (Action m) Document
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action m Document -> ExceptT String (Action m) Document)
-> Action m Document -> ExceptT String (Action m) Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
client1
Bool -> String -> ExceptT String (Action m) ()
forall (m :: * -> *).
Monad m =>
Bool -> String -> ExceptT String m ()
shortcircuit (Label -> Document -> Bool
true1 Label
"ok" Document
server1) (Document -> String
forall a. Show a => a -> String
show Document
server1)
let serverPayload1 :: ByteString
serverPayload1 = ByteString -> ByteString
B64.decodeLenient (ByteString -> ByteString)
-> (Document -> ByteString) -> Document -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
B.pack (String -> ByteString)
-> (Document -> String) -> Document -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Document -> String
forall v. Val v => Label -> Document -> v
at Label
"payload" (Document -> ByteString) -> Document -> ByteString
forall a b. (a -> b) -> a -> b
$ Document
server1
let serverData1 :: Map ByteString ByteString
serverData1 = ByteString -> Map ByteString ByteString
parseSCRAM ByteString
serverPayload1
let iterations :: Int
iterations = 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 -> String -> ExceptT String (Action m) ()
forall (m :: * -> *).
Monad m =>
Bool -> String -> ExceptT String m ()
shortcircuit (ByteString -> ByteString -> Bool
B.isInfixOf ByteString
nonce ByteString
snonce) String
"nonce"
let withoutProof :: ByteString
withoutProof = [ByteString] -> ByteString
B.concat [String -> ByteString
B.pack String
"c=biws,r=", ByteString
snonce]
let digest :: ByteString
digest = case HashAlgorithm
algo of
HashAlgorithm
SHA1 -> ByteString -> ByteString
B16.encode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
MD5.hash (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Label -> String
T.unpack Label
un String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
":mongo:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Label -> String
T.unpack Label
pw
HashAlgorithm
SHA256 -> String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Label -> String
T.unpack (Label -> String) -> Label -> String
forall a b. (a -> b) -> a -> b
$ Label -> Label
saslprep Label
pw
let saltedPass :: ByteString
saltedPass = HashAlgorithm -> ByteString -> ByteString -> Int -> ByteString
scramHI HashAlgorithm
algo 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 = HashAlgorithm -> ByteString -> ByteString
hash HashAlgorithm
algo 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 client2 :: Document
client2 =
[ Label
"saslContinue" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)
, Label
"conversationId" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"conversationId" Document
server1 :: Int)
, Label
"payload" Label -> String -> Field
forall v. Val v => Label -> v -> Field
=: ByteString -> String
B.unpack (ByteString -> ByteString
B64.encode ByteString
clientFinal)
]
Document
server2 <- Action m Document -> ExceptT String (Action m) Document
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action m Document -> ExceptT String (Action m) Document)
-> Action m Document -> ExceptT String (Action m) Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
client2
Bool -> String -> ExceptT String (Action m) ()
forall (m :: * -> *).
Monad m =>
Bool -> String -> ExceptT String m ()
shortcircuit (Label -> Document -> Bool
true1 Label
"ok" Document
server2) (Document -> String
forall a. Show a => a -> String
show Document
server2)
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 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
$ Label -> Document -> String
forall v. Val v => Label -> Document -> v
at Label
"payload" Document
server2
let serverData2 :: Map ByteString ByteString
serverData2 = ByteString -> Map ByteString ByteString
parseSCRAM ByteString
serverPayload2
let serverSigComp :: ByteString
serverSigComp = 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 -> String -> ExceptT String (Action m) ()
forall (m :: * -> *).
Monad m =>
Bool -> String -> ExceptT String m ()
shortcircuit (ByteString
serverSig ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
serverSigComp) String
"server signature does not match"
if Label -> Document -> Bool
true1 Label
"done" Document
server2
then () -> ExceptT String (Action m) ()
forall a. a -> ExceptT String (Action m) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do
let client2Step2 :: Document
client2Step2 = [ Label
"saslContinue" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)
, Label
"conversationId" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"conversationId" Document
server1 :: Int)
, Label
"payload" Label -> Value -> Field
forall v. Val v => Label -> v -> Field
=: Label -> Value
String Label
""]
Document
server3 <- Action m Document -> ExceptT String (Action m) Document
forall (m :: * -> *) a. Monad m => m a -> ExceptT String m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Action m Document -> ExceptT String (Action m) Document)
-> Action m Document -> ExceptT String (Action m) Document
forall a b. (a -> b) -> a -> b
$ Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
client2Step2
Bool -> String -> ExceptT String (Action m) ()
forall (m :: * -> *).
Monad m =>
Bool -> String -> ExceptT String m ()
shortcircuit (Label -> Document -> Bool
true1 Label
"ok" Document
server3) String
"server3"
shortcircuit :: Monad m => Bool -> String -> ExceptT String m ()
shortcircuit :: forall (m :: * -> *).
Monad m =>
Bool -> String -> ExceptT String m ()
shortcircuit Bool
True String
_ = () -> ExceptT String m ()
forall a. a -> ExceptT String m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
shortcircuit Bool
False String
reason = String -> ExceptT String m ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE (ShowS
forall a. Show a => a -> String
show String
reason)
scramHI :: HashAlgorithm -> B.ByteString -> B.ByteString -> Int -> B.ByteString
scramHI :: HashAlgorithm -> ByteString -> ByteString -> Int -> ByteString
scramHI HashAlgorithm
algo 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 b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (ByteString, ByteString) -> Int -> (ByteString, ByteString)
com (ByteString
u1, ByteString
u1) [Int
1..(Int
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 (HashAlgorithm -> ByteString -> ByteString
hash HashAlgorithm
algo) 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
. (Label -> (ByteString, ByteString))
-> [Label] -> [(ByteString, ByteString)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Label, Label) -> (ByteString, ByteString)
cleanup ((Label, Label) -> (ByteString, ByteString))
-> (Label -> (Label, Label)) -> Label -> (ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Label -> Label -> (Label, Label)
Label -> Label -> (Label, Label)
T.breakOn Label
"=") ([Label] -> [(ByteString, ByteString)])
-> (ByteString -> [Label])
-> ByteString
-> [(ByteString, ByteString)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Label -> Label -> [Label]
Label -> Label -> [Label]
T.splitOn Label
"," (Label -> [Label])
-> (ByteString -> Label) -> ByteString -> [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Label
T.pack (String -> Label) -> (ByteString -> String) -> ByteString -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack
where cleanup :: (Label, Label) -> (ByteString, ByteString)
cleanup (Label
t1, Label
t2) = (String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Label -> String
T.unpack Label
t1, String -> ByteString
B.pack (String -> ByteString) -> (Label -> String) -> Label -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> String
T.unpack (Label -> ByteString) -> Label -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Label -> Label
T.drop Int
1 Label
t2)
retrieveServerData :: (MonadIO m) => Action m ServerData
retrieveServerData :: forall (m :: * -> *). MonadIO m => Action m ServerData
retrieveServerData = do
Document
d <- Label -> Action m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
"isMaster"
let newSd :: ServerData
newSd = 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
$ Label -> Document -> Maybe Bool
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"isMaster" Document
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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"minWireVersion" Document
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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxWireVersion" Document
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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxMessageSizeBytes" Document
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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxBsonObjectSize" Document
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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"maxWriteBatchSize" Document
d
}
ServerData -> Action m ServerData
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ServerData
newSd
type Collection = Text
allCollections :: MonadIO m => Action m [Collection]
allCollections :: forall (m :: * -> *). MonadIO m => Action m [Label]
allCollections = do
Pipe
p <- (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
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Pipeline
docs <- Cursor -> Action m Pipeline
forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest (Cursor -> Action m Pipeline)
-> ReaderT MongoContext m Cursor -> Action m Pipeline
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 (Document -> Label -> Query
query [] Label
"system.namespaces") {sort = ["name" =: (1 :: Int)]}
([Label] -> Action m [Label]
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Label] -> Action m [Label])
-> ([Label] -> [Label]) -> [Label] -> Action m [Label]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Label -> Bool) -> [Label] -> [Label]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Label -> Bool) -> Label -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Label -> Bool
isSpecial Label
db)) ((Document -> Label) -> Pipeline -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map (Label -> Label
dropDbPrefix (Label -> Label) -> (Document -> Label) -> Document -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"name") Pipeline
docs)
else
if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
then do
Document
r <- Label -> Action m Document
forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
"listCollections"
let curData :: Maybe (CursorId, Label, Pipeline)
curData = do
(Doc Document
curDoc) <- Document
r Document -> Label -> Maybe Value
forall a. Val a => Document -> Label -> Maybe a
!? Label
"cursor"
(CursorId
curId :: Int64) <- Document
curDoc Document -> Label -> Maybe CursorId
forall a. Val a => Document -> Label -> Maybe a
!? Label
"id"
(Label
curNs :: Text) <- Document
curDoc Document -> Label -> Maybe Label
forall a. Val a => Document -> Label -> Maybe a
!? Label
"ns"
([Value]
firstBatch :: [Value]) <- Document
curDoc Document -> Label -> Maybe [Value]
forall a. Val a => Document -> Label -> Maybe a
!? Label
"firstBatch"
(CursorId, Label, Pipeline) -> Maybe (CursorId, Label, Pipeline)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (CursorId
curId, Label
curNs, (Value -> Maybe Document) -> [Value] -> Pipeline
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Value -> Maybe Document
forall a. Val a => Value -> Maybe a
cast' [Value]
firstBatch :: [Document])
case Maybe (CursorId, Label, Pipeline)
curData of
Maybe (CursorId, Label, Pipeline)
Nothing -> [Label] -> Action m [Label]
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just (CursorId
curId, Label
curNs, Pipeline
firstBatch) -> do
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Cursor
nc <- Label
-> Label -> Limit -> DelayedBatch -> ReaderT MongoContext m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
curNs Limit
0 (DelayedBatch -> ReaderT MongoContext m Cursor)
-> DelayedBatch -> ReaderT MongoContext m Cursor
forall a b. (a -> b) -> a -> b
$ Batch -> DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Batch -> DelayedBatch) -> Batch -> DelayedBatch
forall a b. (a -> b) -> a -> b
$ Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
forall a. Maybe a
Nothing CursorId
curId Pipeline
firstBatch
Pipeline
docs <- Cursor -> Action m Pipeline
forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest Cursor
nc
[Label] -> Action m [Label]
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Label] -> Action m [Label]) -> [Label] -> Action m [Label]
forall a b. (a -> b) -> a -> b
$ (Document -> Maybe Label) -> Pipeline -> [Label]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Document
d -> Document
d Document -> Label -> Maybe Label
forall a. Val a => Document -> Label -> Maybe a
!? Label
"name") Pipeline
docs
else do
let q :: Query
q = [QueryOption]
-> Selection
-> Document
-> Limit
-> Limit
-> Document
-> Bool
-> Limit
-> Document
-> Query
Query [] (Document -> Label -> Selection
Select [Label
"listCollections" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)] Label
"$cmd") [] Limit
0 Limit
0 [] Bool
False Limit
0 []
(Cmd, Maybe Limit)
qr <- Bool -> Query -> Action m (Cmd, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q
DelayedBatch
dBatch <- IO DelayedBatch -> ReaderT MongoContext m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
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 -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
p (Cmd, Maybe Limit)
qr []
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
Cursor
nc <- Label
-> Label -> Limit -> DelayedBatch -> ReaderT MongoContext m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
"$cmd" Limit
0 DelayedBatch
dBatch
Pipeline
docs <- Cursor -> Action m Pipeline
forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest Cursor
nc
[Label] -> Action m [Label]
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Label] -> Action m [Label]) -> [Label] -> Action m [Label]
forall a b. (a -> b) -> a -> b
$ (Document -> Maybe Label) -> Pipeline -> [Label]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (\Document
d -> Document
d Document -> Label -> Maybe Label
forall a. Val a => Document -> Label -> Maybe a
!? Label
"name") Pipeline
docs
where
dropDbPrefix :: Label -> Label
dropDbPrefix = HasCallStack => Label -> Label
Label -> Label
T.tail (Label -> Label) -> (Label -> Label) -> Label -> Label
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Label -> Label
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'.')
isSpecial :: Label -> Label -> Bool
isSpecial Label
db Label
col = (Char -> Bool) -> Label -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'$') Label
col Bool -> Bool -> Bool
&& Label
db Label -> Label -> Label
<.> Label
col Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
/= Label
"local.oplog.$main"
data Selection = Select {Selection -> Document
selector :: Selector, Selection -> Label
coll :: Collection} deriving (Int -> Selection -> ShowS
[Selection] -> ShowS
Selection -> String
(Int -> Selection -> ShowS)
-> (Selection -> String)
-> ([Selection] -> ShowS)
-> Show Selection
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Selection -> ShowS
showsPrec :: Int -> Selection -> ShowS
$cshow :: Selection -> String
show :: Selection -> String
$cshowList :: [Selection] -> ShowS
showList :: [Selection] -> ShowS
Show, Selection -> Selection -> Bool
(Selection -> Selection -> Bool)
-> (Selection -> Selection -> Bool) -> Eq Selection
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Selection -> Selection -> Bool
== :: Selection -> Selection -> Bool
$c/= :: Selection -> Selection -> Bool
/= :: Selection -> Selection -> Bool
Eq)
type Selector = Document
whereJS :: Selector -> Javascript -> Selector
whereJS :: Document -> FinalizeFun -> Document
whereJS Document
sel FinalizeFun
js = (Label
"$where" Label -> FinalizeFun -> Field
forall v. Val v => Label -> v -> Field
=: FinalizeFun
js) Field -> Document -> Document
forall a. a -> [a] -> [a]
: Document
sel
class Select aQueryOrSelection where
select :: Selector -> Collection -> aQueryOrSelection
instance Select Selection where
select :: Document -> Label -> Selection
select = Document -> Label -> Selection
Select
instance Select Query where
select :: Document -> Label -> Query
select = Document -> Label -> Query
query
data WriteMode =
NoConfirm
| Confirm GetLastError
deriving (Int -> WriteMode -> ShowS
[WriteMode] -> ShowS
WriteMode -> String
(Int -> WriteMode -> ShowS)
-> (WriteMode -> String)
-> ([WriteMode] -> ShowS)
-> Show WriteMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> WriteMode -> ShowS
showsPrec :: Int -> WriteMode -> ShowS
$cshow :: WriteMode -> String
show :: WriteMode -> String
$cshowList :: [WriteMode] -> ShowS
showList :: [WriteMode] -> ShowS
Show, WriteMode -> WriteMode -> Bool
(WriteMode -> WriteMode -> Bool)
-> (WriteMode -> WriteMode -> Bool) -> Eq WriteMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: WriteMode -> WriteMode -> Bool
== :: WriteMode -> WriteMode -> Bool
$c/= :: WriteMode -> WriteMode -> Bool
/= :: WriteMode -> WriteMode -> Bool
Eq)
write :: Notice -> Action IO (Maybe Document)
write :: Notice -> Action IO (Maybe Document)
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 Document))
-> Action IO (Maybe Document)
forall a b.
ReaderT MongoContext IO a
-> (a -> ReaderT MongoContext IO b) -> ReaderT MongoContext IO b
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 Document -> Action IO (Maybe Document)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Document
forall a. Maybe a
Nothing
Confirm Document
params -> do
let q :: Query
q = Document -> Label -> Query
query ((Label
"getlasterror" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)) Field -> Document -> Document
forall a. a -> [a] -> [a]
: Document
params) Label
"$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 Limit
_ CursorId
_ [Document
doc] <- do
(Request, Maybe Limit)
r <- Bool -> Query -> Action IO (Request, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
False Query
q {limit = 1}
DelayedBatch
rr <- IO DelayedBatch -> ReaderT MongoContext IO DelayedBatch
forall a. IO a -> ReaderT MongoContext IO a
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 Limit) -> IO DelayedBatch
request Pipe
pipe [Notice
notice] (Request, Maybe Limit)
r
DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
rr
Maybe Document -> Action IO (Maybe Document)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Document -> Action IO (Maybe Document))
-> Maybe Document -> Action IO (Maybe Document)
forall a b. (a -> b) -> a -> b
$ Document -> Maybe Document
forall a. a -> Maybe a
Just Document
doc
insert :: (MonadIO m) => Collection -> Document -> Action m Value
insert :: forall (m :: * -> *).
MonadIO m =>
Label -> Document -> Action m Value
insert Label
col Document
doc = do
Document
doc' <- IO Document -> ReaderT MongoContext m Document
forall a. IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Document -> ReaderT MongoContext m Document)
-> IO Document -> ReaderT MongoContext m Document
forall a b. (a -> b) -> a -> b
$ Document -> IO Document
assignId Document
doc
Either Failure [Value]
res <- [InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
forall (m :: * -> *).
MonadIO m =>
[InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
insertBlock [] Label
col (Int
0, [Document
doc'])
case Either Failure [Value]
res of
Left Failure
failure -> IO Value -> Action m Value
forall a. IO a -> ReaderT MongoContext m a
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 a. a -> ReaderT MongoContext m a
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. HasCallStack => [a] -> a
head [Value]
r
insert_ :: (MonadIO m) => Collection -> Document -> Action m ()
insert_ :: forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
insert_ Label
col Document
doc = Label -> Document -> Action m Value
forall (m :: * -> *).
MonadIO m =>
Label -> Document -> Action m Value
insert Label
col Document
doc Action m Value
-> ReaderT MongoContext m () -> ReaderT MongoContext m ()
forall a b.
ReaderT MongoContext m a
-> ReaderT MongoContext m b -> ReaderT MongoContext m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReaderT MongoContext m ()
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertMany :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
insertMany :: forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertMany = [InsertOption] -> Label -> Pipeline -> Action m [Value]
forall (m :: * -> *).
MonadIO m =>
[InsertOption] -> Label -> Pipeline -> Action m [Value]
insert' []
insertMany_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
insertMany_ :: forall (m :: * -> *). MonadIO m => Label -> Pipeline -> Action m ()
insertMany_ Label
col Pipeline
docs = Label -> Pipeline -> Action m [Value]
forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertMany Label
col Pipeline
docs Action m [Value]
-> ReaderT MongoContext m () -> ReaderT MongoContext m ()
forall a b.
ReaderT MongoContext m a
-> ReaderT MongoContext m b -> ReaderT MongoContext m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReaderT MongoContext m ()
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertAll :: (MonadIO m) => Collection -> [Document] -> Action m [Value]
insertAll :: forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertAll = [InsertOption] -> Label -> Pipeline -> Action m [Value]
forall (m :: * -> *).
MonadIO m =>
[InsertOption] -> Label -> Pipeline -> Action m [Value]
insert' [InsertOption
KeepGoing]
insertAll_ :: (MonadIO m) => Collection -> [Document] -> Action m ()
insertAll_ :: forall (m :: * -> *). MonadIO m => Label -> Pipeline -> Action m ()
insertAll_ Label
col Pipeline
docs = Label -> Pipeline -> Action m [Value]
forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m [Value]
insertAll Label
col Pipeline
docs Action m [Value]
-> ReaderT MongoContext m () -> ReaderT MongoContext m ()
forall a b.
ReaderT MongoContext m a
-> ReaderT MongoContext m b -> ReaderT MongoContext m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> ReaderT MongoContext m ()
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertCommandDocument :: [InsertOption] -> Collection -> [Document] -> Document -> Document
insertCommandDocument :: [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col Pipeline
docs Document
writeConcern =
[ Label
"insert" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
col
, Label
"ordered" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: (InsertOption
KeepGoing InsertOption -> [InsertOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [InsertOption]
opts)
, Label
"documents" Label -> Pipeline -> Field
forall v. Val v => Label -> v -> Field
=: Pipeline
docs
, Label
"writeConcern" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
writeConcern
]
takeRightsUpToLeft :: [Either a b] -> [b]
takeRightsUpToLeft :: forall a b. [Either a b] -> [b]
takeRightsUpToLeft [Either a b]
l = [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' :: forall (m :: * -> *).
MonadIO m =>
[InsertOption] -> Label -> Pipeline -> Action m [Value]
insert' [InsertOption]
opts Label
col Pipeline
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
Pipeline
docs' <- IO Pipeline -> ReaderT MongoContext m Pipeline
forall a. IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Pipeline -> ReaderT MongoContext m Pipeline)
-> IO Pipeline -> ReaderT MongoContext m Pipeline
forall a b. (a -> b) -> a -> b
$ (Document -> IO Document) -> Pipeline -> IO Pipeline
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Document -> IO Document
assignId Pipeline
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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
let docSize :: Int
docSize = Document -> Int
sizeOfDocument (Document -> Int) -> Document -> Int
forall a b. (a -> b) -> a -> b
$ [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col [] Document
writeConcern
let ordered :: Bool
ordered = InsertOption
KeepGoing InsertOption -> [InsertOption] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [InsertOption]
opts
let preChunks :: [Either Failure Pipeline]
preChunks = Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit
(ServerData -> Int
maxBsonObjectSize ServerData
sd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
docSize)
(ServerData -> Int
maxWriteBatchSize ServerData
sd)
Pipeline
docs'
let chunks :: [Pipeline]
chunks =
if Bool
ordered
then [Either Failure Pipeline] -> [Pipeline]
forall a b. [Either a b] -> [b]
takeRightsUpToLeft [Either Failure Pipeline]
preChunks
else [Either Failure Pipeline] -> [Pipeline]
forall a b. [Either a b] -> [b]
rights [Either Failure Pipeline]
preChunks
let lens :: [Int]
lens = (Pipeline -> Int) -> [Pipeline] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Pipeline -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pipeline]
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, Pipeline)]
-> ((Int, Pipeline)
-> 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] -> [Pipeline] -> [(Int, Pipeline)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lSums [Pipeline]
chunks) (((Int, Pipeline)
-> ReaderT MongoContext m (Either Failure [Value]))
-> ReaderT MongoContext m [Either Failure [Value]])
-> ((Int, Pipeline)
-> ReaderT MongoContext m (Either Failure [Value]))
-> ReaderT MongoContext m [Either Failure [Value]]
forall a b. (a -> b) -> a -> b
$ [InsertOption]
-> Label
-> (Int, Pipeline)
-> ReaderT MongoContext m (Either Failure [Value])
forall (m :: * -> *).
MonadIO m =>
[InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
insertBlock [InsertOption]
opts Label
col
let lchunks :: [Failure]
lchunks = [Either Failure Pipeline] -> [Failure]
forall a b. [Either a b] -> [a]
lefts [Either Failure Pipeline]
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 a. [a] -> 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 a. IO a -> ReaderT MongoContext m a
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. HasCallStack => [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 a. [a] -> 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 a. IO a -> ReaderT MongoContext m a
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. HasCallStack => [a] -> a
head [Failure]
lresults
[Value] -> Action m [Value]
forall a. a -> ReaderT MongoContext m a
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 :: forall (m :: * -> *).
MonadIO m =>
[InsertOption]
-> Label -> (Int, Pipeline) -> Action m (Either Failure [Value])
insertBlock [InsertOption]
_ Label
_ (Int
_, []) = Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 Label
col (Int
prevCount, Pipeline
docs) = do
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
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 Document
res <- Action IO (Maybe Document)
-> ReaderT MongoContext m (Maybe Document)
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (Action IO (Maybe Document)
-> ReaderT MongoContext m (Maybe Document))
-> Action IO (Maybe Document)
-> ReaderT MongoContext m (Maybe Document)
forall a b. (a -> b) -> a -> b
$ Notice -> Action IO (Maybe Document)
write (Label -> [InsertOption] -> Pipeline -> Notice
Insert (Label
db Label -> Label -> Label
<.> Label
col) [InsertOption]
opts Pipeline
docs)
let errorMessage :: Maybe Failure
errorMessage = do
Document
jRes <- Maybe Document
res
String
em <- Label -> Document -> Maybe String
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"err" Document
jRes
Failure -> Maybe Failure
forall a. a -> Maybe a
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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"code" Document
jRes) String
em
case Maybe Failure
errorMessage of
Just Failure
failure -> Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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
$ (Document -> Value) -> Pipeline -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Value
valueAt Label
"_id") Pipeline
docs
else if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17 then 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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col Pipeline
docs Document
writeConcern
case (Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc, Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc) of
(Maybe Value
Nothing, Maybe Value
Nothing) -> Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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
$ (Document -> Value) -> Pipeline -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Value
valueAt Label
"_id") Pipeline
docs
(Just (Array [Value]
errs), Maybe Value
Nothing) -> do
let writeErrors :: [Failure]
writeErrors = (Value -> Failure) -> [Value] -> [Failure]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
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]
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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 [ 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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
doc) (String -> Failure) -> String -> Failure
forall a b. (a -> b) -> a -> b
$ Value -> String
forall a. Show a => a -> String
show Value
writeConcernErr]
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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document -> Document -> Document
merge Document
params [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]
Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ [InsertOption] -> Label -> Pipeline -> Document -> Document
insertCommandDocument [InsertOption]
opts Label
col Pipeline
docs Document
writeConcern
case (Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc, Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc) of
(Maybe Value
Nothing, Maybe Value
Nothing) -> Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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
$ (Document -> Value) -> Pipeline -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Label -> Document -> Value
valueAt Label
"_id") Pipeline
docs
(Just (Array [Value]
errs), Maybe Value
Nothing) -> do
let writeErrors :: [Failure]
writeErrors = (Value -> Failure) -> [Value] -> [Failure]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Value -> Failure
anyToWriteError Int
prevCount) [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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
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]
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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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]
-> ReaderT MongoContext m (Either Failure [Value])
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Failure [Value]
-> ReaderT MongoContext m (Either Failure [Value]))
-> Either Failure [Value]
-> ReaderT MongoContext 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 [ 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 -> 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
$ Label -> Document -> Maybe Int
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"ok" Document
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 -> Pipeline -> [Either Failure Pipeline]
splitAtLimit Int
maxSize Int
maxCount Pipeline
list = (Pipeline -> (Either Failure Pipeline, Pipeline))
-> Pipeline -> [Either Failure Pipeline]
forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chop (Int
-> Int
-> Pipeline
-> Pipeline
-> (Either Failure Pipeline, Pipeline)
go Int
0 Int
0 []) Pipeline
list
where
go :: Int -> Int -> [Document] -> [Document] -> (Either Failure [Document], [Document])
go :: Int
-> Int
-> Pipeline
-> Pipeline
-> (Either Failure Pipeline, Pipeline)
go Int
_ Int
_ Pipeline
res [] = (Pipeline -> Either Failure Pipeline
forall a b. b -> Either a b
Right (Pipeline -> Either Failure Pipeline)
-> Pipeline -> Either Failure Pipeline
forall a b. (a -> b) -> a -> b
$ Pipeline -> Pipeline
forall a. [a] -> [a]
reverse Pipeline
res, [])
go Int
curSize Int
curCount Pipeline
res (Document
x : Pipeline
xs) =
let size :: Int
size = Document -> Int
sizeOfDocument Document
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
8
in
if (Int
curSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size 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
if Int
curCount Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
then (Failure -> Either Failure Pipeline
forall a b. a -> Either a b
Left (Failure -> Either Failure Pipeline)
-> Failure -> Either Failure Pipeline
forall a b. (a -> b) -> a -> b
$ Int -> Int -> String -> Failure
WriteFailure Int
0 Int
0 String
"One document is too big for the message", Pipeline
xs)
else (Pipeline -> Either Failure Pipeline
forall a b. b -> Either a b
Right (Pipeline -> Either Failure Pipeline)
-> Pipeline -> Either Failure Pipeline
forall a b. (a -> b) -> a -> b
$ Pipeline -> Pipeline
forall a. [a] -> [a]
reverse Pipeline
res, Document
x Document -> Pipeline -> Pipeline
forall a. a -> [a] -> [a]
: Pipeline
xs)
else Int
-> Int
-> Pipeline
-> Pipeline
-> (Either Failure Pipeline, Pipeline)
go (Int
curSize Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
size) (Int
curCount Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Document
x Document -> Pipeline -> Pipeline
forall a. a -> [a] -> [a]
: Pipeline
res) Pipeline
xs
chop :: ([a] -> (b, [a])) -> [a] -> [b]
chop :: forall a b. ([a] -> (b, [a])) -> [a] -> [b]
chop [a] -> (b, [a])
_ [] = []
chop [a] -> (b, [a])
f [a]
as = let (b
b, [a]
as') = [a] -> (b, [a])
f [a]
as in b
b 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 :: Document -> Int
sizeOfDocument Document
d = CursorId -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CursorId -> Int) -> CursorId -> Int
forall a b. (a -> b) -> a -> b
$ ByteString -> CursorId
LBS.length (ByteString -> CursorId) -> ByteString -> CursorId
forall a b. (a -> b) -> a -> b
$ Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ Document -> Put
putDocument Document
d
assignId :: Document -> IO Document
assignId :: Document -> IO Document
assignId Document
doc = if (Field -> Bool) -> Document -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Label
"_id" Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
==) (Label -> Bool) -> (Field -> Label) -> Field -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Field -> Label
label) Document
doc
then Document -> IO Document
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Document
doc
else (\ObjectId
oid -> (Label
"_id" Label -> ObjectId -> Field
forall v. Val v => Label -> v -> Field
=: ObjectId
oid) Field -> Document -> Document
forall a. a -> [a] -> [a]
: Document
doc) (ObjectId -> Document) -> IO ObjectId -> IO Document
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO ObjectId
genObjectId
save :: (MonadIO m)
=> Collection -> Document -> Action m ()
save :: forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
save Label
col Document
doc = case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"_id" Document
doc of
Maybe Value
Nothing -> Label -> Document -> Action m ()
forall (m :: * -> *). MonadIO m => Label -> Document -> Action m ()
insert_ Label
col Document
doc
Just Value
i -> Selection -> Document -> Action m ()
forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
upsert (Document -> Label -> Selection
Select [Label
"_id" Label -> Value -> Field
:= Value
i] Label
col) Document
doc
replace :: (MonadIO m)
=> Selection -> Document -> Action m ()
replace :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
replace = [UpdateOption] -> Selection -> Document -> Action m ()
forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update []
repsert :: (MonadIO m)
=> Selection -> Document -> Action m ()
repsert :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
repsert = [UpdateOption] -> Selection -> Document -> Action m ()
forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption
Upsert]
{-# DEPRECATED repsert "use upsert instead" #-}
upsert :: (MonadIO m)
=> Selection -> Document -> Action m ()
upsert :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
upsert = [UpdateOption] -> Selection -> Document -> Action m ()
forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption
Upsert]
type Modifier = Document
modify :: (MonadIO m)
=> Selection -> Modifier -> Action m ()
modify :: forall (m :: * -> *).
MonadIO m =>
Selection -> Document -> Action m ()
modify = [UpdateOption] -> Selection -> Document -> Action m ()
forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption
MultiUpdate]
update :: (MonadIO m)
=> [UpdateOption] -> Selection -> Document -> Action m ()
update :: forall (m :: * -> *).
MonadIO m =>
[UpdateOption] -> Selection -> Document -> Action m ()
update [UpdateOption]
opts (Select Document
sel Label
col) Document
up = do
Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext m Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
then do
MongoContext
ctx <- ReaderT MongoContext m MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
IO () -> Action m ()
forall a. IO a -> ReaderT MongoContext m a
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 Document) -> ReaderT MongoContext IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action IO (Maybe Document) -> ReaderT MongoContext IO ())
-> Action IO (Maybe Document) -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ Notice -> Action IO (Maybe Document)
write (Label -> [UpdateOption] -> Document -> Document -> Notice
Update (Label
db Label -> Label -> Label
<.> Label
col) [UpdateOption]
opts Document
sel Document
up)) MongoContext
ctx
else do
(IOError -> Failure) -> IO () -> Action m ()
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure (IO () -> Action m ()) -> IO () -> Action m ()
forall a b. (a -> b) -> a -> b
$
Pipe -> [Cmd] -> Maybe FlagBit -> Document -> IO ()
P.sendOpMsg
Pipe
pipe
[Notice -> Cmd
Nc (Label -> [UpdateOption] -> Document -> Document -> Notice
Update (Label
db Label -> Label -> Label
<.> Label
col) [UpdateOption]
opts Document
sel Document
up)]
(FlagBit -> Maybe FlagBit
forall a. a -> Maybe a
Just FlagBit
P.MoreToCome)
[Label
"writeConcern" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]]
updateCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
updateCommandDocument :: Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument Label
col Bool
ordered Pipeline
updates Document
writeConcern =
[ Label
"update" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
col
, Label
"ordered" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
ordered
, Label
"updates" Label -> Pipeline -> Field
forall v. Val v => Label -> v -> Field
=: Pipeline
updates
, Label
"writeConcern" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
writeConcern
]
updateMany :: (MonadIO m)
=> Collection
-> [(Selector, Document, [UpdateOption])]
-> Action m WriteResult
updateMany :: forall (m :: * -> *).
MonadIO m =>
Label
-> [(Document, Document, [UpdateOption])] -> Action m WriteResult
updateMany = Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
forall (m :: * -> *).
MonadIO m =>
Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
update' Bool
True
updateAll :: (MonadIO m)
=> Collection
-> [(Selector, Document, [UpdateOption])]
-> Action m WriteResult
updateAll :: forall (m :: * -> *).
MonadIO m =>
Label
-> [(Document, Document, [UpdateOption])] -> Action m WriteResult
updateAll = Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
forall (m :: * -> *).
MonadIO m =>
Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
update' Bool
False
update' :: (MonadIO m)
=> Bool
-> Collection
-> [(Selector, Document, [UpdateOption])]
-> Action m WriteResult
update' :: forall (m :: * -> *).
MonadIO m =>
Bool
-> Label
-> [(Document, Document, [UpdateOption])]
-> Action m WriteResult
update' Bool
ordered Label
col [(Document, Document, [UpdateOption])]
updateDocs = do
Pipe
p <- (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 :: Pipeline
updates = ((Document, Document, [UpdateOption]) -> Document)
-> [(Document, Document, [UpdateOption])] -> Pipeline
forall a b. (a -> b) -> [a] -> [b]
map (\(Document
s, Document
d, [UpdateOption]
os) -> [ Label
"q" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
s
, Label
"u" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
d
, Label
"upsert" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: (UpdateOption
Upsert UpdateOption -> [UpdateOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpdateOption]
os)
, Label
"multi" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: (UpdateOption
MultiUpdate UpdateOption -> [UpdateOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [UpdateOption]
os)])
[(Document, Document, [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 a. IO a -> ReaderT MongoContext m a
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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
let docSize :: Int
docSize = Document -> Int
sizeOfDocument (Document -> Int) -> Document -> Int
forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument
Label
col
Bool
ordered
[]
Document
writeConcern
let preChunks :: [Either Failure Pipeline]
preChunks = Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit
(ServerData -> Int
maxBsonObjectSize ServerData
sd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
docSize)
(ServerData -> Int
maxWriteBatchSize ServerData
sd)
Pipeline
updates
let chunks :: [Pipeline]
chunks =
if Bool
ordered
then [Either Failure Pipeline] -> [Pipeline]
forall a b. [Either a b] -> [b]
takeRightsUpToLeft [Either Failure Pipeline]
preChunks
else [Either Failure Pipeline] -> [Pipeline]
forall a b. [Either a b] -> [b]
rights [Either Failure Pipeline]
preChunks
let lens :: [Int]
lens = (Pipeline -> Int) -> [Pipeline] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map Pipeline -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Pipeline]
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, Pipeline)]
-> ((Int, Pipeline) -> IO WriteResult)
-> IO [WriteResult]
forall (m :: * -> *) b a.
(Monad m, Result b) =>
Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor Bool
ordered ([Int] -> [Pipeline] -> [(Int, Pipeline)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lSums [Pipeline]
chunks) (((Int, Pipeline) -> IO WriteResult) -> IO [WriteResult])
-> ((Int, Pipeline) -> IO WriteResult) -> IO [WriteResult]
forall a b. (a -> b) -> a -> b
$ \(Int, Pipeline)
b -> do
ReaderT MongoContext IO WriteResult
-> MongoContext -> IO WriteResult
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bool
-> Label -> (Int, Pipeline) -> ReaderT MongoContext IO WriteResult
forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
updateBlock Bool
ordered Label
col (Int, Pipeline)
b) MongoContext
ctx
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 a. a -> IO a
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 = (WriteResult -> Bool) -> [WriteResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any WriteResult -> Bool
failed [WriteResult]
blocks
let updatedTotal :: Int
updatedTotal = [Int] -> Int
forall a. Num a => [a] -> a
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 (WriteResult -> Bool) -> [WriteResult] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe Int -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Int -> Bool)
-> (WriteResult -> Maybe Int) -> WriteResult -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ (WriteResult -> Maybe Int) -> [WriteResult] -> [Int]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe WriteResult -> Maybe Int
nModified [WriteResult]
blocks
let totalWriteErrors :: [Failure]
totalWriteErrors = (WriteResult -> [Failure]) -> [WriteResult] -> [Failure]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteResult -> [Failure]
writeErrors [WriteResult]
blocks
let totalWriteConcernErrors :: [Failure]
totalWriteConcernErrors = (WriteResult -> [Failure]) -> [WriteResult] -> [Failure]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteResult -> [Failure]
writeConcernErrors [WriteResult]
blocks
let upsertedTotal :: [Upserted]
upsertedTotal = (WriteResult -> [Upserted]) -> [WriteResult] -> [Upserted]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap WriteResult -> [Upserted]
upserted [WriteResult]
blocks
WriteResult -> IO WriteResult
forall a. a -> IO a
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 a. a -> IO a
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 :: forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
updateBlock Bool
ordered Label
col (Int
prevCount, Pipeline
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 a. IO a -> ReaderT MongoContext m a
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 if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17 then 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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = 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
$ Document
doc Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let writeErrorsResults :: WriteResult
writeErrorsResults =
case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (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 Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(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
$ Document
err Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"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
$ Document
err Document -> Label -> Maybe String
forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(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 = [Upserted]
-> (Pipeline -> [Upserted]) -> Maybe Pipeline -> [Upserted]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Document -> Upserted) -> Pipeline -> [Upserted]
forall a b. (a -> b) -> [a] -> [b]
map Document -> Upserted
docToUpserted) (Document
doc Document -> Label -> Maybe Pipeline
forall a. Val a => Document -> Label -> Maybe a
!? Label
"upserted")
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
n (Document
doc Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"nModified") Int
0 [Upserted]
upsertedList [] []
WriteResult -> Action m WriteResult
forall a. a -> ReaderT MongoContext m a
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. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
writeErrorsResults, WriteResult
writeConcernResults, WriteResult
successResults]
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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document -> Document -> Document
merge Document
params [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]
Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
updateCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = 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
$ Document
doc Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let writeErrorsResults :: WriteResult
writeErrorsResults =
case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (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 Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0) Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(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
$ Document
err Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"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
$ Document
err Document -> Label -> Maybe String
forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
(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 = [Upserted]
-> (Pipeline -> [Upserted]) -> Maybe Pipeline -> [Upserted]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((Document -> Upserted) -> Pipeline -> [Upserted]
forall a b. (a -> b) -> [a] -> [b]
map Document -> Upserted
docToUpserted) (Document
doc Document -> Label -> Maybe Pipeline
forall a. Val a => Document -> Label -> Maybe a
!? Label
"upserted")
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
n (Document
doc Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"nModified") Int
0 [Upserted]
upsertedList [] []
WriteResult -> Action m WriteResult
forall a. a -> ReaderT MongoContext m a
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. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
writeErrorsResults, WriteResult
writeConcernResults, WriteResult
successResults]
interruptibleFor :: (Monad m, Result b) => Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor :: forall (m :: * -> *) b a.
(Monad m, Result b) =>
Bool -> [a] -> (a -> m b) -> m [b]
interruptibleFor Bool
ordered = [b] -> [a] -> (a -> m b) -> m [b]
go []
where
go :: [b] -> [a] -> (a -> m b) -> m [b]
go ![b]
res [] a -> m b
_ = [b] -> m [b]
forall a. a -> m a
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 a. a -> m a
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 :: Document -> Upserted
docToUpserted Document
doc = Int -> ObjectId -> Upserted
Upserted Int
ind ObjectId
uid
where
ind :: Int
ind = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"index" Document
doc
uid :: ObjectId
uid = Label -> Document -> ObjectId
forall v. Val v => Label -> Document -> v
at Label
"_id" Document
doc
docToWriteError :: Document -> Failure
docToWriteError :: Document -> Failure
docToWriteError Document
doc = Int -> Int -> String -> Failure
WriteFailure Int
ind Int
code String
msg
where
ind :: Int
ind = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"index" Document
doc
code :: Int
code = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"code" Document
doc
msg :: String
msg = Label -> Document -> String
forall v. Val v => Label -> Document -> v
at Label
"errmsg" Document
doc
delete :: (MonadIO m)
=> Selection -> Action m ()
delete :: forall (m :: * -> *). MonadIO m => Selection -> Action m ()
delete Selection
s = do
Pipe
pipe <- (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
pipe
if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
then [DeleteOption] -> Selection -> Action m ()
forall (m :: * -> *).
MonadIO m =>
[DeleteOption] -> Selection -> Action m ()
deleteHelper [] Selection
s
else Label -> [(Document, [DeleteOption])] -> Action m WriteResult
forall (m :: * -> *).
MonadIO m =>
Label -> [(Document, [DeleteOption])] -> Action m WriteResult
deleteMany (Selection -> Label
coll Selection
s) [([], [])] Action m WriteResult -> Action m () -> Action m ()
forall a b.
ReaderT MongoContext m a
-> ReaderT MongoContext m b -> ReaderT MongoContext m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> Action m ()
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
deleteOne :: (MonadIO m)
=> Selection -> Action m ()
deleteOne :: forall (m :: * -> *). MonadIO m => Selection -> Action m ()
deleteOne sel :: Selection
sel@((Select Document
sel' Label
col)) = do
Pipe
pipe <- (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
pipe
if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
then [DeleteOption] -> Selection -> Action m ()
forall (m :: * -> *).
MonadIO m =>
[DeleteOption] -> Selection -> Action m ()
deleteHelper [DeleteOption
SingleRemove] Selection
sel
else do
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
(IOError -> Failure) -> IO () -> Action m ()
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure (IO () -> Action m ()) -> IO () -> Action m ()
forall a b. (a -> b) -> a -> b
$
Pipe -> [Cmd] -> Maybe FlagBit -> Document -> IO ()
P.sendOpMsg
Pipe
pipe
[Notice -> Cmd
Nc (Label -> [DeleteOption] -> Document -> Notice
Delete (Label
db Label -> Label -> Label
<.> Label
col) [] Document
sel')]
(FlagBit -> Maybe FlagBit
forall a. a -> Maybe a
Just FlagBit
P.MoreToCome)
[Label
"writeConcern" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]]
deleteHelper :: (MonadIO m)
=> [DeleteOption] -> Selection -> Action m ()
deleteHelper :: forall (m :: * -> *).
MonadIO m =>
[DeleteOption] -> Selection -> Action m ()
deleteHelper [DeleteOption]
opts (Select Document
sel Label
col) = do
MongoContext
ctx <- ReaderT MongoContext m MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
IO () -> Action m ()
forall a. IO a -> ReaderT MongoContext m a
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 Document) -> ReaderT MongoContext IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Action IO (Maybe Document) -> ReaderT MongoContext IO ())
-> Action IO (Maybe Document) -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ Notice -> Action IO (Maybe Document)
write (Label -> [DeleteOption] -> Document -> Notice
Delete (Label
db Label -> Label -> Label
<.> Label
col) [DeleteOption]
opts Document
sel)) MongoContext
ctx
deleteMany :: (MonadIO m)
=> Collection
-> [(Selector, [DeleteOption])]
-> Action m WriteResult
deleteMany :: forall (m :: * -> *).
MonadIO m =>
Label -> [(Document, [DeleteOption])] -> Action m WriteResult
deleteMany = Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
forall (m :: * -> *).
MonadIO m =>
Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
delete' Bool
True
deleteAll :: (MonadIO m)
=> Collection
-> [(Selector, [DeleteOption])]
-> Action m WriteResult
deleteAll :: forall (m :: * -> *).
MonadIO m =>
Label -> [(Document, [DeleteOption])] -> Action m WriteResult
deleteAll = Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
forall (m :: * -> *).
MonadIO m =>
Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
delete' Bool
False
deleteCommandDocument :: Collection -> Bool -> [Document] -> Document -> Document
deleteCommandDocument :: Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered Pipeline
deletes Document
writeConcern =
[ Label
"delete" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
col
, Label
"ordered" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
ordered
, Label
"deletes" Label -> Pipeline -> Field
forall v. Val v => Label -> v -> Field
=: Pipeline
deletes
, Label
"writeConcern" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
writeConcern
]
delete' :: (MonadIO m)
=> Bool
-> Collection
-> [(Selector, [DeleteOption])]
-> Action m WriteResult
delete' :: forall (m :: * -> *).
MonadIO m =>
Bool
-> Label -> [(Document, [DeleteOption])] -> Action m WriteResult
delete' Bool
ordered Label
col [(Document, [DeleteOption])]
deleteDocs = do
Pipe
p <- (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 :: Pipeline
deletes = ((Document, [DeleteOption]) -> Document)
-> [(Document, [DeleteOption])] -> Pipeline
forall a b. (a -> b) -> [a] -> [b]
map (\(Document
s, [DeleteOption]
os) -> [ Label
"q" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
s
, Label
"limit" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: if DeleteOption
SingleRemove DeleteOption -> [DeleteOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DeleteOption]
os
then (Int
1 :: Int)
else (Int
0 :: Int)
])
[(Document, [DeleteOption])]
deleteDocs
WriteMode
mode <- (MongoContext -> WriteMode) -> ReaderT MongoContext m WriteMode
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> WriteMode
mongoWriteMode
let writeConcern :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
let docSize :: Int
docSize = Document -> Int
sizeOfDocument (Document -> Int) -> Document -> Int
forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered [] Document
writeConcern
let chunks :: [Either Failure Pipeline]
chunks = Int -> Int -> Pipeline -> [Either Failure Pipeline]
splitAtLimit
(ServerData -> Int
maxBsonObjectSize ServerData
sd Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
docSize)
(ServerData -> Int
maxWriteBatchSize ServerData
sd)
Pipeline
deletes
MongoContext
ctx <- ReaderT MongoContext m MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
let lens :: [Int]
lens = (Either Failure Pipeline -> Int)
-> [Either Failure Pipeline] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map ((Failure -> Int)
-> (Pipeline -> Int) -> Either Failure Pipeline -> 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) Pipeline -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length) [Either Failure Pipeline]
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 a. a -> m a
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, Pipeline) -> IO WriteResult
doChunk (Int, Pipeline)
b = ReaderT MongoContext IO WriteResult
-> MongoContext -> IO WriteResult
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Bool
-> Label -> (Int, Pipeline) -> ReaderT MongoContext IO WriteResult
forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
deleteBlock Bool
ordered Label
col (Int, Pipeline)
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 a. IO a -> ReaderT MongoContext m a
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 Pipeline)]
-> ((Int, Either Failure Pipeline) -> 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 Pipeline] -> [(Int, Either Failure Pipeline)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int]
lSums [Either Failure Pipeline]
chunks) (((Int, Either Failure Pipeline) -> IO WriteResult)
-> IO [WriteResult])
-> ((Int, Either Failure Pipeline) -> IO WriteResult)
-> IO [WriteResult]
forall a b. (a -> b) -> a -> b
$ \(Int
n, Either Failure Pipeline
c) ->
case Either Failure Pipeline
c of
Left Failure
e -> Failure -> IO WriteResult
forall {m :: * -> *}. Monad m => Failure -> m WriteResult
failureResult Failure
e
Right Pipeline
b -> (Int, Pipeline) -> IO WriteResult
doChunk (Int
n, Pipeline
b)
WriteResult -> Action m WriteResult
forall a. a -> ReaderT MongoContext m a
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. HasCallStack => (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 :: forall (m :: * -> *).
MonadIO m =>
Bool -> Label -> (Int, Pipeline) -> Action m WriteResult
deleteBlock Bool
ordered Label
col (Int
prevCount, Pipeline
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 a. IO a -> ReaderT MongoContext m a
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 if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
2 Bool -> Bool -> Bool
&& ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17 then 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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document
params
Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = 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
$ Document
doc Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 Maybe Int
forall a. Maybe a
Nothing Int
n [] [] []
let writeErrorsResults :: WriteResult
writeErrorsResults =
case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 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 Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 Maybe Int
forall a. Maybe a
Nothing Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
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
$ Document
err Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"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
$ Document
err Document -> Label -> Maybe String
forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
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 a. a -> ReaderT MongoContext m a
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. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
successResults, WriteResult
writeErrorsResults, WriteResult
writeConcernResults]
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 :: Document
writeConcern = case WriteMode
mode of
WriteMode
NoConfirm -> [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
0 :: Int32)]
Confirm Document
params -> Document -> Document -> Document
merge Document
params [Label
"w" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)]
Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ Label -> Bool -> Pipeline -> Document -> Document
deleteCommandDocument Label
col Bool
ordered Pipeline
docs Document
writeConcern
let n :: Int
n = 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
$ Document
doc Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"n"
let successResults :: WriteResult
successResults = Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 Maybe Int
forall a. Maybe a
Nothing Int
n [] [] []
let writeErrorsResults :: WriteResult
writeErrorsResults =
case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeErrors" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 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 Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"writeConcernError" Document
doc of
Maybe Value
Nothing -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult Bool
False Int
0 Maybe Int
forall a. Maybe a
Nothing Int
0 [] [] []
Just (Doc Document
err) -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
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
$ Document
err Document -> Label -> Maybe Int
forall a. Val a => Document -> Label -> Maybe a
!? Label
"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
$ Document
err Document -> Label -> Maybe String
forall a. Val a => Document -> Label -> Maybe a
!? Label
"errmsg")
]
Just Value
unknownErr -> Bool
-> Int
-> Maybe Int
-> Int
-> [Upserted]
-> [Failure]
-> [Failure]
-> WriteResult
WriteResult
Bool
True
Int
0
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 a. a -> ReaderT MongoContext m a
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. HasCallStack => (a -> a -> a) -> [a] -> a
foldl1' WriteResult -> WriteResult -> WriteResult
mergeWriteResults [WriteResult
successResults, WriteResult
writeErrorsResults, WriteResult
writeConcernResults]
anyToWriteError :: Int -> Value -> Failure
anyToWriteError :: Int -> Value -> Failure
anyToWriteError Int
_ (Doc Document
d) = Document -> Failure
docToWriteError Document
d
anyToWriteError Int
ind Value
_ = Int -> String -> Failure
ProtocolFailure Int
ind String
"Unknown bson value"
data ReadMode =
Fresh
| StaleOk
deriving (Int -> ReadMode -> ShowS
[ReadMode] -> ShowS
ReadMode -> String
(Int -> ReadMode -> ShowS)
-> (ReadMode -> String) -> ([ReadMode] -> ShowS) -> Show ReadMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadMode -> ShowS
showsPrec :: Int -> ReadMode -> ShowS
$cshow :: ReadMode -> String
show :: ReadMode -> String
$cshowList :: [ReadMode] -> ShowS
showList :: [ReadMode] -> ShowS
Show, ReadMode -> ReadMode -> Bool
(ReadMode -> ReadMode -> Bool)
-> (ReadMode -> ReadMode -> Bool) -> Eq ReadMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReadMode -> ReadMode -> Bool
== :: ReadMode -> ReadMode -> Bool
$c/= :: ReadMode -> ReadMode -> Bool
/= :: ReadMode -> ReadMode -> Bool
Eq)
readModeOption :: ReadMode -> [QueryOption]
readModeOption :: ReadMode -> [QueryOption]
readModeOption ReadMode
Fresh = []
readModeOption ReadMode
StaleOk = [QueryOption
SlaveOK]
data Query = Query {
Query -> [QueryOption]
options :: [QueryOption],
Query -> Selection
selection :: Selection,
Query -> Document
project :: Projector,
Query -> Limit
skip :: Word32,
Query -> Limit
limit :: Limit,
Query -> Document
sort :: Order,
Query -> Bool
snapshot :: Bool,
Query -> Limit
batchSize :: BatchSize,
Query -> Document
hint :: Order
} deriving (Int -> Query -> ShowS
[Query] -> ShowS
Query -> String
(Int -> Query -> ShowS)
-> (Query -> String) -> ([Query] -> ShowS) -> Show Query
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Query -> ShowS
showsPrec :: Int -> Query -> ShowS
$cshow :: Query -> String
show :: Query -> String
$cshowList :: [Query] -> ShowS
showList :: [Query] -> ShowS
Show, Query -> Query -> Bool
(Query -> Query -> Bool) -> (Query -> Query -> Bool) -> Eq Query
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Query -> Query -> Bool
== :: Query -> Query -> Bool
$c/= :: Query -> Query -> Bool
/= :: Query -> Query -> Bool
Eq)
type Projector = Document
type Limit = Word32
type Order = Document
type BatchSize = Word32
noticeCommands :: [Text]
noticeCommands :: [Label]
noticeCommands = [ Label
"aggregate"
, Label
"count"
, Label
"delete"
, Label
"findAndModify"
, Label
"insert"
, Label
"listCollections"
, Label
"update"
]
adminCommands :: [Text]
adminCommands :: [Label]
adminCommands = [ Label
"buildinfo"
, Label
"clone"
, Label
"collstats"
, Label
"copydb"
, Label
"copydbgetnonce"
, Label
"create"
, Label
"dbstats"
, Label
"deleteIndexes"
, Label
"drop"
, Label
"dropDatabase"
, Label
"renameCollection"
, Label
"repairDatabase"
, Label
"serverStatus"
, Label
"validate"
]
query :: Selector -> Collection -> Query
query :: Document -> Label -> Query
query Document
sel Label
col = [QueryOption]
-> Selection
-> Document
-> Limit
-> Limit
-> Document
-> Bool
-> Limit
-> Document
-> Query
Query [] (Document -> Label -> Selection
Select Document
sel Label
col) [] Limit
0 Limit
0 [] Bool
False Limit
0 []
find :: MonadIO m => Query -> Action m Cursor
find :: forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find q :: Query
q@Query{Selection
selection :: Query -> Selection
selection :: Selection
selection, Limit
batchSize :: Query -> Limit
batchSize :: Limit
batchSize} = do
Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext m Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
then do
(Request, Maybe Limit)
qr <- Bool -> Query -> Action m (Request, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
False Query
q
DelayedBatch
dBatch <- IO DelayedBatch -> ReaderT MongoContext m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
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 Limit) -> IO DelayedBatch
request Pipe
pipe [] (Request, Maybe Limit)
qr
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db (Selection -> Label
coll Selection
selection) Limit
batchSize DelayedBatch
dBatch
else do
(Cmd, Maybe Limit)
qr <- Bool -> Query -> Action m (Cmd, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q
let newQr :: (Cmd, Maybe Limit)
newQr =
case (Cmd, Maybe Limit) -> Cmd
forall a b. (a, b) -> a
fst (Cmd, Maybe Limit)
qr of
Req P.Query{Int32
Document
[QueryOption]
Label
qBatchSize :: Request -> Int32
qFullCollection :: Request -> Label
qOptions :: Request -> [QueryOption]
qProjector :: Request -> Document
qSelector :: Request -> Document
qSkip :: Request -> Int32
qOptions :: [QueryOption]
qFullCollection :: Label
qSkip :: Int32
qBatchSize :: Int32
qSelector :: Document
qProjector :: Document
..} ->
let coll :: Label
coll = [Label] -> Label
forall a. HasCallStack => [a] -> a
last ([Label] -> Label) -> [Label] -> Label
forall a b. (a -> b) -> a -> b
$ HasCallStack => Label -> Label -> [Label]
Label -> Label -> [Label]
T.splitOn Label
"." Label
qFullCollection
in (Request -> Cmd
Req (Request -> Cmd) -> Request -> Cmd
forall a b. (a -> b) -> a -> b
$ P.Query {qSelector :: Document
qSelector = Document -> Document -> Document
merge Document
qSelector [ Label
"find" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll ], Int32
Document
[QueryOption]
Label
qBatchSize :: Int32
qFullCollection :: Label
qOptions :: [QueryOption]
qProjector :: Document
qSkip :: Int32
qOptions :: [QueryOption]
qFullCollection :: Label
qSkip :: Int32
qBatchSize :: Int32
qProjector :: Document
..}, (Cmd, Maybe Limit) -> Maybe Limit
forall a b. (a, b) -> b
snd (Cmd, Maybe Limit)
qr)
Cmd
_ -> String -> (Cmd, Maybe Limit)
forall a. HasCallStack => String -> a
error String
"impossible"
DelayedBatch
dBatch <- IO DelayedBatch -> ReaderT MongoContext m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
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 -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Cmd, Maybe Limit)
newQr []
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db (Selection -> Label
coll Selection
selection) Limit
batchSize DelayedBatch
dBatch
findCommand :: (MonadIO m) => Query -> Action m Cursor
findCommand :: forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
findCommand q :: Query
q@Query{Bool
Document
[QueryOption]
Limit
Selection
sort :: Query -> Document
limit :: Query -> Limit
options :: Query -> [QueryOption]
selection :: Query -> Selection
project :: Query -> Document
skip :: Query -> Limit
snapshot :: Query -> Bool
batchSize :: Query -> Limit
hint :: Query -> Document
options :: [QueryOption]
selection :: Selection
project :: Document
skip :: Limit
limit :: Limit
sort :: Document
snapshot :: Bool
batchSize :: Limit
hint :: Document
..} = do
Pipe
pipe <- (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
pipe
if ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
then do
let aColl :: Label
aColl = Selection -> Label
coll Selection
selection
Document
response <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$
[ Label
"find" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
aColl
, Label
"filter" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Selection -> Document
selector Selection
selection
, Label
"sort" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
sort
, Label
"projection" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
project
, Label
"hint" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
hint
, Label
"skip" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: Limit -> Int32
forall a. Integral a => a -> Int32
toInt32 Limit
skip
]
Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ Pipeline -> Document
forall a. Monoid a => [a] -> a
mconcat
[ Label
"batchSize" Label -> Maybe Int32 -> Document
forall a. Val a => Label -> Maybe a -> Document
=? (Limit -> Bool) -> (Limit -> Int32) -> Limit -> Maybe Int32
forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe (Limit -> Limit -> Bool
forall a. Eq a => a -> a -> Bool
/= Limit
0) Limit -> Int32
forall a. Integral a => a -> Int32
toInt32 Limit
batchSize
, Label
"limit" Label -> Maybe Int32 -> Document
forall a. Val a => Label -> Maybe a -> Document
=? (Limit -> Bool) -> (Limit -> Int32) -> Limit -> Maybe Int32
forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe (Limit -> Limit -> Bool
forall a. Eq a => a -> a -> Bool
/= Limit
0) Limit -> Int32
forall a. Integral a => a -> Int32
toInt32 Limit
limit
]
Label -> Document -> Action m (Either String Cursor)
forall (m :: * -> *).
MonadIO m =>
Label -> Document -> Action m (Either String Cursor)
getCursorFromResponse Label
aColl Document
response
Action m (Either String Cursor)
-> (Either String Cursor -> Action m Cursor) -> Action m Cursor
forall a b.
ReaderT MongoContext m a
-> (a -> ReaderT MongoContext m b) -> ReaderT MongoContext m b
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 a. IO a -> ReaderT MongoContext m a
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 (Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"code" Document
response)) Cursor -> Action m Cursor
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return
else Query -> Action m Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find Query
q
where
toInt32 :: Integral a => a -> Int32
toInt32 :: forall a. Integral a => a -> Int32
toInt32 = a -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral
toMaybe :: (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe :: forall a b. (a -> Bool) -> (a -> b) -> a -> Maybe b
toMaybe a -> Bool
predicate a -> b
f a
a
| a -> Bool
predicate a
a = b -> Maybe b
forall a. a -> Maybe a
Just (a -> b
f a
a)
| Bool
otherwise = Maybe b
forall a. Maybe a
Nothing
isHandshake :: Document -> Bool
isHandshake :: Document -> Bool
isHandshake = (Document -> Document -> Bool
forall a. Eq a => a -> a -> Bool
== [Label
"isMaster" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Int32
1 :: Int32)])
findOne :: (MonadIO m) => Query -> Action m (Maybe Document)
findOne :: forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
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
let legacyQuery :: Action m (Maybe Document)
legacyQuery = do
(Request, Maybe Limit)
qr <- Bool -> Query -> Action m (Request, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
False Query
q {limit = 1}
DelayedBatch
rq <- IO DelayedBatch -> ReaderT MongoContext m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
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 Limit) -> IO DelayedBatch
request Pipe
pipe [] (Request, Maybe Limit)
qr
Batch Maybe Limit
_ CursorId
_ Pipeline
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 Document -> Action m (Maybe Document)
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pipeline -> Maybe Document
forall a. [a] -> Maybe a
listToMaybe Pipeline
docs)
if Document -> Bool
isHandshake (Selection -> Document
selector (Selection -> Document) -> Selection -> Document
forall a b. (a -> b) -> a -> b
$ Query -> Selection
selection Query
q)
then Action m (Maybe Document)
legacyQuery
else do
let sd :: ServerData
sd = Pipe -> ServerData
P.serverData Pipe
pipe
if (ServerData -> Int
maxWireVersion ServerData
sd Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17)
then Action m (Maybe Document)
legacyQuery
else do
(Cmd, Maybe Limit)
qr <- Bool -> Query -> Action m (Cmd, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
False Query
q {limit = 1}
let newQr :: (Cmd, Maybe Limit)
newQr =
case (Cmd, Maybe Limit) -> Cmd
forall a b. (a, b) -> a
fst (Cmd, Maybe Limit)
qr of
Req P.Query{Int32
Document
[QueryOption]
Label
qBatchSize :: Request -> Int32
qFullCollection :: Request -> Label
qOptions :: Request -> [QueryOption]
qProjector :: Request -> Document
qSelector :: Request -> Document
qSkip :: Request -> Int32
qOptions :: [QueryOption]
qFullCollection :: Label
qSkip :: Int32
qBatchSize :: Int32
qSelector :: Document
qProjector :: Document
..} ->
let coll :: Label
coll = [Label] -> Label
forall a. HasCallStack => [a] -> a
last ([Label] -> Label) -> [Label] -> Label
forall a b. (a -> b) -> a -> b
$ HasCallStack => Label -> Label -> [Label]
Label -> Label -> [Label]
T.splitOn Label
"." Label
qFullCollection
labels :: [Value]
labels = [Maybe Value] -> [Value]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Value] -> [Value]) -> [Maybe Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ (Label -> Maybe Value) -> [Label] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map (\Label
f -> Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
f Document
qSelector) ([Label]
noticeCommands [Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++ [Label]
adminCommands) :: [Value]
in if [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Value]
labels
then (Request -> Cmd
Req P.Query {qSelector :: Document
qSelector = Document -> Document -> Document
merge Document
qSelector [ Label
"find" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll ], Int32
Document
[QueryOption]
Label
qBatchSize :: Int32
qFullCollection :: Label
qOptions :: [QueryOption]
qProjector :: Document
qSkip :: Int32
qOptions :: [QueryOption]
qFullCollection :: Label
qSkip :: Int32
qBatchSize :: Int32
qProjector :: Document
..}, (Cmd, Maybe Limit) -> Maybe Limit
forall a b. (a, b) -> b
snd (Cmd, Maybe Limit)
qr)
else (Cmd, Maybe Limit)
qr
Cmd
_ -> String -> (Cmd, Maybe Limit)
forall a. HasCallStack => String -> a
error String
"impossible"
DelayedBatch
rq <- IO DelayedBatch -> ReaderT MongoContext m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
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 -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Cmd, Maybe Limit)
newQr []
Batch Maybe Limit
_ CursorId
_ Pipeline
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 Document -> Action m (Maybe Document)
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pipeline -> Maybe Document
forall a. [a] -> Maybe a
listToMaybe Pipeline
docs)
fetch :: (MonadIO m) => Query -> Action m Document
fetch :: forall (m :: * -> *). MonadIO m => Query -> Action m Document
fetch Query
q = Query -> Action m (Maybe Document)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Document)
findOne Query
q Action m (Maybe Document)
-> (Maybe Document -> ReaderT MongoContext m Document)
-> ReaderT MongoContext m Document
forall a b.
ReaderT MongoContext m a
-> (a -> ReaderT MongoContext m b) -> ReaderT MongoContext m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReaderT MongoContext m Document
-> (Document -> ReaderT MongoContext m Document)
-> Maybe Document
-> ReaderT MongoContext m Document
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO Document -> ReaderT MongoContext m Document
forall a. IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Document -> ReaderT MongoContext m Document)
-> IO Document -> ReaderT MongoContext m Document
forall a b. (a -> b) -> a -> b
$ Failure -> IO Document
forall e a. Exception e => e -> IO a
throwIO (Failure -> IO Document) -> Failure -> IO Document
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) Document -> ReaderT MongoContext m Document
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return
data FindAndModifyOpts
= FamRemove Bool
| FamUpdate
{ FindAndModifyOpts -> Document
famUpdate :: Document
, FindAndModifyOpts -> Bool
famNew :: Bool
, FindAndModifyOpts -> Bool
famUpsert :: Bool
}
deriving Int -> FindAndModifyOpts -> ShowS
[FindAndModifyOpts] -> ShowS
FindAndModifyOpts -> String
(Int -> FindAndModifyOpts -> ShowS)
-> (FindAndModifyOpts -> String)
-> ([FindAndModifyOpts] -> ShowS)
-> Show FindAndModifyOpts
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FindAndModifyOpts -> ShowS
showsPrec :: Int -> FindAndModifyOpts -> ShowS
$cshow :: FindAndModifyOpts -> String
show :: FindAndModifyOpts -> String
$cshowList :: [FindAndModifyOpts] -> ShowS
showList :: [FindAndModifyOpts] -> ShowS
Show
defFamUpdateOpts :: Document -> FindAndModifyOpts
defFamUpdateOpts :: Document -> FindAndModifyOpts
defFamUpdateOpts Document
ups = FamUpdate
{ famNew :: Bool
famNew = Bool
True
, famUpsert :: Bool
famUpsert = Bool
False
, famUpdate :: Document
famUpdate = Document
ups
}
findAndModify :: (MonadIO m)
=> Query
-> Document
-> Action m (Either String Document)
findAndModify :: forall (m :: * -> *).
MonadIO m =>
Query -> Document -> Action m (Either String Document)
findAndModify Query
q Document
ups = do
Either String (Maybe Document)
eres <- Query
-> FindAndModifyOpts -> Action m (Either String (Maybe Document))
forall (m :: * -> *).
MonadIO m =>
Query
-> FindAndModifyOpts -> Action m (Either String (Maybe Document))
findAndModifyOpts Query
q (Document -> FindAndModifyOpts
defFamUpdateOpts Document
ups)
Either String Document -> Action m (Either String Document)
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Document -> Action m (Either String Document))
-> Either String Document -> Action m (Either String Document)
forall a b. (a -> b) -> a -> b
$ case Either String (Maybe Document)
eres of
Left String
l -> String -> Either String Document
forall a b. a -> Either a b
Left String
l
Right Maybe Document
r -> case Maybe Document
r of
Maybe Document
Nothing -> String -> Either String Document
forall a b. a -> Either a b
Left String
"findAndModify: impossible null result"
Just Document
doc -> Document -> Either String Document
forall a b. b -> Either a b
Right Document
doc
findAndModifyOpts :: (MonadIO m)
=> Query
-> FindAndModifyOpts
-> Action m (Either String (Maybe Document))
findAndModifyOpts :: forall (m :: * -> *).
MonadIO m =>
Query
-> FindAndModifyOpts -> Action m (Either String (Maybe Document))
findAndModifyOpts Query {
selection :: Query -> Selection
selection = Select Document
sel Label
collection
, project :: Query -> Document
project = Document
project
, sort :: Query -> Document
sort = Document
sort
} FindAndModifyOpts
famOpts = do
Document
result <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand
([ Label
"findAndModify" Label -> Value -> Field
:= Label -> Value
String Label
collection
, Label
"query" Label -> Value -> Field
:= Document -> Value
Doc Document
sel
, Label
"fields" Label -> Value -> Field
:= Document -> Value
Doc Document
project
, Label
"sort" Label -> Value -> Field
:= Document -> Value
Doc Document
sort
] Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++
case FindAndModifyOpts
famOpts of
FamRemove Bool
shouldRemove -> [ Label
"remove" Label -> Value -> Field
:= Bool -> Value
Bool Bool
shouldRemove ]
FamUpdate {Bool
Document
famUpdate :: FindAndModifyOpts -> Document
famNew :: FindAndModifyOpts -> Bool
famUpsert :: FindAndModifyOpts -> Bool
famUpdate :: Document
famNew :: Bool
famUpsert :: Bool
..} ->
[ Label
"update" Label -> Value -> Field
:= Document -> Value
Doc Document
famUpdate
, Label
"new" Label -> Value -> Field
:= Bool -> Value
Bool Bool
famNew
, Label
"upsert" Label -> Value -> Field
:= Bool -> Value
Bool Bool
famUpsert
])
Either String (Maybe Document)
-> Action m (Either String (Maybe Document))
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe Document)
-> Action m (Either String (Maybe Document)))
-> Either String (Maybe Document)
-> Action m (Either String (Maybe Document))
forall a b. (a -> b) -> a -> b
$ case Document -> Maybe String
lookupErr Document
result of
Just String
e -> String -> Either String (Maybe Document)
leftErr String
e
Maybe String
Nothing -> case Label -> Document -> Maybe (Maybe Document)
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"value" Document
result of
Maybe (Maybe Document)
Nothing -> String -> Either String (Maybe Document)
leftErr String
"no document found"
Just Maybe Document
mdoc -> case Maybe Document
mdoc of
Just doc :: Document
doc@(Field
_:Document
_) -> Maybe Document -> Either String (Maybe Document)
forall a b. b -> Either a b
Right (Document -> Maybe Document
forall a. a -> Maybe a
Just Document
doc)
Just [] -> case FindAndModifyOpts
famOpts of
FamUpdate { famUpsert :: FindAndModifyOpts -> Bool
famUpsert = Bool
True, famNew :: FindAndModifyOpts -> Bool
famNew = Bool
False } -> Maybe Document -> Either String (Maybe Document)
forall a b. b -> Either a b
Right Maybe Document
forall a. Maybe a
Nothing
FindAndModifyOpts
_ -> String -> Either String (Maybe Document)
leftErr (String -> Either String (Maybe Document))
-> String -> Either String (Maybe Document)
forall a b. (a -> b) -> a -> b
$ Document -> String
forall a. Show a => a -> String
show Document
result
Maybe Document
_ -> String -> Either String (Maybe Document)
leftErr (String -> Either String (Maybe Document))
-> String -> Either String (Maybe Document)
forall a b. (a -> b) -> a -> b
$ Document -> String
forall a. Show a => a -> String
show Document
result
where
leftErr :: String -> Either String (Maybe Document)
leftErr String
err = String -> Either String (Maybe Document)
forall a b. a -> Either a b
Left (String -> Either String (Maybe Document))
-> String -> Either String (Maybe Document)
forall a b. (a -> b) -> a -> b
$ String
"findAndModify " String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` Label -> String
forall a. Show a => a -> String
show Label
collection
String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` String
"\nfrom query: " String -> ShowS
forall a. Monoid a => a -> a -> a
`mappend` Document -> String
forall a. Show a => a -> String
show Document
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 :: Document -> Maybe String
lookupErr Document
result = do
Document
errObject <- Label -> Document -> Maybe Document
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"lastErrorObject" Document
result
Label -> Document -> Maybe String
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"err" Document
errObject
explain :: (MonadIO m) => Query -> Action m Document
explain :: forall (m :: * -> *). MonadIO m => Query -> Action m Document
explain Query
q = do
Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext m Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
(Request, Maybe Limit)
qr <- Bool -> Query -> Action m (Request, Maybe Limit)
forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
True Query
q {limit = 1}
DelayedBatch
r <- IO DelayedBatch -> ReaderT MongoContext m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
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 Limit) -> IO DelayedBatch
request Pipe
pipe [] (Request, Maybe Limit)
qr
Batch Maybe Limit
_ CursorId
_ Pipeline
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
Document -> Action m Document
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Document -> Action m Document) -> Document -> Action m Document
forall a b. (a -> b) -> a -> b
$ if Pipeline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs then String -> Document
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 Pipeline -> Document
forall a. HasCallStack => [a] -> a
head Pipeline
docs
count :: (MonadIO m) => Query -> Action m Int
count :: forall (m :: * -> *). MonadIO m => Query -> Action m Int
count Query{selection :: Query -> Selection
selection = Select Document
sel Label
col, Limit
skip :: Query -> Limit
skip :: Limit
skip, Limit
limit :: Query -> Limit
limit :: Limit
limit} = Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"n" (Document -> Int)
-> ReaderT MongoContext m Document -> ReaderT MongoContext m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand
([Label
"count" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
col, Label
"query" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
sel, Label
"skip" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Limit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
skip :: Int32)]
Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ (Label
"limit" Label -> Maybe Int32 -> Document
forall a. Val a => Label -> Maybe a -> Document
=? if Limit
limit Limit -> Limit -> Bool
forall a. Eq a => a -> a -> Bool
== Limit
0 then Maybe Int32
forall a. Maybe a
Nothing else Int32 -> Maybe Int32
forall a. a -> Maybe a
Just (Limit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
limit :: Int32)))
distinct :: (MonadIO m) => Label -> Selection -> Action m [Value]
distinct :: forall (m :: * -> *).
MonadIO m =>
Label -> Selection -> Action m [Value]
distinct Label
k (Select Document
sel Label
col) = Label -> Document -> [Value]
forall v. Val v => Label -> Document -> v
at Label
"values" (Document -> [Value])
-> ReaderT MongoContext m Document
-> ReaderT MongoContext m [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Document -> ReaderT MongoContext m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
"distinct" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
col, Label
"key" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
k, Label
"query" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
sel]
queryRequest :: (Monad m, MonadIO m) => Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest :: forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Request, Maybe Limit)
queryRequest Bool
isExplain Query{Bool
Document
[QueryOption]
Limit
Selection
sort :: Query -> Document
limit :: Query -> Limit
options :: Query -> [QueryOption]
selection :: Query -> Selection
project :: Query -> Document
skip :: Query -> Limit
snapshot :: Query -> Bool
batchSize :: Query -> Limit
hint :: Query -> Document
options :: [QueryOption]
selection :: Selection
project :: Document
skip :: Limit
limit :: Limit
sort :: Document
snapshot :: Bool
batchSize :: Limit
hint :: Document
..} = do
MongoContext
ctx <- ReaderT MongoContext m MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
(Request, Maybe Limit) -> Action m (Request, Maybe Limit)
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Request, Maybe Limit) -> Action m (Request, Maybe Limit))
-> (Request, Maybe Limit) -> Action m (Request, Maybe Limit)
forall a b. (a -> b) -> a -> b
$ ReadMode -> Label -> (Request, Maybe Limit)
queryRequest' (MongoContext -> ReadMode
mongoReadMode MongoContext
ctx) (MongoContext -> Label
mongoDatabase MongoContext
ctx)
where
queryRequest' :: ReadMode -> Label -> (Request, Maybe Limit)
queryRequest' ReadMode
rm Label
db = (P.Query{Int32
Document
[QueryOption]
Label
qBatchSize :: Int32
qFullCollection :: Label
qOptions :: [QueryOption]
qProjector :: Document
qSelector :: Document
qSkip :: Int32
qOptions :: [QueryOption]
qFullCollection :: Label
qSkip :: Int32
qBatchSize :: Int32
qProjector :: Document
qSelector :: Document
..}, Maybe Limit
remainingLimit) where
qOptions :: [QueryOption]
qOptions = ReadMode -> [QueryOption]
readModeOption ReadMode
rm [QueryOption] -> [QueryOption] -> [QueryOption]
forall a. [a] -> [a] -> [a]
++ [QueryOption]
options
qFullCollection :: Label
qFullCollection = Label
db Label -> Label -> Label
<.> Selection -> Label
coll Selection
selection
qSkip :: Int32
qSkip = Limit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
skip
(Int32
qBatchSize, Maybe Limit
remainingLimit) = Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize (if Limit
limit Limit -> Limit -> Bool
forall a. Eq a => a -> a -> Bool
== Limit
0 then Maybe Limit
forall a. Maybe a
Nothing else Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
limit)
qProjector :: Document
qProjector = Document
project
mOrder :: Maybe Field
mOrder = if Document -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
sort then Maybe Field
forall a. Maybe a
Nothing else Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"$orderby" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
sort)
mSnapshot :: Maybe Field
mSnapshot = if Bool
snapshot then Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"$snapshot" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True) else Maybe Field
forall a. Maybe a
Nothing
mHint :: Maybe Field
mHint = if Document -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
hint then Maybe Field
forall a. Maybe a
Nothing else Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"$hint" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
hint)
mExplain :: Maybe Field
mExplain = if Bool
isExplain then Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"$explain" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True) else Maybe Field
forall a. Maybe a
Nothing
special :: Document
special = [Maybe Field] -> Document
forall a. [Maybe a] -> [a]
catMaybes [Maybe Field
mOrder, Maybe Field
mSnapshot, Maybe Field
mHint, Maybe Field
mExplain]
qSelector :: Document
qSelector = if Document -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
special then Document
s else (Label
"$query" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
s) Field -> Document -> Document
forall a. a -> [a] -> [a]
: Document
special where s :: Document
s = Selection -> Document
selector Selection
selection
queryRequestOpMsg :: (Monad m, MonadIO m) => Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg :: forall (m :: * -> *).
(Monad m, MonadIO m) =>
Bool -> Query -> Action m (Cmd, Maybe Limit)
queryRequestOpMsg Bool
isExplain Query{Bool
Document
[QueryOption]
Limit
Selection
sort :: Query -> Document
limit :: Query -> Limit
options :: Query -> [QueryOption]
selection :: Query -> Selection
project :: Query -> Document
skip :: Query -> Limit
snapshot :: Query -> Bool
batchSize :: Query -> Limit
hint :: Query -> Document
options :: [QueryOption]
selection :: Selection
project :: Document
skip :: Limit
limit :: Limit
sort :: Document
snapshot :: Bool
batchSize :: Limit
hint :: Document
..} = do
MongoContext
ctx <- ReaderT MongoContext m MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
(Cmd, Maybe Limit) -> Action m (Cmd, Maybe Limit)
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Cmd, Maybe Limit) -> Action m (Cmd, Maybe Limit))
-> (Cmd, Maybe Limit) -> Action m (Cmd, Maybe Limit)
forall a b. (a -> b) -> a -> b
$ ReadMode -> Label -> (Cmd, Maybe Limit)
queryRequest' (MongoContext -> ReadMode
mongoReadMode MongoContext
ctx) (MongoContext -> Label
mongoDatabase MongoContext
ctx)
where
queryRequest' :: ReadMode -> Label -> (Cmd, Maybe Limit)
queryRequest' ReadMode
rm Label
db = (Request -> Cmd
Req P.Query{Int32
Document
[QueryOption]
Label
qBatchSize :: Int32
qFullCollection :: Label
qOptions :: [QueryOption]
qProjector :: Document
qSelector :: Document
qSkip :: Int32
qOptions :: [QueryOption]
qFullCollection :: Label
qSkip :: Int32
qBatchSize :: Int32
qProjector :: Document
qSelector :: Document
..}, Maybe Limit
remainingLimit) where
qOptions :: [QueryOption]
qOptions = ReadMode -> [QueryOption]
readModeOption ReadMode
rm [QueryOption] -> [QueryOption] -> [QueryOption]
forall a. [a] -> [a] -> [a]
++ [QueryOption]
options
qFullCollection :: Label
qFullCollection = Label
db Label -> Label -> Label
<.> Selection -> Label
coll Selection
selection
qSkip :: Int32
qSkip = Limit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
skip
(Int32
qBatchSize, Maybe Limit
remainingLimit) = Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize (if Limit
limit Limit -> Limit -> Bool
forall a. Eq a => a -> a -> Bool
== Limit
0 then Maybe Limit
forall a. Maybe a
Nothing else Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
limit)
isNotCommand :: Bool
isNotCommand = [Value] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Value] -> Bool) -> [Value] -> Bool
forall a b. (a -> b) -> a -> b
$ [Maybe Value] -> [Value]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Value] -> [Value]) -> [Maybe Value] -> [Value]
forall a b. (a -> b) -> a -> b
$ (Label -> Maybe Value) -> [Label] -> [Maybe Value]
forall a b. (a -> b) -> [a] -> [b]
map (\Label
l -> Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
l (Selection -> Document
selector Selection
selection)) ([Label]
noticeCommands [Label] -> [Label] -> [Label]
forall a. [a] -> [a] -> [a]
++ [Label]
adminCommands)
mOrder :: Maybe Field
mOrder = if Document -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
sort then Maybe Field
forall a. Maybe a
Nothing else Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"sort" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
sort)
mSnapshot :: Maybe Field
mSnapshot = if Bool
snapshot then Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"snapshot" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True) else Maybe Field
forall a. Maybe a
Nothing
mHint :: Maybe Field
mHint = if Document -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Document
hint then Maybe Field
forall a. Maybe a
Nothing else Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"hint" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
hint)
mExplain :: Maybe Field
mExplain = if Bool
isExplain then Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"$explain" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True) else Maybe Field
forall a. Maybe a
Nothing
special :: Document
special = [Maybe Field] -> Document
forall a. [Maybe a] -> [a]
catMaybes [Maybe Field
mOrder, Maybe Field
mSnapshot, Maybe Field
mHint, Maybe Field
mExplain]
qProjector :: Document
qProjector = if Bool
isNotCommand then [Label
"projection" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
project] else Document
project
qSelector :: Document
qSelector = if Bool
isNotCommand then Document
c else Document
s
where s :: Document
s = Selection -> Document
selector Selection
selection
bSize :: Maybe Field
bSize = if Int32
qBatchSize Int32 -> Int32 -> Bool
forall a. Eq a => a -> a -> Bool
== Int32
0 then Maybe Field
forall a. Maybe a
Nothing else Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"batchSize" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: Int32
qBatchSize)
mLimit :: Maybe Field
mLimit = if Limit
limit Limit -> Limit -> Bool
forall a. Eq a => a -> a -> Bool
== Limit
0 then Maybe Field
forall a. Maybe a
Nothing else Maybe Field -> (Limit -> Maybe Field) -> Maybe Limit -> Maybe Field
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Field
forall a. Maybe a
Nothing (\Limit
rL -> Field -> Maybe Field
forall a. a -> Maybe a
Just (Label
"limit"