-- | Query and update documents

{-# LANGUAGE OverloadedStrings, RecordWildCards, NamedFieldPuns, TupleSections, FlexibleContexts, FlexibleInstances, UndecidableInstances, MultiParamTypeClasses, TypeFamilies, CPP, DeriveDataTypeable, ScopedTypeVariables, BangPatterns #-}

module Database.MongoDB.Query (
    -- * Monad
    Action, access, Failure(..), ErrorCode,
    AccessMode(..), GetLastError, master, slaveOk, accessMode,
    liftDB,
    MongoContext(..), HasMongoContext(..),
    -- * Database
    Database, allDatabases, useDb, thisDatabase,
    -- ** Authentication
    Username, Password, auth, authMongoCR, authSCRAMSHA1, authSCRAMSHA256,
    -- * Collection
    Collection, allCollections,
    -- ** Selection
    Selection(..), Selector, whereJS,
    Select(select),
    -- * Write
    -- ** Insert
    insert, insert_, insertMany, insertMany_, insertAll, insertAll_,
    -- ** Update
    save, replace, repsert, upsert, Modifier, modify, updateMany, updateAll,
    WriteResult(..), UpdateOption(..), Upserted(..),
    -- ** Delete
    delete, deleteOne, deleteMany, deleteAll, DeleteOption(..),
    -- * Read
    -- ** Query
    Query(..), QueryOption(NoCursorTimeout, TailableCursor, AwaitData, Partial),
    Projector, Limit, Order, BatchSize,
    explain, find, findCommand, findOne, fetch,
    findAndModify, findAndModifyOpts, FindAndModifyOpts(..), defFamUpdateOpts,
    count, distinct,
    -- *** Cursor
    Cursor, nextBatch, next, nextN, rest, closeCursor, isCursorClosed,
    -- ** Aggregate
    Pipeline, AggregateConfig(..), aggregate, aggregateCursor,
    -- ** Group
    Group(..), GroupKey(..), group,
    -- ** MapReduce
    MapReduce(..), MapFun, ReduceFun, FinalizeFun, MROut(..), MRMerge(..),
    MRResult, mapReduce, runMR, runMR',
    -- * Command
    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)

-- * Monad

type Action = ReaderT MongoContext
-- ^ A monad on top of m (which must be a MonadIO) that may access the database and may fail with a DB 'Failure'

access :: (MonadIO m) => Pipe -> AccessMode -> Database -> Action m a -> m a
-- ^ Run action against database on server at other end of pipe. Use access mode for any reads and writes.
-- Throw 'Failure' in case of any error.
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
..}

-- | A connection failure, or a read or write exception like cursor expired or inserting a duplicate key.
-- Note, unexpected data from the server is not a Failure, rather it is a programming error (you should call 'error' in this case) because the client and server are incompatible and requires a programming change.
data Failure =
     ConnectionFailure IOError  -- ^ TCP connection ('Pipeline') failed. May work if you try again on the same Mongo 'Connection' which will create a new Pipe.
    | CursorNotFoundFailure CursorId  -- ^ Cursor expired because it wasn't accessed for over 10 minutes, or this cursor came from a different server that the one you are currently connected to (perhaps a fail over happen between servers in a replica set)
    | QueryFailure ErrorCode String  -- ^ Query failed for some reason as described in the string
    | WriteFailure Int ErrorCode String -- ^ Error observed by getLastError after a write, error description is in string, index of failed document is the first argument
    | WriteConcernFailure Int String  -- ^ Write concern error. It's reported only by insert, update, delete commands. Not by wire protocol.
    | DocNotFound Selection  -- ^ 'fetch' found no document matching selection
    | AggregateFailure String -- ^ 'aggregate' returned an error
    | CompoundFailure [Failure] -- ^ When we need to aggregate several failures and report them.
    | ProtocolFailure Int String -- ^ The structure of the returned documents doesn't match what we expected
    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
-- ^ Error code from @getLastError@ or query failure.

-- | Type of reads and writes to perform.
data AccessMode =
     ReadStaleOk  -- ^ Read-only action, reading stale data from a slave is OK.
    | UnconfirmedWrites  -- ^ Read-write action, slave not OK, every write is fire & forget.
    | ConfirmWrites GetLastError  -- ^ Read-write action, slave not OK, every write is confirmed with @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
-- ^ Parameters for @getLastError@ command. For example @[\"w\" =: 2]@ tells the server to wait for the write to reach at least two servers in replica set before acknowledging. See <http://www.mongodb.org/display/DOCS/Last+Error+Commands> for more options.

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
                  -- ^ Mongodb server before 2.6 doesn't allow to calculate this value.
                  -- This field is meaningless if we can't calculate the number of modified documents.
                  , 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
-- ^ Same as 'ConfirmWrites' []
master :: AccessMode
master = Document -> AccessMode
ConfirmWrites []

slaveOk :: AccessMode
-- ^ Same as 'ReadStaleOk'
slaveOk :: AccessMode
slaveOk = AccessMode
ReadStaleOk

accessMode :: (Monad m) => AccessMode -> Action m a -> Action m a
-- ^ Run action with given 'AccessMode'
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

-- | Values needed when executing a db operation
data MongoContext = MongoContext {
    MongoContext -> Pipe
mongoPipe :: Pipe, -- ^ operations read/write to this pipelined TCP connection to a MongoDB server
    MongoContext -> AccessMode
mongoAccessMode :: AccessMode, -- ^ read/write operation will use this access mode
    MongoContext -> Label
mongoDatabase :: Database -- ^ operations query/update this 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)

-- * Database

type Database = Text

allDatabases :: (MonadIO m) => Action m [Database]
-- ^ List all databases residing on server
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
-- ^ Current database in use
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
-- ^ Run action against given database
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})

-- * Authentication

auth :: MonadIO m => Username -> Password -> Action m Bool
-- ^ Authenticate with the current database (if server is running in secure mode). Return whether authentication was successful or not. Reauthentication is required for every new pipe. SCRAM-SHA-1 will be used for server versions 3.0+, MONGO-CR for lower versions.
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
-- ^ Authenticate with the current database, using the MongoDB-CR authentication mechanism (default in MongoDB server < 3.0)
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

-- | It should technically perform SASLprep, but the implementation is currently id
saslprep :: Text -> Text
saslprep :: Label -> Label
saslprep = Label -> Label
forall a. a -> a
id

authSCRAMWith :: MonadIO m => HashAlgorithm -> Username -> Password -> Action m Bool
-- ^ Authenticate with the current database, using the SCRAM-SHA-1 authentication mechanism (default in MongoDB server >= 3.0)
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)

-- As long as server api  is not requested OP_Query has to be used. See:
-- https://github.com/mongodb/specifications/blob/6dc6f80026f0f8d99a8c81f996389534b14f6602/source/mongodb-handshake/handshake.rst#specification
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

-- * Collection

type Collection = Text
-- ^ Collection name (not prefixed with database)

allCollections :: MonadIO m => Action m [Collection]
-- ^ List all collections in this database
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"

-- * Selection

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)
-- ^ Selects documents in collection that match selector

type Selector = Document
-- ^ Filter for a query, analogous to the where clause in SQL. @[]@ matches all documents in collection. @[\"x\" =: a, \"y\" =: b]@ is analogous to @where x = a and y = b@ in SQL. See <http://www.mongodb.org/display/DOCS/Querying> for full selector syntax.

whereJS :: Selector -> Javascript -> Selector
-- ^ Add Javascript predicate to selector, in which case a document must match both selector and predicate
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
    -- ^ 'Query' or 'Selection' that selects documents in collection that match selector. The choice of type depends on use, for example, in @'find' (select sel col)@ it is a Query, and in @'delete' (select sel col)@ it is a Selection.

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

-- * Write

data WriteMode =
      NoConfirm  -- ^ Submit writes without receiving acknowledgments. Fast. Assumes writes succeed even though they may not.
    | Confirm GetLastError  -- ^ Receive an acknowledgment after every write, and raise exception if one says the write failed. This is acomplished by sending the getLastError command, with given 'GetLastError' parameters, after every write.
    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)
-- ^ Send write to server, and if write-mode is 'Safe' then include getLastError request and raise 'WriteFailure' if it reports an error.
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

insert :: (MonadIO m) => Collection -> Document -> Action m Value
-- ^ Insert document into collection and return its \"_id\" value, which is created automatically if not supplied
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 ()
-- ^ Same as 'insert' except don't return _id
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]
-- ^ Insert documents into collection and return their \"_id\" values,
-- which are created automatically if not supplied.
-- If a document fails to be inserted (eg. due to duplicate key)
-- then remaining docs are aborted, and @LastError@ is set.
-- An exception will be throw if any error occurs.
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 ()
-- ^ Same as 'insertMany' except don't return _ids
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]
-- ^ Insert documents into collection and return their \"_id\" values,
-- which are created automatically if not supplied. If a document fails
-- to be inserted (eg. due to duplicate key) then remaining docs
-- are still inserted.
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 ()
-- ^ Same as 'insertAll' except don't return _ids
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 documents into collection and return their \"_id\" values, which are created automatically if not supplied
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)
                                           -- size of auxiliary part of insert
                                           -- document should be subtracted from
                                           -- the overall size
                      (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])
-- ^ This will fail if the list of documents is bigger than restrictions
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
              -- In older versions of ^^ the protocol we can't really say which document failed.
              -- So we just report the accumulated number of documents in the previous blocks.

        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 {- 8 bytes =
            1 byte: element type.
            6 bytes: key name. |key| <= log (maxWriteBatchSize = 100000)
            1 byte: \x00.
            See https://bsonspec.org/spec.html
          -}
          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
-- ^ Assign a unique value to _id field if missing
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

-- ** Update

save :: (MonadIO m)
     => Collection -> Document -> Action m ()
-- ^ Save document to collection, meaning insert it if its new (has no \"_id\" field) or upsert it if its not new (has \"_id\" field)
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 first document in selection with given document
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 ()
-- ^ Replace first document in selection with given document, or insert document if selection is empty
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 ()
-- ^ Update first document in selection with given document, or insert document if selection is empty
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
-- ^ Update operations on fields in a document. See <https://docs.mongodb.com/manual/reference/operator/update/>

modify :: (MonadIO m)
       => Selection -> Modifier -> Action m ()
-- ^ Update all documents in selection using given modifier
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 first document in selection using updater document, unless 'MultiUpdate' option is supplied then update all documents in selection. If 'Upsert' option is supplied then treat updater as document and insert it if selection is empty.
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
  ]

{-| Bulk update operation. If one update fails it will not update the remaining
    documents. Current returned value is only a place holder. With mongodb server
    before 2.6 it will send update requests one by one. In order to receive
    error messages in versions under 2.6 you need to user confirmed writes.
    Otherwise even if the errors had place the list of errors will be empty and
    the result will be success. After 2.6 it will use bulk update feature in
    mongodb.
 -}
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

{-| Bulk update operation. If one update fails it will proceed with the
    remaining documents. With mongodb server before 2.6 it will send update
    requests one by one. In order to receive error messages in versions under
    2.6 you need to use confirmed writes.  Otherwise even if the errors had
    place the list of errors will be empty and the result will be success.
    After 2.6 it will use bulk update feature in mongodb.
 -}
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)
                                             -- size of auxiliary part of update
                                             -- document should be subtracted from
                                             -- the overall size
                        (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 -- nRemoved
                  [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)
        -- This function is used in foldl1' function. The first argument is the accumulator.
        -- The list in the accumulator is usually longer than the subsequent value which goes in the second argument.
        -- So, changing the order of list concatenation allows us to keep linear complexity of the
        -- whole list accumulation process.
        ([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

delete :: (MonadIO m)
       => Selection -> Action m ()
-- ^ Delete all documents in selection
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 ()
-- ^ Delete first document in selection
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
        -- Starting with v6 confirming writes via getLastError as it is
        -- performed in the deleteHelper call via its call to write is
        -- deprecated. To confirm writes now an appropriate writeConcern has to be
        -- set. These confirmations were discarded in deleteHelper anyway so no
        -- need to dispatch on the writeConcern as it is currently done in deleteHelper
        -- via write for older versions
        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

{-| Bulk delete operation. If one delete fails it will not delete the remaining
    documents. Current returned value is only a place holder. With mongodb server
    before 2.6 it will send delete requests one by one. After 2.6 it will use
    bulk delete feature in mongodb.
 -}
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

{-| Bulk delete operation. If one delete fails it will proceed with the
    remaining documents. Current returned value is only a place holder. With
    mongodb server before 2.6 it will send delete requests one by one. After 2.6
    it will use bulk delete feature in mongodb.
 -}
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) -- Remove only one matching
                                               else (Int
0 :: Int) -- Remove all matching
                                 ])
                    [(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)
                                           -- size of auxiliary part of delete
                                           -- document should be subtracted from
                                           -- the overall size
                      (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"

-- * Read

data ReadMode =
      Fresh  -- ^ read from master only
    | StaleOk  -- ^ read from slave ok
    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]

-- ** Query

-- | Use 'select' to create a basic query with defaults, then modify if desired. For example, @(select sel col) {limit = 10}@
data Query = Query {
    Query -> [QueryOption]
options :: [QueryOption],  -- ^ Default = @[]@
    Query -> Selection
selection :: Selection,
    Query -> Document
project :: Projector,  -- ^ @[]@ = all fields. Default = @[]@
    Query -> Limit
skip :: Word32,  -- ^ Number of initial matching documents to skip. Default = 0
    Query -> Limit
limit :: Limit, -- ^ Maximum number of documents to return, 0 = no limit. Default = 0
    Query -> Document
sort :: Order,  -- ^ Sort results by this order, @[]@ = no sort. Default = @[]@
    Query -> Bool
snapshot :: Bool,  -- ^ If true assures no duplicates are returned, or objects missed, which were present at both the start and end of the query's execution (even if the object were updated). If an object is new during the query, or deleted during the query, it may or may not be returned, even with snapshot mode. Note that short query responses (less than 1MB) are always effectively snapshotted. Default = @False@
    Query -> Limit
batchSize :: BatchSize,  -- ^ The number of document to return in each batch response from the server. 0 means use Mongo default. Default = 0
    Query -> Document
hint :: Order  -- ^ Force MongoDB to use this index, @[]@ = no hint. Default = @[]@
    } 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
-- ^ Fields to return, analogous to the select clause in SQL. @[]@ means return whole document (analogous to * in SQL). @[\"x\" =: 1, \"y\" =: 1]@ means return only @x@ and @y@ fields of each document. @[\"x\" =: 0]@ means return all fields except @x@.

type Limit = Word32
-- ^ Maximum number of documents to return, i.e. cursor will close after iterating over this number of documents. 0 means no limit.

type Order = Document
-- ^ Fields to sort by. Each one is associated with 1 or -1. Eg. @[\"x\" =: 1, \"y\" =: -1]@ means sort by @x@ ascending then @y@ descending

type BatchSize = Word32
-- ^ The number of document to return in each batch response from the server. 0 means use Mongo default.

-- noticeCommands and adminCommands are needed to identify whether
-- queryRequestOpMsg is called via runCommand or not. If not it will
-- behave like being called by a "find"-like command and add additional fields
-- specific to the find command into the selector, such as "filter", "projection" etc.
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
-- ^ Selects documents in collection that match selector. It uses no query options, projects all fields, does not skip any documents, does not limit result size, uses default batch size, does not sort, does not hint, and does not snapshot.
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
-- ^ Fetch documents satisfying query
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)
                -- queryRequestOpMsg only returns Cmd types constructed via Req
                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
-- ^ Fetch documents satisfying query using the command "find"
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 -- optional fields. They should not be present if set to 0 and mongo will use defaults
             [ 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)
-- ^ Fetch first document satisfying query or @Nothing@ if none satisfy it
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
                          -- We have to understand whether findOne is called as
                          -- command directly. This is necessary since findOne is used via
                          -- runCommand as a vehicle to execute any type of commands and notices.
                          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
-- ^ Same as 'findOne' except throw 'DocNotFound' if none match
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

-- | Options for @findAndModify@
data FindAndModifyOpts
  = FamRemove Bool -- ^ remove the selected document when the boolean is @True@
  | FamUpdate
    { FindAndModifyOpts -> Document
famUpdate :: Document -- ^ the update instructions, or a replacement document
    , FindAndModifyOpts -> Bool
famNew :: Bool -- ^ return the document with the modifications made on the update
    , FindAndModifyOpts -> Bool
famUpsert :: Bool -- ^ create a new document if no documents match the query
    }
  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

-- | Default options used by 'findAndModify'.
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
                       }

-- | Run the @findAndModify@ command as an update without an upsert and new set to @True@.
-- Return a single updated document (@new@ option is set to @True@).
--
-- See 'findAndModifyOpts' for more options.
findAndModify :: (MonadIO m)
              => Query
              -> Document -- ^ updates
              -> 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
      -- only possible when upsert is True and new is False
      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

-- | Run the @findAndModify@ command
-- (allows more options than 'findAndModify')
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    -- return updated document, not original document
                , Label
"upsert" Label -> Value -> Field
:= Bool -> Value
Bool Bool
famUpsert -- insert if nothing is found
                ])
    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

    -- return Nothing means ok, Just is the error message
    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
-- ^ Return performance stats of query execution
explain :: forall (m :: * -> *). MonadIO m => Query -> Action m Document
explain Query
q = do  -- same as findOne but with explain set to true
    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
-- ^ Fetch number of documents satisfying query (including effect of skip and/or limit if present)
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]
-- ^ Fetch distinct values of field in selected documents
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)
-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
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)
-- ^ Translate Query to Protocol.Query. If first arg is true then add special $explain attribute.
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)
        -- Check whether this query is not a command in disguise. If
        -- isNotCommand is true, then we treat this as a find command and add
        -- the relevant fields to the selector
        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" Label -> Int32 -> Field
forall v. Val v => Label -> v -> Field
=: (Limit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
rL :: Int32))) Maybe Limit
remainingLimit
                c :: Document
c = (Label
"filter" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
s) Field -> Document -> Document
forall a. a -> [a] -> [a]
: Document
special Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ Maybe Field -> Document
forall a. Maybe a -> [a]
maybeToList Maybe Field
bSize Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ Maybe Field -> Document
forall a. Maybe a -> [a]
maybeToList Maybe Field
mLimit

batchSizeRemainingLimit :: BatchSize -> Maybe Limit -> (Int32, Maybe Limit)
-- ^ Given batchSize and limit return P.qBatchSize and remaining limit
batchSizeRemainingLimit :: Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize Maybe Limit
mLimit =
  let remaining :: Limit
remaining =
        case Maybe Limit
mLimit of
          Maybe Limit
Nothing    -> Limit
batchSize
          Just Limit
limit ->
            if Limit
0 Limit -> Limit -> Bool
forall a. Ord a => a -> a -> Bool
< Limit
batchSize Bool -> Bool -> Bool
&& Limit
batchSize Limit -> Limit -> Bool
forall a. Ord a => a -> a -> Bool
< Limit
limit
              then Limit
batchSize
              else Limit
limit
  in (Limit -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
remaining, Maybe Limit
mLimit)

type DelayedBatch = IO Batch
-- ^ A promised batch which may fail

data Batch = Batch (Maybe Limit) CursorId [Document]
-- ^ CursorId = 0 means cursor is finished. Documents is remaining documents to serve in current batch. Limit is number of documents to return. Nothing means no limit.

request :: Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
-- ^ Send notices and request and return promised batch
request :: Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [Notice]
ns (Request
req, Maybe Limit
remainingLimit) = do
    IO Reply
promise <- (IOError -> Failure) -> IO (IO Reply) -> IO (IO Reply)
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure (IO (IO Reply) -> IO (IO Reply)) -> IO (IO Reply) -> IO (IO Reply)
forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> Request -> IO (IO Reply)
P.call Pipe
pipe [Notice]
ns Request
req
    let protectedPromise :: IO Reply
protectedPromise = (IOError -> Failure) -> IO Reply -> IO Reply
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure IO Reply
promise
    DelayedBatch -> IO DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch -> IO DelayedBatch)
-> DelayedBatch -> IO DelayedBatch
forall a b. (a -> b) -> a -> b
$ Maybe Limit -> Reply -> DelayedBatch
fromReply Maybe Limit
remainingLimit (Reply -> DelayedBatch) -> IO Reply -> DelayedBatch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Reply
protectedPromise

requestOpMsg :: Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
-- ^ Send notices and request and return promised batch
requestOpMsg :: Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Req Request
r, Maybe Limit
remainingLimit) Document
params = do
  IO Reply
promise <- (IOError -> Failure) -> IO (IO Reply) -> IO (IO Reply)
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure (IO (IO Reply) -> IO (IO Reply)) -> IO (IO Reply) -> IO (IO Reply)
forall a b. (a -> b) -> a -> b
$ Pipe -> Request -> Maybe FlagBit -> Document -> IO (IO Reply)
P.callOpMsg Pipe
pipe Request
r Maybe FlagBit
forall a. Maybe a
Nothing Document
params
  let protectedPromise :: IO Reply
protectedPromise = (IOError -> Failure) -> IO Reply -> IO Reply
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure IO Reply
promise
  DelayedBatch -> IO DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch -> IO DelayedBatch)
-> DelayedBatch -> IO DelayedBatch
forall a b. (a -> b) -> a -> b
$ Maybe Limit -> Reply -> DelayedBatch
fromReply Maybe Limit
remainingLimit (Reply -> DelayedBatch) -> IO Reply -> DelayedBatch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Reply
protectedPromise
requestOpMsg Pipe
_ (Cmd, Maybe Limit)
_ Document
_ = String -> IO DelayedBatch
forall a. HasCallStack => String -> a
error String
"requestOpMsg: Only messages of type Query are supported"

fromReply :: Maybe Limit -> Reply -> DelayedBatch
-- ^ Convert Reply to Batch or Failure
fromReply :: Maybe Limit -> Reply -> DelayedBatch
fromReply Maybe Limit
limit Reply{Int32
CursorId
Pipeline
[ResponseFlag]
rResponseFlags :: [ResponseFlag]
rCursorId :: CursorId
rStartingFrom :: Int32
rDocuments :: Pipeline
rResponseFlags :: Reply -> [ResponseFlag]
rCursorId :: Reply -> CursorId
rStartingFrom :: Reply -> Int32
rDocuments :: Reply -> Pipeline
..} = do
    (ResponseFlag -> IO ()) -> [ResponseFlag] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ResponseFlag -> IO ()
checkResponseFlag [ResponseFlag]
rResponseFlags
    Batch -> DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
rCursorId Pipeline
rDocuments)
 where
    -- If response flag indicates failure then throw it, otherwise do nothing
    checkResponseFlag :: ResponseFlag -> IO ()
checkResponseFlag ResponseFlag
flag = case ResponseFlag
flag of
        ResponseFlag
AwaitCapable -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        ResponseFlag
CursorNotFound -> Failure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Failure -> IO ()) -> Failure -> IO ()
forall a b. (a -> b) -> a -> b
$ CursorId -> Failure
CursorNotFoundFailure CursorId
rCursorId
        ResponseFlag
QueryError -> Failure -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Failure -> IO ()) -> Failure -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> String -> Failure
QueryFailure (Label -> Document -> Int
forall v. Val v => Label -> Document -> v
at Label
"code" (Document -> Int) -> Document -> Int
forall a b. (a -> b) -> a -> b
$ Pipeline -> Document
forall a. HasCallStack => [a] -> a
head Pipeline
rDocuments) (Label -> Document -> String
forall v. Val v => Label -> Document -> v
at Label
"$err" (Document -> String) -> Document -> String
forall a b. (a -> b) -> a -> b
$ Pipeline -> Document
forall a. HasCallStack => [a] -> a
head Pipeline
rDocuments)
fromReply Maybe Limit
limit ReplyOpMsg{Pipeline
[FlagBit]
Maybe Int32
flagBits :: [FlagBit]
sections :: Pipeline
checksum :: Maybe Int32
flagBits :: Reply -> [FlagBit]
sections :: Reply -> Pipeline
checksum :: Reply -> Maybe Int32
..} = do
    let section :: Document
section = Pipeline -> Document
forall a. HasCallStack => [a] -> a
head Pipeline
sections
        cur :: Maybe Document
cur = Maybe Document
-> (Value -> Maybe Document) -> Maybe Value -> Maybe Document
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe Document
forall a. Maybe a
Nothing Value -> Maybe Document
forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast (Maybe Value -> Maybe Document) -> Maybe Value -> Maybe Document
forall a b. (a -> b) -> a -> b
$ Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"cursor" Document
section
    case Maybe Document
cur of
      Maybe Document
Nothing -> Batch -> DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
0 Pipeline
sections)
      Just Document
doc ->
          case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"firstBatch" Document
doc of
            Just Value
ar -> do
              let docs :: Pipeline
docs = Maybe Pipeline -> Pipeline
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Pipeline -> Pipeline) -> Maybe Pipeline -> Pipeline
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Pipeline
forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast Value
ar
                  id' :: CursorId
id' = Maybe CursorId -> CursorId
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CursorId -> CursorId) -> Maybe CursorId -> CursorId
forall a b. (a -> b) -> a -> b
$ Value -> Maybe CursorId
forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast (Value -> Maybe CursorId) -> Value -> Maybe CursorId
forall a b. (a -> b) -> a -> b
$ Label -> Document -> Value
valueAt Label
"id" Document
doc
              Batch -> DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
id' Pipeline
docs)
            -- A cursor without a firstBatch field, should be a reply to a
            -- getMore query and thus have a nextBatch key
            Maybe Value
Nothing -> do
              let docs :: Pipeline
docs = Maybe Pipeline -> Pipeline
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Pipeline -> Pipeline) -> Maybe Pipeline -> Pipeline
forall a b. (a -> b) -> a -> b
$ Value -> Maybe Pipeline
forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast (Value -> Maybe Pipeline) -> Value -> Maybe Pipeline
forall a b. (a -> b) -> a -> b
$ Label -> Document -> Value
valueAt Label
"nextBatch" Document
doc
                  id' :: CursorId
id' = Maybe CursorId -> CursorId
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe CursorId -> CursorId) -> Maybe CursorId -> CursorId
forall a b. (a -> b) -> a -> b
$ Value -> Maybe CursorId
forall a (m :: * -> *). (Val a, MonadFail m) => Value -> m a
cast (Value -> Maybe CursorId) -> Value -> Maybe CursorId
forall a b. (a -> b) -> a -> b
$ Label -> Document -> Value
valueAt Label
"id" Document
doc
              Batch -> DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
limit CursorId
id' Pipeline
docs)

fulfill :: DelayedBatch -> Action IO Batch
-- ^ Demand and wait for result, raise failure if exception
fulfill :: DelayedBatch -> ReaderT MongoContext IO Batch
fulfill = DelayedBatch -> ReaderT MongoContext IO Batch
forall a. IO a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- *** Cursor

data Cursor = Cursor FullCollection BatchSize (MVar DelayedBatch)
-- ^ Iterator over results of a query. Use 'next' to iterate or 'rest' to get all results. A cursor is closed when it is explicitly closed, all results have been read from it, garbage collected, or not used for over 10 minutes (unless 'NoCursorTimeout' option was specified in 'Query'). Reading from a closed cursor raises a 'CursorNotFoundFailure'. Note, a cursor is not closed when the pipe is closed, so you can open another pipe to the same server and continue using the cursor.

newCursor :: MonadIO m => Database -> Collection -> BatchSize -> DelayedBatch -> Action m Cursor
-- ^ Create new cursor. If you don't read all results then close it. Cursor will be closed automatically when all results are read from it or when eventually garbage collected.
newCursor :: forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
col Limit
batchSize DelayedBatch
dBatch = do
    MVar DelayedBatch
var <- IO (MVar DelayedBatch)
-> ReaderT MongoContext m (MVar DelayedBatch)
forall a. IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MVar DelayedBatch)
 -> ReaderT MongoContext m (MVar DelayedBatch))
-> IO (MVar DelayedBatch)
-> ReaderT MongoContext m (MVar DelayedBatch)
forall a b. (a -> b) -> a -> b
$ DelayedBatch -> IO (MVar DelayedBatch)
forall a. a -> IO (MVar a)
MV.newMVar DelayedBatch
dBatch
    let cursor :: Cursor
cursor = Label -> Limit -> MVar DelayedBatch -> Cursor
Cursor (Label
db Label -> Label -> Label
<.> Label
col) Limit
batchSize MVar DelayedBatch
var
    Weak (MVar DelayedBatch)
_ <- Action IO (Weak (MVar DelayedBatch))
-> ReaderT MongoContext m (Weak (MVar DelayedBatch))
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (Action IO (Weak (MVar DelayedBatch))
 -> ReaderT MongoContext m (Weak (MVar DelayedBatch)))
-> Action IO (Weak (MVar DelayedBatch))
-> ReaderT MongoContext m (Weak (MVar DelayedBatch))
forall a b. (a -> b) -> a -> b
$ MVar DelayedBatch
-> ReaderT MongoContext IO ()
-> Action IO (Weak (MVar DelayedBatch))
forall a.
MVar a -> ReaderT MongoContext IO () -> Action IO (Weak (MVar a))
mkWeakMVar MVar DelayedBatch
var (Cursor -> ReaderT MongoContext IO ()
forall (m :: * -> *). MonadIO m => Cursor -> Action m ()
closeCursor Cursor
cursor)
    Cursor -> Action m Cursor
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return Cursor
cursor

nextBatch :: MonadIO m => Cursor -> Action m [Document]
-- ^ Return next batch of documents in query result, which will be empty if finished.
nextBatch :: forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
nextBatch (Cursor Label
fcol Limit
batchSize MVar DelayedBatch
var) = Action IO Pipeline -> ReaderT MongoContext m Pipeline
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (Action IO Pipeline -> ReaderT MongoContext m Pipeline)
-> Action IO Pipeline -> ReaderT MongoContext m Pipeline
forall a b. (a -> b) -> a -> b
$ MVar DelayedBatch
-> (DelayedBatch -> Action IO (DelayedBatch, Pipeline))
-> Action IO Pipeline
forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar DelayedBatch
var ((DelayedBatch -> Action IO (DelayedBatch, Pipeline))
 -> Action IO Pipeline)
-> (DelayedBatch -> Action IO (DelayedBatch, Pipeline))
-> Action IO Pipeline
forall a b. (a -> b) -> a -> b
$ \DelayedBatch
dBatch -> do
    -- Pre-fetch next batch promise from server and return current batch.
    Batch Maybe Limit
mLimit CursorId
cid Pipeline
docs <- ReaderT MongoContext IO Batch -> ReaderT MongoContext IO Batch
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (ReaderT MongoContext IO Batch -> ReaderT MongoContext IO Batch)
-> ReaderT MongoContext IO Batch -> ReaderT MongoContext IO Batch
forall a b. (a -> b) -> a -> b
$ Label -> Limit -> DelayedBatch -> ReaderT MongoContext IO Batch
fulfill' Label
fcol Limit
batchSize DelayedBatch
dBatch
    let newLimit :: Maybe Limit
newLimit = do
              Limit
limit <- Maybe Limit
mLimit
              Limit -> Maybe Limit
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Limit -> Maybe Limit) -> Limit -> Maybe Limit
forall a b. (a -> b) -> a -> b
$ Limit
limit Limit -> Limit -> Limit
forall a. Num a => a -> a -> a
- Limit -> Limit -> Limit
forall a. Ord a => a -> a -> a
min Limit
limit (Int -> Limit
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Limit) -> Int -> Limit
forall a b. (a -> b) -> a -> b
$ Pipeline -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Pipeline
docs)
    let emptyBatch :: DelayedBatch
emptyBatch = 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 (Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) CursorId
0 []
    let getNextBatch :: ReaderT MongoContext IO DelayedBatch
getNextBatch = Label
-> Limit
-> Maybe Limit
-> CursorId
-> ReaderT MongoContext IO DelayedBatch
forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
newLimit CursorId
cid
    let resultDocs :: Pipeline
resultDocs = (Pipeline -> Pipeline)
-> (Limit -> Pipeline -> Pipeline)
-> Maybe Limit
-> Pipeline
-> Pipeline
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Pipeline -> Pipeline
forall a. a -> a
id (Int -> Pipeline -> Pipeline
forall a. Int -> [a] -> [a]
take (Int -> Pipeline -> Pipeline)
-> (Limit -> Int) -> Limit -> Pipeline -> Pipeline
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Limit -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral) Maybe Limit
mLimit Pipeline
docs
    case (CursorId
cid, Maybe Limit
newLimit) of
      (CursorId
0, Maybe Limit
_)      -> (DelayedBatch, Pipeline) -> Action IO (DelayedBatch, Pipeline)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
emptyBatch, Pipeline
resultDocs)
      (CursorId
_, Just Limit
0) -> do
        Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext IO Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
        (IOError -> Failure) -> IO () -> ReaderT MongoContext IO ()
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure (IO () -> ReaderT MongoContext IO ())
-> IO () -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> IO ()
P.send Pipe
pipe [[CursorId] -> Notice
KillCursors [CursorId
cid]]
        (DelayedBatch, Pipeline) -> Action IO (DelayedBatch, Pipeline)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
emptyBatch, Pipeline
resultDocs)
      (CursorId
_, Maybe Limit
_)      -> (, Pipeline
resultDocs) (DelayedBatch -> (DelayedBatch, Pipeline))
-> ReaderT MongoContext IO DelayedBatch
-> Action IO (DelayedBatch, Pipeline)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT MongoContext IO DelayedBatch
getNextBatch

fulfill' :: FullCollection -> BatchSize -> DelayedBatch -> Action IO Batch
-- Discard pre-fetched batch if empty with nonzero cid.
fulfill' :: Label -> Limit -> DelayedBatch -> ReaderT MongoContext IO Batch
fulfill' Label
fcol Limit
batchSize DelayedBatch
dBatch = do
    b :: Batch
b@(Batch Maybe Limit
limit CursorId
cid Pipeline
docs) <- DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
dBatch
    if CursorId
cid CursorId -> CursorId -> Bool
forall a. Eq a => a -> a -> Bool
/= CursorId
0 Bool -> Bool -> Bool
&& Pipeline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs Bool -> Bool -> Bool
&& (Maybe Limit
limit Maybe Limit -> Maybe Limit -> Bool
forall a. Ord a => a -> a -> Bool
> Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0)
        then Label
-> Limit
-> Maybe Limit
-> CursorId
-> ReaderT MongoContext IO DelayedBatch
forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
limit CursorId
cid ReaderT MongoContext IO DelayedBatch
-> (DelayedBatch -> ReaderT MongoContext IO Batch)
-> ReaderT MongoContext IO Batch
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
>>= DelayedBatch -> ReaderT MongoContext IO Batch
fulfill
        else Batch -> ReaderT MongoContext IO Batch
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Batch
b

nextBatch' :: (MonadIO m) => FullCollection -> BatchSize -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' :: forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
limit CursorId
cid = do
    Pipe
pipe <- (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 IO DelayedBatch -> Action m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DelayedBatch -> Action m DelayedBatch)
-> IO DelayedBatch -> Action m DelayedBatch
forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> (Request, Maybe Limit) -> IO DelayedBatch
request Pipe
pipe [] (Label -> Int32 -> CursorId -> Request
GetMore Label
fcol Int32
batchSize' CursorId
cid, Maybe Limit
remLimit)
      else IO DelayedBatch -> Action m DelayedBatch
forall a. IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DelayedBatch -> Action m DelayedBatch)
-> IO DelayedBatch -> Action m DelayedBatch
forall a b. (a -> b) -> a -> b
$ Pipe -> (Cmd, Maybe Limit) -> Document -> IO DelayedBatch
requestOpMsg Pipe
pipe (Request -> Cmd
Req (Request -> Cmd) -> Request -> Cmd
forall a b. (a -> b) -> a -> b
$ Label -> Int32 -> CursorId -> Request
GetMore Label
fcol Int32
batchSize' CursorId
cid, Maybe Limit
remLimit) []
    where (Int32
batchSize', Maybe Limit
remLimit) = Limit -> Maybe Limit -> (Int32, Maybe Limit)
batchSizeRemainingLimit Limit
batchSize Maybe Limit
limit

next :: MonadIO m => Cursor -> Action m (Maybe Document)
-- ^ Return next document in query result, or Nothing if finished.
next :: forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Document)
next (Cursor Label
fcol Limit
batchSize MVar DelayedBatch
var) = 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
$ MVar DelayedBatch
-> (DelayedBatch -> Action IO (DelayedBatch, Maybe Document))
-> Action IO (Maybe Document)
forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar DelayedBatch
var DelayedBatch -> Action IO (DelayedBatch, Maybe Document)
nextState where
    -- Pre-fetch next batch promise from server when last one in current batch is returned.
    -- nextState:: DelayedBatch -> Action m (DelayedBatch, Maybe Document)
    nextState :: DelayedBatch -> Action IO (DelayedBatch, Maybe Document)
nextState DelayedBatch
dBatch = do
        Batch Maybe Limit
mLimit CursorId
cid Pipeline
docs <- ReaderT MongoContext IO Batch -> ReaderT MongoContext IO Batch
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (ReaderT MongoContext IO Batch -> ReaderT MongoContext IO Batch)
-> ReaderT MongoContext IO Batch -> ReaderT MongoContext IO Batch
forall a b. (a -> b) -> a -> b
$ Label -> Limit -> DelayedBatch -> ReaderT MongoContext IO Batch
fulfill' Label
fcol Limit
batchSize DelayedBatch
dBatch
        if Maybe Limit
mLimit Maybe Limit -> Maybe Limit -> Bool
forall a. Eq a => a -> a -> Bool
== Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0
          then (DelayedBatch, Maybe Document)
-> Action IO (DelayedBatch, Maybe Document)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) CursorId
0 [], Maybe Document
forall a. Maybe a
Nothing)
          else
            case Pipeline
docs of
                Document
doc : Pipeline
docs' -> do
                    let newLimit :: Maybe Limit
newLimit = do
                              Limit
limit <- Maybe Limit
mLimit
                              Limit -> Maybe Limit
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Limit -> Maybe Limit) -> Limit -> Maybe Limit
forall a b. (a -> b) -> a -> b
$ Limit
limit Limit -> Limit -> Limit
forall a. Num a => a -> a -> a
- Limit
1
                    DelayedBatch
dBatch' <- if Pipeline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs' Bool -> Bool -> Bool
&& CursorId
cid CursorId -> CursorId -> Bool
forall a. Eq a => a -> a -> Bool
/= CursorId
0 Bool -> Bool -> Bool
&& ((Maybe Limit
newLimit Maybe Limit -> Maybe Limit -> Bool
forall a. Ord a => a -> a -> Bool
> Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) Bool -> Bool -> Bool
|| Maybe Limit -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Limit
newLimit)
                        then Label
-> Limit
-> Maybe Limit
-> CursorId
-> ReaderT MongoContext IO DelayedBatch
forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
newLimit CursorId
cid
                        else DelayedBatch -> ReaderT MongoContext IO DelayedBatch
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch -> ReaderT MongoContext IO DelayedBatch)
-> DelayedBatch -> ReaderT MongoContext IO DelayedBatch
forall a b. (a -> b) -> a -> b
$ Batch -> DelayedBatch
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Limit -> CursorId -> Pipeline -> Batch
Batch Maybe Limit
newLimit CursorId
cid Pipeline
docs')
                    Bool -> ReaderT MongoContext IO () -> ReaderT MongoContext IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Limit
newLimit Maybe Limit -> Maybe Limit -> Bool
forall a. Eq a => a -> a -> Bool
== Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) (ReaderT MongoContext IO () -> ReaderT MongoContext IO ())
-> ReaderT MongoContext IO () -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> ReaderT MongoContext IO () -> ReaderT MongoContext IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CursorId
cid CursorId -> CursorId -> Bool
forall a. Eq a => a -> a -> Bool
== CursorId
0) (ReaderT MongoContext IO () -> ReaderT MongoContext IO ())
-> ReaderT MongoContext IO () -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ do
                      Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext IO Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
                      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 (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 [[CursorId] -> Notice
KillCursors [CursorId
cid]]
                        else (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 -> [Cmd] -> Maybe FlagBit -> Document -> IO ()
P.sendOpMsg Pipe
pipe [KillC -> Cmd
Kc (Notice -> Label -> KillC
P.KillC ([CursorId] -> Notice
KillCursors [CursorId
cid]) Label
fcol)] (FlagBit -> Maybe FlagBit
forall a. a -> Maybe a
Just FlagBit
MoreToCome) []
                    (DelayedBatch, Maybe Document)
-> Action IO (DelayedBatch, Maybe Document)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
dBatch', Document -> Maybe Document
forall a. a -> Maybe a
Just Document
doc)
                [] -> if CursorId
cid CursorId -> CursorId -> Bool
forall a. Eq a => a -> a -> Bool
== CursorId
0
                    then (DelayedBatch, Maybe Document)
-> Action IO (DelayedBatch, Maybe Document)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) CursorId
0 [], Maybe Document
forall a. Maybe a
Nothing)  -- finished
                    else do
                      DelayedBatch
nb <- Label
-> Limit
-> Maybe Limit
-> CursorId
-> ReaderT MongoContext IO DelayedBatch
forall (m :: * -> *).
MonadIO m =>
Label -> Limit -> Maybe Limit -> CursorId -> Action m DelayedBatch
nextBatch' Label
fcol Limit
batchSize Maybe Limit
mLimit CursorId
cid
                      (DelayedBatch, Maybe Document)
-> Action IO (DelayedBatch, Maybe Document)
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DelayedBatch
nb, Maybe Document
forall a. Maybe a
Nothing)

nextN :: MonadIO m => Int -> Cursor -> Action m [Document]
-- ^ Return next N documents or less if end is reached
nextN :: forall (m :: * -> *).
MonadIO m =>
Int -> Cursor -> Action m Pipeline
nextN Int
n Cursor
c = [Maybe Document] -> Pipeline
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Document] -> Pipeline)
-> ReaderT MongoContext m [Maybe Document]
-> ReaderT MongoContext m Pipeline
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int
-> ReaderT MongoContext m (Maybe Document)
-> ReaderT MongoContext m [Maybe Document]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
n (Cursor -> ReaderT MongoContext m (Maybe Document)
forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Document)
next Cursor
c)

rest :: MonadIO m => Cursor -> Action m [Document]
-- ^ Return remaining documents in query result
rest :: forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest Cursor
c = ReaderT MongoContext m (Maybe Document)
-> ReaderT MongoContext m Pipeline
forall (m :: * -> *) a. Monad m => m (Maybe a) -> m [a]
loop (Cursor -> ReaderT MongoContext m (Maybe Document)
forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Document)
next Cursor
c)

closeCursor :: MonadIO m => Cursor -> Action m ()
closeCursor :: forall (m :: * -> *). MonadIO m => Cursor -> Action m ()
closeCursor (Cursor Label
_ Limit
_ MVar DelayedBatch
var) = ReaderT MongoContext IO () -> ReaderT MongoContext m ()
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (ReaderT MongoContext IO () -> ReaderT MongoContext m ())
-> ReaderT MongoContext IO () -> ReaderT MongoContext m ()
forall a b. (a -> b) -> a -> b
$ MVar DelayedBatch
-> (DelayedBatch -> Action IO (DelayedBatch, ()))
-> ReaderT MongoContext IO ()
forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar DelayedBatch
var ((DelayedBatch -> Action IO (DelayedBatch, ()))
 -> ReaderT MongoContext IO ())
-> (DelayedBatch -> Action IO (DelayedBatch, ()))
-> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ \DelayedBatch
dBatch -> do
    Batch Maybe Limit
_ CursorId
cid Pipeline
_ <- DelayedBatch -> ReaderT MongoContext IO Batch
fulfill DelayedBatch
dBatch
    Bool -> ReaderT MongoContext IO () -> ReaderT MongoContext IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CursorId
cid CursorId -> CursorId -> Bool
forall a. Eq a => a -> a -> Bool
== CursorId
0) (ReaderT MongoContext IO () -> ReaderT MongoContext IO ())
-> ReaderT MongoContext IO () -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ do
      Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext IO Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
      (IOError -> Failure) -> IO () -> ReaderT MongoContext IO ()
forall (m :: * -> *) e e' a.
(MonadIO m, Exception e, Exception e') =>
(e -> e') -> IO a -> m a
liftIOE IOError -> Failure
ConnectionFailure (IO () -> ReaderT MongoContext IO ())
-> IO () -> ReaderT MongoContext IO ()
forall a b. (a -> b) -> a -> b
$ Pipe -> [Notice] -> IO ()
P.send Pipe
pipe [[CursorId] -> Notice
KillCursors [CursorId
cid]]
    (DelayedBatch, ()) -> Action IO (DelayedBatch, ())
forall a. a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) CursorId
0 [], ())

isCursorClosed :: MonadIO m => Cursor -> Action m Bool
isCursorClosed :: forall (m :: * -> *). MonadIO m => Cursor -> Action m Bool
isCursorClosed (Cursor Label
_ Limit
_ MVar DelayedBatch
var) = do
        Batch Maybe Limit
_ CursorId
cid Pipeline
docs <- ReaderT MongoContext IO Batch -> ReaderT MongoContext m Batch
forall env (m :: * -> *) a.
(MonadReader env m, HasMongoContext env, MonadIO m) =>
Action IO a -> m a
liftDB (ReaderT MongoContext IO Batch -> ReaderT MongoContext m Batch)
-> ReaderT MongoContext IO Batch -> ReaderT MongoContext m Batch
forall a b. (a -> b) -> a -> b
$ DelayedBatch -> ReaderT MongoContext IO Batch
fulfill (DelayedBatch -> ReaderT MongoContext IO Batch)
-> ReaderT MongoContext IO DelayedBatch
-> ReaderT MongoContext IO Batch
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MVar DelayedBatch -> ReaderT MongoContext IO DelayedBatch
forall (m :: * -> *) a. MonadBase IO m => MVar a -> m a
readMVar MVar DelayedBatch
var
        Bool -> Action m Bool
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (CursorId
cid CursorId -> CursorId -> Bool
forall a. Eq a => a -> a -> Bool
== CursorId
0 Bool -> Bool -> Bool
&& Pipeline -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null Pipeline
docs)

-- ** Aggregate

type Pipeline = [Document]
-- ^ The Aggregate Pipeline

aggregate :: (MonadIO m) => Collection -> Pipeline -> Action m [Document]
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
aggregate :: forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> Action m Pipeline
aggregate Label
aColl Pipeline
agg = do
    Label -> Pipeline -> AggregateConfig -> Action m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> AggregateConfig -> Action m Cursor
aggregateCursor Label
aColl Pipeline
agg AggregateConfig
forall a. Default a => a
def Action m Cursor
-> (Cursor -> Action m Pipeline) -> Action m Pipeline
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
>>= Cursor -> Action m Pipeline
forall (m :: * -> *). MonadIO m => Cursor -> Action m Pipeline
rest

data AggregateConfig = AggregateConfig
  { AggregateConfig -> Bool
allowDiskUse :: Bool -- ^ Enable writing to temporary files (aggregations have a 100Mb RAM limit)
  }
  deriving Int -> AggregateConfig -> ShowS
[AggregateConfig] -> ShowS
AggregateConfig -> String
(Int -> AggregateConfig -> ShowS)
-> (AggregateConfig -> String)
-> ([AggregateConfig] -> ShowS)
-> Show AggregateConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AggregateConfig -> ShowS
showsPrec :: Int -> AggregateConfig -> ShowS
$cshow :: AggregateConfig -> String
show :: AggregateConfig -> String
$cshowList :: [AggregateConfig] -> ShowS
showList :: [AggregateConfig] -> ShowS
Show

instance Default AggregateConfig where
  def :: AggregateConfig
def = AggregateConfig
    { allowDiskUse :: Bool
allowDiskUse = Bool
False
    }

aggregateCommand :: Collection -> Pipeline -> AggregateConfig -> Document
aggregateCommand :: Label -> Pipeline -> AggregateConfig -> Document
aggregateCommand Label
aColl Pipeline
agg AggregateConfig {Bool
allowDiskUse :: AggregateConfig -> Bool
allowDiskUse :: Bool
..} =
  [ Label
"aggregate" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
aColl
  , Label
"pipeline" Label -> Pipeline -> Field
forall v. Val v => Label -> v -> Field
=: Pipeline
agg
  , Label
"cursor" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: ([] :: Document)
  , Label
"allowDiskUse" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
allowDiskUse
  ]

aggregateCursor :: (MonadIO m) => Collection -> Pipeline -> AggregateConfig -> Action m Cursor
-- ^ Runs an aggregate and unpacks the result. See <http://docs.mongodb.org/manual/core/aggregation/> for details.
aggregateCursor :: forall (m :: * -> *).
MonadIO m =>
Label -> Pipeline -> AggregateConfig -> Action m Cursor
aggregateCursor Label
aColl Pipeline
agg AggregateConfig
cfg = 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
        Document
response <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (Label -> Pipeline -> AggregateConfig -> Document
aggregateCommand Label
aColl Pipeline
agg AggregateConfig
cfg)
        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
. String -> Failure
AggregateFailure) Cursor -> Action m Cursor
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      else do
        let q :: Query
q = Document -> Label -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Document -> Label -> aQueryOrSelection
select (Label -> Pipeline -> AggregateConfig -> Document
aggregateCommand Label
aColl Pipeline
agg AggregateConfig
cfg) Label
aColl
        (Cmd, Maybe Limit)
qr <- 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
pipe (Cmd, Maybe Limit)
qr []
        Label
db <- Action m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
        Cursor -> Either String Cursor
forall a b. b -> Either a b
Right (Cursor -> Either String Cursor)
-> Action m Cursor -> Action m (Either String Cursor)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
aColl Limit
0 DelayedBatch
dBatch
           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
. String -> Failure
AggregateFailure) Cursor -> Action m Cursor
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return

getCursorFromResponse
  :: (MonadIO m)
  => Collection
  -> Document
  -> Action m (Either String Cursor)
getCursorFromResponse :: forall (m :: * -> *).
MonadIO m =>
Label -> Document -> Action m (Either String Cursor)
getCursorFromResponse Label
aColl Document
response
  | Label -> Document -> Bool
true1 Label
"ok" Document
response = ExceptT String (ReaderT MongoContext m) Cursor
-> ReaderT MongoContext m (Either String Cursor)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String (ReaderT MongoContext m) Cursor
 -> ReaderT MongoContext m (Either String Cursor))
-> ExceptT String (ReaderT MongoContext m) Cursor
-> ReaderT MongoContext m (Either String Cursor)
forall a b. (a -> b) -> a -> b
$ do
      Document
cursor     <- Label -> Document -> Maybe Document
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"cursor" Document
response Maybe Document
-> String -> ExceptT String (ReaderT MongoContext m) Document
forall {m :: * -> *} {a} {e}.
Monad m =>
Maybe a -> e -> ExceptT e m a
?? String
"cursor is missing"
      Pipeline
firstBatch <- Label -> Document -> Maybe Pipeline
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"firstBatch" Document
cursor Maybe Pipeline
-> String -> ExceptT String (ReaderT MongoContext m) Pipeline
forall {m :: * -> *} {a} {e}.
Monad m =>
Maybe a -> e -> ExceptT e m a
?? String
"firstBatch is missing"
      CursorId
cursorId   <- Label -> Document -> Maybe CursorId
forall v (m :: * -> *).
(Val v, MonadFail m) =>
Label -> Document -> m v
lookup Label
"id" Document
cursor Maybe CursorId
-> String -> ExceptT String (ReaderT MongoContext m) CursorId
forall {m :: * -> *} {a} {e}.
Monad m =>
Maybe a -> e -> ExceptT e m a
?? String
"id is missing"
      Label
db         <- ReaderT MongoContext m Label
-> ExceptT String (ReaderT MongoContext m) Label
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 ReaderT MongoContext m Label
forall (m :: * -> *). Monad m => Action m Label
thisDatabase
      ReaderT MongoContext m Cursor
-> ExceptT String (ReaderT MongoContext m) Cursor
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 (ReaderT MongoContext m Cursor
 -> ExceptT String (ReaderT MongoContext m) Cursor)
-> ReaderT MongoContext m Cursor
-> ExceptT String (ReaderT MongoContext m) Cursor
forall a b. (a -> b) -> a -> b
$ Label
-> Label -> Limit -> DelayedBatch -> ReaderT MongoContext m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
db Label
aColl Limit
0 (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
cursorId Pipeline
firstBatch)
  | Bool
otherwise = Either String Cursor
-> ReaderT MongoContext m (Either String Cursor)
forall a. a -> ReaderT MongoContext m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String Cursor
 -> ReaderT MongoContext m (Either String Cursor))
-> Either String Cursor
-> ReaderT MongoContext m (Either String Cursor)
forall a b. (a -> b) -> a -> b
$ String -> Either String Cursor
forall a b. a -> Either a b
Left (String -> Either String Cursor) -> String -> Either String Cursor
forall a b. (a -> b) -> a -> b
$ Label -> Document -> String
forall v. Val v => Label -> Document -> v
at Label
"errmsg" Document
response
  where
    Maybe a
Nothing ?? :: Maybe a -> e -> ExceptT e m a
?? e
e = e -> ExceptT e m a
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE e
e
    Just a
a ?? e
_ = a -> ExceptT e m a
forall a. a -> ExceptT e m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- ** Group

-- | Groups documents in collection by key then reduces (aggregates) each group
data Group = Group {
    Group -> Label
gColl :: Collection,
    Group -> GroupKey
gKey :: GroupKey,  -- ^ Fields to group by
    Group -> FinalizeFun
gReduce :: Javascript,  -- ^ @(doc, agg) -> ()@. The reduce function reduces (aggregates) the objects iterated. Typical operations of a reduce function include summing and counting. It takes two arguments, the current document being iterated over and the aggregation value, and updates the aggregate value.
    Group -> Document
gInitial :: Document,  -- ^ @agg@. Initial aggregation value supplied to reduce
    Group -> Document
gCond :: Selector,  -- ^ Condition that must be true for a row to be considered. @[]@ means always true.
    Group -> Maybe FinalizeFun
gFinalize :: Maybe Javascript  -- ^ @agg -> () | result@. An optional function to be run on each item in the result set just before the item is returned. Can either modify the item (e.g., add an average field given a count and a total) or return a replacement object (returning a new object with just @_id@ and average fields).
    } deriving (Int -> Group -> ShowS
[Group] -> ShowS
Group -> String
(Int -> Group -> ShowS)
-> (Group -> String) -> ([Group] -> ShowS) -> Show Group
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Group -> ShowS
showsPrec :: Int -> Group -> ShowS
$cshow :: Group -> String
show :: Group -> String
$cshowList :: [Group] -> ShowS
showList :: [Group] -> ShowS
Show, Group -> Group -> Bool
(Group -> Group -> Bool) -> (Group -> Group -> Bool) -> Eq Group
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Group -> Group -> Bool
== :: Group -> Group -> Bool
$c/= :: Group -> Group -> Bool
/= :: Group -> Group -> Bool
Eq)

data GroupKey = Key [Label] | KeyF Javascript  deriving (Int -> GroupKey -> ShowS
[GroupKey] -> ShowS
GroupKey -> String
(Int -> GroupKey -> ShowS)
-> (GroupKey -> String) -> ([GroupKey] -> ShowS) -> Show GroupKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GroupKey -> ShowS
showsPrec :: Int -> GroupKey -> ShowS
$cshow :: GroupKey -> String
show :: GroupKey -> String
$cshowList :: [GroupKey] -> ShowS
showList :: [GroupKey] -> ShowS
Show, GroupKey -> GroupKey -> Bool
(GroupKey -> GroupKey -> Bool)
-> (GroupKey -> GroupKey -> Bool) -> Eq GroupKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GroupKey -> GroupKey -> Bool
== :: GroupKey -> GroupKey -> Bool
$c/= :: GroupKey -> GroupKey -> Bool
/= :: GroupKey -> GroupKey -> Bool
Eq)
-- ^ Fields to group by, or function (@doc -> key@) returning a "key object" to be used as the grouping key. Use 'KeyF' instead of 'Key' to specify a key that is not an existing member of the object (or, to access embedded members).

groupDocument :: Group -> Document
-- ^ Translate Group data into expected document form
groupDocument :: Group -> Document
groupDocument Group{Document
Maybe FinalizeFun
Label
FinalizeFun
GroupKey
gColl :: Group -> Label
gKey :: Group -> GroupKey
gReduce :: Group -> FinalizeFun
gInitial :: Group -> Document
gCond :: Group -> Document
gFinalize :: Group -> Maybe FinalizeFun
gColl :: Label
gKey :: GroupKey
gReduce :: FinalizeFun
gInitial :: Document
gCond :: Document
gFinalize :: Maybe FinalizeFun
..} =
    (Label
"finalize" Label -> Maybe FinalizeFun -> Document
forall a. Val a => Label -> Maybe a -> Document
=? Maybe FinalizeFun
gFinalize) Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ [
    Label
"ns" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
gColl,
    case GroupKey
gKey of Key [Label]
k -> Label
"key" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: (Label -> Field) -> [Label] -> Document
forall a b. (a -> b) -> [a] -> [b]
map (Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
True) [Label]
k; KeyF FinalizeFun
f -> Label
"$keyf" Label -> FinalizeFun -> Field
forall v. Val v => Label -> v -> Field
=: FinalizeFun
f,
    Label
"$reduce" Label -> FinalizeFun -> Field
forall v. Val v => Label -> v -> Field
=: FinalizeFun
gReduce,
    Label
"initial" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
gInitial,
    Label
"cond" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
gCond ]

group :: (MonadIO m) => Group -> Action m [Document]
-- ^ Execute group query and return resulting aggregate value for each distinct key
group :: forall (m :: * -> *). MonadIO m => Group -> Action m Pipeline
group Group
g = Label -> Document -> Pipeline
forall v. Val v => Label -> Document -> v
at Label
"retval" (Document -> Pipeline)
-> ReaderT MongoContext m Document
-> ReaderT MongoContext m Pipeline
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
"group" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Group -> Document
groupDocument Group
g]

-- ** MapReduce

-- | Maps every document in collection to a list of (key, value) pairs, then for each unique key reduces all its associated values to a single result. There are additional parameters that may be set to tweak this basic operation.
-- This implements the latest version of map-reduce that requires MongoDB 1.7.4 or greater. To map-reduce against an older server use 'runCommand' directly as described in http://www.mongodb.org/display/DOCS/MapReduce.
data MapReduce = MapReduce {
    MapReduce -> Label
rColl :: Collection,
    MapReduce -> FinalizeFun
rMap :: MapFun,
    MapReduce -> FinalizeFun
rReduce :: ReduceFun,
    MapReduce -> Document
rSelect :: Selector,  -- ^ Operate on only those documents selected. Default is @[]@ meaning all documents.
    MapReduce -> Document
rSort :: Order,  -- ^ Default is @[]@ meaning no sort
    MapReduce -> Limit
rLimit :: Limit,  -- ^ Default is 0 meaning no limit
    MapReduce -> MROut
rOut :: MROut,  -- ^ Output to a collection with a certain merge policy. Default is no collection ('Inline'). Note, you don't want this default if your result set is large.
    MapReduce -> Maybe FinalizeFun
rFinalize :: Maybe FinalizeFun,  -- ^ Function to apply to all the results when finished. Default is Nothing.
    MapReduce -> Document
rScope :: Document,  -- ^ Variables (environment) that can be accessed from map/reduce/finalize. Default is @[]@.
    MapReduce -> Bool
rVerbose :: Bool  -- ^ Provide statistics on job execution time. Default is False.
    } deriving (Int -> MapReduce -> ShowS
[MapReduce] -> ShowS
MapReduce -> String
(Int -> MapReduce -> ShowS)
-> (MapReduce -> String)
-> ([MapReduce] -> ShowS)
-> Show MapReduce
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MapReduce -> ShowS
showsPrec :: Int -> MapReduce -> ShowS
$cshow :: MapReduce -> String
show :: MapReduce -> String
$cshowList :: [MapReduce] -> ShowS
showList :: [MapReduce] -> ShowS
Show, MapReduce -> MapReduce -> Bool
(MapReduce -> MapReduce -> Bool)
-> (MapReduce -> MapReduce -> Bool) -> Eq MapReduce
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MapReduce -> MapReduce -> Bool
== :: MapReduce -> MapReduce -> Bool
$c/= :: MapReduce -> MapReduce -> Bool
/= :: MapReduce -> MapReduce -> Bool
Eq)

type MapFun = Javascript
-- ^ @() -> void@. The map function references the variable @this@ to inspect the current object under consideration. The function must call @emit(key,value)@ at least once, but may be invoked any number of times, as may be appropriate.

type ReduceFun = Javascript
-- ^ @(key, [value]) -> value@. The reduce function receives a key and an array of values and returns an aggregate result value. The MapReduce engine may invoke reduce functions iteratively; thus, these functions must be idempotent.  That is, the following must hold for your reduce function: @reduce(k, [reduce(k,vs)]) == reduce(k,vs)@. If you need to perform an operation only once, use a finalize function. The output of emit (the 2nd param) and reduce should be the same format to make iterative reduce possible.

type FinalizeFun = Javascript
-- ^ @(key, value) -> final_value@. A finalize function may be run after reduction.  Such a function is optional and is not necessary for many map/reduce cases.  The finalize function takes a key and a value, and returns a finalized value.

data MROut =
      Inline -- ^ Return results directly instead of writing them to an output collection. Results must fit within 16MB limit of a single document
    | Output MRMerge Collection (Maybe Database) -- ^ Write results to given collection, in other database if specified. Follow merge policy when entry already exists
    deriving (Int -> MROut -> ShowS
[MROut] -> ShowS
MROut -> String
(Int -> MROut -> ShowS)
-> (MROut -> String) -> ([MROut] -> ShowS) -> Show MROut
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MROut -> ShowS
showsPrec :: Int -> MROut -> ShowS
$cshow :: MROut -> String
show :: MROut -> String
$cshowList :: [MROut] -> ShowS
showList :: [MROut] -> ShowS
Show, MROut -> MROut -> Bool
(MROut -> MROut -> Bool) -> (MROut -> MROut -> Bool) -> Eq MROut
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MROut -> MROut -> Bool
== :: MROut -> MROut -> Bool
$c/= :: MROut -> MROut -> Bool
/= :: MROut -> MROut -> Bool
Eq)

data MRMerge =
      Replace  -- ^ Clear all old data and replace it with new data
    | Merge  -- ^ Leave old data but overwrite entries with the same key with new data
    | Reduce  -- ^ Leave old data but combine entries with the same key via MR's reduce function
    deriving (Int -> MRMerge -> ShowS
[MRMerge] -> ShowS
MRMerge -> String
(Int -> MRMerge -> ShowS)
-> (MRMerge -> String) -> ([MRMerge] -> ShowS) -> Show MRMerge
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MRMerge -> ShowS
showsPrec :: Int -> MRMerge -> ShowS
$cshow :: MRMerge -> String
show :: MRMerge -> String
$cshowList :: [MRMerge] -> ShowS
showList :: [MRMerge] -> ShowS
Show, MRMerge -> MRMerge -> Bool
(MRMerge -> MRMerge -> Bool)
-> (MRMerge -> MRMerge -> Bool) -> Eq MRMerge
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MRMerge -> MRMerge -> Bool
== :: MRMerge -> MRMerge -> Bool
$c/= :: MRMerge -> MRMerge -> Bool
/= :: MRMerge -> MRMerge -> Bool
Eq)

type MRResult = Document
-- ^ Result of running a MapReduce has some stats besides the output. See http://www.mongodb.org/display/DOCS/MapReduce#MapReduce-Resultobject

mrDocument :: MapReduce -> Document
-- ^ Translate MapReduce data into expected document form
mrDocument :: MapReduce -> Document
mrDocument MapReduce{Bool
Document
Maybe FinalizeFun
Limit
Label
FinalizeFun
MROut
rColl :: MapReduce -> Label
rMap :: MapReduce -> FinalizeFun
rReduce :: MapReduce -> FinalizeFun
rSelect :: MapReduce -> Document
rSort :: MapReduce -> Document
rLimit :: MapReduce -> Limit
rOut :: MapReduce -> MROut
rFinalize :: MapReduce -> Maybe FinalizeFun
rScope :: MapReduce -> Document
rVerbose :: MapReduce -> Bool
rColl :: Label
rMap :: FinalizeFun
rReduce :: FinalizeFun
rSelect :: Document
rSort :: Document
rLimit :: Limit
rOut :: MROut
rFinalize :: Maybe FinalizeFun
rScope :: Document
rVerbose :: Bool
..} =
    (Label
"mapreduce" Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
rColl) Field -> Document -> Document
forall a. a -> [a] -> [a]
:
    (Label
"out" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: MROut -> Document
mrOutDoc MROut
rOut) Field -> Document -> Document
forall a. a -> [a] -> [a]
:
    (Label
"finalize" Label -> Maybe FinalizeFun -> Document
forall a. Val a => Label -> Maybe a -> Document
=? Maybe FinalizeFun
rFinalize) Document -> Document -> Document
forall a. [a] -> [a] -> [a]
++ [
    Label
"map" Label -> FinalizeFun -> Field
forall v. Val v => Label -> v -> Field
=: FinalizeFun
rMap,
    Label
"reduce" Label -> FinalizeFun -> Field
forall v. Val v => Label -> v -> Field
=: FinalizeFun
rReduce,
    Label
"query" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
rSelect,
    Label
"sort" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
rSort,
    Label
"limit" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Limit -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Limit
rLimit :: Int),
    Label
"scope" Label -> Document -> Field
forall v. Val v => Label -> v -> Field
=: Document
rScope,
    Label
"verbose" Label -> Bool -> Field
forall v. Val v => Label -> v -> Field
=: Bool
rVerbose ]

mrOutDoc :: MROut -> Document
-- ^ Translate MROut into expected document form
mrOutDoc :: MROut -> Document
mrOutDoc MROut
Inline = [Label
"inline" Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]
mrOutDoc (Output MRMerge
mrMerge Label
coll Maybe Label
mDB) = (MRMerge -> Label
forall {a}. IsString a => MRMerge -> a
mergeName MRMerge
mrMerge Label -> Label -> Field
forall v. Val v => Label -> v -> Field
=: Label
coll) Field -> Document -> Document
forall a. a -> [a] -> [a]
: Maybe Label -> Document
forall {v}. Val v => Maybe v -> Document
mdb Maybe Label
mDB where
    mergeName :: MRMerge -> a
mergeName MRMerge
Replace = a
"replace"
    mergeName MRMerge
Merge = a
"merge"
    mergeName MRMerge
Reduce = a
"reduce"
    mdb :: Maybe v -> Document
mdb Maybe v
Nothing = []
    mdb (Just v
db) = [Label
"db" Label -> v -> Field
forall v. Val v => Label -> v -> Field
=: v
db]

mapReduce :: Collection -> MapFun -> ReduceFun -> MapReduce
-- ^ MapReduce on collection with given map and reduce functions. Remaining attributes are set to their defaults, which are stated in their comments.
mapReduce :: Label -> FinalizeFun -> FinalizeFun -> MapReduce
mapReduce Label
col FinalizeFun
map' FinalizeFun
red = Label
-> FinalizeFun
-> FinalizeFun
-> Document
-> Document
-> Limit
-> MROut
-> Maybe FinalizeFun
-> Document
-> Bool
-> MapReduce
MapReduce Label
col FinalizeFun
map' FinalizeFun
red [] [] Limit
0 MROut
Inline Maybe FinalizeFun
forall a. Maybe a
Nothing [] Bool
False

runMR :: MonadIO m => MapReduce -> Action m Cursor
-- ^ Run MapReduce and return cursor of results. Error if map/reduce fails (because of bad Javascript)
runMR :: forall (m :: * -> *). MonadIO m => MapReduce -> Action m Cursor
runMR MapReduce
mr = do
    Document
res <- MapReduce -> Action m Document
forall (m :: * -> *). MonadIO m => MapReduce -> Action m Document
runMR' MapReduce
mr
    case Label -> Document -> Maybe Value
forall (m :: * -> *). MonadFail m => Label -> Document -> m Value
look Label
"result" Document
res of
        Just (String Label
coll) -> Query -> Action m Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find (Query -> Action m Cursor) -> Query -> Action m Cursor
forall a b. (a -> b) -> a -> b
$ Document -> Label -> Query
query [] Label
coll
        Just (Doc Document
doc) -> Label -> Action m Cursor -> Action m Cursor
forall (m :: * -> *) a.
Monad m =>
Label -> Action m a -> Action m a
useDb (Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"db" Document
doc) (Action m Cursor -> Action m Cursor)
-> Action m Cursor -> Action m Cursor
forall a b. (a -> b) -> a -> b
$ Query -> Action m Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
find (Query -> Action m Cursor) -> Query -> Action m Cursor
forall a b. (a -> b) -> a -> b
$ Document -> Label -> Query
query [] (Label -> Document -> Label
forall v. Val v => Label -> Document -> v
at Label
"collection" Document
doc)
        Just Value
x -> String -> Action m Cursor
forall a. HasCallStack => String -> a
error (String -> Action m Cursor) -> String -> Action m Cursor
forall a b. (a -> b) -> a -> b
$ String
"unexpected map-reduce result field: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Value -> String
forall a. Show a => a -> String
show Value
x
        Maybe Value
Nothing -> Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
forall (m :: * -> *).
MonadIO m =>
Label -> Label -> Limit -> DelayedBatch -> Action m Cursor
newCursor Label
"" Label
"" Limit
0 (DelayedBatch -> Action m Cursor)
-> DelayedBatch -> Action 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 (Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
0) CursorId
0 (Label -> Document -> Pipeline
forall v. Val v => Label -> Document -> v
at Label
"results" Document
res)

runMR' :: (MonadIO m) => MapReduce -> Action m MRResult
-- ^ Run MapReduce and return a MR result document containing stats and the results if Inlined. Error if the map/reduce failed (because of bad Javascript).
runMR' :: forall (m :: * -> *). MonadIO m => MapReduce -> Action m Document
runMR' MapReduce
mr = do
    Document
doc <- Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand (MapReduce -> Document
mrDocument MapReduce
mr)
    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 Label -> Document -> Bool
true1 Label
"ok" Document
doc then Document
doc else String -> Document
forall a. HasCallStack => String -> a
error (String -> Document) -> String -> Document
forall a b. (a -> b) -> a -> b
$ String
"mapReduce error:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Document -> String
forall a. Show a => a -> String
show Document
doc String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nin:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ MapReduce -> String
forall a. Show a => a -> String
show MapReduce
mr

-- * Command

type Command = Document
-- ^ A command is a special query or action against the database. See <http://www.mongodb.org/display/DOCS/Commands> for details.

runCommand :: (MonadIO m) => Command -> Action m Document
runCommand :: forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand Document
params = do
    Pipe
pipe <- (MongoContext -> Pipe) -> ReaderT MongoContext m Pipe
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks MongoContext -> Pipe
mongoPipe
    if Document -> Bool
isHandshake Document
params Bool -> Bool -> Bool
|| ServerData -> Int
maxWireVersion (Pipe -> ServerData
P.serverData Pipe
pipe) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
17
      then Pipe -> Document -> Action m Document
forall (m :: * -> *).
MonadIO m =>
Pipe -> Document -> ReaderT MongoContext m Document
runCommandLegacy Pipe
pipe Document
params
      else Pipe -> Document -> Action m Document
forall (m :: * -> *).
MonadIO m =>
Pipe -> Document -> ReaderT MongoContext m Document
runCommand' Pipe
pipe Document
params

runCommandLegacy :: MonadIO m => Pipe -> Selector -> ReaderT MongoContext m Document
runCommandLegacy :: forall (m :: * -> *).
MonadIO m =>
Pipe -> Document -> ReaderT MongoContext m Document
runCommandLegacy Pipe
pipe Document
params = 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 (Document -> Label -> Query
query Document
params Label
"$cmd") {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
    case Pipeline
docs of
      [Document
doc] -> Document -> ReaderT MongoContext m Document
forall a. a -> ReaderT MongoContext m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
doc
      Pipeline
_ -> String -> ReaderT MongoContext m Document
forall a. HasCallStack => String -> a
error (String -> ReaderT MongoContext m Document)
-> String -> ReaderT MongoContext m Document
forall a b. (a -> b) -> a -> b
$ String
"Nothing returned for command: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Document -> String
forall a. Show a => a -> String
show Document
params

runCommand' :: MonadIO m => Pipe -> Selector -> ReaderT MongoContext m Document
runCommand' :: forall (m :: * -> *).
MonadIO m =>
Pipe -> Document -> ReaderT MongoContext m Document
runCommand' Pipe
pipe Document
params = do
    MongoContext
ctx <- ReaderT MongoContext m MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
    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 ( Request -> Cmd
Req (Label -> Document -> Request
P.Message (MongoContext -> Label
mongoDatabase MongoContext
ctx) Document
params), Limit -> Maybe Limit
forall a. a -> Maybe a
Just Limit
1) []
    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
    case Pipeline
docs of
      [Document
doc] -> Document -> ReaderT MongoContext m Document
forall a. a -> ReaderT MongoContext m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Document
doc
      Pipeline
_ -> String -> ReaderT MongoContext m Document
forall a. HasCallStack => String -> a
error (String -> ReaderT MongoContext m Document)
-> String -> ReaderT MongoContext m Document
forall a b. (a -> b) -> a -> b
$ String
"Nothing returned for command: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Document -> String
forall a. Show a => a -> String
show Document
params

runCommand1 :: (MonadIO m) => Text -> Action m Document
-- ^ @runCommand1 foo = runCommand [foo =: 1]@
runCommand1 :: forall (m :: * -> *). MonadIO m => Label -> Action m Document
runCommand1 Label
c = Document -> Action m Document
forall (m :: * -> *). MonadIO m => Document -> Action m Document
runCommand [Label
c Label -> Int -> Field
forall v. Val v => Label -> v -> Field
=: (Int
1 :: Int)]

eval :: (MonadIO m, Val v) => Javascript -> Action m v
-- ^ Run code on server
eval :: forall (m :: * -> *) v.
(MonadIO m, Val v) =>
FinalizeFun -> Action m v
eval FinalizeFun
code = 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
7
      then Label -> Document -> v
forall v. Val v => Label -> Document -> v
at Label
"retval" (Document -> v) -> ReaderT MongoContext m Document -> Action m v
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
"$eval" Label -> FinalizeFun -> Field
forall v. Val v => Label -> v -> Field
=: FinalizeFun
code]
      else String -> Action m v
forall a. HasCallStack => String -> a
error String
"The command db.eval() has been removed since MongoDB 4.2"

modifyMVar :: MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar :: forall a b. MVar a -> (a -> Action IO (a, b)) -> Action IO b
modifyMVar MVar a
v a -> Action IO (a, b)
f = do
  MongoContext
ctx <- ReaderT MongoContext IO MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask
  IO b -> Action IO b
forall a. IO a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> Action IO b) -> IO b -> Action IO b
forall a b. (a -> b) -> a -> b
$ MVar a -> (a -> IO (a, b)) -> IO b
forall a b. MVar a -> (a -> IO (a, b)) -> IO b
MV.modifyMVar MVar a
v (\a
x -> Action IO (a, b) -> MongoContext -> IO (a, b)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (a -> Action IO (a, b)
f a
x) MongoContext
ctx)

mkWeakMVar :: MVar a -> Action IO () -> Action IO (Weak (MVar a))
mkWeakMVar :: forall a.
MVar a -> ReaderT MongoContext IO () -> Action IO (Weak (MVar a))
mkWeakMVar MVar a
m ReaderT MongoContext IO ()
closing = do
  MongoContext
ctx <- ReaderT MongoContext IO MongoContext
forall r (m :: * -> *). MonadReader r m => m r
ask

#if MIN_VERSION_base(4,6,0)
  IO (Weak (MVar a)) -> Action IO (Weak (MVar a))
forall a. IO a -> ReaderT MongoContext IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Weak (MVar a)) -> Action IO (Weak (MVar a)))
-> IO (Weak (MVar a)) -> Action IO (Weak (MVar a))
forall a b. (a -> b) -> a -> b
$ MVar a -> IO () -> IO (Weak (MVar a))
forall a. MVar a -> IO () -> IO (Weak (MVar a))
MV.mkWeakMVar MVar a
m (IO () -> IO (Weak (MVar a))) -> IO () -> IO (Weak (MVar a))
forall a b. (a -> b) -> a -> b
$ ReaderT MongoContext IO () -> MongoContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT MongoContext IO ()
closing MongoContext
ctx
#else
  liftIO $ MV.addMVarFinalizer m $ runReaderT closing ctx
#endif


{- Authors: Tony Hannan <tony@10gen.com>
   Copyright 2011 10gen Inc.
   Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at: http://www.apache.org/licenses/LICENSE-2.0. Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License. -}