{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} -- Pattern match 'PersistDbSpecific'
-- | Use persistent-mongodb the same way you would use other persistent
-- libraries and refer to the general persistent documentation.
-- There are some new MongoDB specific filters under the filters section.
-- These help extend your query into a nested document.
--
-- However, at some point you will find the normal Persistent APIs lacking.
-- and want lower level-level MongoDB access.
-- There are functions available to make working with the raw driver
-- easier: they are under the Entity conversion section.
-- You should still use the same connection pool that you are using for Persistent.
--
-- MongoDB is a schema-less database.
-- The MongoDB Persistent backend does not help perform migrations.
-- Unlike SQL backends, uniqueness constraints cannot be created for you.
-- You must place a unique index on unique fields.
module Database.Persist.MongoDB
    (
    -- * Entity conversion
      collectionName
    , docToEntityEither
    , docToEntityThrow
    , recordToDocument
    , documentFromEntity
    , toInsertDoc
    , entityToInsertDoc
    , updatesToDoc
    , filtersToDoc
    , toUniquesDoc

    -- * MongoDB specific queries
    -- $nested
    , (->.), (~>.), (?&->.), (?&~>.), (&->.), (&~>.)
    -- ** Filters
    -- $filters
    , nestEq, nestNe, nestGe, nestLe, nestIn, nestNotIn
    , anyEq, nestAnyEq, nestBsonEq, anyBsonEq
    , inList, ninList
    , (=~.)
    -- non-operator forms of filters
    , NestedField(..)
    , MongoRegexSearchable
    , MongoRegex

    -- ** Updates
    -- $updates
    , nestSet, nestInc, nestDec, nestMul, push, pull, pullAll, addToSet, eachOp

    -- * Key conversion helpers
    , BackendKey(..)
    , keyToOid
    , oidToKey
    , recordTypeFromKey
    , readMayObjectId
    , readMayMongoKey
    , keyToText

    -- * PersistField conversion
    , fieldName

    -- * using connections
    , withConnection
    , withMongoPool
    , withMongoDBConn
    , withMongoDBPool
    , createMongoDBPool
    , runMongoDBPool
    , runMongoDBPoolDef
    , ConnectionPool
    , Connection
    , MongoAuth (..)

    -- * Connection configuration
    , MongoConf (..)
    , defaultMongoConf
    , defaultHost
    , defaultAccessMode
    , defaultPoolStripes
    , defaultConnectionIdleTime
    , defaultStripeConnections
    , applyDockerEnv

    -- ** using raw MongoDB pipes
    , PipePool
    , createMongoDBPipePool
    , runMongoDBPipePool

    -- * network type
    , HostName

    -- * MongoDB driver types
    , Database
    , DB.Action
    , DB.AccessMode(..)
    , DB.master
    , DB.slaveOk
    , (DB.=:)
    , DB.ObjectId
    , DB.MongoContext
    , DB.PortID

    -- * Database.Persist
    , module Database.Persist
    ) where

import Control.Exception (throw, throwIO)
import Control.Monad (forM_, liftM, unless, (>=>))
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.IO.Class as Trans
import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO)
import Control.Monad.Trans.Reader (ask, runReaderT)
import qualified Data.List.NonEmpty as NEL

import Data.Acquire (mkAcquire)
import Data.Aeson
       ( FromJSON(..)
       , ToJSON(..)
       , Value(Number)
       , withObject
       , withText
       , (.!=)
       , (.:)
       , (.:?)
       )
import Data.Aeson.Types (modifyFailure)
import Data.Bits (shiftR)
import Data.Bson (ObjectId(..))
import qualified Data.ByteString as BS
import Data.Conduit
import Data.Maybe (fromJust, mapMaybe)
import Data.Monoid (mappend)
import qualified Data.Pool as Pool
import qualified Data.Serialize as Serialize
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import Data.Time (NominalDiffTime)
import Data.Time.Calendar (Day(..))
import qualified Data.Traversable as Traversable
#ifdef HIGH_PRECISION_DATE
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
#endif
import Data.Word (Word16)
import Network.Socket (HostName)
import Numeric (readHex)
import System.Environment (lookupEnv)
import Unsafe.Coerce (unsafeCoerce)
import Web.HttpApiData
       ( FromHttpApiData(..)
       , ToHttpApiData(..)
       , parseUrlPieceMaybe
       , parseUrlPieceWithPrefix
       , readTextData
       )
import Web.PathPieces (PathPiece(..))

#ifdef DEBUG
import FileLocation (debug)
#endif

import qualified Database.MongoDB as DB
import Database.MongoDB.Query (Database)

import Database.Persist
import Database.Persist.EntityDef.Internal (toEmbedEntityDef)
import qualified Database.Persist.Sql as Sql

instance HasPersistBackend DB.MongoContext where
    type BaseBackend DB.MongoContext = DB.MongoContext
    persistBackend :: MongoContext -> BaseBackend MongoContext
persistBackend = MongoContext -> BaseBackend MongoContext
forall a. a -> a
id

recordTypeFromKey :: Key record -> record
recordTypeFromKey :: Key record -> record
recordTypeFromKey Key record
_ = [Char] -> record
forall a. HasCallStack => [Char] -> a
error [Char]
"recordTypeFromKey"

newtype NoOrphanNominalDiffTime = NoOrphanNominalDiffTime NominalDiffTime
                                deriving (Int -> NoOrphanNominalDiffTime -> ShowS
[NoOrphanNominalDiffTime] -> ShowS
NoOrphanNominalDiffTime -> [Char]
(Int -> NoOrphanNominalDiffTime -> ShowS)
-> (NoOrphanNominalDiffTime -> [Char])
-> ([NoOrphanNominalDiffTime] -> ShowS)
-> Show NoOrphanNominalDiffTime
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NoOrphanNominalDiffTime] -> ShowS
$cshowList :: [NoOrphanNominalDiffTime] -> ShowS
show :: NoOrphanNominalDiffTime -> [Char]
$cshow :: NoOrphanNominalDiffTime -> [Char]
showsPrec :: Int -> NoOrphanNominalDiffTime -> ShowS
$cshowsPrec :: Int -> NoOrphanNominalDiffTime -> ShowS
Show, NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool
(NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool)
-> (NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool)
-> Eq NoOrphanNominalDiffTime
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool
$c/= :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool
== :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool
$c== :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime -> Bool
Eq, Integer -> NoOrphanNominalDiffTime
NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
(NoOrphanNominalDiffTime
 -> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime)
-> (NoOrphanNominalDiffTime
    -> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime)
-> (NoOrphanNominalDiffTime
    -> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime)
-> (NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime)
-> (NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime)
-> (NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime)
-> (Integer -> NoOrphanNominalDiffTime)
-> Num NoOrphanNominalDiffTime
forall a.
(a -> a -> a)
-> (a -> a -> a)
-> (a -> a -> a)
-> (a -> a)
-> (a -> a)
-> (a -> a)
-> (Integer -> a)
-> Num a
fromInteger :: Integer -> NoOrphanNominalDiffTime
$cfromInteger :: Integer -> NoOrphanNominalDiffTime
signum :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
$csignum :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
abs :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
$cabs :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
negate :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
$cnegate :: NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
* :: NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
$c* :: NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
- :: NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
$c- :: NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
+ :: NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
$c+ :: NoOrphanNominalDiffTime
-> NoOrphanNominalDiffTime -> NoOrphanNominalDiffTime
Num)

instance FromJSON NoOrphanNominalDiffTime where
    parseJSON :: Value -> Parser NoOrphanNominalDiffTime
parseJSON (Number Scientific
x) = (NoOrphanNominalDiffTime -> Parser NoOrphanNominalDiffTime
forall (m :: * -> *) a. Monad m => a -> m a
return (NoOrphanNominalDiffTime -> Parser NoOrphanNominalDiffTime)
-> (Scientific -> NoOrphanNominalDiffTime)
-> Scientific
-> Parser NoOrphanNominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NominalDiffTime -> NoOrphanNominalDiffTime
NoOrphanNominalDiffTime (NominalDiffTime -> NoOrphanNominalDiffTime)
-> (Scientific -> NominalDiffTime)
-> Scientific
-> NoOrphanNominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational (Rational -> NominalDiffTime)
-> (Scientific -> Rational) -> Scientific -> NominalDiffTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scientific -> Rational
forall a. Real a => a -> Rational
toRational) Scientific
x
    parseJSON Value
_ = [Char] -> Parser NoOrphanNominalDiffTime
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"couldn't parse diff time"

newtype NoOrphanPortID = NoOrphanPortID DB.PortID deriving (Int -> NoOrphanPortID -> ShowS
[NoOrphanPortID] -> ShowS
NoOrphanPortID -> [Char]
(Int -> NoOrphanPortID -> ShowS)
-> (NoOrphanPortID -> [Char])
-> ([NoOrphanPortID] -> ShowS)
-> Show NoOrphanPortID
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [NoOrphanPortID] -> ShowS
$cshowList :: [NoOrphanPortID] -> ShowS
show :: NoOrphanPortID -> [Char]
$cshow :: NoOrphanPortID -> [Char]
showsPrec :: Int -> NoOrphanPortID -> ShowS
$cshowsPrec :: Int -> NoOrphanPortID -> ShowS
Show, NoOrphanPortID -> NoOrphanPortID -> Bool
(NoOrphanPortID -> NoOrphanPortID -> Bool)
-> (NoOrphanPortID -> NoOrphanPortID -> Bool) -> Eq NoOrphanPortID
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: NoOrphanPortID -> NoOrphanPortID -> Bool
$c/= :: NoOrphanPortID -> NoOrphanPortID -> Bool
== :: NoOrphanPortID -> NoOrphanPortID -> Bool
$c== :: NoOrphanPortID -> NoOrphanPortID -> Bool
Eq)


instance FromJSON NoOrphanPortID where
    parseJSON :: Value -> Parser NoOrphanPortID
parseJSON (Number  Scientific
x) = (NoOrphanPortID -> Parser NoOrphanPortID
forall (m :: * -> *) a. Monad m => a -> m a
return (NoOrphanPortID -> Parser NoOrphanPortID)
-> (Word16 -> NoOrphanPortID) -> Word16 -> Parser NoOrphanPortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortID -> NoOrphanPortID
NoOrphanPortID (PortID -> NoOrphanPortID)
-> (Word16 -> PortID) -> Word16 -> NoOrphanPortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortNumber -> PortID
DB.PortNumber (PortNumber -> PortID)
-> (Word16 -> PortNumber) -> Word16 -> PortID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral ) Word16
cnvX
      where cnvX :: Word16
            cnvX :: Word16
cnvX = Scientific -> Word16
forall a b. (RealFrac a, Integral b) => a -> b
round Scientific
x
    parseJSON Value
_ = [Char] -> Parser NoOrphanPortID
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"couldn't parse port number"


data Connection = Connection DB.Pipe DB.Database
type ConnectionPool = Pool.Pool Connection

instance ToHttpApiData (BackendKey DB.MongoContext) where
    toUrlPiece :: BackendKey MongoContext -> Text
toUrlPiece = BackendKey MongoContext -> Text
keyToText

instance FromHttpApiData (BackendKey DB.MongoContext) where
    parseUrlPiece :: Text -> Either Text (BackendKey MongoContext)
parseUrlPiece Text
input = do
      Text
s <- Text -> Text -> Either Text Text
forall a. FromHttpApiData a => Text -> Text -> Either Text a
parseUrlPieceWithPrefix Text
"o" Text
input Either Text Text -> Either Text Text -> Either Text Text
forall a b. Either a b -> Either a b -> Either a b
<!> Text -> Either Text Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
input
      ObjectId -> BackendKey MongoContext
MongoKey (ObjectId -> BackendKey MongoContext)
-> Either Text ObjectId -> Either Text (BackendKey MongoContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Either Text ObjectId
forall a. Read a => Text -> Either Text a
readTextData Text
s
      where
        infixl 3 <!>
        Left a
_ <!> :: Either a b -> Either a b -> Either a b
<!> Either a b
y = Either a b
y
        Either a b
x      <!> Either a b
_ = Either a b
x

-- | ToPathPiece is used to convert a key to/from text
instance PathPiece (BackendKey DB.MongoContext) where
  toPathPiece :: BackendKey MongoContext -> Text
toPathPiece   = BackendKey MongoContext -> Text
forall a. ToHttpApiData a => a -> Text
toUrlPiece
  fromPathPiece :: Text -> Maybe (BackendKey MongoContext)
fromPathPiece = Text -> Maybe (BackendKey MongoContext)
forall a. FromHttpApiData a => Text -> Maybe a
parseUrlPieceMaybe

keyToText :: BackendKey DB.MongoContext -> Text
keyToText :: BackendKey MongoContext -> Text
keyToText = [Char] -> Text
T.pack ([Char] -> Text)
-> (BackendKey MongoContext -> [Char])
-> BackendKey MongoContext
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectId -> [Char]
forall a. Show a => a -> [Char]
show (ObjectId -> [Char])
-> (BackendKey MongoContext -> ObjectId)
-> BackendKey MongoContext
-> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackendKey MongoContext -> ObjectId
unMongoKey

-- | Convert a Text to a Key
readMayMongoKey :: Text -> Maybe (BackendKey DB.MongoContext)
readMayMongoKey :: Text -> Maybe (BackendKey MongoContext)
readMayMongoKey = (ObjectId -> BackendKey MongoContext)
-> Maybe ObjectId -> Maybe (BackendKey MongoContext)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ObjectId -> BackendKey MongoContext
MongoKey (Maybe ObjectId -> Maybe (BackendKey MongoContext))
-> (Text -> Maybe ObjectId)
-> Text
-> Maybe (BackendKey MongoContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe ObjectId
readMayObjectId

readMayObjectId :: Text -> Maybe DB.ObjectId
readMayObjectId :: Text -> Maybe ObjectId
readMayObjectId Text
str =
  case ((ObjectId, [Char]) -> Bool)
-> [(ObjectId, [Char])] -> [(ObjectId, [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Char] -> Bool)
-> ((ObjectId, [Char]) -> [Char]) -> (ObjectId, [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ObjectId, [Char]) -> [Char]
forall a b. (a, b) -> b
snd) ([(ObjectId, [Char])] -> [(ObjectId, [Char])])
-> [(ObjectId, [Char])] -> [(ObjectId, [Char])]
forall a b. (a -> b) -> a -> b
$ ReadS ObjectId
forall a. Read a => ReadS a
reads ReadS ObjectId -> ReadS ObjectId
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
str :: [(DB.ObjectId,String)] of
    (ObjectId
parsed,[Char]
_):[] -> ObjectId -> Maybe ObjectId
forall a. a -> Maybe a
Just ObjectId
parsed
    [(ObjectId, [Char])]
_ -> Maybe ObjectId
forall a. Maybe a
Nothing

instance PersistField DB.ObjectId where
    toPersistValue :: ObjectId -> PersistValue
toPersistValue = ObjectId -> PersistValue
oidToPersistValue
    fromPersistValue :: PersistValue -> Either Text ObjectId
fromPersistValue oid :: PersistValue
oid@(PersistObjectId ByteString
_) = ObjectId -> Either Text ObjectId
forall a b. b -> Either a b
Right (ObjectId -> Either Text ObjectId)
-> ObjectId -> Either Text ObjectId
forall a b. (a -> b) -> a -> b
$ PersistValue -> ObjectId
persistObjectIdToDbOid PersistValue
oid
    fromPersistValue (PersistByteString ByteString
bs) = PersistValue -> Either Text ObjectId
forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue (ByteString -> PersistValue
PersistObjectId ByteString
bs)
    fromPersistValue PersistValue
_ = Text -> Either Text ObjectId
forall a b. a -> Either a b
Left (Text -> Either Text ObjectId) -> Text -> Either Text ObjectId
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
"expected PersistObjectId"

instance Sql.PersistFieldSql DB.ObjectId where
    sqlType :: Proxy ObjectId -> SqlType
sqlType Proxy ObjectId
_ = Text -> SqlType
Sql.SqlOther Text
"doesn't make much sense for MongoDB"

instance Sql.PersistFieldSql (BackendKey DB.MongoContext) where
    sqlType :: Proxy (BackendKey MongoContext) -> SqlType
sqlType Proxy (BackendKey MongoContext)
_ = Text -> SqlType
Sql.SqlOther Text
"doesn't make much sense for MongoDB"


withConnection :: (Trans.MonadIO m)
               => MongoConf
               -> (ConnectionPool -> m b) -> m b
withConnection :: MongoConf -> (ConnectionPool -> m b) -> m b
withConnection MongoConf
mc =
  Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> (ConnectionPool -> m b)
-> m b
forall (m :: * -> *) b.
MonadIO m =>
Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> (ConnectionPool -> m b)
-> m b
withMongoDBPool (MongoConf -> Text
mgDatabase MongoConf
mc) (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ MongoConf -> Text
mgHost MongoConf
mc) (MongoConf -> PortID
mgPort MongoConf
mc) (MongoConf -> Maybe MongoAuth
mgAuth MongoConf
mc) (MongoConf -> Int
mgPoolStripes MongoConf
mc) (MongoConf -> Int
mgStripeConnections MongoConf
mc) (MongoConf -> NominalDiffTime
mgConnectionIdleTime MongoConf
mc)

withMongoDBConn :: (Trans.MonadIO m)
                => Database -> HostName -> DB.PortID
                -> Maybe MongoAuth -> NominalDiffTime
                -> (ConnectionPool -> m b) -> m b
withMongoDBConn :: Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> NominalDiffTime
-> (ConnectionPool -> m b)
-> m b
withMongoDBConn Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mauth NominalDiffTime
connectionIdleTime = Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> (ConnectionPool -> m b)
-> m b
forall (m :: * -> *) b.
MonadIO m =>
Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> (ConnectionPool -> m b)
-> m b
withMongoDBPool Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mauth Int
1 Int
1 NominalDiffTime
connectionIdleTime

createPipe :: HostName -> DB.PortID -> IO DB.Pipe
createPipe :: [Char] -> PortID -> IO Pipe
createPipe [Char]
hostname PortID
port = Host -> IO Pipe
DB.connect ([Char] -> PortID -> Host
DB.Host [Char]
hostname PortID
port)

createReplicatSet :: (DB.ReplicaSetName, [DB.Host]) -> Database -> Maybe MongoAuth -> IO Connection
createReplicatSet :: (Text, [Host]) -> Text -> Maybe MongoAuth -> IO Connection
createReplicatSet (Text, [Host])
rsSeed Text
dbname Maybe MongoAuth
mAuth = do
    Pipe
pipe <- (Text, [Host]) -> IO ReplicaSet
DB.openReplicaSet (Text, [Host])
rsSeed IO ReplicaSet -> (ReplicaSet -> IO Pipe) -> IO Pipe
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ReplicaSet -> IO Pipe
DB.primary
    Pipe -> Text -> Maybe MongoAuth -> IO ()
testAccess Pipe
pipe Text
dbname Maybe MongoAuth
mAuth
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection) -> Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ Pipe -> Text -> Connection
Connection Pipe
pipe Text
dbname

createRsPool :: (Trans.MonadIO m) => Database -> ReplicaSetConfig
              -> Maybe MongoAuth
              -> Int -- ^ pool size (number of stripes)
              -> Int -- ^ stripe size (number of connections per stripe)
              -> NominalDiffTime -- ^ time a connection is left idle before closing
              -> m ConnectionPool
createRsPool :: Text
-> ReplicaSetConfig
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createRsPool Text
dbname (ReplicaSetConfig Text
rsName [Host]
rsHosts) Maybe MongoAuth
mAuth Int
connectionPoolSize Int
stripeSize NominalDiffTime
connectionIdleTime = do
    IO ConnectionPool -> m ConnectionPool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO ConnectionPool -> m ConnectionPool)
-> IO ConnectionPool -> m ConnectionPool
forall a b. (a -> b) -> a -> b
$ IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO ConnectionPool
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool
                          ((Text, [Host]) -> Text -> Maybe MongoAuth -> IO Connection
createReplicatSet (Text
rsName, [Host]
rsHosts) Text
dbname Maybe MongoAuth
mAuth)
                          (\(Connection Pipe
pipe Text
_) -> Pipe -> IO ()
DB.close Pipe
pipe)
                          Int
connectionPoolSize
                          NominalDiffTime
connectionIdleTime
                          Int
stripeSize

testAccess :: DB.Pipe -> Database -> Maybe MongoAuth -> IO ()
testAccess :: Pipe -> Text -> Maybe MongoAuth -> IO ()
testAccess Pipe
pipe Text
dbname Maybe MongoAuth
mAuth = do
    Bool
_ <- case Maybe MongoAuth
mAuth of
      Just (MongoAuth Text
user Text
pass) -> Pipe -> AccessMode -> Text -> Action IO Bool -> IO Bool
forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Text -> Action m a -> m a
DB.access Pipe
pipe AccessMode
DB.UnconfirmedWrites Text
dbname (Text -> Text -> Action IO Bool
forall (m :: * -> *). MonadIO m => Text -> Text -> Action m Bool
DB.auth Text
user Text
pass)
      Maybe MongoAuth
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
forall a. HasCallStack => a
undefined
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

createConnection :: Database -> HostName -> DB.PortID -> Maybe MongoAuth -> IO Connection
createConnection :: Text -> [Char] -> PortID -> Maybe MongoAuth -> IO Connection
createConnection Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mAuth = do
    Pipe
pipe <- [Char] -> PortID -> IO Pipe
createPipe [Char]
hostname PortID
port
    Pipe -> Text -> Maybe MongoAuth -> IO ()
testAccess Pipe
pipe Text
dbname Maybe MongoAuth
mAuth
    Connection -> IO Connection
forall (m :: * -> *) a. Monad m => a -> m a
return (Connection -> IO Connection) -> Connection -> IO Connection
forall a b. (a -> b) -> a -> b
$ Pipe -> Text -> Connection
Connection Pipe
pipe Text
dbname

createMongoDBPool :: (Trans.MonadIO m) => Database -> HostName -> DB.PortID
                  -> Maybe MongoAuth
                  -> Int -- ^ pool size (number of stripes)
                  -> Int -- ^ stripe size (number of connections per stripe)
                  -> NominalDiffTime -- ^ time a connection is left idle before closing
                  -> m ConnectionPool
createMongoDBPool :: Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createMongoDBPool Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mAuth Int
connectionPoolSize Int
stripeSize NominalDiffTime
connectionIdleTime = do
  IO ConnectionPool -> m ConnectionPool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO ConnectionPool -> m ConnectionPool)
-> IO ConnectionPool -> m ConnectionPool
forall a b. (a -> b) -> a -> b
$ IO Connection
-> (Connection -> IO ())
-> Int
-> NominalDiffTime
-> Int
-> IO ConnectionPool
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool
                          (Text -> [Char] -> PortID -> Maybe MongoAuth -> IO Connection
createConnection Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mAuth)
                          (\(Connection Pipe
pipe Text
_) -> Pipe -> IO ()
DB.close Pipe
pipe)
                          Int
connectionPoolSize
                          NominalDiffTime
connectionIdleTime
                          Int
stripeSize


createMongoPool :: (Trans.MonadIO m) => MongoConf -> m ConnectionPool
createMongoPool :: MongoConf -> m ConnectionPool
createMongoPool c :: MongoConf
c@MongoConf{mgReplicaSetConfig :: MongoConf -> Maybe ReplicaSetConfig
mgReplicaSetConfig = Just (ReplicaSetConfig Text
rsName [Host]
hosts)} =
      Text
-> ReplicaSetConfig
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
forall (m :: * -> *).
MonadIO m =>
Text
-> ReplicaSetConfig
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createRsPool
         (MongoConf -> Text
mgDatabase MongoConf
c)
         (Text -> [Host] -> ReplicaSetConfig
ReplicaSetConfig Text
rsName (([Char] -> PortID -> Host
DB.Host (Text -> [Char]
T.unpack (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ MongoConf -> Text
mgHost MongoConf
c) (MongoConf -> PortID
mgPort MongoConf
c))Host -> [Host] -> [Host]
forall a. a -> [a] -> [a]
:[Host]
hosts))
         (MongoConf -> Maybe MongoAuth
mgAuth MongoConf
c)
         (MongoConf -> Int
mgPoolStripes MongoConf
c) (MongoConf -> Int
mgStripeConnections MongoConf
c) (MongoConf -> NominalDiffTime
mgConnectionIdleTime MongoConf
c)
createMongoPool c :: MongoConf
c@MongoConf{mgReplicaSetConfig :: MongoConf -> Maybe ReplicaSetConfig
mgReplicaSetConfig = Maybe ReplicaSetConfig
Nothing} =
      Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
forall (m :: * -> *).
MonadIO m =>
Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createMongoDBPool
         (MongoConf -> Text
mgDatabase MongoConf
c) (Text -> [Char]
T.unpack (MongoConf -> Text
mgHost MongoConf
c)) (MongoConf -> PortID
mgPort MongoConf
c)
         (MongoConf -> Maybe MongoAuth
mgAuth MongoConf
c)
         (MongoConf -> Int
mgPoolStripes MongoConf
c) (MongoConf -> Int
mgStripeConnections MongoConf
c) (MongoConf -> NominalDiffTime
mgConnectionIdleTime MongoConf
c)

type PipePool = Pool.Pool DB.Pipe

-- | A pool of plain MongoDB pipes.
-- The database parameter has not yet been applied yet.
-- This is useful for switching between databases (on the same host and port)
-- Unlike the normal pool, no authentication is available
createMongoDBPipePool :: (Trans.MonadIO m) => HostName -> DB.PortID
                  -> Int -- ^ pool size (number of stripes)
                  -> Int -- ^ stripe size (number of connections per stripe)
                  -> NominalDiffTime -- ^ time a connection is left idle before closing
                  -> m PipePool
createMongoDBPipePool :: [Char] -> PortID -> Int -> Int -> NominalDiffTime -> m PipePool
createMongoDBPipePool [Char]
hostname PortID
port Int
connectionPoolSize Int
stripeSize NominalDiffTime
connectionIdleTime =
  IO PipePool -> m PipePool
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO PipePool -> m PipePool) -> IO PipePool -> m PipePool
forall a b. (a -> b) -> a -> b
$ IO Pipe
-> (Pipe -> IO ()) -> Int -> NominalDiffTime -> Int -> IO PipePool
forall a.
IO a
-> (a -> IO ()) -> Int -> NominalDiffTime -> Int -> IO (Pool a)
Pool.createPool
                          ([Char] -> PortID -> IO Pipe
createPipe [Char]
hostname PortID
port)
                          Pipe -> IO ()
DB.close
                          Int
connectionPoolSize
                          NominalDiffTime
connectionIdleTime
                          Int
stripeSize

withMongoPool :: (Trans.MonadIO m) => MongoConf -> (ConnectionPool -> m b) -> m b
withMongoPool :: MongoConf -> (ConnectionPool -> m b) -> m b
withMongoPool MongoConf
conf ConnectionPool -> m b
connectionReader = MongoConf -> m ConnectionPool
forall (m :: * -> *). MonadIO m => MongoConf -> m ConnectionPool
createMongoPool MongoConf
conf m ConnectionPool -> (ConnectionPool -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ConnectionPool -> m b
connectionReader

withMongoDBPool :: (Trans.MonadIO m) =>
  Database -> HostName -> DB.PortID -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b
withMongoDBPool :: Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> (ConnectionPool -> m b)
-> m b
withMongoDBPool Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mauth Int
poolStripes Int
stripeConnections NominalDiffTime
connectionIdleTime ConnectionPool -> m b
connectionReader = do
  ConnectionPool
pool <- Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
forall (m :: * -> *).
MonadIO m =>
Text
-> [Char]
-> PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createMongoDBPool Text
dbname [Char]
hostname PortID
port Maybe MongoAuth
mauth Int
poolStripes Int
stripeConnections NominalDiffTime
connectionIdleTime
  ConnectionPool -> m b
connectionReader ConnectionPool
pool

-- | run a pool created with 'createMongoDBPipePool'
runMongoDBPipePool :: MonadUnliftIO m => DB.AccessMode -> Database -> DB.Action m a -> PipePool -> m a
runMongoDBPipePool :: AccessMode -> Text -> Action m a -> PipePool -> m a
runMongoDBPipePool AccessMode
accessMode Text
db Action m a
action PipePool
pool =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
  PipePool -> (Pipe -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource PipePool
pool ((Pipe -> IO a) -> IO a) -> (Pipe -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Pipe
pipe ->
  m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ Pipe -> AccessMode -> Text -> Action m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Text -> Action m a -> m a
DB.access Pipe
pipe AccessMode
accessMode Text
db Action m a
action

runMongoDBPool :: MonadUnliftIO m => DB.AccessMode  -> DB.Action m a -> ConnectionPool -> m a
runMongoDBPool :: AccessMode -> Action m a -> ConnectionPool -> m a
runMongoDBPool AccessMode
accessMode Action m a
action ConnectionPool
pool =
  ((forall a. m a -> IO a) -> IO a) -> m a
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO a) -> m a)
-> ((forall a. m a -> IO a) -> IO a) -> m a
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
  ConnectionPool -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
Pool.withResource ConnectionPool
pool ((Connection -> IO a) -> IO a) -> (Connection -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \(Connection Pipe
pipe Text
db) ->
  m a -> IO a
forall a. m a -> IO a
run (m a -> IO a) -> m a -> IO a
forall a b. (a -> b) -> a -> b
$ Pipe -> AccessMode -> Text -> Action m a -> m a
forall (m :: * -> *) a.
MonadIO m =>
Pipe -> AccessMode -> Text -> Action m a -> m a
DB.access Pipe
pipe AccessMode
accessMode Text
db Action m a
action


-- | use default 'AccessMode'
runMongoDBPoolDef :: MonadUnliftIO m => DB.Action m a -> ConnectionPool -> m a
runMongoDBPoolDef :: Action m a -> ConnectionPool -> m a
runMongoDBPoolDef = AccessMode -> Action m a -> ConnectionPool -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
AccessMode -> Action m a -> ConnectionPool -> m a
runMongoDBPool AccessMode
defaultAccessMode

queryByKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
           => Key record -> DB.Query
queryByKey :: Key record -> Query
queryByKey Key record
k = (Selector -> Text -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Selector -> Text -> aQueryOrSelection
DB.select (Key record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selector
keyToMongoDoc Key record
k) (Key record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Text
collectionNameFromKey Key record
k)) {project :: Selector
DB.project = Key record -> Selector
forall record. PersistEntity record => Key record -> Selector
projectionFromKey Key record
k}

selectByKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
            => Key record -> DB.Selection
selectByKey :: Key record -> Selection
selectByKey Key record
k = Selector -> Text -> Selection
forall aQueryOrSelection.
Select aQueryOrSelection =>
Selector -> Text -> aQueryOrSelection
DB.select (Key record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selector
keyToMongoDoc Key record
k) (Key record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Text
collectionNameFromKey Key record
k)

updatesToDoc :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
             => [Update record] -> DB.Document
updatesToDoc :: [Update record] -> Selector
updatesToDoc [Update record]
upds = (Update record -> Field) -> [Update record] -> Selector
forall a b. (a -> b) -> [a] -> [b]
map Update record -> Field
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Update record -> Field
updateToMongoField [Update record]
upds

updateToBson :: Text
             -> PersistValue
             -> Either PersistUpdate MongoUpdateOperation
             -> DB.Field
updateToBson :: Text
-> PersistValue
-> Either PersistUpdate MongoUpdateOperation
-> Field
updateToBson Text
fname PersistValue
v Either PersistUpdate MongoUpdateOperation
up =
#ifdef DEBUG
  debug (
#endif
    Text
opName Text -> Value -> Field
DB.:= Selector -> Value
DB.Doc [Text
fname Text -> Value -> Field
DB.:= Value
opValue]
#ifdef DEBUG
    )
#endif
  where
    inc :: Text
inc = Text
"$inc"
    mul :: Text
mul = Text
"$mul"
    (Text
opName, Value
opValue) = case Either PersistUpdate MongoUpdateOperation
up of
      Left PersistUpdate
pup -> case (PersistUpdate
pup, PersistValue
v) of
        (PersistUpdate
Assign, PersistValue
PersistNull) -> (Text
"$unset", Int64 -> Value
DB.Int64 Int64
1)
        (PersistUpdate
Assign,PersistValue
a)    -> (Text
"$set", PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
a)
        (PersistUpdate
Add, PersistValue
a)      -> (Text
inc, PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
a)
        (PersistUpdate
Subtract, PersistInt64 Int64
i) -> (Text
inc, Int64 -> Value
DB.Int64 (-Int64
i))
        (PersistUpdate
Multiply, PersistInt64 Int64
i) -> (Text
mul, Int64 -> Value
DB.Int64 Int64
i)
        (PersistUpdate
Multiply, PersistDouble Double
d) -> (Text
mul, Double -> Value
DB.Float Double
d)
        (PersistUpdate
Subtract, PersistValue
_) -> [Char] -> (Text, Value)
forall a. HasCallStack => [Char] -> a
error [Char]
"expected PersistInt64 for a subtraction"
        (PersistUpdate
Multiply, PersistValue
_) -> [Char] -> (Text, Value)
forall a. HasCallStack => [Char] -> a
error [Char]
"expected PersistInt64 or PersistDouble for a subtraction"
        -- Obviously this could be supported for floats by multiplying with 1/x
        (PersistUpdate
Divide, PersistValue
_)   -> PersistException -> (Text, Value)
forall a e. Exception e => e -> a
throw (PersistException -> (Text, Value))
-> PersistException -> (Text, Value)
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"divide not supported"
        (BackendSpecificUpdate Text
bsup, PersistValue
_) -> PersistException -> (Text, Value)
forall a e. Exception e => e -> a
throw (PersistException -> (Text, Value))
-> PersistException -> (Text, Value)
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$
          [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"did not expect BackendSpecificUpdate " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
bsup
      Right MongoUpdateOperation
mup -> case MongoUpdateOperation
mup of
        MongoEach MongoUpdateOperator
op  -> case MongoUpdateOperator
op of
           MongoUpdateOperator
MongoPull -> (Text
"$pullAll", PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
v)
           MongoUpdateOperator
_         -> (MongoUpdateOperator -> Text
opToText MongoUpdateOperator
op, Selector -> Value
DB.Doc [Text
"$each" Text -> Value -> Field
DB.:= PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
v])
        MongoSimple MongoUpdateOperator
x -> (MongoUpdateOperator -> Text
opToText MongoUpdateOperator
x, PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
v)




updateToMongoField :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                   => Update record -> DB.Field
updateToMongoField :: Update record -> Field
updateToMongoField (Update EntityField record typ
field typ
v PersistUpdate
up) = Text
-> PersistValue
-> Either PersistUpdate MongoUpdateOperation
-> Field
updateToBson (EntityField record typ -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField record typ
field) (typ -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue typ
v) (PersistUpdate -> Either PersistUpdate MongoUpdateOperation
forall a b. a -> Either a b
Left PersistUpdate
up)
updateToMongoField (BackendUpdate BackendSpecificUpdate (PersistEntityBackend record) record
up)  = MongoUpdate record -> Field
forall record. PersistEntity record => MongoUpdate record -> Field
mongoUpdateToDoc BackendSpecificUpdate (PersistEntityBackend record) record
MongoUpdate record
up


-- | convert a unique key into a MongoDB document
toUniquesDoc :: forall record. (PersistEntity record) => Unique record -> [DB.Field]
toUniquesDoc :: Unique record -> Selector
toUniquesDoc Unique record
uniq = (Text -> Value -> Field) -> [Text] -> [Value] -> Selector
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Value -> Field
(DB.:=)
  (((FieldNameHS, FieldNameDB) -> Text)
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (FieldNameDB -> Text
unFieldNameDB (FieldNameDB -> Text)
-> ((FieldNameHS, FieldNameDB) -> FieldNameDB)
-> (FieldNameHS, FieldNameDB)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FieldNameHS, FieldNameDB) -> FieldNameDB
forall a b. (a, b) -> b
snd) ([(FieldNameHS, FieldNameDB)] -> [Text])
-> [(FieldNameHS, FieldNameDB)] -> [Text]
forall a b. (a -> b) -> a -> b
$ NonEmpty (FieldNameHS, FieldNameDB) -> [(FieldNameHS, FieldNameDB)]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty (FieldNameHS, FieldNameDB)
 -> [(FieldNameHS, FieldNameDB)])
-> NonEmpty (FieldNameHS, FieldNameDB)
-> [(FieldNameHS, FieldNameDB)]
forall a b. (a -> b) -> a -> b
$ Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
forall record.
PersistEntity record =>
Unique record -> NonEmpty (FieldNameHS, FieldNameDB)
persistUniqueToFieldNames Unique record
uniq)
  ((PersistValue -> Value) -> [PersistValue] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> Value
forall a. Val a => a -> Value
DB.val (Unique record -> [PersistValue]
forall record.
PersistEntity record =>
Unique record -> [PersistValue]
persistUniqueToValues Unique record
uniq))

-- | convert a PersistEntity into document fields.
-- for inserts only: nulls are ignored so they will be unset in the document.
-- 'recordToDocument' includes nulls
toInsertDoc :: forall record.  (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
            => record -> DB.Document
toInsertDoc :: record -> Selector
toInsertDoc record
record =
    [EmbedFieldDef] -> [PersistValue] -> Selector
zipFilter
        (EmbedEntityDef -> [EmbedFieldDef]
embeddedFields (EmbedEntityDef -> [EmbedFieldDef])
-> EmbedEntityDef -> [EmbedFieldDef]
forall a b. (a -> b) -> a -> b
$ EntityDef -> EmbedEntityDef
toEmbedEntityDef EntityDef
entDef)
        ((SomePersistField -> PersistValue)
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map SomePersistField -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue ([SomePersistField] -> [PersistValue])
-> [SomePersistField] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record)
  where
    entDef :: EntityDef
entDef = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
record
    zipFilter :: [EmbedFieldDef] -> [PersistValue] -> Selector
zipFilter [EmbedFieldDef]
xs [PersistValue]
ys =
        ((EmbedFieldDef, PersistValue) -> Field)
-> [(EmbedFieldDef, PersistValue)] -> Selector
forall a b. (a -> b) -> [a] -> [b]
map (\(EmbedFieldDef
fd, PersistValue
pv) ->
            EmbedFieldDef -> Text
fieldToLabel EmbedFieldDef
fd
                Text -> Value -> Field
DB.:=
                    PersistValue -> Value
embeddedVal PersistValue
pv
        )
        ([(EmbedFieldDef, PersistValue)] -> Selector)
-> [(EmbedFieldDef, PersistValue)] -> Selector
forall a b. (a -> b) -> a -> b
$ ((EmbedFieldDef, PersistValue) -> Bool)
-> [(EmbedFieldDef, PersistValue)]
-> [(EmbedFieldDef, PersistValue)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(EmbedFieldDef
_, PersistValue
pv) -> Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PersistValue -> Bool
isNull PersistValue
pv)
        ([(EmbedFieldDef, PersistValue)]
 -> [(EmbedFieldDef, PersistValue)])
-> [(EmbedFieldDef, PersistValue)]
-> [(EmbedFieldDef, PersistValue)]
forall a b. (a -> b) -> a -> b
$ [EmbedFieldDef]
-> [PersistValue] -> [(EmbedFieldDef, PersistValue)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EmbedFieldDef]
xs [PersistValue]
ys
      where
        isNull :: PersistValue -> Bool
isNull PersistValue
PersistNull = Bool
True
        isNull (PersistMap [(Text, PersistValue)]
m) = [(Text, PersistValue)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Text, PersistValue)]
m
        isNull (PersistList [PersistValue]
l) = [PersistValue] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PersistValue]
l
        isNull PersistValue
_ = Bool
False

    -- make sure to removed nulls from embedded entities also.
    -- note that persistent no longer supports embedded maps
    -- with fields. This means any embedded bson object will
    -- insert null. But top level will not.
    embeddedVal :: PersistValue -> DB.Value
    embeddedVal :: PersistValue -> Value
embeddedVal (PersistMap [(Text, PersistValue)]
m) =
        Selector -> Value
DB.Doc (Selector -> Value) -> Selector -> Value
forall a b. (a -> b) -> a -> b
$ ((Text, PersistValue) -> Field)
-> [(Text, PersistValue)] -> Selector
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Text
k, PersistValue
v) -> Text
k Text -> Value -> Field
DB.:= PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
v) ([(Text, PersistValue)] -> Selector)
-> [(Text, PersistValue)] -> Selector
forall a b. (a -> b) -> a -> b
$ [(Text, PersistValue)]
m
            -- zipFilter fields $ map snd m
    embeddedVal (PersistList [PersistValue]
l) =
        [Value] -> Value
DB.Array ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (PersistValue -> Value) -> [PersistValue] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> Value
embeddedVal [PersistValue]
l
    embeddedVal PersistValue
pv =
        PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
pv

entityToInsertDoc :: forall record.  (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                  => Entity record -> DB.Document
entityToInsertDoc :: Entity record -> Selector
entityToInsertDoc (Entity Key record
key record
record) = Key record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selector
keyToMongoDoc Key record
key Selector -> Selector -> Selector
forall a. [a] -> [a] -> [a]
++ record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Selector
toInsertDoc record
record

collectionName :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
               => record -> Text
collectionName :: record -> Text
collectionName = EntityNameDB -> Text
unEntityNameDB (EntityNameDB -> Text)
-> (record -> EntityNameDB) -> record -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EntityDef -> EntityNameDB
getEntityDBName (EntityDef -> EntityNameDB)
-> (record -> EntityDef) -> record -> EntityNameDB
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef)
-> (record -> Maybe record) -> record -> EntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. record -> Maybe record
forall a. a -> Maybe a
Just

-- | convert a PersistEntity into document fields.
-- unlike 'toInsertDoc', nulls are included.
recordToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                 => record -> DB.Document
recordToDocument :: record -> Selector
recordToDocument record
record = [FieldNameDB] -> [SomePersistField] -> Selector
forall a. PersistField a => [FieldNameDB] -> [a] -> Selector
zipToDoc ((FieldDef -> FieldNameDB) -> [FieldDef] -> [FieldNameDB]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> FieldNameDB
fieldDB ([FieldDef] -> [FieldNameDB]) -> [FieldDef] -> [FieldNameDB]
forall a b. (a -> b) -> a -> b
$ EntityDef -> [FieldDef]
getEntityFields EntityDef
entity) (record -> [SomePersistField]
forall record. PersistEntity record => record -> [SomePersistField]
toPersistFields record
record)
  where
    entity :: EntityDef
entity = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
record

documentFromEntity :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                   => Entity record -> DB.Document
documentFromEntity :: Entity record -> Selector
documentFromEntity (Entity Key record
key record
record) =
    Key record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selector
keyToMongoDoc Key record
key Selector -> Selector -> Selector
forall a. [a] -> [a] -> [a]
++ record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Selector
recordToDocument record
record

zipToDoc :: PersistField a => [FieldNameDB] -> [a] -> [DB.Field]
zipToDoc :: [FieldNameDB] -> [a] -> Selector
zipToDoc [] [a]
_  = []
zipToDoc [FieldNameDB]
_  [] = []
zipToDoc (FieldNameDB
e:[FieldNameDB]
efields) (a
p:[a]
pfields) =
  let pv :: PersistValue
pv = a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
p
  in  (FieldNameDB -> Text
unFieldNameDB FieldNameDB
e Text -> Value -> Field
DB.:= PersistValue -> Value
forall a. Val a => a -> Value
DB.val PersistValue
pv)Field -> Selector -> Selector
forall a. a -> [a] -> [a]
:[FieldNameDB] -> [a] -> Selector
forall a. PersistField a => [FieldNameDB] -> [a] -> Selector
zipToDoc [FieldNameDB]
efields [a]
pfields

fieldToLabel :: EmbedFieldDef -> Text
fieldToLabel :: EmbedFieldDef -> Text
fieldToLabel = FieldNameDB -> Text
unFieldNameDB (FieldNameDB -> Text)
-> (EmbedFieldDef -> FieldNameDB) -> EmbedFieldDef -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. EmbedFieldDef -> FieldNameDB
emFieldDB

keyFrom_idEx :: (Trans.MonadIO m, PersistEntity record) => DB.Value -> m (Key record)
keyFrom_idEx :: Value -> m (Key record)
keyFrom_idEx Value
idVal = case Value -> Either Text (Key record)
forall record.
PersistEntity record =>
Value -> Either Text (Key record)
keyFrom_id Value
idVal of
    Right Key record
k  -> Key record -> m (Key record)
forall (m :: * -> *) a. Monad m => a -> m a
return Key record
k
    Left Text
err -> IO (Key record) -> m (Key record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Key record) -> m (Key record))
-> IO (Key record) -> m (Key record)
forall a b. (a -> b) -> a -> b
$ PersistException -> IO (Key record)
forall e a. Exception e => e -> IO a
throwIO (PersistException -> IO (Key record))
-> PersistException -> IO (Key record)
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$ Text
"could not convert key: "
        Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`Data.Monoid.mappend` [Char] -> Text
T.pack (Value -> [Char]
forall a. Show a => a -> [Char]
show Value
idVal)
        Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
err

keyFrom_id :: (PersistEntity record) => DB.Value -> Either Text (Key record)
keyFrom_id :: Value -> Either Text (Key record)
keyFrom_id Value
idVal = case Value -> PersistValue
cast Value
idVal of
    (PersistMap [(Text, PersistValue)]
m) -> [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues ([PersistValue] -> Either Text (Key record))
-> [PersistValue] -> Either Text (Key record)
forall a b. (a -> b) -> a -> b
$ ((Text, PersistValue) -> PersistValue)
-> [(Text, PersistValue)] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map (Text, PersistValue) -> PersistValue
forall a b. (a, b) -> b
snd [(Text, PersistValue)]
m
    PersistValue
pv -> [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue
pv]

-- | It would make sense to define the instance for ObjectId
-- and then use newtype deriving
-- however, that would create an orphan instance
instance ToJSON (BackendKey DB.MongoContext) where
    toJSON :: BackendKey MongoContext -> Value
toJSON (MongoKey (Oid x y)) = [Char] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Char] -> Value) -> [Char] -> Value
forall a b. (a -> b) -> a -> b
$ Int -> Word32 -> ShowS
forall n. (Show n, Integral n) => Int -> n -> ShowS
DB.showHexLen Int
8 Word32
x ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> Word64 -> ShowS
forall n. (Show n, Integral n) => Int -> n -> ShowS
DB.showHexLen Int
16 Word64
y [Char]
""

instance FromJSON (BackendKey DB.MongoContext) where
    parseJSON :: Value -> Parser (BackendKey MongoContext)
parseJSON = [Char]
-> (Text -> Parser (BackendKey MongoContext))
-> Value
-> Parser (BackendKey MongoContext)
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"MongoKey" ((Text -> Parser (BackendKey MongoContext))
 -> Value -> Parser (BackendKey MongoContext))
-> (Text -> Parser (BackendKey MongoContext))
-> Value
-> Parser (BackendKey MongoContext)
forall a b. (a -> b) -> a -> b
$ \Text
t ->
        Parser (BackendKey MongoContext)
-> (ByteString -> Parser (BackendKey MongoContext))
-> Maybe ByteString
-> Parser (BackendKey MongoContext)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
          ([Char] -> Parser (BackendKey MongoContext)
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid base64")
          (BackendKey MongoContext -> Parser (BackendKey MongoContext)
forall (m :: * -> *) a. Monad m => a -> m a
return (BackendKey MongoContext -> Parser (BackendKey MongoContext))
-> (ByteString -> BackendKey MongoContext)
-> ByteString
-> Parser (BackendKey MongoContext)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectId -> BackendKey MongoContext
MongoKey (ObjectId -> BackendKey MongoContext)
-> (ByteString -> ObjectId)
-> ByteString
-> BackendKey MongoContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistValue -> ObjectId
persistObjectIdToDbOid (PersistValue -> ObjectId)
-> (ByteString -> PersistValue) -> ByteString -> ObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> PersistValue
PersistObjectId)
          (Maybe ByteString -> Parser (BackendKey MongoContext))
-> Maybe ByteString -> Parser (BackendKey MongoContext)
forall a b. (a -> b) -> a -> b
$ ((Integer, [Char]) -> ByteString)
-> Maybe (Integer, [Char]) -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Integer -> ByteString
i2bs (Int
8 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
12) (Integer -> ByteString)
-> ((Integer, [Char]) -> Integer)
-> (Integer, [Char])
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer, [Char]) -> Integer
forall a b. (a, b) -> a
fst) (Maybe (Integer, [Char]) -> Maybe ByteString)
-> Maybe (Integer, [Char]) -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ [(Integer, [Char])] -> Maybe (Integer, [Char])
forall a. [a] -> Maybe a
headMay ([(Integer, [Char])] -> Maybe (Integer, [Char]))
-> [(Integer, [Char])] -> Maybe (Integer, [Char])
forall a b. (a -> b) -> a -> b
$ ReadS Integer
forall a. (Eq a, Num a) => ReadS a
readHex ReadS Integer -> ReadS Integer
forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
      where
        -- should these be exported from Types/Base.hs ?
        headMay :: [a] -> Maybe a
headMay []    = Maybe a
forall a. Maybe a
Nothing
        headMay (a
x:[a]
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
x

        -- taken from crypto-api
        -- |@i2bs bitLen i@ converts @i@ to a 'ByteString' of @bitLen@ bits (must be a multiple of 8).
        i2bs :: Int -> Integer -> BS.ByteString
        i2bs :: Int -> Integer -> ByteString
i2bs Int
l Integer
i = (Int -> Maybe (Word8, Int)) -> Int -> ByteString
forall a. (a -> Maybe (Word8, a)) -> a -> ByteString
BS.unfoldr (\Int
l' -> if Int
l' Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Maybe (Word8, Int)
forall a. Maybe a
Nothing else (Word8, Int) -> Maybe (Word8, Int)
forall a. a -> Maybe a
Just (Integer -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
l'), Int
l' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
8)) (Int
lInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
8)
        {-# INLINE i2bs #-}

-- | older versions versions of haddock (like that on hackage) do not show that this defines
-- @BackendKey DB.MongoContext = MongoKey { unMongoKey :: DB.ObjectId }@
instance PersistCore DB.MongoContext where
    newtype BackendKey DB.MongoContext = MongoKey { BackendKey MongoContext -> ObjectId
unMongoKey :: DB.ObjectId }
        deriving (Int -> BackendKey MongoContext -> ShowS
[BackendKey MongoContext] -> ShowS
BackendKey MongoContext -> [Char]
(Int -> BackendKey MongoContext -> ShowS)
-> (BackendKey MongoContext -> [Char])
-> ([BackendKey MongoContext] -> ShowS)
-> Show (BackendKey MongoContext)
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BackendKey MongoContext] -> ShowS
$cshowList :: [BackendKey MongoContext] -> ShowS
show :: BackendKey MongoContext -> [Char]
$cshow :: BackendKey MongoContext -> [Char]
showsPrec :: Int -> BackendKey MongoContext -> ShowS
$cshowsPrec :: Int -> BackendKey MongoContext -> ShowS
Show, ReadPrec [BackendKey MongoContext]
ReadPrec (BackendKey MongoContext)
Int -> ReadS (BackendKey MongoContext)
ReadS [BackendKey MongoContext]
(Int -> ReadS (BackendKey MongoContext))
-> ReadS [BackendKey MongoContext]
-> ReadPrec (BackendKey MongoContext)
-> ReadPrec [BackendKey MongoContext]
-> Read (BackendKey MongoContext)
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [BackendKey MongoContext]
$creadListPrec :: ReadPrec [BackendKey MongoContext]
readPrec :: ReadPrec (BackendKey MongoContext)
$creadPrec :: ReadPrec (BackendKey MongoContext)
readList :: ReadS [BackendKey MongoContext]
$creadList :: ReadS [BackendKey MongoContext]
readsPrec :: Int -> ReadS (BackendKey MongoContext)
$creadsPrec :: Int -> ReadS (BackendKey MongoContext)
Read, BackendKey MongoContext -> BackendKey MongoContext -> Bool
(BackendKey MongoContext -> BackendKey MongoContext -> Bool)
-> (BackendKey MongoContext -> BackendKey MongoContext -> Bool)
-> Eq (BackendKey MongoContext)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
$c/= :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
== :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
$c== :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
Eq, Eq (BackendKey MongoContext)
Eq (BackendKey MongoContext)
-> (BackendKey MongoContext -> BackendKey MongoContext -> Ordering)
-> (BackendKey MongoContext -> BackendKey MongoContext -> Bool)
-> (BackendKey MongoContext -> BackendKey MongoContext -> Bool)
-> (BackendKey MongoContext -> BackendKey MongoContext -> Bool)
-> (BackendKey MongoContext -> BackendKey MongoContext -> Bool)
-> (BackendKey MongoContext
    -> BackendKey MongoContext -> BackendKey MongoContext)
-> (BackendKey MongoContext
    -> BackendKey MongoContext -> BackendKey MongoContext)
-> Ord (BackendKey MongoContext)
BackendKey MongoContext -> BackendKey MongoContext -> Bool
BackendKey MongoContext -> BackendKey MongoContext -> Ordering
BackendKey MongoContext
-> BackendKey MongoContext -> BackendKey MongoContext
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BackendKey MongoContext
-> BackendKey MongoContext -> BackendKey MongoContext
$cmin :: BackendKey MongoContext
-> BackendKey MongoContext -> BackendKey MongoContext
max :: BackendKey MongoContext
-> BackendKey MongoContext -> BackendKey MongoContext
$cmax :: BackendKey MongoContext
-> BackendKey MongoContext -> BackendKey MongoContext
>= :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
$c>= :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
> :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
$c> :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
<= :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
$c<= :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
< :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
$c< :: BackendKey MongoContext -> BackendKey MongoContext -> Bool
compare :: BackendKey MongoContext -> BackendKey MongoContext -> Ordering
$ccompare :: BackendKey MongoContext -> BackendKey MongoContext -> Ordering
$cp1Ord :: Eq (BackendKey MongoContext)
Ord, BackendKey MongoContext -> PersistValue
PersistValue -> Either Text (BackendKey MongoContext)
(BackendKey MongoContext -> PersistValue)
-> (PersistValue -> Either Text (BackendKey MongoContext))
-> PersistField (BackendKey MongoContext)
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text (BackendKey MongoContext)
$cfromPersistValue :: PersistValue -> Either Text (BackendKey MongoContext)
toPersistValue :: BackendKey MongoContext -> PersistValue
$ctoPersistValue :: BackendKey MongoContext -> PersistValue
PersistField)

instance PersistStoreWrite DB.MongoContext where
    insert :: record -> ReaderT MongoContext m (Key record)
insert record
record = Text -> Selector -> Action m Value
forall (m :: * -> *).
MonadIO m =>
Text -> Selector -> Action m Value
DB.insert (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
record) (record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Selector
toInsertDoc record
record)
                Action m Value
-> (Value -> ReaderT MongoContext m (Key record))
-> ReaderT MongoContext m (Key record)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ReaderT MongoContext m (Key record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record) =>
Value -> m (Key record)
keyFrom_idEx

    insertMany :: [record] -> ReaderT MongoContext m [Key record]
insertMany [] = [Key record] -> ReaderT MongoContext m [Key record]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    insertMany records :: [record]
records@(record
r:[record]
_) = (Value -> ReaderT MongoContext m (Key record))
-> [Value] -> ReaderT MongoContext m [Key record]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Value -> ReaderT MongoContext m (Key record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record) =>
Value -> m (Key record)
keyFrom_idEx ([Value] -> ReaderT MongoContext m [Key record])
-> ReaderT MongoContext m [Value]
-> ReaderT MongoContext m [Key record]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        Text -> [Selector] -> ReaderT MongoContext m [Value]
forall (m :: * -> *).
MonadIO m =>
Text -> [Selector] -> Action m [Value]
DB.insertMany (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
r) ((record -> Selector) -> [record] -> [Selector]
forall a b. (a -> b) -> [a] -> [b]
map record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Selector
toInsertDoc [record]
records)

    insertEntityMany :: [Entity record] -> ReaderT MongoContext m ()
insertEntityMany [] = () -> ReaderT MongoContext m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    insertEntityMany ents :: [Entity record]
ents@(Entity Key record
_ record
r : [Entity record]
_) =
        Text -> [Selector] -> ReaderT MongoContext m ()
forall (m :: * -> *).
MonadIO m =>
Text -> [Selector] -> Action m ()
DB.insertMany_ (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
r) ((Entity record -> Selector) -> [Entity record] -> [Selector]
forall a b. (a -> b) -> [a] -> [b]
map Entity record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Entity record -> Selector
entityToInsertDoc [Entity record]
ents)

    insertKey :: Key record -> record -> ReaderT MongoContext m ()
insertKey Key record
k record
record = Text -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *). MonadIO m => Text -> Selector -> Action m ()
DB.insert_ (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
record) (Selector -> ReaderT MongoContext m ())
-> Selector -> ReaderT MongoContext m ()
forall a b. (a -> b) -> a -> b
$
                         Entity record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Entity record -> Selector
entityToInsertDoc (Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
record)

    repsert :: Key record -> record -> ReaderT MongoContext m ()
repsert   Key record
k record
record = Text -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *). MonadIO m => Text -> Selector -> Action m ()
DB.save (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
record) (Selector -> ReaderT MongoContext m ())
-> Selector -> ReaderT MongoContext m ()
forall a b. (a -> b) -> a -> b
$
                         Entity record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Entity record -> Selector
documentFromEntity (Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
k record
record)

    replace :: Key record -> record -> ReaderT MongoContext m ()
replace Key record
k record
record = do
        Selection -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *).
MonadIO m =>
Selection -> Selector -> Action m ()
DB.replace (Key record -> Selection
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selection
selectByKey Key record
k) (record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Selector
recordToDocument record
record)
        () -> ReaderT MongoContext m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    delete :: Key record -> ReaderT MongoContext m ()
delete Key record
k =
        Selection -> ReaderT MongoContext m ()
forall (m :: * -> *). MonadIO m => Selection -> Action m ()
DB.deleteOne Select :: Selector -> Text -> Selection
DB.Select {
          coll :: Text
DB.coll = Key record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Text
collectionNameFromKey Key record
k
        , selector :: Selector
DB.selector = Key record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selector
keyToMongoDoc Key record
k
        }

    update :: Key record -> [Update record] -> ReaderT MongoContext m ()
update Key record
_ [] = () -> ReaderT MongoContext m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    update Key record
key [Update record]
upds =
        Selection -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *).
MonadIO m =>
Selection -> Selector -> Action m ()
DB.modify
           (Selector -> Text -> Selection
DB.Select (Key record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Selector
keyToMongoDoc Key record
key) (Key record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Text
collectionNameFromKey Key record
key))
           (Selector -> ReaderT MongoContext m ())
-> Selector -> ReaderT MongoContext m ()
forall a b. (a -> b) -> a -> b
$ [Update record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Update record] -> Selector
updatesToDoc [Update record]
upds

    updateGet :: Key record -> [Update record] -> ReaderT MongoContext m record
updateGet Key record
key [Update record]
upds = do
        MongoContext
context <- ReaderT MongoContext m MongoContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        Either [Char] Selector
result <- IO (Either [Char] Selector)
-> ReaderT MongoContext m (Either [Char] Selector)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either [Char] Selector)
 -> ReaderT MongoContext m (Either [Char] Selector))
-> IO (Either [Char] Selector)
-> ReaderT MongoContext m (Either [Char] Selector)
forall a b. (a -> b) -> a -> b
$ ReaderT MongoContext IO (Either [Char] Selector)
-> MongoContext -> IO (Either [Char] Selector)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Query
-> Selector -> ReaderT MongoContext IO (Either [Char] Selector)
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
Query -> Selector -> Action m (Either [Char] Selector)
DB.findAndModify (Key record -> Query
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Query
queryByKey Key record
key) ([Update record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Update record] -> Selector
updatesToDoc [Update record]
upds)) MongoContext
context
        ([Char] -> ReaderT MongoContext m record)
-> (Selector -> ReaderT MongoContext m record)
-> Either [Char] Selector
-> ReaderT MongoContext m record
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either [Char] -> ReaderT MongoContext m record
err Selector -> ReaderT MongoContext m record
instantiate Either [Char] Selector
result
      where
        instantiate :: Selector -> ReaderT MongoContext m record
instantiate Selector
doc = do
            Entity Key record
_ record
rec <- EntityDef -> Selector -> ReaderT MongoContext m (Entity record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
EntityDef -> Selector -> m (Entity record)
fromPersistValuesThrow EntityDef
t Selector
doc
            record -> ReaderT MongoContext m record
forall (m :: * -> *) a. Monad m => a -> m a
return record
rec
        err :: [Char] -> ReaderT MongoContext m record
err [Char]
msg = IO record -> ReaderT MongoContext m record
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO record -> ReaderT MongoContext m record)
-> IO record -> ReaderT MongoContext m record
forall a b. (a -> b) -> a -> b
$ UpdateException -> IO record
forall e a. Exception e => e -> IO a
throwIO (UpdateException -> IO record) -> UpdateException -> IO record
forall a b. (a -> b) -> a -> b
$ [Char] -> UpdateException
KeyNotFound ([Char] -> UpdateException) -> [Char] -> UpdateException
forall a b. (a -> b) -> a -> b
$ Key record -> [Char]
forall a. Show a => a -> [Char]
show Key record
key [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg
        t :: EntityDef
t = Key record -> EntityDef
forall record. PersistEntity record => Key record -> EntityDef
entityDefFromKey Key record
key

instance PersistStoreRead DB.MongoContext where
    get :: Key record -> ReaderT MongoContext m (Maybe record)
get Key record
k = do
            Maybe Selector
d <- Query -> Action m (Maybe Selector)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Selector)
DB.findOne (Key record -> Query
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
Key record -> Query
queryByKey Key record
k)
            case Maybe Selector
d of
              Maybe Selector
Nothing -> Maybe record -> ReaderT MongoContext m (Maybe record)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe record
forall a. Maybe a
Nothing
              Just Selector
doc -> do
                Entity Key record
_ record
ent <- EntityDef -> Selector -> ReaderT MongoContext m (Entity record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
EntityDef -> Selector -> m (Entity record)
fromPersistValuesThrow EntityDef
t Selector
doc
                Maybe record -> ReaderT MongoContext m (Maybe record)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe record -> ReaderT MongoContext m (Maybe record))
-> Maybe record -> ReaderT MongoContext m (Maybe record)
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
ent
          where
            t :: EntityDef
t = Key record -> EntityDef
forall record. PersistEntity record => Key record -> EntityDef
entityDefFromKey Key record
k

instance PersistUniqueRead DB.MongoContext where
    getBy :: Unique record -> ReaderT MongoContext m (Maybe (Entity record))
getBy Unique record
uniq = do
        Maybe Selector
mdoc <- Query -> Action m (Maybe Selector)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Selector)
DB.findOne (Query -> Action m (Maybe Selector))
-> Query -> Action m (Maybe Selector)
forall a b. (a -> b) -> a -> b
$
          (Selector -> Text -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Selector -> Text -> aQueryOrSelection
DB.select (Unique record -> Selector
forall record. PersistEntity record => Unique record -> Selector
toUniquesDoc Unique record
uniq) (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
rec)) {project :: Selector
DB.project = record -> Selector
forall record. PersistEntity record => record -> Selector
projectionFromRecord record
rec}
        case Maybe Selector
mdoc of
            Maybe Selector
Nothing -> Maybe (Entity record)
-> ReaderT MongoContext m (Maybe (Entity record))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Entity record)
forall a. Maybe a
Nothing
            Just Selector
doc -> (Entity record -> Maybe (Entity record))
-> ReaderT MongoContext m (Entity record)
-> ReaderT MongoContext m (Maybe (Entity record))
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Entity record -> Maybe (Entity record)
forall a. a -> Maybe a
Just (ReaderT MongoContext m (Entity record)
 -> ReaderT MongoContext m (Maybe (Entity record)))
-> ReaderT MongoContext m (Entity record)
-> ReaderT MongoContext m (Maybe (Entity record))
forall a b. (a -> b) -> a -> b
$ EntityDef -> Selector -> ReaderT MongoContext m (Entity record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
EntityDef -> Selector -> m (Entity record)
fromPersistValuesThrow EntityDef
t Selector
doc
      where
        t :: EntityDef
t = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just record
rec
        rec :: record
rec = Unique record -> record
forall v. Unique v -> v
dummyFromUnique Unique record
uniq

instance PersistUniqueWrite DB.MongoContext where
    deleteBy :: Unique record -> ReaderT MongoContext m ()
deleteBy Unique record
uniq =
        Selection -> ReaderT MongoContext m ()
forall (m :: * -> *). MonadIO m => Selection -> Action m ()
DB.delete Select :: Selector -> Text -> Selection
DB.Select {
          coll :: Text
DB.coll = record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName (record -> Text) -> record -> Text
forall a b. (a -> b) -> a -> b
$ Unique record -> record
forall v. Unique v -> v
dummyFromUnique Unique record
uniq
        , selector :: Selector
DB.selector = Unique record -> Selector
forall record. PersistEntity record => Unique record -> Selector
toUniquesDoc Unique record
uniq
        }

    upsert :: record -> [Update record] -> ReaderT MongoContext m (Entity record)
upsert record
newRecord [Update record]
upds = do
        Unique record
uniq <- record -> ReaderT MongoContext m (Unique record)
forall record backend (m :: * -> *).
(MonadIO m, PersistUniqueWrite backend,
 PersistRecordBackend record backend, OnlyOneUniqueKey record) =>
record -> ReaderT backend m (Unique record)
onlyUnique record
newRecord
        Unique record
-> record
-> [Update record]
-> ReaderT MongoContext m (Entity record)
forall backend record (m :: * -> *).
(PersistUniqueWrite backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record
-> record -> [Update record] -> ReaderT backend m (Entity record)
upsertBy Unique record
uniq record
newRecord [Update record]
upds

-- -        let uniqKeys = map DB.label uniqueDoc
-- -        let insDoc = DB.exclude uniqKeys $ toInsertDoc newRecord
--          let selection = DB.select uniqueDoc $ collectionName newRecord
-- -        if null upds
-- -          then DB.upsert selection ["$set" DB.=: insDoc]
-- -          else do
-- -            DB.upsert selection ["$setOnInsert" DB.=: insDoc]
-- -            DB.modify selection $ updatesToDoc upds
-- -        -- because findAndModify $setOnInsert is broken we do a separate get now

    upsertBy :: Unique record
-> record
-> [Update record]
-> ReaderT MongoContext m (Entity record)
upsertBy Unique record
uniq record
newRecord [Update record]
upds = do
        let uniqueDoc :: Selector
uniqueDoc = Unique record -> Selector
forall record. PersistEntity record => Unique record -> Selector
toUniquesDoc Unique record
uniq :: [DB.Field]
        let uniqKeys :: [Text]
uniqKeys = (Field -> Text) -> Selector -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Field -> Text
DB.label Selector
uniqueDoc :: [DB.Label]
        let insDoc :: Selector
insDoc = [Text] -> Selector -> Selector
DB.exclude [Text]
uniqKeys (Selector -> Selector) -> Selector -> Selector
forall a b. (a -> b) -> a -> b
$ record -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Selector
toInsertDoc record
newRecord :: DB.Document
        let selection :: Selection
selection = Selector -> Text -> Selection
forall aQueryOrSelection.
Select aQueryOrSelection =>
Selector -> Text -> aQueryOrSelection
DB.select Selector
uniqueDoc (Text -> Selection) -> Text -> Selection
forall a b. (a -> b) -> a -> b
$ record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName record
newRecord :: DB.Selection
        Maybe (Entity record)
mdoc <- Unique record -> ReaderT MongoContext m (Maybe (Entity record))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique record
uniq
        case Maybe (Entity record)
mdoc of
          Maybe (Entity record)
Nothing -> Bool -> ReaderT MongoContext m () -> ReaderT MongoContext m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Update record] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Update record]
upds) (Selection -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *).
MonadIO m =>
Selection -> Selector -> Action m ()
DB.upsert Selection
selection [Text
"$setOnInsert" Text -> Selector -> Field
forall v. Val v => Text -> v -> Field
DB.=: Selector
insDoc])
          Just Entity record
_ -> Bool -> ReaderT MongoContext m () -> ReaderT MongoContext m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Update record] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Update record]
upds) (Selection -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *).
MonadIO m =>
Selection -> Selector -> Action m ()
DB.modify Selection
selection (Selector -> ReaderT MongoContext m ())
-> Selector -> ReaderT MongoContext m ()
forall a b. (a -> b) -> a -> b
$ [Text] -> Selector -> Selector
DB.exclude [Text]
uniqKeys (Selector -> Selector) -> Selector -> Selector
forall a b. (a -> b) -> a -> b
$ [Update record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Update record] -> Selector
updatesToDoc [Update record]
upds)
        Maybe (Entity record)
newMdoc <- Unique record -> ReaderT MongoContext m (Maybe (Entity record))
forall backend record (m :: * -> *).
(PersistUniqueRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
Unique record -> ReaderT backend m (Maybe (Entity record))
getBy Unique record
uniq
        case Maybe (Entity record)
newMdoc of
          Maybe (Entity record)
Nothing -> [Char] -> ReaderT MongoContext m (Entity record)
forall a. [Char] -> ReaderT MongoContext m a
err [Char]
"possible race condition: getBy found Nothing"
          Just Entity record
doc -> Entity record -> ReaderT MongoContext m (Entity record)
forall (m :: * -> *) a. Monad m => a -> m a
return Entity record
doc
      where
        err :: [Char] -> ReaderT MongoContext m a
err = IO a -> ReaderT MongoContext m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO a -> ReaderT MongoContext m a)
-> ([Char] -> IO a) -> [Char] -> ReaderT MongoContext m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateException -> IO a
forall e a. Exception e => e -> IO a
throwIO (UpdateException -> IO a)
-> ([Char] -> UpdateException) -> [Char] -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> UpdateException
UpsertError
        {-
        -- cannot use findAndModify
        -- because $setOnInsert is crippled
        -- https://jira.mongodb.org/browse/SERVER-2643
        result <- DB.findAndModifyOpts
            selection
            (DB.defFamUpdateOpts ("$setOnInsert" DB.=: insDoc : ["$set" DB.=: insDoc]))
              { DB.famUpsert = True }
        either err instantiate result
      where
        -- this is only possible when new is False
        instantiate Nothing = error "upsert: impossible null"
        instantiate (Just doc) =
            fromPersistValuesThrow (entityDef $ Just newRecord) doc
            -}


-- | It would make more sense to call this _id, but GHC treats leading underscore in special ways
id_ :: T.Text
id_ :: Text
id_ = Text
"_id"

-- _id is always the primary key in MongoDB
-- but _id can contain any unique value
keyToMongoDoc :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                  => Key record -> DB.Document
keyToMongoDoc :: Key record -> Selector
keyToMongoDoc Key record
k = case EntityDef -> Maybe CompositeDef
entityPrimary (EntityDef -> Maybe CompositeDef)
-> EntityDef -> Maybe CompositeDef
forall a b. (a -> b) -> a -> b
$ Key record -> EntityDef
forall record. PersistEntity record => Key record -> EntityDef
entityDefFromKey Key record
k of
    Maybe CompositeDef
Nothing   -> [FieldNameDB] -> [PersistValue] -> Selector
forall a. PersistField a => [FieldNameDB] -> [a] -> Selector
zipToDoc [Text -> FieldNameDB
FieldNameDB Text
id_] [PersistValue]
values
    Just CompositeDef
pdef -> [Text
id_ Text -> Selector -> Field
forall v. Val v => Text -> v -> Field
DB.=: [FieldNameDB] -> [PersistValue] -> Selector
forall a. PersistField a => [FieldNameDB] -> [a] -> Selector
zipToDoc (CompositeDef -> [FieldNameDB]
primaryNames CompositeDef
pdef)  [PersistValue]
values]
  where
    primaryNames :: CompositeDef -> [FieldNameDB]
primaryNames = (FieldDef -> FieldNameDB) -> [FieldDef] -> [FieldNameDB]
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> FieldNameDB
fieldDB ([FieldDef] -> [FieldNameDB])
-> (CompositeDef -> [FieldDef]) -> CompositeDef -> [FieldNameDB]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty FieldDef -> [FieldDef]
forall a. NonEmpty a -> [a]
NEL.toList (NonEmpty FieldDef -> [FieldDef])
-> (CompositeDef -> NonEmpty FieldDef)
-> CompositeDef
-> [FieldDef]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CompositeDef -> NonEmpty FieldDef
compositeFields
    values :: [PersistValue]
values = Key record -> [PersistValue]
forall record. PersistEntity record => Key record -> [PersistValue]
keyToValues Key record
k

entityDefFromKey :: PersistEntity record => Key record -> EntityDef
entityDefFromKey :: Key record -> EntityDef
entityDefFromKey = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef)
-> (Key record -> Maybe record) -> Key record -> EntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. record -> Maybe record
forall a. a -> Maybe a
Just (record -> Maybe record)
-> (Key record -> record) -> Key record -> Maybe record
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key record -> record
forall record. Key record -> record
recordTypeFromKey

collectionNameFromKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
                      => Key record -> Text
collectionNameFromKey :: Key record -> Text
collectionNameFromKey = record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName (record -> Text) -> (Key record -> record) -> Key record -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key record -> record
forall record. Key record -> record
recordTypeFromKey

projectionFromEntityDef :: EntityDef -> DB.Projector
projectionFromEntityDef :: EntityDef -> Selector
projectionFromEntityDef EntityDef
eDef =
  (FieldDef -> Field) -> [FieldDef] -> Selector
forall a b. (a -> b) -> [a] -> [b]
map FieldDef -> Field
toField (EntityDef -> [FieldDef]
getEntityFields EntityDef
eDef)
  where
    toField :: FieldDef -> DB.Field
    toField :: FieldDef -> Field
toField FieldDef
fDef = (FieldNameDB -> Text
unFieldNameDB (FieldDef -> FieldNameDB
fieldDB FieldDef
fDef)) Text -> Int -> Field
forall v. Val v => Text -> v -> Field
DB.=: (Int
1 :: Int)

projectionFromKey :: PersistEntity record => Key record -> DB.Projector
projectionFromKey :: Key record -> Selector
projectionFromKey = EntityDef -> Selector
projectionFromEntityDef (EntityDef -> Selector)
-> (Key record -> EntityDef) -> Key record -> Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key record -> EntityDef
forall record. PersistEntity record => Key record -> EntityDef
entityDefFromKey

projectionFromRecord :: PersistEntity record => record -> DB.Projector
projectionFromRecord :: record -> Selector
projectionFromRecord = EntityDef -> Selector
projectionFromEntityDef (EntityDef -> Selector)
-> (record -> EntityDef) -> record -> Selector
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef)
-> (record -> Maybe record) -> record -> EntityDef
forall b c a. (b -> c) -> (a -> b) -> a -> c
. record -> Maybe record
forall a. a -> Maybe a
Just


instance PersistQueryWrite DB.MongoContext where
    updateWhere :: [Filter record] -> [Update record] -> ReaderT MongoContext m ()
updateWhere [Filter record]
_ [] = () -> ReaderT MongoContext m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    updateWhere [Filter record]
filts [Update record]
upds =
        Selection -> Selector -> ReaderT MongoContext m ()
forall (m :: * -> *).
MonadIO m =>
Selection -> Selector -> Action m ()
DB.modify Select :: Selector -> Text -> Selection
DB.Select {
          coll :: Text
DB.coll = record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName (record -> Text) -> record -> Text
forall a b. (a -> b) -> a -> b
$ [Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts
        , selector :: Selector
DB.selector = [Filter record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> Selector
filtersToDoc [Filter record]
filts
        } (Selector -> ReaderT MongoContext m ())
-> Selector -> ReaderT MongoContext m ()
forall a b. (a -> b) -> a -> b
$ [Update record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Update record] -> Selector
updatesToDoc [Update record]
upds

    deleteWhere :: [Filter record] -> ReaderT MongoContext m ()
deleteWhere [Filter record]
filts = do
        Selection -> ReaderT MongoContext m ()
forall (m :: * -> *). MonadIO m => Selection -> Action m ()
DB.delete Select :: Selector -> Text -> Selection
DB.Select {
          coll :: Text
DB.coll = record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName (record -> Text) -> record -> Text
forall a b. (a -> b) -> a -> b
$ [Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts
        , selector :: Selector
DB.selector = [Filter record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> Selector
filtersToDoc [Filter record]
filts
        }

instance PersistQueryRead DB.MongoContext where
    count :: [Filter record] -> ReaderT MongoContext m Int
count [Filter record]
filts = do
        Int
i <- Query -> ReaderT MongoContext m Int
forall (m :: * -> *). MonadIO m => Query -> Action m Int
DB.count Query
query
        Int -> ReaderT MongoContext m Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ReaderT MongoContext m Int)
-> Int -> ReaderT MongoContext m Int
forall a b. (a -> b) -> a -> b
$ Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i
      where
        query :: Query
query = Selector -> Text -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Selector -> Text -> aQueryOrSelection
DB.select ([Filter record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> Selector
filtersToDoc [Filter record]
filts) (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$
                  record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName (record -> Text) -> record -> Text
forall a b. (a -> b) -> a -> b
$ [Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts

    exists :: [Filter record] -> ReaderT MongoContext m Bool
exists [Filter record]
filts = do
        Int
cnt <- [Filter record] -> ReaderT MongoContext m Int
forall backend (m :: * -> *) record.
(PersistQueryRead backend, MonadIO m,
 PersistRecordBackend record backend) =>
[Filter record] -> ReaderT backend m Int
count [Filter record]
filts
        Bool -> ReaderT MongoContext m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
cnt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0)

    -- | uses cursor option NoCursorTimeout
    -- If there is no sorting, it will turn the $snapshot option on
    -- and explicitly closes the cursor when done
    selectSourceRes :: [Filter record]
-> [SelectOpt record]
-> ReaderT
     MongoContext m1 (Acquire (ConduitM () (Entity record) m2 ()))
selectSourceRes [Filter record]
filts [SelectOpt record]
opts = do
        MongoContext
context <- ReaderT MongoContext m1 MongoContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        Acquire (ConduitM () (Entity record) m2 ())
-> ReaderT
     MongoContext m1 (Acquire (ConduitM () (Entity record) m2 ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (MongoContext -> Cursor -> ConduitM () (Entity record) m2 ()
pullCursor MongoContext
context (Cursor -> ConduitM () (Entity record) m2 ())
-> Acquire Cursor -> Acquire (ConduitM () (Entity record) m2 ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO Cursor -> (Cursor -> IO ()) -> Acquire Cursor
forall a. IO a -> (a -> IO ()) -> Acquire a
mkAcquire (MongoContext -> IO Cursor
open MongoContext
context) (MongoContext -> Cursor -> IO ()
close MongoContext
context))
      where
        close :: DB.MongoContext -> DB.Cursor -> IO ()
        close :: MongoContext -> Cursor -> IO ()
close MongoContext
context Cursor
cursor = ReaderT MongoContext IO () -> MongoContext -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Cursor -> ReaderT MongoContext IO ()
forall (m :: * -> *). MonadIO m => Cursor -> Action m ()
DB.closeCursor Cursor
cursor) MongoContext
context
        open :: DB.MongoContext -> IO DB.Cursor
        open :: MongoContext -> IO Cursor
open = ReaderT MongoContext IO Cursor -> MongoContext -> IO Cursor
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Query -> ReaderT MongoContext IO Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
DB.find ([Filter record] -> [SelectOpt record] -> Query
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> [SelectOpt record] -> Query
makeQuery [Filter record]
filts [SelectOpt record]
opts)
                   -- it is an error to apply $snapshot when sorting
                   { snapshot :: Bool
DB.snapshot = Bool
noSort
                   , options :: [QueryOption]
DB.options = [QueryOption
DB.NoCursorTimeout]
                   })
        pullCursor :: MongoContext -> Cursor -> ConduitM () (Entity record) m2 ()
pullCursor MongoContext
context Cursor
cursor = do
            [Selector]
mdoc <- IO [Selector] -> ConduitT () (Entity record) m2 [Selector]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Selector] -> ConduitT () (Entity record) m2 [Selector])
-> IO [Selector] -> ConduitT () (Entity record) m2 [Selector]
forall a b. (a -> b) -> a -> b
$ ReaderT MongoContext IO [Selector] -> MongoContext -> IO [Selector]
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Cursor -> ReaderT MongoContext IO [Selector]
forall (m :: * -> *). MonadIO m => Cursor -> Action m [Selector]
DB.nextBatch Cursor
cursor) MongoContext
context
            case [Selector]
mdoc of
                [] -> () -> ConduitM () (Entity record) m2 ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                [Selector]
docs -> do
                    [Selector]
-> (Selector -> ConduitM () (Entity record) m2 ())
-> ConduitM () (Entity record) m2 ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Selector]
docs ((Selector -> ConduitM () (Entity record) m2 ())
 -> ConduitM () (Entity record) m2 ())
-> (Selector -> ConduitM () (Entity record) m2 ())
-> ConduitM () (Entity record) m2 ()
forall a b. (a -> b) -> a -> b
$ EntityDef
-> Selector -> ConduitT () (Entity record) m2 (Entity record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
EntityDef -> Selector -> m (Entity record)
fromPersistValuesThrow EntityDef
t (Selector -> ConduitT () (Entity record) m2 (Entity record))
-> (Entity record -> ConduitM () (Entity record) m2 ())
-> Selector
-> ConduitM () (Entity record) m2 ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Entity record -> ConduitM () (Entity record) m2 ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield
                    MongoContext -> Cursor -> ConduitM () (Entity record) m2 ()
pullCursor MongoContext
context Cursor
cursor
        t :: EntityDef
t = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just (record -> Maybe record) -> record -> Maybe record
forall a b. (a -> b) -> a -> b
$ [Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts
        (Int
_, Int
_, [SelectOpt record]
orders) = [SelectOpt record] -> (Int, Int, [SelectOpt record])
forall val.
PersistEntity val =>
[SelectOpt val] -> (Int, Int, [SelectOpt val])
limitOffsetOrder [SelectOpt record]
opts
        noSort :: Bool
noSort = [SelectOpt record] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SelectOpt record]
orders

    selectFirst :: [Filter record]
-> [SelectOpt record]
-> ReaderT MongoContext m (Maybe (Entity record))
selectFirst [Filter record]
filts [SelectOpt record]
opts = Query -> Action m (Maybe Selector)
forall (m :: * -> *).
MonadIO m =>
Query -> Action m (Maybe Selector)
DB.findOne ([Filter record] -> [SelectOpt record] -> Query
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> [SelectOpt record] -> Query
makeQuery [Filter record]
filts [SelectOpt record]
opts)
                         Action m (Maybe Selector)
-> (Maybe Selector
    -> ReaderT MongoContext m (Maybe (Entity record)))
-> ReaderT MongoContext m (Maybe (Entity record))
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Selector -> ReaderT MongoContext m (Entity record))
-> Maybe Selector -> ReaderT MongoContext m (Maybe (Entity record))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
Traversable.mapM (EntityDef -> Selector -> ReaderT MongoContext m (Entity record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
EntityDef -> Selector -> m (Entity record)
fromPersistValuesThrow EntityDef
t)
      where
        t :: EntityDef
t = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just (record -> Maybe record) -> record -> Maybe record
forall a b. (a -> b) -> a -> b
$ [Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts

    selectKeysRes :: [Filter record]
-> [SelectOpt record]
-> ReaderT
     MongoContext m1 (Acquire (ConduitM () (Key record) m2 ()))
selectKeysRes [Filter record]
filts [SelectOpt record]
opts = do
        MongoContext
context <- ReaderT MongoContext m1 MongoContext
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        let make :: ConduitM () (Key record) m2 ()
make = do
                Cursor
cursor <- IO Cursor -> ConduitT () (Key record) m2 Cursor
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Cursor -> ConduitT () (Key record) m2 Cursor)
-> IO Cursor -> ConduitT () (Key record) m2 Cursor
forall a b. (a -> b) -> a -> b
$ (ReaderT MongoContext IO Cursor -> MongoContext -> IO Cursor)
-> MongoContext -> ReaderT MongoContext IO Cursor -> IO Cursor
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT MongoContext IO Cursor -> MongoContext -> IO Cursor
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT MongoContext
context (ReaderT MongoContext IO Cursor -> IO Cursor)
-> ReaderT MongoContext IO Cursor -> IO Cursor
forall a b. (a -> b) -> a -> b
$ Query -> ReaderT MongoContext IO Cursor
forall (m :: * -> *). MonadIO m => Query -> Action m Cursor
DB.find (Query -> ReaderT MongoContext IO Cursor)
-> Query -> ReaderT MongoContext IO Cursor
forall a b. (a -> b) -> a -> b
$ ([Filter record] -> [SelectOpt record] -> Query
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> [SelectOpt record] -> Query
makeQuery [Filter record]
filts [SelectOpt record]
opts) {
                    project :: Selector
DB.project = [Text
id_ Text -> Int -> Field
forall v. Val v => Text -> v -> Field
DB.=: (Int
1 :: Int)]
                  }
                MongoContext -> Cursor -> ConduitM () (Key record) m2 ()
forall (m :: * -> *) record i.
(MonadIO m, PersistEntity record) =>
MongoContext -> Cursor -> ConduitT i (Key record) m ()
pullCursor MongoContext
context Cursor
cursor
        Acquire (ConduitM () (Key record) m2 ())
-> ReaderT
     MongoContext m1 (Acquire (ConduitM () (Key record) m2 ()))
forall (m :: * -> *) a. Monad m => a -> m a
return (Acquire (ConduitM () (Key record) m2 ())
 -> ReaderT
      MongoContext m1 (Acquire (ConduitM () (Key record) m2 ())))
-> Acquire (ConduitM () (Key record) m2 ())
-> ReaderT
     MongoContext m1 (Acquire (ConduitM () (Key record) m2 ()))
forall a b. (a -> b) -> a -> b
$ ConduitM () (Key record) m2 ()
-> Acquire (ConduitM () (Key record) m2 ())
forall (m :: * -> *) a. Monad m => a -> m a
return ConduitM () (Key record) m2 ()
make
      where
        pullCursor :: MongoContext -> Cursor -> ConduitT i (Key record) m ()
pullCursor MongoContext
context Cursor
cursor = do
            Maybe Selector
mdoc <- IO (Maybe Selector) -> ConduitT i (Key record) m (Maybe Selector)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Selector) -> ConduitT i (Key record) m (Maybe Selector))
-> IO (Maybe Selector)
-> ConduitT i (Key record) m (Maybe Selector)
forall a b. (a -> b) -> a -> b
$ ReaderT MongoContext IO (Maybe Selector)
-> MongoContext -> IO (Maybe Selector)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Cursor -> ReaderT MongoContext IO (Maybe Selector)
forall (m :: * -> *).
MonadIO m =>
Cursor -> Action m (Maybe Selector)
DB.next Cursor
cursor) MongoContext
context
            case Maybe Selector
mdoc of
                Maybe Selector
Nothing -> () -> ConduitT i (Key record) m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Just [Text
_id DB.:= Value
idVal] -> do
                    Key record
k <- IO (Key record) -> ConduitT i (Key record) m (Key record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Key record) -> ConduitT i (Key record) m (Key record))
-> IO (Key record) -> ConduitT i (Key record) m (Key record)
forall a b. (a -> b) -> a -> b
$ Value -> IO (Key record)
forall (m :: * -> *) record.
(MonadIO m, PersistEntity record) =>
Value -> m (Key record)
keyFrom_idEx Value
idVal
                    Key record -> ConduitT i (Key record) m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield Key record
k
                    MongoContext -> Cursor -> ConduitT i (Key record) m ()
pullCursor MongoContext
context Cursor
cursor
                Just Selector
y -> IO () -> ConduitT i (Key record) m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ConduitT i (Key record) m ())
-> IO () -> ConduitT i (Key record) m ()
forall a b. (a -> b) -> a -> b
$ PersistException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (PersistException -> IO ()) -> PersistException -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMarshalError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"Unexpected in selectKeys: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Selector -> [Char]
forall a. Show a => a -> [Char]
show Selector
y

orderClause :: PersistEntity val => SelectOpt val -> DB.Field
orderClause :: SelectOpt val -> Field
orderClause SelectOpt val
o = case SelectOpt val
o of
                  Asc EntityField val typ
f  -> EntityField val typ -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField val typ
f Text -> Int -> Field
forall v. Val v => Text -> v -> Field
DB.=: ( Int
1 :: Int)
                  Desc EntityField val typ
f -> EntityField val typ -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField val typ
f Text -> Int -> Field
forall v. Val v => Text -> v -> Field
DB.=: (-Int
1 :: Int)
                  SelectOpt val
_      -> [Char] -> Field
forall a. HasCallStack => [Char] -> a
error [Char]
"orderClause: expected Asc or Desc"


makeQuery :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => [Filter record] -> [SelectOpt record] -> DB.Query
makeQuery :: [Filter record] -> [SelectOpt record] -> Query
makeQuery [Filter record]
filts [SelectOpt record]
opts =
    (Selector -> Text -> Query
forall aQueryOrSelection.
Select aQueryOrSelection =>
Selector -> Text -> aQueryOrSelection
DB.select ([Filter record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
[Filter record] -> Selector
filtersToDoc [Filter record]
filts) (record -> Text
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
record -> Text
collectionName (record -> Text) -> record -> Text
forall a b. (a -> b) -> a -> b
$ [Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts)) {
      limit :: Word32
DB.limit = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
limit
    , skip :: Word32
DB.skip  = Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
offset
    , sort :: Selector
DB.sort  = Selector
orders
    , project :: Selector
DB.project = record -> Selector
forall record. PersistEntity record => record -> Selector
projectionFromRecord ([Filter record] -> record
forall v. [Filter v] -> v
dummyFromFilts [Filter record]
filts)
    }
  where
    (Int
limit, Int
offset, [SelectOpt record]
orders') = [SelectOpt record] -> (Int, Int, [SelectOpt record])
forall val.
PersistEntity val =>
[SelectOpt val] -> (Int, Int, [SelectOpt val])
limitOffsetOrder [SelectOpt record]
opts
    orders :: Selector
orders = (SelectOpt record -> Field) -> [SelectOpt record] -> Selector
forall a b. (a -> b) -> [a] -> [b]
map SelectOpt record -> Field
forall val. PersistEntity val => SelectOpt val -> Field
orderClause [SelectOpt record]
orders'

filtersToDoc :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => [Filter record] -> DB.Document
filtersToDoc :: [Filter record] -> Selector
filtersToDoc [Filter record]
filts =
#ifdef DEBUG
  debug $
#endif
    if [Filter record] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Filter record]
filts then [] else MultiFilter -> [Filter record] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
MultiFilter -> [Filter record] -> Selector
multiFilter MultiFilter
AndDollar [Filter record]
filts

filterToDocument :: (PersistEntity val, PersistEntityBackend val ~ DB.MongoContext) => Filter val -> DB.Document
filterToDocument :: Filter val -> Selector
filterToDocument Filter val
f =
    case Filter val
f of
      Filter EntityField val typ
field FilterValue typ
v PersistFilter
filt -> [Text -> FilterValue typ -> PersistFilter -> Field
forall a.
PersistField a =>
Text -> FilterValue a -> PersistFilter -> Field
filterToBSON (EntityField val typ -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField val typ
field) FilterValue typ
v PersistFilter
filt]
      BackendFilter BackendSpecificFilter (PersistEntityBackend val) val
mf -> MongoFilter val -> Selector
forall record.
PersistEntity record =>
MongoFilter record -> Selector
mongoFilterToDoc BackendSpecificFilter (PersistEntityBackend val) val
MongoFilter val
mf
      -- The empty filter case should never occur when the user uses ||.
      -- An empty filter list will throw an exception in multiFilter
      --
      -- The alternative would be to create a query which always returns true
      -- However, I don't think an end user ever wants that.
      FilterOr [Filter val]
fs  -> MultiFilter -> [Filter val] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
MultiFilter -> [Filter record] -> Selector
multiFilter MultiFilter
OrDollar [Filter val]
fs
      -- Ignore an empty filter list instead of throwing an exception.
      -- \$and is necessary in only a few cases, but it makes query construction easier
      FilterAnd [] -> []
      FilterAnd [Filter val]
fs -> MultiFilter -> [Filter val] -> Selector
forall record.
(PersistEntity record,
 PersistEntityBackend record ~ MongoContext) =>
MultiFilter -> [Filter record] -> Selector
multiFilter MultiFilter
AndDollar [Filter val]
fs

data MultiFilter = OrDollar | AndDollar deriving Int -> MultiFilter -> ShowS
[MultiFilter] -> ShowS
MultiFilter -> [Char]
(Int -> MultiFilter -> ShowS)
-> (MultiFilter -> [Char])
-> ([MultiFilter] -> ShowS)
-> Show MultiFilter
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MultiFilter] -> ShowS
$cshowList :: [MultiFilter] -> ShowS
show :: MultiFilter -> [Char]
$cshow :: MultiFilter -> [Char]
showsPrec :: Int -> MultiFilter -> ShowS
$cshowsPrec :: Int -> MultiFilter -> ShowS
Show
toMultiOp :: MultiFilter -> Text
toMultiOp :: MultiFilter -> Text
toMultiOp MultiFilter
OrDollar  = Text
orDollar
toMultiOp MultiFilter
AndDollar = Text
andDollar

multiFilter :: forall record. (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => MultiFilter -> [Filter record] -> [DB.Field]
multiFilter :: MultiFilter -> [Filter record] -> Selector
multiFilter MultiFilter
_ [] = PersistException -> Selector
forall a e. Exception e => e -> a
throw (PersistException -> Selector) -> PersistException -> Selector
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBError Text
"An empty list of filters was given"
multiFilter MultiFilter
multi [Filter record]
filters =
  case (MultiFilter
multi, (Selector -> Bool) -> [Selector] -> [Selector]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Selector -> Bool) -> Selector -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Selector -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ((Filter record -> Selector) -> [Filter record] -> [Selector]
forall a b. (a -> b) -> [a] -> [b]
map Filter record -> Selector
forall val.
(PersistEntity val, PersistEntityBackend val ~ MongoContext) =>
Filter val -> Selector
filterToDocument [Filter record]
filters)) of
    -- a $or must have at least 2 items
    (MultiFilter
OrDollar,  []) -> Selector
forall a. a
orError
    (MultiFilter
AndDollar, []) -> []
    (MultiFilter
OrDollar,    Selector
_:[]) -> Selector
forall a. a
orError
    (MultiFilter
AndDollar, Selector
doc:[]) -> Selector
doc
    (MultiFilter
_, [Selector]
doc) -> [MultiFilter -> Text
toMultiOp MultiFilter
multi Text -> Value -> Field
DB.:= [Value] -> Value
DB.Array ((Selector -> Value) -> [Selector] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map Selector -> Value
DB.Doc [Selector]
doc)]
  where
    orError :: a
orError = PersistException -> a
forall a e. Exception e => e -> a
throw (PersistException -> a) -> PersistException -> a
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$
        Text
"An empty list of filters was given to one side of ||."

existsDollar, orDollar, andDollar :: Text
existsDollar :: Text
existsDollar = Text
"$exists"
orDollar :: Text
orDollar = Text
"$or"
andDollar :: Text
andDollar = Text
"$and"

filterToBSON :: forall a. ( PersistField a)
             => Text
             -> FilterValue a
             -> PersistFilter
             -> DB.Field
filterToBSON :: Text -> FilterValue a -> PersistFilter -> Field
filterToBSON Text
fname FilterValue a
v PersistFilter
filt = case PersistFilter
filt of
    PersistFilter
Eq -> Field
nullEq
    PersistFilter
Ne -> Field
nullNeq
    PersistFilter
_  -> Field
notEquality
  where
    dbv :: Value
dbv = FilterValue a -> Value
forall a. PersistField a => FilterValue a -> Value
toValue FilterValue a
v
    notEquality :: Field
notEquality = Text
fname Text -> Selector -> Field
forall v. Val v => Text -> v -> Field
DB.=: [PersistFilter -> Text
forall p. IsString p => PersistFilter -> p
showFilter PersistFilter
filt Text -> Value -> Field
DB.:= Value
dbv]

    nullEq :: Field
nullEq = case Value
dbv of
      Value
DB.Null -> Text
orDollar Text -> [Selector] -> Field
forall v. Val v => Text -> v -> Field
DB.=:
        [ [Text
fname Text -> Value -> Field
DB.:= Value
DB.Null]
        , [Text
fname Text -> Value -> Field
DB.:= Selector -> Value
DB.Doc [Text
existsDollar Text -> Value -> Field
DB.:= Bool -> Value
DB.Bool Bool
False]]
        ]
      Value
_ -> Text
fname Text -> Value -> Field
DB.:= Value
dbv

    nullNeq :: Field
nullNeq = case Value
dbv of
      Value
DB.Null ->
        Text
fname Text -> Value -> Field
DB.:= Selector -> Value
DB.Doc
          [ PersistFilter -> Text
forall p. IsString p => PersistFilter -> p
showFilter PersistFilter
Ne Text -> Value -> Field
DB.:= Value
DB.Null
          , Text
existsDollar Text -> Value -> Field
DB.:= Bool -> Value
DB.Bool Bool
True
          ]
      Value
_ -> Field
notEquality

    showFilter :: PersistFilter -> p
showFilter PersistFilter
Ne = p
"$ne"
    showFilter PersistFilter
Gt = p
"$gt"
    showFilter PersistFilter
Lt = p
"$lt"
    showFilter PersistFilter
Ge = p
"$gte"
    showFilter PersistFilter
Le = p
"$lte"
    showFilter PersistFilter
In = p
"$in"
    showFilter PersistFilter
NotIn = p
"$nin"
    showFilter PersistFilter
Eq = [Char] -> p
forall a. HasCallStack => [Char] -> a
error [Char]
"EQ filter not expected"
    showFilter (BackendSpecificFilter Text
bsf) = PersistException -> p
forall a e. Exception e => e -> a
throw (PersistException -> p) -> PersistException -> p
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"did not expect BackendSpecificFilter " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
bsf


mongoFilterToBSON :: forall typ. PersistField typ
                  => Text
                  -> MongoFilterOperator typ
                  -> DB.Document
mongoFilterToBSON :: Text -> MongoFilterOperator typ -> Selector
mongoFilterToBSON Text
fname MongoFilterOperator typ
filt = case MongoFilterOperator typ
filt of
    (PersistFilterOperator FilterValue typ
v PersistFilter
op) -> [Text -> FilterValue typ -> PersistFilter -> Field
forall a.
PersistField a =>
Text -> FilterValue a -> PersistFilter -> Field
filterToBSON Text
fname FilterValue typ
v PersistFilter
op]
    (MongoFilterOperator Value
bval)   -> [Text
fname Text -> Value -> Field
DB.:= Value
bval]

mongoUpdateToBson :: forall typ. PersistField typ
                  => Text
                  -> UpdateValueOp typ
                  -> DB.Field
mongoUpdateToBson :: Text -> UpdateValueOp typ -> Field
mongoUpdateToBson Text
fname UpdateValueOp typ
upd = case UpdateValueOp typ
upd of
    UpdateValueOp (Left typ
v)  Either PersistUpdate MongoUpdateOperation
op -> Text
-> PersistValue
-> Either PersistUpdate MongoUpdateOperation
-> Field
updateToBson Text
fname (typ -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue typ
v) Either PersistUpdate MongoUpdateOperation
op
    UpdateValueOp (Right [typ]
v) Either PersistUpdate MongoUpdateOperation
op -> Text
-> PersistValue
-> Either PersistUpdate MongoUpdateOperation
-> Field
updateToBson Text
fname ([PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue) -> [PersistValue] -> PersistValue
forall a b. (a -> b) -> a -> b
$ (typ -> PersistValue) -> [typ] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map typ -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue [typ]
v) Either PersistUpdate MongoUpdateOperation
op

mongoUpdateToDoc :: PersistEntity record => MongoUpdate record -> DB.Field
mongoUpdateToDoc :: MongoUpdate record -> Field
mongoUpdateToDoc (NestedUpdate   NestedField record typ
field UpdateValueOp typ
op) = Text -> UpdateValueOp typ -> Field
forall typ. PersistField typ => Text -> UpdateValueOp typ -> Field
mongoUpdateToBson (NestedField record typ -> Text
forall record typ.
PersistEntity record =>
NestedField record typ -> Text
nestedFieldName NestedField record typ
field) UpdateValueOp typ
op
mongoUpdateToDoc (ArrayUpdate EntityField record [typ]
field UpdateValueOp typ
op)    = Text -> UpdateValueOp typ -> Field
forall typ. PersistField typ => Text -> UpdateValueOp typ -> Field
mongoUpdateToBson (EntityField record [typ] -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField record [typ]
field) UpdateValueOp typ
op

mongoFilterToDoc :: PersistEntity record => MongoFilter record -> DB.Document
mongoFilterToDoc :: MongoFilter record -> Selector
mongoFilterToDoc (NestedFilter   NestedField record typ
field MongoFilterOperator typ
op) = Text -> MongoFilterOperator typ -> Selector
forall typ.
PersistField typ =>
Text -> MongoFilterOperator typ -> Selector
mongoFilterToBSON (NestedField record typ -> Text
forall record typ.
PersistEntity record =>
NestedField record typ -> Text
nestedFieldName NestedField record typ
field) MongoFilterOperator typ
op
mongoFilterToDoc (ArrayFilter EntityField record [typ]
field MongoFilterOperator typ
op) = Text -> MongoFilterOperator typ -> Selector
forall typ.
PersistField typ =>
Text -> MongoFilterOperator typ -> Selector
mongoFilterToBSON (EntityField record [typ] -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField record [typ]
field) MongoFilterOperator typ
op
mongoFilterToDoc (NestedArrayFilter NestedField record [typ]
field MongoFilterOperator typ
op) = Text -> MongoFilterOperator typ -> Selector
forall typ.
PersistField typ =>
Text -> MongoFilterOperator typ -> Selector
mongoFilterToBSON (NestedField record [typ] -> Text
forall record typ.
PersistEntity record =>
NestedField record typ -> Text
nestedFieldName NestedField record [typ]
field) MongoFilterOperator typ
op
mongoFilterToDoc (RegExpFilter EntityField record typ
fn (Text
reg, Text
opts)) = [ EntityField record typ -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField record typ
fn  Text -> Value -> Field
DB.:= Regex -> Value
DB.RegEx (Text -> Text -> Regex
DB.Regex Text
reg Text
opts)]

nestedFieldName :: forall record typ. PersistEntity record => NestedField record typ -> Text
nestedFieldName :: NestedField record typ -> Text
nestedFieldName = Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text)
-> (NestedField record typ -> [Text])
-> NestedField record typ
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NestedField record typ -> [Text]
forall r1 r2. PersistEntity r1 => NestedField r1 r2 -> [Text]
nesFldName
  where
    nesFldName :: forall r1 r2. (PersistEntity r1) => NestedField r1 r2 -> [DB.Label]
    nesFldName :: NestedField r1 r2 -> [Text]
nesFldName (EntityField r1 [emb]
nf1 `LastEmbFld` EntityField emb r2
nf2)          = [EntityField r1 [emb] -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField r1 [emb]
nf1, EntityField emb r2 -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField emb r2
nf2]
    nesFldName ( EntityField r1 [emb]
f1 `MidEmbFld`  NestedField emb r2
f2)           = EntityField r1 [emb] -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField r1 [emb]
f1 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NestedField emb r2 -> [Text]
forall r1 r2. PersistEntity r1 => NestedField r1 r2 -> [Text]
nesFldName NestedField emb r2
f2
    nesFldName ( EntityField r1 nest
f1 `MidNestFlds` NestedField nest r2
f2)          = EntityField r1 nest -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField r1 nest
f1 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NestedField nest r2 -> [Text]
forall r1 r2. PersistEntity r1 => NestedField r1 r2 -> [Text]
nesFldName NestedField nest r2
f2
    nesFldName ( EntityField r1 (Maybe nest)
f1 `MidNestFldsNullable` NestedField nest r2
f2)  = EntityField r1 (Maybe nest) -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField r1 (Maybe nest)
f1 Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: NestedField nest r2 -> [Text]
forall r1 r2. PersistEntity r1 => NestedField r1 r2 -> [Text]
nesFldName NestedField nest r2
f2
    nesFldName (EntityField r1 nest
nf1 `LastNestFld` EntityField nest r2
nf2)         = [EntityField r1 nest -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField r1 nest
nf1, EntityField nest r2 -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField nest r2
nf2]
    nesFldName (EntityField r1 (Maybe nest)
nf1 `LastNestFldNullable` EntityField nest r2
nf2) = [EntityField r1 (Maybe nest) -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField r1 (Maybe nest)
nf1, EntityField nest r2 -> Text
forall record typ.
PersistEntity record =>
EntityField record typ -> Text
fieldName EntityField nest r2
nf2]

toValue :: forall a.  PersistField a => FilterValue a -> DB.Value
toValue :: FilterValue a -> Value
toValue FilterValue a
val =
    case FilterValue a
val of
      FilterValue a
v   -> PersistValue -> Value
forall a. Val a => a -> Value
DB.val (PersistValue -> Value) -> PersistValue -> Value
forall a b. (a -> b) -> a -> b
$ a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
v
      UnsafeValue a
v   -> PersistValue -> Value
forall a. Val a => a -> Value
DB.val (PersistValue -> Value) -> PersistValue -> Value
forall a b. (a -> b) -> a -> b
$ a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue a
v
      FilterValues [a]
vs -> [PersistValue] -> Value
forall a. Val a => a -> Value
DB.val ([PersistValue] -> Value) -> [PersistValue] -> Value
forall a b. (a -> b) -> a -> b
$ (a -> PersistValue) -> [a] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map a -> PersistValue
forall a. PersistField a => a -> PersistValue
toPersistValue [a]
vs

fieldName ::  forall record typ.  (PersistEntity record) => EntityField record typ -> DB.Label
fieldName :: EntityField record typ -> Text
fieldName EntityField record typ
f | FieldDef -> FieldNameHS
fieldHaskell FieldDef
fd FieldNameHS -> FieldNameHS -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> FieldNameHS
FieldNameHS Text
"Id" = Text
id_
            | Bool
otherwise = FieldNameDB -> Text
unFieldNameDB (FieldNameDB -> Text) -> FieldNameDB -> Text
forall a b. (a -> b) -> a -> b
$ FieldDef -> FieldNameDB
fieldDB (FieldDef -> FieldNameDB) -> FieldDef -> FieldNameDB
forall a b. (a -> b) -> a -> b
$ FieldDef
fd
  where
    fd :: FieldDef
fd = EntityField record typ -> FieldDef
forall record typ.
PersistEntity record =>
EntityField record typ -> FieldDef
persistFieldDef EntityField record typ
f

docToEntityEither :: forall record. (PersistEntity record) => DB.Document -> Either T.Text (Entity record)
docToEntityEither :: Selector -> Either Text (Entity record)
docToEntityEither Selector
doc = Either Text (Entity record)
entity
  where
    entDef :: EntityDef
entDef = Maybe record -> EntityDef
forall record (proxy :: * -> *).
PersistEntity record =>
proxy record -> EntityDef
entityDef (Maybe record -> EntityDef) -> Maybe record -> EntityDef
forall a b. (a -> b) -> a -> b
$ record -> Maybe record
forall a. a -> Maybe a
Just (Either Text (Entity record) -> record
forall err ent. Either err (Entity ent) -> ent
getType Either Text (Entity record)
entity)
    entity :: Either Text (Entity record)
entity = EntityDef -> Selector -> Either Text (Entity record)
forall record.
PersistEntity record =>
EntityDef -> Selector -> Either Text (Entity record)
eitherFromPersistValues EntityDef
entDef Selector
doc
    getType :: Either err (Entity ent) -> ent
    getType :: Either err (Entity ent) -> ent
getType = [Char] -> Either err (Entity ent) -> ent
forall a. HasCallStack => [Char] -> a
error [Char]
"docToEntityEither/getType: never here"

docToEntityThrow :: forall m record. (Trans.MonadIO m, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => DB.Document -> m (Entity record)
docToEntityThrow :: Selector -> m (Entity record)
docToEntityThrow Selector
doc =
    case Selector -> Either Text (Entity record)
forall record.
PersistEntity record =>
Selector -> Either Text (Entity record)
docToEntityEither Selector
doc of
        Left Text
s -> IO (Entity record) -> m (Entity record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO (Entity record) -> m (Entity record))
-> (PersistException -> IO (Entity record))
-> PersistException
-> m (Entity record)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistException -> IO (Entity record)
forall e a. Exception e => e -> IO a
throwIO (PersistException -> m (Entity record))
-> PersistException -> m (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMarshalError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$ Text
s
        Right Entity record
entity -> Entity record -> m (Entity record)
forall (m :: * -> *) a. Monad m => a -> m a
return Entity record
entity


fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => EntityDef -> [DB.Field] -> m (Entity record)
fromPersistValuesThrow :: EntityDef -> Selector -> m (Entity record)
fromPersistValuesThrow EntityDef
entDef Selector
doc =
    case EntityDef -> Selector -> Either Text (Entity record)
forall record.
PersistEntity record =>
EntityDef -> Selector -> Either Text (Entity record)
eitherFromPersistValues EntityDef
entDef Selector
doc of
        Left Text
t -> IO (Entity record) -> m (Entity record)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO (IO (Entity record) -> m (Entity record))
-> (PersistException -> IO (Entity record))
-> PersistException
-> m (Entity record)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PersistException -> IO (Entity record)
forall e a. Exception e => e -> IO a
throwIO (PersistException -> m (Entity record))
-> PersistException -> m (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMarshalError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$
                   EntityNameHS -> Text
unEntityNameHS (EntityDef -> EntityNameHS
getEntityHaskellName EntityDef
entDef) Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
": " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
t
        Right Entity record
entity -> Entity record -> m (Entity record)
forall (m :: * -> *) a. Monad m => a -> m a
return Entity record
entity

mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft a -> c
_ (Right b
r) = b -> Either c b
forall a b. b -> Either a b
Right b
r
mapLeft a -> c
f (Left a
l)  = c -> Either c b
forall a b. a -> Either a b
Left (a -> c
f a
l)

eitherFromPersistValues :: (PersistEntity record) => EntityDef -> [DB.Field] -> Either T.Text (Entity record)
eitherFromPersistValues :: EntityDef -> Selector -> Either Text (Entity record)
eitherFromPersistValues EntityDef
entDef Selector
doc = case Maybe PersistValue
mKey of
   Maybe PersistValue
Nothing  -> Either Text (Entity record) -> Either Text (Entity record)
forall a. Either Text a -> Either Text a
addDetail (Either Text (Entity record) -> Either Text (Entity record))
-> Either Text (Entity record) -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Text -> Either Text (Entity record)
forall a b. a -> Either a b
Left (Text -> Either Text (Entity record))
-> Text -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Text
"could not find _id field: "
   Just PersistValue
kpv -> do
      record
body <- Either Text record -> Either Text record
forall a. Either Text a -> Either Text a
addDetail ([PersistValue] -> Either Text record
forall record.
PersistEntity record =>
[PersistValue] -> Either Text record
fromPersistValues (((Text, PersistValue) -> PersistValue)
-> [(Text, PersistValue)] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map (Text, PersistValue) -> PersistValue
forall a b. (a, b) -> b
snd ([(Text, PersistValue)] -> [PersistValue])
-> [(Text, PersistValue)] -> [PersistValue]
forall a b. (a -> b) -> a -> b
$ EmbedEntityDef -> [(Text, PersistValue)] -> [(Text, PersistValue)]
orderPersistValues (EntityDef -> EmbedEntityDef
toEmbedEntityDef EntityDef
entDef) [(Text, PersistValue)]
castDoc))
      Key record
key <- [PersistValue] -> Either Text (Key record)
forall record.
PersistEntity record =>
[PersistValue] -> Either Text (Key record)
keyFromValues [PersistValue
kpv]
      Entity record -> Either Text (Entity record)
forall (m :: * -> *) a. Monad m => a -> m a
return (Entity record -> Either Text (Entity record))
-> Entity record -> Either Text (Entity record)
forall a b. (a -> b) -> a -> b
$ Key record -> record -> Entity record
forall record. Key record -> record -> Entity record
Entity Key record
key record
body
  where
    addDetail :: Either Text a -> Either Text a
    addDetail :: Either Text a -> Either Text a
addDetail = (Text -> Text) -> Either Text a -> Either Text a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft (\Text
msg -> Text
msg Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` Text
" for doc: " Text -> Text -> Text
forall a. Monoid a => a -> a -> a
`mappend` [Char] -> Text
T.pack (Selector -> [Char]
forall a. Show a => a -> [Char]
show Selector
doc))
    castDoc :: [(Text, PersistValue)]
castDoc = Selector -> [(Text, PersistValue)]
assocListFromDoc Selector
doc
    -- normally _id is the first field
    mKey :: Maybe PersistValue
mKey = Text -> [(Text, PersistValue)] -> Maybe PersistValue
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Text
id_ [(Text, PersistValue)]
castDoc

-- | unlike many SQL databases, MongoDB makes no guarantee of the ordering
-- of the fields returned in the document.
-- Ordering might be maintained if persistent were the only user of the db,
-- but other tools may be using MongoDB.
--
-- Persistent creates a Haskell record from a list of PersistValue
-- But most importantly it puts all PersistValues in the proper order
orderPersistValues :: EmbedEntityDef -> [(Text, PersistValue)] -> [(Text, PersistValue)]
orderPersistValues :: EmbedEntityDef -> [(Text, PersistValue)] -> [(Text, PersistValue)]
orderPersistValues EmbedEntityDef
entDef [(Text, PersistValue)]
castDoc =
    [(Text, Maybe (Either SelfEmbed EntityNameHS))]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
forall a.
[(Text, Maybe (Either a EntityNameHS))]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
match [(Text, Maybe (Either SelfEmbed EntityNameHS))]
castColumns [(Text, PersistValue)]
castDoc []
  where
    castColumns :: [(Text, Maybe (Either SelfEmbed EntityNameHS))]
castColumns =
        (EmbedFieldDef -> (Text, Maybe (Either SelfEmbed EntityNameHS)))
-> [EmbedFieldDef]
-> [(Text, Maybe (Either SelfEmbed EntityNameHS))]
forall a b. (a -> b) -> [a] -> [b]
map EmbedFieldDef -> (Text, Maybe (Either SelfEmbed EntityNameHS))
nameAndEmbed (EmbedEntityDef -> [EmbedFieldDef]
embeddedFields EmbedEntityDef
entDef)
    nameAndEmbed :: EmbedFieldDef -> (Text, Maybe (Either SelfEmbed EntityNameHS))
nameAndEmbed EmbedFieldDef
fdef =
        (EmbedFieldDef -> Text
fieldToLabel EmbedFieldDef
fdef, EmbedFieldDef -> Maybe (Either SelfEmbed EntityNameHS)
emFieldEmbed EmbedFieldDef
fdef)

    -- TODO: the below reasoning should be re-thought now that we are no longer inserting null: searching for a null column will look at every returned field before giving up
    -- Also, we are now doing the _id lookup at the start.
    --
    -- we have an alist of fields that need to be the same order as entityColumns
    --
    -- this naive lookup is O(n^2)
    -- reorder = map (fromJust . (flip Prelude.lookup $ castDoc)) castColumns
    --
    -- this is O(n * log(n))
    -- reorder =  map (\c -> (M.fromList castDoc) M.! c) castColumns
    --
    -- and finally, this is O(n * log(n))
    -- * do an alist lookup for each column
    -- * but once we found an item in the alist use a new alist without that item for future lookups
    -- * so for the last query there is only one item left
    --
    match :: [(Text, Maybe (Either a EntityNameHS) )]
          -> [(Text, PersistValue)]
          -> [(Text, PersistValue)]
          -> [(Text, PersistValue)]
    -- when there are no more Persistent castColumns we are done
    --
    -- allow extra mongoDB fields that persistent does not know about
    -- another application may use fields we don't care about
    -- our own application may set extra fields with the raw driver
    match :: [(Text, Maybe (Either a EntityNameHS))]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
match [] [(Text, PersistValue)]
_ [(Text, PersistValue)]
values = [(Text, PersistValue)]
values
    match ((Text
fName, Maybe (Either a EntityNameHS)
medef) : [(Text, Maybe (Either a EntityNameHS))]
columns) [(Text, PersistValue)]
fields [(Text, PersistValue)]
values =
        let
            ((Text
_, PersistValue
pv) , [(Text, PersistValue)]
unused) =
                [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> ((Text, PersistValue), [(Text, PersistValue)])
matchOne [(Text, PersistValue)]
fields []
        in
            [(Text, Maybe (Either a EntityNameHS))]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
forall a.
[(Text, Maybe (Either a EntityNameHS))]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
match [(Text, Maybe (Either a EntityNameHS))]
columns [(Text, PersistValue)]
unused ([(Text, PersistValue)] -> [(Text, PersistValue)])
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a b. (a -> b) -> a -> b
$
                [(Text, PersistValue)]
values [(Text, PersistValue)]
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. [a] -> [a] -> [a]
++ [(Text
fName, Maybe (Either a EntityNameHS) -> PersistValue -> PersistValue
forall a. Maybe a -> PersistValue -> PersistValue
nestedOrder Maybe (Either a EntityNameHS)
medef PersistValue
pv)]
      where
        -- support for embedding other persistent objects into a schema for
        -- mongodb cannot be currently supported in persistent.
        -- The order will be undetermined but that's ok because there is no
        -- schema migration for mongodb anyways.
        -- nestedOrder (Just _) (PersistMap m) = PersistMap m
        nestedOrder :: Maybe a -> PersistValue -> PersistValue
nestedOrder (Just a
em) (PersistList [PersistValue]
l) = [PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue) -> [PersistValue] -> PersistValue
forall a b. (a -> b) -> a -> b
$ (PersistValue -> PersistValue) -> [PersistValue] -> [PersistValue]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe a -> PersistValue -> PersistValue
nestedOrder (a -> Maybe a
forall a. a -> Maybe a
Just a
em)) [PersistValue]
l
        nestedOrder Maybe a
_ PersistValue
found = PersistValue
found

        matchOne :: [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> ((Text, PersistValue), [(Text, PersistValue)])
matchOne ((Text, PersistValue)
field:[(Text, PersistValue)]
fs) [(Text, PersistValue)]
tried =
            if Text
fName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Text, PersistValue) -> Text
forall a b. (a, b) -> a
fst (Text, PersistValue)
field
                then ((Text, PersistValue)
field, [(Text, PersistValue)]
tried [(Text, PersistValue)]
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. [a] -> [a] -> [a]
++ [(Text, PersistValue)]
fs)
                else [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> ((Text, PersistValue), [(Text, PersistValue)])
matchOne [(Text, PersistValue)]
fs ((Text, PersistValue)
field(Text, PersistValue)
-> [(Text, PersistValue)] -> [(Text, PersistValue)]
forall a. a -> [a] -> [a]
:[(Text, PersistValue)]
tried)
        -- if field is not found, assume it was a Nothing
        --
        -- a Nothing could be stored as null, but that would take up space.
        -- instead, we want to store no field at all: that takes less space.
        -- Also, another ORM may be doing the same
        -- Also, this adding a Maybe field means no migration required
        matchOne [] [(Text, PersistValue)]
tried = ((Text
fName, PersistValue
PersistNull), [(Text, PersistValue)]
tried)

assocListFromDoc :: DB.Document -> [(Text, PersistValue)]
assocListFromDoc :: Selector -> [(Text, PersistValue)]
assocListFromDoc = (Field -> (Text, PersistValue))
-> Selector -> [(Text, PersistValue)]
forall a b. (a -> b) -> [a] -> [b]
Prelude.map (\Field
f -> ( (Field -> Text
DB.label Field
f), Value -> PersistValue
cast (Field -> Value
DB.value Field
f) ) )

oidToPersistValue :: DB.ObjectId -> PersistValue
oidToPersistValue :: ObjectId -> PersistValue
oidToPersistValue = ByteString -> PersistValue
PersistObjectId (ByteString -> PersistValue)
-> (ObjectId -> ByteString) -> ObjectId -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectId -> ByteString
forall a. Serialize a => a -> ByteString
Serialize.encode

oidToKey :: (ToBackendKey DB.MongoContext record) => DB.ObjectId -> Key record
oidToKey :: ObjectId -> Key record
oidToKey = BackendKey MongoContext -> Key record
forall backend record.
ToBackendKey backend record =>
BackendKey backend -> Key record
fromBackendKey (BackendKey MongoContext -> Key record)
-> (ObjectId -> BackendKey MongoContext) -> ObjectId -> Key record
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ObjectId -> BackendKey MongoContext
MongoKey

persistObjectIdToDbOid :: PersistValue -> DB.ObjectId
persistObjectIdToDbOid :: PersistValue -> ObjectId
persistObjectIdToDbOid (PersistObjectId ByteString
k) = case ByteString -> Either [Char] ObjectId
forall a. Serialize a => ByteString -> Either [Char] a
Serialize.decode ByteString
k of
                  Left [Char]
msg -> PersistException -> ObjectId
forall a e. Exception e => e -> a
throw (PersistException -> ObjectId) -> PersistException -> ObjectId
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistError (Text -> PersistException) -> Text -> PersistException
forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ [Char]
"error decoding " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ (ByteString -> [Char]
forall a. Show a => a -> [Char]
show ByteString
k) [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ [Char]
msg
                  Right ObjectId
o -> ObjectId
o
persistObjectIdToDbOid PersistValue
_ = PersistException -> ObjectId
forall a e. Exception e => e -> a
throw (PersistException -> ObjectId) -> PersistException -> ObjectId
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistInvalidField Text
"expected PersistObjectId"

keyToOid :: ToBackendKey DB.MongoContext record => Key record -> DB.ObjectId
keyToOid :: Key record -> ObjectId
keyToOid = BackendKey MongoContext -> ObjectId
unMongoKey (BackendKey MongoContext -> ObjectId)
-> (Key record -> BackendKey MongoContext)
-> Key record
-> ObjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Key record -> BackendKey MongoContext
forall backend record.
ToBackendKey backend record =>
Key record -> BackendKey backend
toBackendKey

instance DB.Val PersistValue where
  val :: PersistValue -> Value
val (PersistInt64 Int64
x)   = Int64 -> Value
DB.Int64 Int64
x
  val (PersistText Text
x)    = Text -> Value
DB.String Text
x
  val (PersistDouble Double
x)  = Double -> Value
DB.Float Double
x
  val (PersistBool Bool
x)    = Bool -> Value
DB.Bool Bool
x
#ifdef HIGH_PRECISION_DATE
  val (PersistUTCTime x) = DB.Int64 $ round $ 1000 * 1000 * 1000 * (utcTimeToPOSIXSeconds x)
#else
  -- this is just millisecond precision: https://jira.mongodb.org/browse/SERVER-1460
  val (PersistUTCTime UTCTime
x) = UTCTime -> Value
DB.UTC UTCTime
x
#endif
  val (PersistDay Day
d)     = Int64 -> Value
DB.Int64 (Int64 -> Value) -> Int64 -> Value
forall a b. (a -> b) -> a -> b
$ Integer -> Int64
forall a. Num a => Integer -> a
fromInteger (Integer -> Int64) -> Integer -> Int64
forall a b. (a -> b) -> a -> b
$ Day -> Integer
toModifiedJulianDay Day
d
  val (PersistValue
PersistNull)      = Value
DB.Null
  val (PersistList [PersistValue]
l)    = [Value] -> Value
DB.Array ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ (PersistValue -> Value) -> [PersistValue] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map PersistValue -> Value
forall a. Val a => a -> Value
DB.val [PersistValue]
l
  val (PersistMap  [(Text, PersistValue)]
m)    = Selector -> Value
DB.Doc (Selector -> Value) -> Selector -> Value
forall a b. (a -> b) -> a -> b
$ ((Text, PersistValue) -> Field)
-> [(Text, PersistValue)] -> Selector
forall a b. (a -> b) -> [a] -> [b]
map (\(Text
k, PersistValue
v)-> Text -> PersistValue -> Field
forall v. Val v => Text -> v -> Field
(DB.=:) Text
k PersistValue
v) [(Text, PersistValue)]
m
  val (PersistByteString ByteString
x) = Binary -> Value
DB.Bin (ByteString -> Binary
DB.Binary ByteString
x)
  val x :: PersistValue
x@(PersistObjectId ByteString
_) = ObjectId -> Value
DB.ObjId (ObjectId -> Value) -> ObjectId -> Value
forall a b. (a -> b) -> a -> b
$ PersistValue -> ObjectId
persistObjectIdToDbOid PersistValue
x
  val (PersistTimeOfDay TimeOfDay
_)  = PersistException -> Value
forall a e. Exception e => e -> a
throw (PersistException -> Value) -> PersistException -> Value
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"PersistTimeOfDay not implemented for the MongoDB backend. only PersistUTCTime currently implemented"
  val (PersistRational Rational
_)   = PersistException -> Value
forall a e. Exception e => e -> a
throw (PersistException -> Value) -> PersistException -> Value
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"PersistRational not implemented for the MongoDB backend"
  val (PersistArray [PersistValue]
a)      = PersistValue -> Value
forall a. Val a => a -> Value
DB.val (PersistValue -> Value) -> PersistValue -> Value
forall a b. (a -> b) -> a -> b
$ [PersistValue] -> PersistValue
PersistList [PersistValue]
a
  val (PersistDbSpecific ByteString
_)   = PersistException -> Value
forall a e. Exception e => e -> a
throw (PersistException -> Value) -> PersistException -> Value
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"PersistDbSpecific not implemented for the MongoDB backend"
  val (PersistLiteral_ LiteralType
_ ByteString
_)   = PersistException -> Value
forall a e. Exception e => e -> a
throw (PersistException -> Value) -> PersistException -> Value
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"PersistLiteral not implemented for the MongoDB backend"
  cast' :: Value -> Maybe PersistValue
cast' (DB.Float Double
x)  = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (Double -> PersistValue
PersistDouble Double
x)
  cast' (DB.Int32 Int32
x)  = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Int64 -> PersistValue
PersistInt64 (Int64 -> PersistValue) -> Int64 -> PersistValue
forall a b. (a -> b) -> a -> b
$ Int32 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
x
  cast' (DB.Int64 Int64
x)  = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Int64 -> PersistValue
PersistInt64 Int64
x
  cast' (DB.String Text
x) = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> PersistValue
PersistText Text
x
  cast' (DB.Bool Bool
x)   = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Bool -> PersistValue
PersistBool Bool
x
  cast' (DB.UTC UTCTime
d)    = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ UTCTime -> PersistValue
PersistUTCTime UTCTime
d
  cast' Value
DB.Null       = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ PersistValue
PersistNull
  cast' (DB.Bin (DB.Binary ByteString
b))   = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> PersistValue
PersistByteString ByteString
b
  cast' (DB.Fun (DB.Function ByteString
f)) = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> PersistValue
PersistByteString ByteString
f
  cast' (DB.Uuid (DB.UUID ByteString
uid))  = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> PersistValue
PersistByteString ByteString
uid
  cast' (DB.Md5 (DB.MD5 ByteString
md5))    = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> PersistValue
PersistByteString ByteString
md5
  cast' (DB.UserDef (DB.UserDefined ByteString
bs)) = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> PersistValue
PersistByteString ByteString
bs
  cast' (DB.RegEx (DB.Regex Text
us1 Text
us2))    = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ByteString -> PersistValue
PersistByteString (ByteString -> PersistValue) -> ByteString -> PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
E.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
us1 Text
us2
  cast' (DB.Doc Selector
doc)  = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ [(Text, PersistValue)] -> PersistValue
PersistMap ([(Text, PersistValue)] -> PersistValue)
-> [(Text, PersistValue)] -> PersistValue
forall a b. (a -> b) -> a -> b
$ Selector -> [(Text, PersistValue)]
assocListFromDoc Selector
doc
  cast' (DB.Array [Value]
xs) = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ [PersistValue] -> PersistValue
PersistList ([PersistValue] -> PersistValue) -> [PersistValue] -> PersistValue
forall a b. (a -> b) -> a -> b
$ (Value -> Maybe PersistValue) -> [Value] -> [PersistValue]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Value -> Maybe PersistValue
forall a. Val a => Value -> Maybe a
DB.cast' [Value]
xs
  cast' (DB.ObjId ObjectId
x)  = PersistValue -> Maybe PersistValue
forall a. a -> Maybe a
Just (PersistValue -> Maybe PersistValue)
-> PersistValue -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ ObjectId -> PersistValue
oidToPersistValue ObjectId
x
  cast' (DB.JavaScr Javascript
_) = PersistException -> Maybe PersistValue
forall a e. Exception e => e -> a
throw (PersistException -> Maybe PersistValue)
-> PersistException -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"cast operation not supported for javascript"
  cast' (DB.Sym Symbol
_)     = PersistException -> Maybe PersistValue
forall a e. Exception e => e -> a
throw (PersistException -> Maybe PersistValue)
-> PersistException -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"cast operation not supported for sym"
  cast' (DB.Stamp MongoStamp
_)   = PersistException -> Maybe PersistValue
forall a e. Exception e => e -> a
throw (PersistException -> Maybe PersistValue)
-> PersistException -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"cast operation not supported for stamp"
  cast' (DB.MinMax MinMaxKey
_)  = PersistException -> Maybe PersistValue
forall a e. Exception e => e -> a
throw (PersistException -> Maybe PersistValue)
-> PersistException -> Maybe PersistValue
forall a b. (a -> b) -> a -> b
$ Text -> PersistException
PersistMongoDBUnsupported Text
"cast operation not supported for minmax"

cast :: DB.Value -> PersistValue
-- since we have case analysys this won't ever be Nothing
-- However, unsupported types do throw an exception in pure code
-- probably should re-work this to throw in IO
cast :: Value -> PersistValue
cast = Maybe PersistValue -> PersistValue
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe PersistValue -> PersistValue)
-> (Value -> Maybe PersistValue) -> Value -> PersistValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Maybe PersistValue
forall a. Val a => Value -> Maybe a
DB.cast'

instance Serialize.Serialize DB.ObjectId where
  put :: Putter ObjectId
put (DB.Oid Word32
w1 Word64
w2) = do Putter Word32
forall t. Serialize t => Putter t
Serialize.put Word32
w1
                          Putter Word64
forall t. Serialize t => Putter t
Serialize.put Word64
w2

  get :: Get ObjectId
get = do Word32
w1 <- Get Word32
forall t. Serialize t => Get t
Serialize.get
           Word64
w2 <- Get Word64
forall t. Serialize t => Get t
Serialize.get
           ObjectId -> Get ObjectId
forall (m :: * -> *) a. Monad m => a -> m a
return (Word32 -> Word64 -> ObjectId
DB.Oid Word32
w1 Word64
w2)

dummyFromUnique :: Unique v -> v
dummyFromUnique :: Unique v -> v
dummyFromUnique Unique v
_ = [Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"dummyFromUnique"
dummyFromFilts :: [Filter v] -> v
dummyFromFilts :: [Filter v] -> v
dummyFromFilts [Filter v]
_ = [Char] -> v
forall a. HasCallStack => [Char] -> a
error [Char]
"dummyFromFilts"

data MongoAuth = MongoAuth DB.Username DB.Password deriving Int -> MongoAuth -> ShowS
[MongoAuth] -> ShowS
MongoAuth -> [Char]
(Int -> MongoAuth -> ShowS)
-> (MongoAuth -> [Char])
-> ([MongoAuth] -> ShowS)
-> Show MongoAuth
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MongoAuth] -> ShowS
$cshowList :: [MongoAuth] -> ShowS
show :: MongoAuth -> [Char]
$cshow :: MongoAuth -> [Char]
showsPrec :: Int -> MongoAuth -> ShowS
$cshowsPrec :: Int -> MongoAuth -> ShowS
Show

-- | Information required to connect to a mongo database
data MongoConf = MongoConf
    { MongoConf -> Text
mgDatabase :: Text
    , MongoConf -> Text
mgHost     :: Text
    , MongoConf -> PortID
mgPort     :: DB.PortID
    , MongoConf -> Maybe MongoAuth
mgAuth     :: Maybe MongoAuth
    , MongoConf -> AccessMode
mgAccessMode :: DB.AccessMode
    , MongoConf -> Int
mgPoolStripes :: Int
    , MongoConf -> Int
mgStripeConnections :: Int
    , MongoConf -> NominalDiffTime
mgConnectionIdleTime :: NominalDiffTime
    -- | YAML fields for this are @rsName@ and @rsSecondaries@
    -- mgHost is assumed to be the primary
    , MongoConf -> Maybe ReplicaSetConfig
mgReplicaSetConfig :: Maybe ReplicaSetConfig
    } deriving Int -> MongoConf -> ShowS
[MongoConf] -> ShowS
MongoConf -> [Char]
(Int -> MongoConf -> ShowS)
-> (MongoConf -> [Char])
-> ([MongoConf] -> ShowS)
-> Show MongoConf
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MongoConf] -> ShowS
$cshowList :: [MongoConf] -> ShowS
show :: MongoConf -> [Char]
$cshow :: MongoConf -> [Char]
showsPrec :: Int -> MongoConf -> ShowS
$cshowsPrec :: Int -> MongoConf -> ShowS
Show

defaultHost :: Text
defaultHost :: Text
defaultHost = Text
"127.0.0.1"
defaultAccessMode :: DB.AccessMode
defaultAccessMode :: AccessMode
defaultAccessMode = Selector -> AccessMode
DB.ConfirmWrites [Text
"w" Text -> Value -> Field
DB.:= Int32 -> Value
DB.Int32 Int32
1]
defaultPoolStripes, defaultStripeConnections :: Int
defaultPoolStripes :: Int
defaultPoolStripes = Int
1
defaultStripeConnections :: Int
defaultStripeConnections = Int
10
defaultConnectionIdleTime :: NominalDiffTime
defaultConnectionIdleTime :: NominalDiffTime
defaultConnectionIdleTime = NominalDiffTime
20

defaultMongoConf :: Text -> MongoConf
defaultMongoConf :: Text -> MongoConf
defaultMongoConf Text
dbName = MongoConf :: Text
-> Text
-> PortID
-> Maybe MongoAuth
-> AccessMode
-> Int
-> Int
-> NominalDiffTime
-> Maybe ReplicaSetConfig
-> MongoConf
MongoConf
  { mgDatabase :: Text
mgDatabase = Text
dbName
  , mgHost :: Text
mgHost = Text
defaultHost
  , mgPort :: PortID
mgPort = PortID
DB.defaultPort
  , mgAuth :: Maybe MongoAuth
mgAuth = Maybe MongoAuth
forall a. Maybe a
Nothing
  , mgAccessMode :: AccessMode
mgAccessMode = AccessMode
defaultAccessMode
  , mgPoolStripes :: Int
mgPoolStripes = Int
defaultPoolStripes
  , mgStripeConnections :: Int
mgStripeConnections = Int
defaultStripeConnections
  , mgConnectionIdleTime :: NominalDiffTime
mgConnectionIdleTime = NominalDiffTime
defaultConnectionIdleTime
  , mgReplicaSetConfig :: Maybe ReplicaSetConfig
mgReplicaSetConfig = Maybe ReplicaSetConfig
forall a. Maybe a
Nothing
  }

data ReplicaSetConfig = ReplicaSetConfig DB.ReplicaSetName [DB.Host]
    deriving Int -> ReplicaSetConfig -> ShowS
[ReplicaSetConfig] -> ShowS
ReplicaSetConfig -> [Char]
(Int -> ReplicaSetConfig -> ShowS)
-> (ReplicaSetConfig -> [Char])
-> ([ReplicaSetConfig] -> ShowS)
-> Show ReplicaSetConfig
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ReplicaSetConfig] -> ShowS
$cshowList :: [ReplicaSetConfig] -> ShowS
show :: ReplicaSetConfig -> [Char]
$cshow :: ReplicaSetConfig -> [Char]
showsPrec :: Int -> ReplicaSetConfig -> ShowS
$cshowsPrec :: Int -> ReplicaSetConfig -> ShowS
Show

instance FromJSON MongoConf where
    parseJSON :: Value -> Parser MongoConf
parseJSON Value
v = ShowS -> Parser MongoConf -> Parser MongoConf
forall a. ShowS -> Parser a -> Parser a
modifyFailure ([Char]
"Persistent: error loading MongoDB conf: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++) (Parser MongoConf -> Parser MongoConf)
-> Parser MongoConf -> Parser MongoConf
forall a b. (a -> b) -> a -> b
$
      ((Object -> Parser MongoConf) -> Value -> Parser MongoConf)
-> Value -> (Object -> Parser MongoConf) -> Parser MongoConf
forall a b c. (a -> b -> c) -> b -> a -> c
flip ([Char] -> (Object -> Parser MongoConf) -> Value -> Parser MongoConf
forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"MongoConf") Value
v ((Object -> Parser MongoConf) -> Parser MongoConf)
-> (Object -> Parser MongoConf) -> Parser MongoConf
forall a b. (a -> b) -> a -> b
$ \Object
o ->do
        Text
db                  <- Object
o Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
.:  Text
"database"
        Text
host                <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"host" Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
defaultHost
        NoOrphanPortID PortID
port <- Object
o Object -> Text -> Parser (Maybe NoOrphanPortID)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"port" Parser (Maybe NoOrphanPortID)
-> NoOrphanPortID -> Parser NoOrphanPortID
forall a. Parser (Maybe a) -> a -> Parser a
.!= PortID -> NoOrphanPortID
NoOrphanPortID PortID
DB.defaultPort
        Int
poolStripes         <- Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"poolstripes" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
defaultPoolStripes
        Int
stripeConnections   <- Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"connections" Parser (Maybe Int) -> Int -> Parser Int
forall a. Parser (Maybe a) -> a -> Parser a
.!= Int
defaultStripeConnections
        NoOrphanNominalDiffTime NominalDiffTime
connectionIdleTime <- Object
o Object -> Text -> Parser (Maybe NoOrphanNominalDiffTime)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"connectionIdleTime" Parser (Maybe NoOrphanNominalDiffTime)
-> NoOrphanNominalDiffTime -> Parser NoOrphanNominalDiffTime
forall a. Parser (Maybe a) -> a -> Parser a
.!= NominalDiffTime -> NoOrphanNominalDiffTime
NoOrphanNominalDiffTime NominalDiffTime
defaultConnectionIdleTime
        Maybe Text
mUser              <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"user"
        Maybe Text
mPass              <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"password"
        Text
accessString       <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"accessMode" Parser (Maybe Text) -> Text -> Parser Text
forall a. Parser (Maybe a) -> a -> Parser a
.!= Text
confirmWrites
        Maybe Text
mRsName            <- Object
o Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"rsName"
        [[Char]]
rsSecondaires      <- Object
o Object -> Text -> Parser (Maybe [[Char]])
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"rsSecondaries" Parser (Maybe [[Char]]) -> [[Char]] -> Parser [[Char]]
forall a. Parser (Maybe a) -> a -> Parser a
.!= []

        Maybe Int
mPoolSize         <- Object
o Object -> Text -> Parser (Maybe Int)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"poolsize"
        case Maybe Int
mPoolSize of
          Maybe Int
Nothing -> () -> Parser ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Just (Int
_::Int) -> [Char] -> Parser ()
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"specified deprecated poolsize attribute. Please specify a connections. You can also specify a pools attribute which defaults to 1. Total connections opened to the db are connections * pools"

        AccessMode
accessMode <- case Text
accessString of
             Text
"ReadStaleOk"       -> AccessMode -> Parser AccessMode
forall (m :: * -> *) a. Monad m => a -> m a
return AccessMode
DB.ReadStaleOk
             Text
"UnconfirmedWrites" -> AccessMode -> Parser AccessMode
forall (m :: * -> *) a. Monad m => a -> m a
return AccessMode
DB.UnconfirmedWrites
             Text
"ConfirmWrites"     -> AccessMode -> Parser AccessMode
forall (m :: * -> *) a. Monad m => a -> m a
return AccessMode
defaultAccessMode
             Text
badAccess -> [Char] -> Parser AccessMode
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser AccessMode) -> [Char] -> Parser AccessMode
forall a b. (a -> b) -> a -> b
$ [Char]
"unknown accessMode: " [Char] -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
badAccess

        let rs :: Maybe ReplicaSetConfig
rs = case (Maybe Text
mRsName, [[Char]]
rsSecondaires) of
                     (Maybe Text
Nothing, []) -> Maybe ReplicaSetConfig
forall a. Maybe a
Nothing
                     (Maybe Text
Nothing, [[Char]]
_) -> [Char] -> Maybe ReplicaSetConfig
forall a. HasCallStack => [Char] -> a
error [Char]
"found rsSecondaries key. Also expected but did not find a rsName key"
                     (Just Text
rsName, [[Char]]
hosts) -> ReplicaSetConfig -> Maybe ReplicaSetConfig
forall a. a -> Maybe a
Just (ReplicaSetConfig -> Maybe ReplicaSetConfig)
-> ReplicaSetConfig -> Maybe ReplicaSetConfig
forall a b. (a -> b) -> a -> b
$ Text -> [Host] -> ReplicaSetConfig
ReplicaSetConfig Text
rsName ([Host] -> ReplicaSetConfig) -> [Host] -> ReplicaSetConfig
forall a b. (a -> b) -> a -> b
$ ([Char] -> Host) -> [[Char]] -> [Host]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Host
DB.readHostPort [[Char]]
hosts

        MongoConf -> Parser MongoConf
forall (m :: * -> *) a. Monad m => a -> m a
return MongoConf :: Text
-> Text
-> PortID
-> Maybe MongoAuth
-> AccessMode
-> Int
-> Int
-> NominalDiffTime
-> Maybe ReplicaSetConfig
-> MongoConf
MongoConf {
            mgDatabase :: Text
mgDatabase = Text
db
          , mgHost :: Text
mgHost = Text
host
          , mgPort :: PortID
mgPort = PortID
port
          , mgAuth :: Maybe MongoAuth
mgAuth =
              case (Maybe Text
mUser, Maybe Text
mPass) of
                (Just Text
user, Just Text
pass) -> MongoAuth -> Maybe MongoAuth
forall a. a -> Maybe a
Just (Text -> Text -> MongoAuth
MongoAuth Text
user Text
pass)
                (Maybe Text, Maybe Text)
_ -> Maybe MongoAuth
forall a. Maybe a
Nothing
          , mgPoolStripes :: Int
mgPoolStripes = Int
poolStripes
          , mgStripeConnections :: Int
mgStripeConnections = Int
stripeConnections
          , mgAccessMode :: AccessMode
mgAccessMode = AccessMode
accessMode
          , mgConnectionIdleTime :: NominalDiffTime
mgConnectionIdleTime = NominalDiffTime
connectionIdleTime
          , mgReplicaSetConfig :: Maybe ReplicaSetConfig
mgReplicaSetConfig = Maybe ReplicaSetConfig
rs
          }
      where
        confirmWrites :: Text
confirmWrites = Text
"ConfirmWrites"

instance PersistConfig MongoConf where
    type PersistConfigBackend MongoConf = DB.Action
    type PersistConfigPool MongoConf = ConnectionPool

    createPoolConfig :: MongoConf -> IO (PersistConfigPool MongoConf)
createPoolConfig = MongoConf -> IO (PersistConfigPool MongoConf)
forall (m :: * -> *). MonadIO m => MongoConf -> m ConnectionPool
createMongoPool

    runPool :: MongoConf
-> PersistConfigBackend MongoConf m a
-> PersistConfigPool MongoConf
-> m a
runPool MongoConf
c = AccessMode -> Action m a -> ConnectionPool -> m a
forall (m :: * -> *) a.
MonadUnliftIO m =>
AccessMode -> Action m a -> ConnectionPool -> m a
runMongoDBPool (MongoConf -> AccessMode
mgAccessMode MongoConf
c)
    loadConfig :: Value -> Parser MongoConf
loadConfig = Value -> Parser MongoConf
forall a. FromJSON a => Value -> Parser a
parseJSON

-- | docker integration: change the host to the mongodb link
applyDockerEnv :: MongoConf -> IO MongoConf
applyDockerEnv :: MongoConf -> IO MongoConf
applyDockerEnv MongoConf
mconf = do
    Maybe [Char]
mHost <- [Char] -> IO (Maybe [Char])
lookupEnv [Char]
"MONGODB_PORT_27017_TCP_ADDR"
    MongoConf -> IO MongoConf
forall (m :: * -> *) a. Monad m => a -> m a
return (MongoConf -> IO MongoConf) -> MongoConf -> IO MongoConf
forall a b. (a -> b) -> a -> b
$ case Maybe [Char]
mHost of
        Maybe [Char]
Nothing -> MongoConf
mconf
        Just [Char]
h -> MongoConf
mconf { mgHost :: Text
mgHost = [Char] -> Text
T.pack [Char]
h }


-- ---------------------------
-- * MongoDB specific Filters

-- $filters
--
-- You can find example usage for all of Persistent in our test cases:
-- <https://github.com/yesodweb/persistent/blob/master/persistent-test/EmbedTest.hs#L144>
--
-- These filters create a query that reaches deeper into a document with
-- nested fields.

type instance BackendSpecificFilter DB.MongoContext record = MongoFilter record
type instance BackendSpecificUpdate DB.MongoContext record = MongoUpdate record

data NestedField record typ
  = forall emb.  PersistEntity emb =>  EntityField record [emb] `LastEmbFld` EntityField emb typ
  | forall emb.  PersistEntity emb =>  EntityField record [emb] `MidEmbFld` NestedField emb typ
  | forall nest. PersistEntity nest => EntityField record nest  `MidNestFlds` NestedField nest typ
  | forall nest. PersistEntity nest => EntityField record (Maybe nest) `MidNestFldsNullable` NestedField nest typ
  | forall nest. PersistEntity nest => EntityField record nest `LastNestFld` EntityField nest typ
  | forall nest. PersistEntity nest => EntityField record (Maybe nest) `LastNestFldNullable` EntityField nest typ

-- | A MongoRegex represents a Regular expression.
-- It is a tuple of the expression and the options for the regular expression, respectively
-- Options are listed here: <http://docs.mongodb.org/manual/reference/operator/query/regex/>
-- If you use the same options you may want to define a helper such as @r t = (t, "ims")@
type MongoRegex = (Text, Text)

-- | Mark the subset of 'PersistField's that can be searched by a mongoDB regex
-- Anything stored as PersistText or an array of PersistText would be valid
class PersistField typ => MongoRegexSearchable typ where

instance MongoRegexSearchable Text
instance MongoRegexSearchable rs => MongoRegexSearchable (Maybe rs)
instance MongoRegexSearchable rs => MongoRegexSearchable [rs]

-- | Filter using a Regular expression.
(=~.) :: forall record searchable. (MongoRegexSearchable searchable, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => EntityField record searchable -> MongoRegex -> Filter record
EntityField record searchable
fld =~. :: EntityField record searchable -> (Text, Text) -> Filter record
=~. (Text, Text)
val = BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall record.
BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record
 -> Filter record)
-> BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall a b. (a -> b) -> a -> b
$ EntityField record searchable -> (Text, Text) -> MongoFilter record
forall record typ.
MongoRegexSearchable typ =>
EntityField record typ -> (Text, Text) -> MongoFilter record
RegExpFilter EntityField record searchable
fld (Text, Text)
val

data MongoFilterOperator typ = PersistFilterOperator (FilterValue typ) PersistFilter
                             | MongoFilterOperator DB.Value

data UpdateValueOp typ =
  UpdateValueOp
    (Either typ [typ])
    (Either PersistUpdate MongoUpdateOperation)
    deriving Int -> UpdateValueOp typ -> ShowS
[UpdateValueOp typ] -> ShowS
UpdateValueOp typ -> [Char]
(Int -> UpdateValueOp typ -> ShowS)
-> (UpdateValueOp typ -> [Char])
-> ([UpdateValueOp typ] -> ShowS)
-> Show (UpdateValueOp typ)
forall typ. Show typ => Int -> UpdateValueOp typ -> ShowS
forall typ. Show typ => [UpdateValueOp typ] -> ShowS
forall typ. Show typ => UpdateValueOp typ -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UpdateValueOp typ] -> ShowS
$cshowList :: forall typ. Show typ => [UpdateValueOp typ] -> ShowS
show :: UpdateValueOp typ -> [Char]
$cshow :: forall typ. Show typ => UpdateValueOp typ -> [Char]
showsPrec :: Int -> UpdateValueOp typ -> ShowS
$cshowsPrec :: forall typ. Show typ => Int -> UpdateValueOp typ -> ShowS
Show

data MongoUpdateOperation = MongoEach   MongoUpdateOperator
                          | MongoSimple MongoUpdateOperator
                          deriving Int -> MongoUpdateOperation -> ShowS
[MongoUpdateOperation] -> ShowS
MongoUpdateOperation -> [Char]
(Int -> MongoUpdateOperation -> ShowS)
-> (MongoUpdateOperation -> [Char])
-> ([MongoUpdateOperation] -> ShowS)
-> Show MongoUpdateOperation
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MongoUpdateOperation] -> ShowS
$cshowList :: [MongoUpdateOperation] -> ShowS
show :: MongoUpdateOperation -> [Char]
$cshow :: MongoUpdateOperation -> [Char]
showsPrec :: Int -> MongoUpdateOperation -> ShowS
$cshowsPrec :: Int -> MongoUpdateOperation -> ShowS
Show
data MongoUpdateOperator = MongoPush
                         | MongoPull
                         | MongoAddToSet
                         deriving Int -> MongoUpdateOperator -> ShowS
[MongoUpdateOperator] -> ShowS
MongoUpdateOperator -> [Char]
(Int -> MongoUpdateOperator -> ShowS)
-> (MongoUpdateOperator -> [Char])
-> ([MongoUpdateOperator] -> ShowS)
-> Show MongoUpdateOperator
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [MongoUpdateOperator] -> ShowS
$cshowList :: [MongoUpdateOperator] -> ShowS
show :: MongoUpdateOperator -> [Char]
$cshow :: MongoUpdateOperator -> [Char]
showsPrec :: Int -> MongoUpdateOperator -> ShowS
$cshowsPrec :: Int -> MongoUpdateOperator -> ShowS
Show

opToText :: MongoUpdateOperator -> Text
opToText :: MongoUpdateOperator -> Text
opToText MongoUpdateOperator
MongoPush     = Text
"$push"
opToText MongoUpdateOperator
MongoPull     = Text
"$pull"
opToText MongoUpdateOperator
MongoAddToSet = Text
"$addToSet"


data MongoFilter record =
        forall typ. PersistField typ =>
          NestedFilter
            (NestedField record typ)
            (MongoFilterOperator typ)
      | forall typ. PersistField typ =>
          ArrayFilter
            (EntityField record [typ])
            (MongoFilterOperator typ)
      | forall typ. PersistField typ =>
          NestedArrayFilter
            (NestedField record [typ])
            (MongoFilterOperator typ)
      | forall typ. MongoRegexSearchable typ =>
          RegExpFilter
            (EntityField record typ)
            MongoRegex

data MongoUpdate record =
        forall typ. PersistField typ =>
          NestedUpdate
            (NestedField record typ)
            (UpdateValueOp typ)
      | forall typ. PersistField typ =>
          ArrayUpdate
            (EntityField record [typ])
            (UpdateValueOp typ)

-- | Point to an array field with an embedded object and give a deeper query into the embedded object.
-- Use with 'nestEq'.
(->.) :: forall record emb typ. PersistEntity emb => EntityField record [emb] -> EntityField emb typ -> NestedField record typ
->. :: EntityField record [emb]
-> EntityField emb typ -> NestedField record typ
(->.)  = EntityField record [emb]
-> EntityField emb typ -> NestedField record typ
forall record typ emb.
PersistEntity emb =>
EntityField record [emb]
-> EntityField emb typ -> NestedField record typ
LastEmbFld

-- | Point to an array field with an embedded object and give a deeper query into the embedded object.
-- This level of nesting is not the final level.
-- Use '->.' or '&->.' to point to the final level.
(~>.) :: forall record typ emb. PersistEntity emb => EntityField record [emb] -> NestedField emb typ -> NestedField record typ
~>. :: EntityField record [emb]
-> NestedField emb typ -> NestedField record typ
(~>.)  = EntityField record [emb]
-> NestedField emb typ -> NestedField record typ
forall record typ emb.
PersistEntity emb =>
EntityField record [emb]
-> NestedField emb typ -> NestedField record typ
MidEmbFld

-- | Point to a nested field to query. This field is not an array type.
-- Use with 'nestEq'.
(&->.) :: forall record typ nest. PersistEntity nest => EntityField record nest -> EntityField nest typ -> NestedField record typ
&->. :: EntityField record nest
-> EntityField nest typ -> NestedField record typ
(&->.) = EntityField record nest
-> EntityField nest typ -> NestedField record typ
forall record typ nest.
PersistEntity nest =>
EntityField record nest
-> EntityField nest typ -> NestedField record typ
LastNestFld

-- | Same as '&->.', but Works against a Maybe type
(?&->.) :: forall record typ nest. PersistEntity nest => EntityField record (Maybe nest) -> EntityField nest typ -> NestedField record typ
?&->. :: EntityField record (Maybe nest)
-> EntityField nest typ -> NestedField record typ
(?&->.) = EntityField record (Maybe nest)
-> EntityField nest typ -> NestedField record typ
forall record typ nest.
PersistEntity nest =>
EntityField record (Maybe nest)
-> EntityField nest typ -> NestedField record typ
LastNestFldNullable


-- | Point to a nested field to query. This field is not an array type.
-- This level of nesting is not the final level.
-- Use '->.' or '&>.' to point to the final level.
(&~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes
&~>. :: EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes
(&~>.)  = EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes
forall record typ nest.
PersistEntity nest =>
EntityField record nest
-> NestedField nest typ -> NestedField record typ
MidNestFlds

-- | Same as '&~>.', but works against a Maybe type
(?&~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> NestedField nes1 nes -> NestedField val nes
?&~>. :: EntityField val (Maybe nes1)
-> NestedField nes1 nes -> NestedField val nes
(?&~>.) = EntityField val (Maybe nes1)
-> NestedField nes1 nes -> NestedField val nes
forall record typ nest.
PersistEntity nest =>
EntityField record (Maybe nest)
-> NestedField nest typ -> NestedField record typ
MidNestFldsNullable


infixr 4 =~.
infixr 5 ~>.
infixr 5 &~>.
infixr 5 ?&~>.
infixr 6 &->.
infixr 6 ?&->.
infixr 6 ->.

infixr 4 `nestEq`
infixr 4 `nestNe`
infixr 4 `nestGe`
infixr 4 `nestLe`
infixr 4 `nestIn`
infixr 4 `nestNotIn`

infixr 4 `anyEq`
infixr 4 `nestAnyEq`
infixr 4 `nestBsonEq`
infixr 4 `anyBsonEq`

infixr 4 `nestSet`
infixr 4 `push`
infixr 4 `pull`
infixr 4 `pullAll`
infixr 4 `addToSet`

-- | The normal Persistent equality test '==.' is not generic enough.
-- Instead use this with the drill-down arrow operaters such as '->.'
--
-- using this as the only query filter is similar to the following in the mongoDB shell
--
-- > db.Collection.find({"object.field": item})
nestEq, nestNe, nestGe, nestLe, nestIn, nestNotIn :: forall record typ.
    ( PersistField typ , PersistEntityBackend record ~ DB.MongoContext)
    => NestedField record typ
    -> typ
    -> Filter record
nestEq :: NestedField record typ -> typ -> Filter record
nestEq = PersistFilter -> NestedField record typ -> typ -> Filter record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
Eq
nestNe :: NestedField record typ -> typ -> Filter record
nestNe = PersistFilter -> NestedField record typ -> typ -> Filter record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
Ne
nestGe :: NestedField record typ -> typ -> Filter record
nestGe = PersistFilter -> NestedField record typ -> typ -> Filter record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
Ge
nestLe :: NestedField record typ -> typ -> Filter record
nestLe = PersistFilter -> NestedField record typ -> typ -> Filter record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
Le
nestIn :: NestedField record typ -> typ -> Filter record
nestIn = PersistFilter -> NestedField record typ -> typ -> Filter record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
In
nestNotIn :: NestedField record typ -> typ -> Filter record
nestNotIn = PersistFilter -> NestedField record typ -> typ -> Filter record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
NotIn

nestedFilterOp :: forall record typ.
       ( PersistField typ
       , PersistEntityBackend record ~ DB.MongoContext
       ) => PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp :: PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp PersistFilter
op NestedField record typ
nf typ
v = BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall record.
BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record
 -> Filter record)
-> BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall a b. (a -> b) -> a -> b
$
   NestedField record typ
-> MongoFilterOperator typ -> MongoFilter record
forall record typ.
PersistField typ =>
NestedField record typ
-> MongoFilterOperator typ -> MongoFilter record
NestedFilter NestedField record typ
nf (MongoFilterOperator typ -> MongoFilter record)
-> MongoFilterOperator typ -> MongoFilter record
forall a b. (a -> b) -> a -> b
$ FilterValue typ -> PersistFilter -> MongoFilterOperator typ
forall typ.
FilterValue typ -> PersistFilter -> MongoFilterOperator typ
PersistFilterOperator (typ -> FilterValue typ
forall typ. typ -> FilterValue typ
FilterValue typ
v) PersistFilter
op

-- | same as `nestEq`, but give a BSON Value
nestBsonEq :: forall record typ.
       ( PersistField typ
       , PersistEntityBackend record ~ DB.MongoContext
       ) => NestedField record typ -> DB.Value -> Filter record
NestedField record typ
nf nestBsonEq :: NestedField record typ -> Value -> Filter record
`nestBsonEq` Value
val = BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall record.
BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record
 -> Filter record)
-> BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall a b. (a -> b) -> a -> b
$
    NestedField record typ
-> MongoFilterOperator typ -> MongoFilter record
forall record typ.
PersistField typ =>
NestedField record typ
-> MongoFilterOperator typ -> MongoFilter record
NestedFilter NestedField record typ
nf (MongoFilterOperator typ -> MongoFilter record)
-> MongoFilterOperator typ -> MongoFilter record
forall a b. (a -> b) -> a -> b
$ Value -> MongoFilterOperator typ
forall typ. Value -> MongoFilterOperator typ
MongoFilterOperator Value
val

-- | Like '(==.)' but for an embedded list.
-- Checks to see if the list contains an item.
--
-- In Haskell we need different equality functions for embedded fields that are lists or non-lists to keep things type-safe.
--
-- using this as the only query filter is similar to the following in the mongoDB shell
--
-- > db.Collection.find({arrayField: arrayItem})
anyEq :: forall record typ.
        ( PersistField typ
        , PersistEntityBackend record ~ DB.MongoContext
        ) => EntityField record [typ] -> typ -> Filter record
EntityField record [typ]
fld anyEq :: EntityField record [typ] -> typ -> Filter record
`anyEq` typ
val = BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall record.
BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record
 -> Filter record)
-> BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall a b. (a -> b) -> a -> b
$
    EntityField record [typ]
-> MongoFilterOperator typ -> MongoFilter record
forall record typ.
PersistField typ =>
EntityField record [typ]
-> MongoFilterOperator typ -> MongoFilter record
ArrayFilter EntityField record [typ]
fld (MongoFilterOperator typ -> MongoFilter record)
-> MongoFilterOperator typ -> MongoFilter record
forall a b. (a -> b) -> a -> b
$ FilterValue typ -> PersistFilter -> MongoFilterOperator typ
forall typ.
FilterValue typ -> PersistFilter -> MongoFilterOperator typ
PersistFilterOperator (typ -> FilterValue typ
forall typ. typ -> FilterValue typ
FilterValue typ
val) PersistFilter
Eq

-- | Like nestEq, but for an embedded list.
-- Checks to see if the nested list contains an item.
nestAnyEq :: forall record typ.
        ( PersistField typ
        , PersistEntityBackend record ~ DB.MongoContext
        ) => NestedField record [typ] -> typ -> Filter record
NestedField record [typ]
fld nestAnyEq :: NestedField record [typ] -> typ -> Filter record
`nestAnyEq` typ
val = BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall record.
BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record
 -> Filter record)
-> BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall a b. (a -> b) -> a -> b
$
    NestedField record [typ]
-> MongoFilterOperator typ -> MongoFilter record
forall record typ.
PersistField typ =>
NestedField record [typ]
-> MongoFilterOperator typ -> MongoFilter record
NestedArrayFilter NestedField record [typ]
fld (MongoFilterOperator typ -> MongoFilter record)
-> MongoFilterOperator typ -> MongoFilter record
forall a b. (a -> b) -> a -> b
$ FilterValue typ -> PersistFilter -> MongoFilterOperator typ
forall typ.
FilterValue typ -> PersistFilter -> MongoFilterOperator typ
PersistFilterOperator (typ -> FilterValue typ
forall typ. typ -> FilterValue typ
FilterValue typ
val) PersistFilter
Eq

-- | same as `anyEq`, but give a BSON Value
anyBsonEq :: forall record typ.
        ( PersistField typ
        , PersistEntityBackend record ~ DB.MongoContext
        ) => EntityField record [typ] -> DB.Value -> Filter record
EntityField record [typ]
fld anyBsonEq :: EntityField record [typ] -> Value -> Filter record
`anyBsonEq` Value
val = BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall record.
BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
BackendFilter (BackendSpecificFilter (PersistEntityBackend record) record
 -> Filter record)
-> BackendSpecificFilter (PersistEntityBackend record) record
-> Filter record
forall a b. (a -> b) -> a -> b
$
    EntityField record [typ]
-> MongoFilterOperator typ -> MongoFilter record
forall record typ.
PersistField typ =>
EntityField record [typ]
-> MongoFilterOperator typ -> MongoFilter record
ArrayFilter EntityField record [typ]
fld (MongoFilterOperator typ -> MongoFilter record)
-> MongoFilterOperator typ -> MongoFilter record
forall a b. (a -> b) -> a -> b
$ Value -> MongoFilterOperator typ
forall typ. Value -> MongoFilterOperator typ
MongoFilterOperator Value
val

nestSet, nestInc, nestDec, nestMul :: forall record typ.
    ( PersistField typ , PersistEntityBackend record ~ DB.MongoContext)
    => NestedField record typ
    -> typ
    -> Update record
nestSet :: NestedField record typ -> typ -> Update record
nestSet = PersistUpdate -> NestedField record typ -> typ -> Update record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp PersistUpdate
Assign
nestInc :: NestedField record typ -> typ -> Update record
nestInc = PersistUpdate -> NestedField record typ -> typ -> Update record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp PersistUpdate
Add
nestDec :: NestedField record typ -> typ -> Update record
nestDec = PersistUpdate -> NestedField record typ -> typ -> Update record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp PersistUpdate
Subtract
nestMul :: NestedField record typ -> typ -> Update record
nestMul = PersistUpdate -> NestedField record typ -> typ -> Update record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp PersistUpdate
Multiply

push, pull, addToSet :: forall record typ.
        ( PersistField typ
        , PersistEntityBackend record ~ DB.MongoContext
        ) => EntityField record [typ] -> typ -> Update record
EntityField record [typ]
fld push :: EntityField record [typ] -> typ -> Update record
`push`     typ
val = MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
forall record typ.
(PersistField typ,
 BackendSpecificUpdate (PersistEntityBackend record) record
 ~ MongoUpdate record) =>
MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
backendArrayOperation MongoUpdateOperator
MongoPush     EntityField record [typ]
fld typ
val
EntityField record [typ]
fld pull :: EntityField record [typ] -> typ -> Update record
`pull`     typ
val = MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
forall record typ.
(PersistField typ,
 BackendSpecificUpdate (PersistEntityBackend record) record
 ~ MongoUpdate record) =>
MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
backendArrayOperation MongoUpdateOperator
MongoPull     EntityField record [typ]
fld typ
val
EntityField record [typ]
fld addToSet :: EntityField record [typ] -> typ -> Update record
`addToSet` typ
val = MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
forall record typ.
(PersistField typ,
 BackendSpecificUpdate (PersistEntityBackend record) record
 ~ MongoUpdate record) =>
MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
backendArrayOperation MongoUpdateOperator
MongoAddToSet EntityField record [typ]
fld typ
val

backendArrayOperation ::
  forall record typ.
  (PersistField typ, BackendSpecificUpdate (PersistEntityBackend record) record ~ MongoUpdate record)
  => MongoUpdateOperator -> EntityField record [typ] -> typ
  -> Update record
backendArrayOperation :: MongoUpdateOperator
-> EntityField record [typ] -> typ -> Update record
backendArrayOperation MongoUpdateOperator
op EntityField record [typ]
fld typ
val = BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
forall record.
BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
BackendUpdate (BackendSpecificUpdate (PersistEntityBackend record) record
 -> Update record)
-> BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
forall a b. (a -> b) -> a -> b
$
    EntityField record [typ] -> UpdateValueOp typ -> MongoUpdate record
forall record typ.
PersistField typ =>
EntityField record [typ] -> UpdateValueOp typ -> MongoUpdate record
ArrayUpdate EntityField record [typ]
fld (UpdateValueOp typ -> MongoUpdate record)
-> UpdateValueOp typ -> MongoUpdate record
forall a b. (a -> b) -> a -> b
$ Either typ [typ]
-> Either PersistUpdate MongoUpdateOperation -> UpdateValueOp typ
forall typ.
Either typ [typ]
-> Either PersistUpdate MongoUpdateOperation -> UpdateValueOp typ
UpdateValueOp (typ -> Either typ [typ]
forall a b. a -> Either a b
Left typ
val) (MongoUpdateOperation -> Either PersistUpdate MongoUpdateOperation
forall a b. b -> Either a b
Right (MongoUpdateOperation -> Either PersistUpdate MongoUpdateOperation)
-> MongoUpdateOperation
-> Either PersistUpdate MongoUpdateOperation
forall a b. (a -> b) -> a -> b
$ MongoUpdateOperator -> MongoUpdateOperation
MongoSimple MongoUpdateOperator
op)

-- | equivalent to $each
--
-- > eachOp push field []
--
-- @eachOp pull@ will get translated to @$pullAll@
eachOp :: forall record typ.
       ( PersistField typ, PersistEntityBackend record ~ DB.MongoContext)
       => (EntityField record [typ] -> typ -> Update record)
       -> EntityField record [typ] -> [typ]
       -> Update record
eachOp :: (EntityField record [typ] -> typ -> Update record)
-> EntityField record [typ] -> [typ] -> Update record
eachOp EntityField record [typ] -> typ -> Update record
haskellOp EntityField record [typ]
fld [typ]
val = case EntityField record [typ] -> typ -> Update record
haskellOp EntityField record [typ]
fld ([Char] -> typ
forall a. HasCallStack => [Char] -> a
error [Char]
"eachOp: undefined") of
    BackendUpdate (ArrayUpdate _ (UpdateValueOp (Left _) (Right (MongoSimple op)))) -> MongoUpdateOperator -> Update record
each MongoUpdateOperator
op
    BackendUpdate (ArrayUpdate{})  -> [Char] -> Update record
forall a. HasCallStack => [Char] -> a
error [Char]
"eachOp: unexpected ArrayUpdate"
    BackendUpdate (NestedUpdate{}) -> [Char] -> Update record
forall a. HasCallStack => [Char] -> a
error [Char]
"eachOp: did not expect NestedUpdate"
    Update{} -> [Char] -> Update record
forall a. HasCallStack => [Char] -> a
error [Char]
"eachOp: did not expect Update"
  where
    each :: MongoUpdateOperator -> Update record
each MongoUpdateOperator
op = BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
forall record.
BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
BackendUpdate (BackendSpecificUpdate (PersistEntityBackend record) record
 -> Update record)
-> BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
forall a b. (a -> b) -> a -> b
$ EntityField record [typ] -> UpdateValueOp typ -> MongoUpdate record
forall record typ.
PersistField typ =>
EntityField record [typ] -> UpdateValueOp typ -> MongoUpdate record
ArrayUpdate EntityField record [typ]
fld (UpdateValueOp typ -> MongoUpdate record)
-> UpdateValueOp typ -> MongoUpdate record
forall a b. (a -> b) -> a -> b
$
      Either typ [typ]
-> Either PersistUpdate MongoUpdateOperation -> UpdateValueOp typ
forall typ.
Either typ [typ]
-> Either PersistUpdate MongoUpdateOperation -> UpdateValueOp typ
UpdateValueOp ([typ] -> Either typ [typ]
forall a b. b -> Either a b
Right [typ]
val) (MongoUpdateOperation -> Either PersistUpdate MongoUpdateOperation
forall a b. b -> Either a b
Right (MongoUpdateOperation -> Either PersistUpdate MongoUpdateOperation)
-> MongoUpdateOperation
-> Either PersistUpdate MongoUpdateOperation
forall a b. (a -> b) -> a -> b
$ MongoUpdateOperator -> MongoUpdateOperation
MongoEach MongoUpdateOperator
op)

pullAll :: forall record typ.
        ( PersistField typ
        , PersistEntityBackend record ~ DB.MongoContext
        ) => EntityField record [typ] -> [typ] -> Update record
EntityField record [typ]
fld pullAll :: EntityField record [typ] -> [typ] -> Update record
`pullAll` [typ]
val = (EntityField record [typ] -> typ -> Update record)
-> EntityField record [typ] -> [typ] -> Update record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
(EntityField record [typ] -> typ -> Update record)
-> EntityField record [typ] -> [typ] -> Update record
eachOp EntityField record [typ] -> typ -> Update record
forall record typ.
(PersistField typ, PersistEntityBackend record ~ MongoContext) =>
EntityField record [typ] -> typ -> Update record
pull EntityField record [typ]
fld [typ]
val


nestedUpdateOp :: forall record typ.
       ( PersistField typ
       , PersistEntityBackend record ~ DB.MongoContext
       ) => PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp :: PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp PersistUpdate
op NestedField record typ
nf typ
v = BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
forall record.
BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
BackendUpdate (BackendSpecificUpdate (PersistEntityBackend record) record
 -> Update record)
-> BackendSpecificUpdate (PersistEntityBackend record) record
-> Update record
forall a b. (a -> b) -> a -> b
$
   NestedField record typ -> UpdateValueOp typ -> MongoUpdate record
forall record typ.
PersistField typ =>
NestedField record typ -> UpdateValueOp typ -> MongoUpdate record
NestedUpdate NestedField record typ
nf (UpdateValueOp typ -> MongoUpdate record)
-> UpdateValueOp typ -> MongoUpdate record
forall a b. (a -> b) -> a -> b
$ Either typ [typ]
-> Either PersistUpdate MongoUpdateOperation -> UpdateValueOp typ
forall typ.
Either typ [typ]
-> Either PersistUpdate MongoUpdateOperation -> UpdateValueOp typ
UpdateValueOp (typ -> Either typ [typ]
forall a b. a -> Either a b
Left typ
v) (PersistUpdate -> Either PersistUpdate MongoUpdateOperation
forall a b. a -> Either a b
Left PersistUpdate
op)

-- | Intersection of lists: if any value in the field is found in the list.
inList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v
EntityField v [typ]
f inList :: EntityField v [typ] -> [typ] -> Filter v
`inList` [typ]
a = EntityField v typ -> FilterValue typ -> PersistFilter -> Filter v
forall record typ.
PersistField typ =>
EntityField record typ
-> FilterValue typ -> PersistFilter -> Filter record
Filter (EntityField v [typ] -> EntityField v typ
forall a b. a -> b
unsafeCoerce EntityField v [typ]
f) ([typ] -> FilterValue typ
forall typ. [typ] -> FilterValue typ
FilterValues [typ]
a) PersistFilter
In
infix 4 `inList`

-- | No intersection of lists: if no value in the field is found in the list.
ninList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v
EntityField v [typ]
f ninList :: EntityField v [typ] -> [typ] -> Filter v
`ninList` [typ]
a = EntityField v typ -> FilterValue typ -> PersistFilter -> Filter v
forall record typ.
PersistField typ =>
EntityField record typ
-> FilterValue typ -> PersistFilter -> Filter record
Filter (EntityField v [typ] -> EntityField v typ
forall a b. a -> b
unsafeCoerce EntityField v [typ]
f) ([typ] -> FilterValue typ
forall typ. [typ] -> FilterValue typ
FilterValues [typ]
a) PersistFilter
NotIn
infix 4 `ninList`