{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Database.Persist.MongoDB
(
collectionName
, docToEntityEither
, docToEntityThrow
, recordToDocument
, documentFromEntity
, toInsertDoc
, entityToInsertDoc
, updatesToDoc
, filtersToDoc
, toUniquesDoc
, (->.), (~>.), (?&->.), (?&~>.), (&->.), (&~>.)
, nestEq, nestNe, nestGe, nestLe, nestIn, nestNotIn
, anyEq, nestAnyEq, nestBsonEq, anyBsonEq
, inList, ninList
, (=~.)
, NestedField(..)
, MongoRegexSearchable
, MongoRegex
, nestSet, nestInc, nestDec, nestMul, push, pull, pullAll, addToSet, eachOp
, BackendKey(..)
, keyToOid
, oidToKey
, recordTypeFromKey
, readMayObjectId
, readMayMongoKey
, keyToText
, fieldName
, withConnection
, withMongoPool
, withMongoDBConn
, withMongoDBPool
, createMongoDBPool
, runMongoDBPool
, runMongoDBPoolDef
, ConnectionPool
, Connection
, MongoAuth (..)
, MongoConf (..)
, defaultMongoConf
, defaultHost
, defaultAccessMode
, defaultPoolStripes
, defaultConnectionIdleTime
, defaultStripeConnections
, applyDockerEnv
, PipePool
, createMongoDBPipePool
, runMongoDBPipePool
, HostName
, Database
, DB.Action
, DB.AccessMode(..)
, DB.master
, DB.slaveOk
, (DB.=:)
, DB.ObjectId
, DB.MongoContext
, DB.PortID
, module Database.Persist
) where
import Control.Exception (throw, throwIO)
import Control.Monad (liftM, (>=>), forM_, 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 Data.Acquire (mkAcquire)
import Data.Aeson (Value (Number), (.:), (.:?), (.!=), FromJSON(..), ToJSON(..), withText, withObject)
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 (mapMaybe, fromJust)
import Data.Monoid (mappend)
import qualified Data.Serialize as Serialize
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Traversable as Traversable
import qualified Data.Pool as Pool
import Data.Time (NominalDiffTime)
import Data.Time.Calendar (Day(..))
#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.PathPieces (PathPiece(..))
import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe, parseUrlPieceWithPrefix, readTextData)
#ifdef DEBUG
import FileLocation (debug)
#endif
import qualified Database.MongoDB as DB
import Database.MongoDB.Query (Database)
import Database.Persist
import qualified Database.Persist.Sql as Sql
instance HasPersistBackend DB.MongoContext where
type BaseBackend DB.MongoContext = DB.MongoContext
persistBackend = id
recordTypeFromKey :: Key record -> record
recordTypeFromKey _ = error "recordTypeFromKey"
newtype NoOrphanNominalDiffTime = NoOrphanNominalDiffTime NominalDiffTime
deriving (Show, Eq, Num)
instance FromJSON NoOrphanNominalDiffTime where
parseJSON (Number x) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x
parseJSON _ = fail "couldn't parse diff time"
newtype NoOrphanPortID = NoOrphanPortID DB.PortID deriving (Show, Eq)
instance FromJSON NoOrphanPortID where
parseJSON (Number x) = (return . NoOrphanPortID . DB.PortNumber . fromIntegral ) cnvX
where cnvX :: Word16
cnvX = round x
parseJSON _ = fail "couldn't parse port number"
data Connection = Connection DB.Pipe DB.Database
type ConnectionPool = Pool.Pool Connection
instance ToHttpApiData (BackendKey DB.MongoContext) where
toUrlPiece = keyToText
instance FromHttpApiData (BackendKey DB.MongoContext) where
parseUrlPiece input = do
s <- parseUrlPieceWithPrefix "o" input <!> return input
MongoKey <$> readTextData s
where
infixl 3 <!>
Left _ <!> y = y
x <!> _ = x
instance PathPiece (BackendKey DB.MongoContext) where
toPathPiece = toUrlPiece
fromPathPiece = parseUrlPieceMaybe
keyToText :: BackendKey DB.MongoContext -> Text
keyToText = T.pack . show . unMongoKey
readMayMongoKey :: Text -> Maybe (BackendKey DB.MongoContext)
readMayMongoKey = fmap MongoKey . readMayObjectId
readMayObjectId :: Text -> Maybe DB.ObjectId
readMayObjectId str =
case filter (null . snd) $ reads $ T.unpack str :: [(DB.ObjectId,String)] of
(parsed,_):[] -> Just parsed
_ -> Nothing
instance PersistField DB.ObjectId where
toPersistValue = oidToPersistValue
fromPersistValue oid@(PersistObjectId _) = Right $ persistObjectIdToDbOid oid
fromPersistValue (PersistByteString bs) = fromPersistValue (PersistObjectId bs)
fromPersistValue _ = Left $ T.pack "expected PersistObjectId"
instance Sql.PersistFieldSql DB.ObjectId where
sqlType _ = Sql.SqlOther "doesn't make much sense for MongoDB"
instance Sql.PersistFieldSql (BackendKey DB.MongoContext) where
sqlType _ = Sql.SqlOther "doesn't make much sense for MongoDB"
withConnection :: (Trans.MonadIO m)
=> MongoConf
-> (ConnectionPool -> m b) -> m b
withConnection mc =
withMongoDBPool (mgDatabase mc) (T.unpack $ mgHost mc) (mgPort mc) (mgAuth mc) (mgPoolStripes mc) (mgStripeConnections mc) (mgConnectionIdleTime mc)
withMongoDBConn :: (Trans.MonadIO m)
=> Database -> HostName -> DB.PortID
-> Maybe MongoAuth -> NominalDiffTime
-> (ConnectionPool -> m b) -> m b
withMongoDBConn dbname hostname port mauth connectionIdleTime = withMongoDBPool dbname hostname port mauth 1 1 connectionIdleTime
createPipe :: HostName -> DB.PortID -> IO DB.Pipe
createPipe hostname port = DB.connect (DB.Host hostname port)
createReplicatSet :: (DB.ReplicaSetName, [DB.Host]) -> Database -> Maybe MongoAuth -> IO Connection
createReplicatSet rsSeed dbname mAuth = do
pipe <- DB.openReplicaSet rsSeed >>= DB.primary
testAccess pipe dbname mAuth
return $ Connection pipe dbname
createRsPool :: (Trans.MonadIO m) => Database -> ReplicaSetConfig
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createRsPool dbname (ReplicaSetConfig rsName rsHosts) mAuth connectionPoolSize stripeSize connectionIdleTime = do
Trans.liftIO $ Pool.createPool
(createReplicatSet (rsName, rsHosts) dbname mAuth)
(\(Connection pipe _) -> DB.close pipe)
connectionPoolSize
connectionIdleTime
stripeSize
testAccess :: DB.Pipe -> Database -> Maybe MongoAuth -> IO ()
testAccess pipe dbname mAuth = do
_ <- case mAuth of
Just (MongoAuth user pass) -> DB.access pipe DB.UnconfirmedWrites dbname (DB.auth user pass)
Nothing -> return undefined
return ()
createConnection :: Database -> HostName -> DB.PortID -> Maybe MongoAuth -> IO Connection
createConnection dbname hostname port mAuth = do
pipe <- createPipe hostname port
testAccess pipe dbname mAuth
return $ Connection pipe dbname
createMongoDBPool :: (Trans.MonadIO m) => Database -> HostName -> DB.PortID
-> Maybe MongoAuth
-> Int
-> Int
-> NominalDiffTime
-> m ConnectionPool
createMongoDBPool dbname hostname port mAuth connectionPoolSize stripeSize connectionIdleTime = do
Trans.liftIO $ Pool.createPool
(createConnection dbname hostname port mAuth)
(\(Connection pipe _) -> DB.close pipe)
connectionPoolSize
connectionIdleTime
stripeSize
createMongoPool :: (Trans.MonadIO m) => MongoConf -> m ConnectionPool
createMongoPool c@MongoConf{mgReplicaSetConfig = Just (ReplicaSetConfig rsName hosts)} =
createRsPool
(mgDatabase c)
(ReplicaSetConfig rsName ((DB.Host (T.unpack $ mgHost c) (mgPort c)):hosts))
(mgAuth c)
(mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c)
createMongoPool c@MongoConf{mgReplicaSetConfig = Nothing} =
createMongoDBPool
(mgDatabase c) (T.unpack (mgHost c)) (mgPort c)
(mgAuth c)
(mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c)
type PipePool = Pool.Pool DB.Pipe
createMongoDBPipePool :: (Trans.MonadIO m) => HostName -> DB.PortID
-> Int
-> Int
-> NominalDiffTime
-> m PipePool
createMongoDBPipePool hostname port connectionPoolSize stripeSize connectionIdleTime =
Trans.liftIO $ Pool.createPool
(createPipe hostname port)
DB.close
connectionPoolSize
connectionIdleTime
stripeSize
withMongoPool :: (Trans.MonadIO m) => MongoConf -> (ConnectionPool -> m b) -> m b
withMongoPool conf connectionReader = createMongoPool conf >>= connectionReader
withMongoDBPool :: (Trans.MonadIO m) =>
Database -> HostName -> DB.PortID -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b
withMongoDBPool dbname hostname port mauth poolStripes stripeConnections connectionIdleTime connectionReader = do
pool <- createMongoDBPool dbname hostname port mauth poolStripes stripeConnections connectionIdleTime
connectionReader pool
runMongoDBPipePool :: MonadUnliftIO m => DB.AccessMode -> Database -> DB.Action m a -> PipePool -> m a
runMongoDBPipePool accessMode db action pool =
withRunInIO $ \run ->
Pool.withResource pool $ \pipe ->
run $ DB.access pipe accessMode db action
runMongoDBPool :: MonadUnliftIO m => DB.AccessMode -> DB.Action m a -> ConnectionPool -> m a
runMongoDBPool accessMode action pool =
withRunInIO $ \run ->
Pool.withResource pool $ \(Connection pipe db) ->
run $ DB.access pipe accessMode db action
runMongoDBPoolDef :: MonadUnliftIO m => DB.Action m a -> ConnectionPool -> m a
runMongoDBPoolDef = runMongoDBPool defaultAccessMode
queryByKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Key record -> DB.Query
queryByKey k = (DB.select (keyToMongoDoc k) (collectionNameFromKey k)) {DB.project = projectionFromKey k}
selectByKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Key record -> DB.Selection
selectByKey k = DB.select (keyToMongoDoc k) (collectionNameFromKey k)
updatesToDoc :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> [Update record] -> DB.Document
updatesToDoc upds = map updateToMongoField upds
updateToBson :: Text
-> PersistValue
-> Either PersistUpdate MongoUpdateOperation
-> DB.Field
updateToBson fname v up =
#ifdef DEBUG
debug (
#endif
opName DB.:= DB.Doc [fname DB.:= opValue]
#ifdef DEBUG
)
#endif
where
inc = "$inc"
mul = "$mul"
(opName, opValue) = case up of
Left pup -> case (pup, v) of
(Assign, PersistNull) -> ("$unset", DB.Int64 1)
(Assign,a) -> ("$set", DB.val a)
(Add, a) -> (inc, DB.val a)
(Subtract, PersistInt64 i) -> (inc, DB.Int64 (-i))
(Multiply, PersistInt64 i) -> (mul, DB.Int64 i)
(Multiply, PersistDouble d) -> (mul, DB.Float d)
(Subtract, _) -> error "expected PersistInt64 for a subtraction"
(Multiply, _) -> error "expected PersistInt64 or PersistDouble for a subtraction"
(Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported"
(BackendSpecificUpdate bsup, _) -> throw $ PersistMongoDBError $
T.pack $ "did not expect BackendSpecificUpdate " ++ T.unpack bsup
Right mup -> case mup of
MongoEach op -> case op of
MongoPull -> ("$pullAll", DB.val v)
_ -> (opToText op, DB.Doc ["$each" DB.:= DB.val v])
MongoSimple x -> (opToText x, DB.val v)
updateToMongoField :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Update record -> DB.Field
updateToMongoField (Update field v up) = updateToBson (fieldName field) (toPersistValue v) (Left up)
updateToMongoField (BackendUpdate up) = mongoUpdateToDoc up
toUniquesDoc :: forall record. (PersistEntity record) => Unique record -> [DB.Field]
toUniquesDoc uniq = zipWith (DB.:=)
(map (unDBName . snd) $ persistUniqueToFieldNames uniq)
(map DB.val (persistUniqueToValues uniq))
toInsertDoc :: forall record. (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> record -> DB.Document
toInsertDoc record = zipFilter (embeddedFields $ toEmbedEntityDef entDef)
(map toPersistValue $ toPersistFields record)
where
entDef = entityDef $ Just record
zipFilter :: [EmbedFieldDef] -> [PersistValue] -> DB.Document
zipFilter [] _ = []
zipFilter _ [] = []
zipFilter (fd:efields) (pv:pvs) =
if isNull pv then recur else
(fieldToLabel fd DB.:= embeddedVal (emFieldEmbed fd) pv):recur
where
recur = zipFilter efields pvs
isNull PersistNull = True
isNull (PersistMap m) = null m
isNull (PersistList l) = null l
isNull _ = False
embeddedVal :: Maybe EmbedEntityDef -> PersistValue -> DB.Value
embeddedVal (Just emDef) (PersistMap m) = DB.Doc $
zipFilter (embeddedFields emDef) $ map snd m
embeddedVal je@(Just _) (PersistList l) = DB.Array $ map (embeddedVal je) l
embeddedVal _ pv = DB.val pv
entityToInsertDoc :: forall record. (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Entity record -> DB.Document
entityToInsertDoc (Entity key record) = keyToMongoDoc key ++ toInsertDoc record
collectionName :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> record -> Text
collectionName = unDBName . entityDB . entityDef . Just
recordToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> record -> DB.Document
recordToDocument record = zipToDoc (map fieldDB $ entityFields entity) (toPersistFields record)
where
entity = entityDef $ Just record
documentFromEntity :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Entity record -> DB.Document
documentFromEntity (Entity key record) =
keyToMongoDoc key ++ recordToDocument record
zipToDoc :: PersistField a => [DBName] -> [a] -> [DB.Field]
zipToDoc [] _ = []
zipToDoc _ [] = []
zipToDoc (e:efields) (p:pfields) =
let pv = toPersistValue p
in (unDBName e DB.:= DB.val pv):zipToDoc efields pfields
fieldToLabel :: EmbedFieldDef -> Text
fieldToLabel = unDBName . emFieldDB
keyFrom_idEx :: (Trans.MonadIO m, PersistEntity record) => DB.Value -> m (Key record)
keyFrom_idEx idVal = case keyFrom_id idVal of
Right k -> return k
Left err -> liftIO $ throwIO $ PersistMongoDBError $ "could not convert key: "
`Data.Monoid.mappend` T.pack (show idVal)
`mappend` err
keyFrom_id :: (PersistEntity record) => DB.Value -> Either Text (Key record)
keyFrom_id idVal = case cast idVal of
(PersistMap m) -> keyFromValues $ map snd m
pv -> keyFromValues [pv]
instance ToJSON (BackendKey DB.MongoContext) where
toJSON (MongoKey (Oid x y)) = toJSON $ DB.showHexLen 8 x $ DB.showHexLen 16 y ""
instance FromJSON (BackendKey DB.MongoContext) where
parseJSON = withText "MongoKey" $ \t ->
maybe
(fail "Invalid base64")
(return . MongoKey . persistObjectIdToDbOid . PersistObjectId)
$ fmap (i2bs (8 * 12) . fst) $ headMay $ readHex $ T.unpack t
where
headMay [] = Nothing
headMay (x:_) = Just x
i2bs :: Int -> Integer -> BS.ByteString
i2bs l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-8)
{-# INLINE i2bs #-}
instance PersistCore DB.MongoContext where
newtype BackendKey DB.MongoContext = MongoKey { unMongoKey :: DB.ObjectId }
deriving (Show, Read, Eq, Ord, PersistField)
instance PersistStoreWrite DB.MongoContext where
insert record = DB.insert (collectionName record) (toInsertDoc record)
>>= keyFrom_idEx
insertMany [] = return []
insertMany records@(r:_) = mapM keyFrom_idEx =<<
DB.insertMany (collectionName r) (map toInsertDoc records)
insertEntityMany [] = return ()
insertEntityMany ents@(Entity _ r : _) =
DB.insertMany_ (collectionName r) (map entityToInsertDoc ents)
insertKey k record = DB.insert_ (collectionName record) $
entityToInsertDoc (Entity k record)
repsert k record = DB.save (collectionName record) $
documentFromEntity (Entity k record)
replace k record = do
DB.replace (selectByKey k) (recordToDocument record)
return ()
delete k =
DB.deleteOne DB.Select {
DB.coll = collectionNameFromKey k
, DB.selector = keyToMongoDoc k
}
update _ [] = return ()
update key upds =
DB.modify
(DB.Select (keyToMongoDoc key) (collectionNameFromKey key))
$ updatesToDoc upds
updateGet key upds = do
result <- DB.findAndModify (queryByKey key) (updatesToDoc upds)
either err instantiate result
where
instantiate doc = do
Entity _ rec <- fromPersistValuesThrow t doc
return rec
err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg
t = entityDefFromKey key
instance PersistStoreRead DB.MongoContext where
get k = do
d <- DB.findOne (queryByKey k)
case d of
Nothing -> return Nothing
Just doc -> do
Entity _ ent <- fromPersistValuesThrow t doc
return $ Just ent
where
t = entityDefFromKey k
instance PersistUniqueRead DB.MongoContext where
getBy uniq = do
mdoc <- DB.findOne $
(DB.select (toUniquesDoc uniq) (collectionName rec)) {DB.project = projectionFromRecord rec}
case mdoc of
Nothing -> return Nothing
Just doc -> liftM Just $ fromPersistValuesThrow t doc
where
t = entityDef $ Just rec
rec = dummyFromUnique uniq
instance PersistUniqueWrite DB.MongoContext where
deleteBy uniq =
DB.delete DB.Select {
DB.coll = collectionName $ dummyFromUnique uniq
, DB.selector = toUniquesDoc uniq
}
upsert newRecord upds = do
uniq <- onlyUnique newRecord
upsertBy uniq newRecord upds
upsertBy uniq newRecord upds = do
let uniqueDoc = toUniquesDoc uniq :: [DB.Field]
let uniqKeys = map DB.label uniqueDoc :: [DB.Label]
let insDoc = DB.exclude uniqKeys $ toInsertDoc newRecord :: DB.Document
let selection = DB.select uniqueDoc $ collectionName newRecord :: DB.Selection
mdoc <- getBy uniq
case mdoc of
Nothing -> unless (null upds) (DB.upsert selection ["$setOnInsert" DB.=: insDoc])
Just _ -> unless (null upds) (DB.modify selection $ DB.exclude uniqKeys $ updatesToDoc upds)
newMdoc <- getBy uniq
case newMdoc of
Nothing -> err "possible race condition: getBy found Nothing"
Just doc -> return doc
where
err = Trans.liftIO . throwIO . UpsertError
id_ :: T.Text
id_ = "_id"
keyToMongoDoc :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Key record -> DB.Document
keyToMongoDoc k = case entityPrimary $ entityDefFromKey k of
Nothing -> zipToDoc [DBName id_] values
Just pdef -> [id_ DB.=: zipToDoc (primaryNames pdef) values]
where
primaryNames = map fieldDB . compositeFields
values = keyToValues k
entityDefFromKey :: PersistEntity record => Key record -> EntityDef
entityDefFromKey = entityDef . Just . recordTypeFromKey
collectionNameFromKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)
=> Key record -> Text
collectionNameFromKey = collectionName . recordTypeFromKey
projectionFromEntityDef :: EntityDef -> DB.Projector
projectionFromEntityDef eDef =
map toField (entityFields eDef)
where
toField :: FieldDef -> DB.Field
toField fDef = (unDBName (fieldDB fDef)) DB.=: (1 :: Int)
projectionFromKey :: PersistEntity record => Key record -> DB.Projector
projectionFromKey = projectionFromEntityDef . entityDefFromKey
projectionFromRecord :: PersistEntity record => record -> DB.Projector
projectionFromRecord = projectionFromEntityDef . entityDef . Just
instance PersistQueryWrite DB.MongoContext where
updateWhere _ [] = return ()
updateWhere filts upds =
DB.modify DB.Select {
DB.coll = collectionName $ dummyFromFilts filts
, DB.selector = filtersToDoc filts
} $ updatesToDoc upds
deleteWhere filts = do
DB.delete DB.Select {
DB.coll = collectionName $ dummyFromFilts filts
, DB.selector = filtersToDoc filts
}
instance PersistQueryRead DB.MongoContext where
count filts = do
i <- DB.count query
return $ fromIntegral i
where
query = DB.select (filtersToDoc filts) $
collectionName $ dummyFromFilts filts
selectSourceRes filts opts = do
context <- ask
return (pullCursor context `fmap` mkAcquire (open context) (close context))
where
close :: DB.MongoContext -> DB.Cursor -> IO ()
close context cursor = runReaderT (DB.closeCursor cursor) context
open :: DB.MongoContext -> IO DB.Cursor
open = runReaderT (DB.find (makeQuery filts opts)
{ DB.snapshot = noSort
, DB.options = [DB.NoCursorTimeout]
})
pullCursor context cursor = do
mdoc <- liftIO $ runReaderT (DB.nextBatch cursor) context
case mdoc of
[] -> return ()
docs -> do
forM_ docs $ fromPersistValuesThrow t >=> yield
pullCursor context cursor
t = entityDef $ Just $ dummyFromFilts filts
(_, _, orders) = limitOffsetOrder opts
noSort = null orders
selectFirst filts opts = DB.findOne (makeQuery filts opts)
>>= Traversable.mapM (fromPersistValuesThrow t)
where
t = entityDef $ Just $ dummyFromFilts filts
selectKeysRes filts opts = do
context <- ask
let make = do
cursor <- liftIO $ flip runReaderT context $ DB.find $ (makeQuery filts opts) {
DB.project = [id_ DB.=: (1 :: Int)]
}
pullCursor context cursor
return $ return make
where
pullCursor context cursor = do
mdoc <- liftIO $ runReaderT (DB.next cursor) context
case mdoc of
Nothing -> return ()
Just [_id DB.:= idVal] -> do
k <- liftIO $ keyFrom_idEx idVal
yield k
pullCursor context cursor
Just y -> liftIO $ throwIO $ PersistMarshalError $ T.pack $ "Unexpected in selectKeys: " ++ show y
orderClause :: PersistEntity val => SelectOpt val -> DB.Field
orderClause o = case o of
Asc f -> fieldName f DB.=: ( 1 :: Int)
Desc f -> fieldName f DB.=: (-1 :: Int)
_ -> error "orderClause: expected Asc or Desc"
makeQuery :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => [Filter record] -> [SelectOpt record] -> DB.Query
makeQuery filts opts =
(DB.select (filtersToDoc filts) (collectionName $ dummyFromFilts filts)) {
DB.limit = fromIntegral limit
, DB.skip = fromIntegral offset
, DB.sort = orders
, DB.project = projectionFromRecord (dummyFromFilts filts)
}
where
(limit, offset, orders') = limitOffsetOrder opts
orders = map orderClause orders'
filtersToDoc :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => [Filter record] -> DB.Document
filtersToDoc filts =
#ifdef DEBUG
debug $
#endif
if null filts then [] else multiFilter AndDollar filts
filterToDocument :: (PersistEntity val, PersistEntityBackend val ~ DB.MongoContext) => Filter val -> DB.Document
filterToDocument f =
case f of
Filter field v filt -> [filterToBSON (fieldName field) v filt]
BackendFilter mf -> mongoFilterToDoc mf
FilterOr fs -> multiFilter OrDollar fs
FilterAnd [] -> []
FilterAnd fs -> multiFilter AndDollar fs
data MultiFilter = OrDollar | AndDollar deriving Show
toMultiOp :: MultiFilter -> Text
toMultiOp OrDollar = orDollar
toMultiOp AndDollar = andDollar
multiFilter :: forall record. (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => MultiFilter -> [Filter record] -> [DB.Field]
multiFilter _ [] = throw $ PersistMongoDBError "An empty list of filters was given"
multiFilter multi filters =
case (multi, filter (not . null) (map filterToDocument filters)) of
(OrDollar, []) -> orError
(AndDollar, []) -> []
(OrDollar, _:[]) -> orError
(AndDollar, doc:[]) -> doc
(_, doc) -> [toMultiOp multi DB.:= DB.Array (map DB.Doc doc)]
where
orError = throw $ PersistMongoDBError $
"An empty list of filters was given to one side of ||."
existsDollar, orDollar, andDollar :: Text
existsDollar = "$exists"
orDollar = "$or"
andDollar = "$and"
filterToBSON :: forall a. ( PersistField a)
=> Text
-> FilterValue a
-> PersistFilter
-> DB.Field
filterToBSON fname v filt = case filt of
Eq -> nullEq
Ne -> nullNeq
_ -> notEquality
where
dbv = toValue v
notEquality = fname DB.=: [showFilter filt DB.:= dbv]
nullEq = case dbv of
DB.Null -> orDollar DB.=:
[ [fname DB.:= DB.Null]
, [fname DB.:= DB.Doc [existsDollar DB.:= DB.Bool False]]
]
_ -> fname DB.:= dbv
nullNeq = case dbv of
DB.Null ->
fname DB.:= DB.Doc
[ showFilter Ne DB.:= DB.Null
, existsDollar DB.:= DB.Bool True
]
_ -> notEquality
showFilter Ne = "$ne"
showFilter Gt = "$gt"
showFilter Lt = "$lt"
showFilter Ge = "$gte"
showFilter Le = "$lte"
showFilter In = "$in"
showFilter NotIn = "$nin"
showFilter Eq = error "EQ filter not expected"
showFilter (BackendSpecificFilter bsf) = throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificFilter " ++ T.unpack bsf
mongoFilterToBSON :: forall typ. PersistField typ
=> Text
-> MongoFilterOperator typ
-> DB.Document
mongoFilterToBSON fname filt = case filt of
(PersistFilterOperator v op) -> [filterToBSON fname v op]
(MongoFilterOperator bval) -> [fname DB.:= bval]
mongoUpdateToBson :: forall typ. PersistField typ
=> Text
-> UpdateValueOp typ
-> DB.Field
mongoUpdateToBson fname upd = case upd of
UpdateValueOp (Left v) op -> updateToBson fname (toPersistValue v) op
UpdateValueOp (Right v) op -> updateToBson fname (PersistList $ map toPersistValue v) op
mongoUpdateToDoc :: PersistEntity record => MongoUpdate record -> DB.Field
mongoUpdateToDoc (NestedUpdate field op) = mongoUpdateToBson (nestedFieldName field) op
mongoUpdateToDoc (ArrayUpdate field op) = mongoUpdateToBson (fieldName field) op
mongoFilterToDoc :: PersistEntity record => MongoFilter record -> DB.Document
mongoFilterToDoc (NestedFilter field op) = mongoFilterToBSON (nestedFieldName field) op
mongoFilterToDoc (ArrayFilter field op) = mongoFilterToBSON (fieldName field) op
mongoFilterToDoc (NestedArrayFilter field op) = mongoFilterToBSON (nestedFieldName field) op
mongoFilterToDoc (RegExpFilter fn (reg, opts)) = [ fieldName fn DB.:= DB.RegEx (DB.Regex reg opts)]
nestedFieldName :: forall record typ. PersistEntity record => NestedField record typ -> Text
nestedFieldName = T.intercalate "." . nesFldName
where
nesFldName :: forall r1 r2. (PersistEntity r1) => NestedField r1 r2 -> [DB.Label]
nesFldName (nf1 `LastEmbFld` nf2) = [fieldName nf1, fieldName nf2]
nesFldName ( f1 `MidEmbFld` f2) = fieldName f1 : nesFldName f2
nesFldName ( f1 `MidNestFlds` f2) = fieldName f1 : nesFldName f2
nesFldName ( f1 `MidNestFldsNullable` f2) = fieldName f1 : nesFldName f2
nesFldName (nf1 `LastNestFld` nf2) = [fieldName nf1, fieldName nf2]
nesFldName (nf1 `LastNestFldNullable` nf2) = [fieldName nf1, fieldName nf2]
toValue :: forall a. PersistField a => FilterValue a -> DB.Value
toValue val =
case val of
FilterValue v -> DB.val $ toPersistValue v
UnsafeValue v -> DB.val $ toPersistValue v
FilterValues vs -> DB.val $ map toPersistValue vs
fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> DB.Label
fieldName f | fieldHaskell fd == HaskellName "Id" = id_
| otherwise = unDBName $ fieldDB $ fd
where
fd = persistFieldDef f
docToEntityEither :: forall record. (PersistEntity record) => DB.Document -> Either T.Text (Entity record)
docToEntityEither doc = entity
where
entDef = entityDef $ Just (getType entity)
entity = eitherFromPersistValues entDef doc
getType :: Either err (Entity ent) -> ent
getType = error "docToEntityEither/getType: never here"
docToEntityThrow :: forall m record. (Trans.MonadIO m, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => DB.Document -> m (Entity record)
docToEntityThrow doc =
case docToEntityEither doc of
Left s -> Trans.liftIO . throwIO $ PersistMarshalError $ s
Right entity -> return entity
fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => EntityDef -> [DB.Field] -> m (Entity record)
fromPersistValuesThrow entDef doc =
case eitherFromPersistValues entDef doc of
Left t -> Trans.liftIO . throwIO $ PersistMarshalError $
unHaskellName (entityHaskell entDef) `mappend` ": " `mappend` t
Right entity -> return entity
mapLeft :: (a -> c) -> Either a b -> Either c b
mapLeft _ (Right r) = Right r
mapLeft f (Left l) = Left (f l)
eitherFromPersistValues :: (PersistEntity record) => EntityDef -> [DB.Field] -> Either T.Text (Entity record)
eitherFromPersistValues entDef doc = case mKey of
Nothing -> addDetail $ Left $ "could not find _id field: "
Just kpv -> do
body <- addDetail (fromPersistValues (map snd $ orderPersistValues (toEmbedEntityDef entDef) castDoc))
key <- keyFromValues [kpv]
return $ Entity key body
where
addDetail :: Either Text a -> Either Text a
addDetail = mapLeft (\msg -> msg `mappend` " for doc: " `mappend` T.pack (show doc))
castDoc = assocListFromDoc doc
mKey = lookup id_ castDoc
orderPersistValues :: EmbedEntityDef -> [(Text, PersistValue)] -> [(Text, PersistValue)]
orderPersistValues entDef castDoc = reorder
where
castColumns = map nameAndEmbed (embeddedFields entDef)
nameAndEmbed fdef = (fieldToLabel fdef, emFieldEmbed fdef)
reorder :: [(Text, PersistValue)]
reorder = match castColumns castDoc []
where
match :: [(Text, Maybe EmbedEntityDef)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
-> [(Text, PersistValue)]
match [] _ values = values
match (column:columns) fields values =
let (found, unused) = matchOne fields []
in match columns unused $ values ++
[(fst column, nestedOrder (snd column) (snd found))]
where
nestedOrder (Just em) (PersistMap m) =
PersistMap $ orderPersistValues em m
nestedOrder (Just em) (PersistList l) =
PersistList $ map (nestedOrder (Just em)) l
nestedOrder _ found = found
matchOne (field:fs) tried =
if fst column == fst field
then (field, tried ++ fs)
else matchOne fs (field:tried)
matchOne [] tried = ((fst column, PersistNull), tried)
assocListFromDoc :: DB.Document -> [(Text, PersistValue)]
assocListFromDoc = Prelude.map (\f -> ( (DB.label f), cast (DB.value f) ) )
oidToPersistValue :: DB.ObjectId -> PersistValue
oidToPersistValue = PersistObjectId . Serialize.encode
oidToKey :: (ToBackendKey DB.MongoContext record) => DB.ObjectId -> Key record
oidToKey = fromBackendKey . MongoKey
persistObjectIdToDbOid :: PersistValue -> DB.ObjectId
persistObjectIdToDbOid (PersistObjectId k) = case Serialize.decode k of
Left msg -> throw $ PersistError $ T.pack $ "error decoding " ++ (show k) ++ ": " ++ msg
Right o -> o
persistObjectIdToDbOid _ = throw $ PersistInvalidField "expected PersistObjectId"
keyToOid :: ToBackendKey DB.MongoContext record => Key record -> DB.ObjectId
keyToOid = unMongoKey . toBackendKey
instance DB.Val PersistValue where
val (PersistInt64 x) = DB.Int64 x
val (PersistText x) = DB.String x
val (PersistDouble x) = DB.Float x
val (PersistBool x) = DB.Bool x
#ifdef HIGH_PRECISION_DATE
val (PersistUTCTime x) = DB.Int64 $ round $ 1000 * 1000 * 1000 * (utcTimeToPOSIXSeconds x)
#else
val (PersistUTCTime x) = DB.UTC x
#endif
val (PersistDay d) = DB.Int64 $ fromInteger $ toModifiedJulianDay d
val (PersistNull) = DB.Null
val (PersistList l) = DB.Array $ map DB.val l
val (PersistMap m) = DB.Doc $ map (\(k, v)-> (DB.=:) k v) m
val (PersistByteString x) = DB.Bin (DB.Binary x)
val x@(PersistObjectId _) = DB.ObjId $ persistObjectIdToDbOid x
val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "PersistTimeOfDay not implemented for the MongoDB backend. only PersistUTCTime currently implemented"
val (PersistRational _) = throw $ PersistMongoDBUnsupported "PersistRational not implemented for the MongoDB backend"
val (PersistArray a) = DB.val $ PersistList a
val (PersistDbSpecific _) = throw $ PersistMongoDBUnsupported "PersistDbSpecific not implemented for the MongoDB backend"
cast' (DB.Float x) = Just (PersistDouble x)
cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x
cast' (DB.Int64 x) = Just $ PersistInt64 x
cast' (DB.String x) = Just $ PersistText x
cast' (DB.Bool x) = Just $ PersistBool x
cast' (DB.UTC d) = Just $ PersistUTCTime d
cast' DB.Null = Just $ PersistNull
cast' (DB.Bin (DB.Binary b)) = Just $ PersistByteString b
cast' (DB.Fun (DB.Function f)) = Just $ PersistByteString f
cast' (DB.Uuid (DB.UUID uid)) = Just $ PersistByteString uid
cast' (DB.Md5 (DB.MD5 md5)) = Just $ PersistByteString md5
cast' (DB.UserDef (DB.UserDefined bs)) = Just $ PersistByteString bs
cast' (DB.RegEx (DB.Regex us1 us2)) = Just $ PersistByteString $ E.encodeUtf8 $ T.append us1 us2
cast' (DB.Doc doc) = Just $ PersistMap $ assocListFromDoc doc
cast' (DB.Array xs) = Just $ PersistList $ mapMaybe DB.cast' xs
cast' (DB.ObjId x) = Just $ oidToPersistValue x
cast' (DB.JavaScr _) = throw $ PersistMongoDBUnsupported "cast operation not supported for javascript"
cast' (DB.Sym _) = throw $ PersistMongoDBUnsupported "cast operation not supported for sym"
cast' (DB.Stamp _) = throw $ PersistMongoDBUnsupported "cast operation not supported for stamp"
cast' (DB.MinMax _) = throw $ PersistMongoDBUnsupported "cast operation not supported for minmax"
cast :: DB.Value -> PersistValue
cast = fromJust . DB.cast'
instance Serialize.Serialize DB.ObjectId where
put (DB.Oid w1 w2) = do Serialize.put w1
Serialize.put w2
get = do w1 <- Serialize.get
w2 <- Serialize.get
return (DB.Oid w1 w2)
dummyFromUnique :: Unique v -> v
dummyFromUnique _ = error "dummyFromUnique"
dummyFromFilts :: [Filter v] -> v
dummyFromFilts _ = error "dummyFromFilts"
data MongoAuth = MongoAuth DB.Username DB.Password deriving Show
data MongoConf = MongoConf
{ mgDatabase :: Text
, mgHost :: Text
, mgPort :: DB.PortID
, mgAuth :: Maybe MongoAuth
, mgAccessMode :: DB.AccessMode
, mgPoolStripes :: Int
, mgStripeConnections :: Int
, mgConnectionIdleTime :: NominalDiffTime
, mgReplicaSetConfig :: Maybe ReplicaSetConfig
} deriving Show
defaultHost :: Text
defaultHost = "127.0.0.1"
defaultAccessMode :: DB.AccessMode
defaultAccessMode = DB.ConfirmWrites ["w" DB.:= DB.Int32 1]
defaultPoolStripes, defaultStripeConnections :: Int
defaultPoolStripes = 1
defaultStripeConnections = 10
defaultConnectionIdleTime :: NominalDiffTime
defaultConnectionIdleTime = 20
defaultMongoConf :: Text -> MongoConf
defaultMongoConf dbName = MongoConf
{ mgDatabase = dbName
, mgHost = defaultHost
, mgPort = DB.defaultPort
, mgAuth = Nothing
, mgAccessMode = defaultAccessMode
, mgPoolStripes = defaultPoolStripes
, mgStripeConnections = defaultStripeConnections
, mgConnectionIdleTime = defaultConnectionIdleTime
, mgReplicaSetConfig = Nothing
}
data ReplicaSetConfig = ReplicaSetConfig DB.ReplicaSetName [DB.Host]
deriving Show
instance FromJSON MongoConf where
parseJSON v = modifyFailure ("Persistent: error loading MongoDB conf: " ++) $
flip (withObject "MongoConf") v $ \o ->do
db <- o .: "database"
host <- o .:? "host" .!= defaultHost
NoOrphanPortID port <- o .:? "port" .!= NoOrphanPortID DB.defaultPort
poolStripes <- o .:? "poolstripes" .!= defaultPoolStripes
stripeConnections <- o .:? "connections" .!= defaultStripeConnections
NoOrphanNominalDiffTime connectionIdleTime <- o .:? "connectionIdleTime" .!= NoOrphanNominalDiffTime defaultConnectionIdleTime
mUser <- o .:? "user"
mPass <- o .:? "password"
accessString <- o .:? "accessMode" .!= confirmWrites
mRsName <- o .:? "rsName"
rsSecondaires <- o .:? "rsSecondaries" .!= []
mPoolSize <- o .:? "poolsize"
case mPoolSize of
Nothing -> return ()
Just (_::Int) -> fail "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 <- case accessString of
"ReadStaleOk" -> return DB.ReadStaleOk
"UnconfirmedWrites" -> return DB.UnconfirmedWrites
"ConfirmWrites" -> return defaultAccessMode
badAccess -> fail $ "unknown accessMode: " ++ T.unpack badAccess
let rs = case (mRsName, rsSecondaires) of
(Nothing, []) -> Nothing
(Nothing, _) -> error "found rsSecondaries key. Also expected but did not find a rsName key"
(Just rsName, hosts) -> Just $ ReplicaSetConfig rsName $ fmap DB.readHostPort hosts
return MongoConf {
mgDatabase = db
, mgHost = host
, mgPort = port
, mgAuth =
case (mUser, mPass) of
(Just user, Just pass) -> Just (MongoAuth user pass)
_ -> Nothing
, mgPoolStripes = poolStripes
, mgStripeConnections = stripeConnections
, mgAccessMode = accessMode
, mgConnectionIdleTime = connectionIdleTime
, mgReplicaSetConfig = rs
}
where
confirmWrites = "ConfirmWrites"
instance PersistConfig MongoConf where
type PersistConfigBackend MongoConf = DB.Action
type PersistConfigPool MongoConf = ConnectionPool
createPoolConfig = createMongoPool
runPool c = runMongoDBPool (mgAccessMode c)
loadConfig = parseJSON
applyDockerEnv :: MongoConf -> IO MongoConf
applyDockerEnv mconf = do
mHost <- lookupEnv "MONGODB_PORT_27017_TCP_ADDR"
return $ case mHost of
Nothing -> mconf
Just h -> mconf { mgHost = T.pack h }
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
type MongoRegex = (Text, Text)
class PersistField typ => MongoRegexSearchable typ where
instance MongoRegexSearchable Text
instance MongoRegexSearchable rs => MongoRegexSearchable (Maybe rs)
instance MongoRegexSearchable rs => MongoRegexSearchable [rs]
(=~.) :: forall record searchable. (MongoRegexSearchable searchable, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => EntityField record searchable -> MongoRegex -> Filter record
fld =~. val = BackendFilter $ RegExpFilter fld val
data MongoFilterOperator typ = PersistFilterOperator (FilterValue typ) PersistFilter
| MongoFilterOperator DB.Value
data UpdateValueOp typ =
UpdateValueOp
(Either typ [typ])
(Either PersistUpdate MongoUpdateOperation)
deriving Show
data MongoUpdateOperation = MongoEach MongoUpdateOperator
| MongoSimple MongoUpdateOperator
deriving Show
data MongoUpdateOperator = MongoPush
| MongoPull
| MongoAddToSet
deriving Show
opToText :: MongoUpdateOperator -> Text
opToText MongoPush = "$push"
opToText MongoPull = "$pull"
opToText MongoAddToSet = "$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)
(->.) :: forall record emb typ. PersistEntity emb => EntityField record [emb] -> EntityField emb typ -> NestedField record typ
(->.) = LastEmbFld
(~>.) :: forall record typ emb. PersistEntity emb => EntityField record [emb] -> NestedField emb typ -> NestedField record typ
(~>.) = MidEmbFld
(&->.) :: forall record typ nest. PersistEntity nest => EntityField record nest -> EntityField nest typ -> NestedField record typ
(&->.) = LastNestFld
(?&->.) :: forall record typ nest. PersistEntity nest => EntityField record (Maybe nest) -> EntityField nest typ -> NestedField record typ
(?&->.) = LastNestFldNullable
(&~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val nes1 -> NestedField nes1 nes -> NestedField val nes
(&~>.) = MidNestFlds
(?&~>.) :: forall val nes nes1. PersistEntity nes1 => EntityField val (Maybe nes1) -> NestedField nes1 nes -> NestedField val nes
(?&~>.) = 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`
nestEq, nestNe, nestGe, nestLe, nestIn, nestNotIn :: forall record typ.
( PersistField typ , PersistEntityBackend record ~ DB.MongoContext)
=> NestedField record typ
-> typ
-> Filter record
nestEq = nestedFilterOp Eq
nestNe = nestedFilterOp Ne
nestGe = nestedFilterOp Ge
nestLe = nestedFilterOp Le
nestIn = nestedFilterOp In
nestNotIn = nestedFilterOp NotIn
nestedFilterOp :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => PersistFilter -> NestedField record typ -> typ -> Filter record
nestedFilterOp op nf v = BackendFilter $
NestedFilter nf $ PersistFilterOperator (FilterValue v) op
nestBsonEq :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => NestedField record typ -> DB.Value -> Filter record
nf `nestBsonEq` val = BackendFilter $
NestedFilter nf $ MongoFilterOperator val
anyEq :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => EntityField record [typ] -> typ -> Filter record
fld `anyEq` val = BackendFilter $
ArrayFilter fld $ PersistFilterOperator (FilterValue val) Eq
nestAnyEq :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => NestedField record [typ] -> typ -> Filter record
fld `nestAnyEq` val = BackendFilter $
NestedArrayFilter fld $ PersistFilterOperator (FilterValue val) Eq
anyBsonEq :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => EntityField record [typ] -> DB.Value -> Filter record
fld `anyBsonEq` val = BackendFilter $
ArrayFilter fld $ MongoFilterOperator val
nestSet, nestInc, nestDec, nestMul :: forall record typ.
( PersistField typ , PersistEntityBackend record ~ DB.MongoContext)
=> NestedField record typ
-> typ
-> Update record
nestSet = nestedUpdateOp Assign
nestInc = nestedUpdateOp Add
nestDec = nestedUpdateOp Subtract
nestMul = nestedUpdateOp Multiply
push, pull, addToSet :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => EntityField record [typ] -> typ -> Update record
fld `push` val = backendArrayOperation MongoPush fld val
fld `pull` val = backendArrayOperation MongoPull fld val
fld `addToSet` val = backendArrayOperation MongoAddToSet fld val
backendArrayOperation ::
forall record typ.
(PersistField typ, BackendSpecificUpdate (PersistEntityBackend record) record ~ MongoUpdate record)
=> MongoUpdateOperator -> EntityField record [typ] -> typ
-> Update record
backendArrayOperation op fld val = BackendUpdate $
ArrayUpdate fld $ UpdateValueOp (Left val) (Right $ MongoSimple op)
eachOp :: forall record typ.
( PersistField typ, PersistEntityBackend record ~ DB.MongoContext)
=> (EntityField record [typ] -> typ -> Update record)
-> EntityField record [typ] -> [typ]
-> Update record
eachOp haskellOp fld val = case haskellOp fld (error "eachOp: undefined") of
BackendUpdate (ArrayUpdate _ (UpdateValueOp (Left _) (Right (MongoSimple op)))) -> each op
BackendUpdate (ArrayUpdate{}) -> error "eachOp: unexpected ArrayUpdate"
BackendUpdate (NestedUpdate{}) -> error "eachOp: did not expect NestedUpdate"
Update{} -> error "eachOp: did not expect Update"
where
each op = BackendUpdate $ ArrayUpdate fld $
UpdateValueOp (Right val) (Right $ MongoEach op)
pullAll :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => EntityField record [typ] -> [typ] -> Update record
fld `pullAll` val = eachOp pull fld val
nestedUpdateOp :: forall record typ.
( PersistField typ
, PersistEntityBackend record ~ DB.MongoContext
) => PersistUpdate -> NestedField record typ -> typ -> Update record
nestedUpdateOp op nf v = BackendUpdate $
NestedUpdate nf $ UpdateValueOp (Left v) (Left op)
inList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v
f `inList` a = Filter (unsafeCoerce f) (FilterValues a) In
infix 4 `inList`
ninList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v
f `ninList` a = Filter (unsafeCoerce f) (FilterValues a) In
infix 4 `ninList`