persistent-mongoDB 1.0.1.0 → 2.13.1.0
raw patch · 8 files changed
Files
- ChangeLog.md +77/−0
- Database/Persist/MongoDB.hs +1502/−641
- persistent-mongoDB.cabal +60/−21
- test/EmbedTestMongo.hs +437/−0
- test/EntityEmbedTestMongo.hs +25/−0
- test/MongoInit.hs +107/−0
- test/RawMongoHelpers.hs +33/−0
- test/main.hs +157/−0
+ ChangeLog.md view
@@ -0,0 +1,77 @@+# Changelog for persistent-mongoDB++## 2.13.1.0++* Restore update write concern behavior with MongoDB Driver for MongoDB >= 6.0 [#1550](https://github.com/yesodweb/persistent/pull/1550)++## 2.13.0.2++* Fix behavioral compatibility with MongoDB Driver for MongoDB >= 6.0 [#1545](https://github.com/yesodweb/persistent/pull/1545)++## 2.13.0.1++* [#1367](https://github.com/yesodweb/persistent/pull/1367),+ [#1366](https://github.com/yesodweb/persistent/pull/1367),+ [#1338](https://github.com/yesodweb/persistent/pull/1338),+ [#1335](https://github.com/yesodweb/persistent/pull/1335)+ * Support GHC 9.2++## 2.13.0.0++* Fix persistent 2.13 changes [#1286](https://github.com/yesodweb/persistent/pull/1286)++## 2.12.0.0++* Decomposed `HaskellName` into `ConstraintNameHS`, `EntityNameHS`, `FieldNameHS`. Decomposed `DBName` into `ConstraintNameDB`, `EntityNameDB`, `FieldNameDB` respectively. [#1174](https://github.com/yesodweb/persistent/pull/1174)++## 2.11.0++* Naive implementation of `exists` function from `PersistQueryRead` type class using `count`. [#1131](https://github.com/yesodweb/persistent/pull/1131/files)++## 2.10.0.1++* Remove unnecessary deriving of Typeable [#1114](https://github.com/yesodweb/persistent/pull/1114)++## 2.10.0.0++* Fix `ninList` filter operator [#1058](https://github.com/yesodweb/persistent/pull/1058)++## 2.9.0.2++* Compatibility with latest mongoDB [#1012](https://github.com/yesodweb/persistent/pull/1012)++## 2.9.0.1++* Compatibility with latest persistent-template for test suite [#1002](https://github.com/yesodweb/persistent/pull/1002/files)++## 2.9.0++* Removed deprecated `entityToDocument`. Please use `recordToDocument` instead. [#894](https://github.com/yesodweb/persistent/pull/894)+* Removed deprecated `multiBsonEq`. Please use `anyBsonEq` instead. [#894](https://github.com/yesodweb/persistent/pull/894)+* Use `portID` from `mongoDB` instead of `network`. [#946](https://github.com/yesodweb/persistent/pull/946)++## 2.8.0++* Switch from `MonadBaseControl` to `MonadUnliftIO`++## 2.6.0++* Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613)+* Relax bounds for http-api-data++## 2.5++* changes for read/write typeclass split++## 2.1.4++* support http-api-data for url serialization++## 2.1.3++* Add list filtering functions `inList` and `ninList`++## 2.1.2++* Add `nestAnyEq` filter function+* Add `FromJSON` instance for `MongoConf`
Database/Persist/MongoDB.hs view
@@ -1,641 +1,1502 @@-{-# LANGUAGE CPP, PackageImports, OverloadedStrings, ScopedTypeVariables #-}-{-# LANGUAGE GeneralizedNewtypeDeriving, MultiParamTypeClasses #-}-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, FlexibleContexts #-}-{-# LANGUAGE RankNTypes, TypeFamilies #-}--{-# LANGUAGE UndecidableInstances #-} -- FIXME-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Database.Persist.MongoDB- (- -- * using connections- withMongoDBConn- , withMongoDBPool- , createMongoDBPool- , runMongoDBPool- , runMongoDBPoolDef- , ConnectionPool- , Connection- , MongoConf (..)- -- * Key conversion helpers- , keyToOid- , oidToKey- -- * Entity conversion- , entityToFields- , toInsertFields- , docToEntityEither- , docToEntityThrow- -- * network type- , HostName- -- * MongoDB driver types- , DB.Action- , DB.AccessMode(..)- , DB.master- , DB.slaveOk- , (DB.=:)- -- * Database.Persist- , module Database.Persist- ) where--import Database.Persist-import Database.Persist.EntityDef-import Database.Persist.Store-import Database.Persist.Query.Internal--import qualified Control.Monad.IO.Class as Trans-import Control.Exception (throw, throwIO)--import qualified Database.MongoDB as DB-import Database.MongoDB.Query (Database)-import Control.Applicative (Applicative)-import Network.Socket (HostName)-import Data.Maybe (mapMaybe, fromJust)-import qualified Data.Text as T-import Data.Text (Text)-import qualified Data.Text.Encoding as E-import qualified Data.Serialize as Serialize-import Web.PathPieces (PathPiece (..))-import Data.Conduit-import Control.Monad.Trans.Class (lift)-import Control.Monad.IO.Class (liftIO)-import Data.Aeson (Value (Object, Number), (.:), (.:?), (.!=), FromJSON(..))-import Control.Monad (mzero)-import Control.Monad.Trans.Control (MonadBaseControl)-import qualified Data.Conduit.Pool as Pool-import Data.Time (NominalDiffTime)-import Data.Attoparsec.Number--#ifdef DEBUG-import FileLocation (debug)-#endif--newtype NoOrphanNominalDiffTime = NoOrphanNominalDiffTime NominalDiffTime- deriving (Show, Eq, Num)--instance FromJSON NoOrphanNominalDiffTime where- parseJSON (Number (I x)) = (return . NoOrphanNominalDiffTime . fromInteger) x- parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x- parseJSON _ = fail "couldn't parse diff time"--data Connection = Connection DB.Pipe DB.Database-type ConnectionPool = Pool.Pool Connection--instance PathPiece (Key DB.Action entity) where- toPathPiece (Key pOid@(PersistObjectId _)) = -- T.pack $ show $ Serialize.encode bsonId- let oid = persistObjectIdToDbOid pOid- in T.pack $ show oid- toPathPiece k = throw $ PersistInvalidField $ T.pack $ "Invalid Key (expected PersistObjectId): " ++ show k-- fromPathPiece str =- case (reads $ (T.unpack str))::[(DB.ObjectId,String)] of- (parsed,_):[] -> Just $ Key $ PersistObjectId $ Serialize.encode parsed- _ -> Nothing---withMongoDBConn :: (Trans.MonadIO m, Applicative m) =>- Database -> HostName -> Maybe MongoAuth -> NominalDiffTime -> (ConnectionPool -> m b) -> m b-withMongoDBConn dbname hostname mauth connectionIdleTime = withMongoDBPool dbname hostname mauth 1 1 connectionIdleTime--createConnection :: Database -> HostName -> Maybe MongoAuth -> IO Connection-createConnection dbname hostname mAuth = do- pipe <- DB.runIOE $ DB.connect (DB.host hostname)- _ <- case mAuth of- Just (MongoAuth user pass) -> DB.access pipe DB.UnconfirmedWrites dbname (DB.auth user pass)- Nothing -> return undefined- return $ Connection pipe dbname--createMongoDBPool :: (Trans.MonadIO m, Applicative m) => Database -> HostName- -> 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 dbname hostname mAuth connectionPoolSize stripeSize connectionIdleTime = do- Trans.liftIO $ Pool.createPool- (createConnection dbname hostname mAuth)- (\(Connection pipe _) -> DB.close pipe)- connectionPoolSize- connectionIdleTime- stripeSize--withMongoDBPool :: (Trans.MonadIO m, Applicative m) =>- Database -> HostName -> Maybe MongoAuth -> Int -> Int -> NominalDiffTime -> (ConnectionPool -> m b) -> m b-withMongoDBPool dbname hostname mauth poolStripes stripeConnections connectionIdleTime connectionReader = do- pool <- createMongoDBPool dbname hostname mauth poolStripes stripeConnections connectionIdleTime- connectionReader pool--runMongoDBPool :: (Trans.MonadIO m, MonadBaseControl IO m) => DB.AccessMode -> DB.Action m a -> ConnectionPool -> m a-runMongoDBPool accessMode action pool =- Pool.withResource pool $ \(Connection pipe db) -> do- res <- DB.access pipe accessMode db action- either (Trans.liftIO . throwIO . PersistMongoDBError . T.pack . show) return res--runMongoDBPoolDef :: (Trans.MonadIO m, MonadBaseControl IO m) => DB.Action m a -> ConnectionPool -> m a-runMongoDBPoolDef = runMongoDBPool (DB.ConfirmWrites ["j" DB.=: True])--filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document-filterByKey k = [_id DB.=: keyToOid k]--queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query -queryByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) --selectByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Selection -selectByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity))--updateFields :: (PersistEntity val) => [Update val] -> [DB.Field]-updateFields upds = map updateToMongoField upds --updateToMongoField :: (PersistEntity val) => Update val -> DB.Field-updateToMongoField (Update field v up) =- opName DB.:= DB.Doc [( (unDBName $ fieldDB $ persistFieldDef field) DB.:= opValue)]- where - (opName, opValue) =- case (up, toPersistValue 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))- (Subtract, _) -> error "expected PersistInt64 for a subtraction"- (Multiply, _) -> throw $ PersistMongoDBUnsupported "multiply not supported"- (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported"---uniqSelector :: forall record. (PersistEntity record) => Unique record DB.Action -> [DB.Field]-uniqSelector uniq = zipWith (DB.:=)- (map (unDBName . snd) $ persistUniqueToFieldNames uniq)- (map DB.val (persistUniqueToValues uniq))---- | convert a PersistEntity into document fields.--- for inserts only: nulls are ignored so they will be unset in the document.--- 'entityToFields' includes nulls-toInsertFields :: forall record. (PersistEntity record) => record -> [DB.Field]-toInsertFields record = zipFilter (entityFields entity) (toPersistFields record)- where- zipFilter [] _ = []- zipFilter _ [] = []- zipFilter (e:efields) (p:pfields) = let pv = toPersistValue p in- if pv == PersistNull then zipFilter efields pfields- else (toLabel e DB.:= DB.val pv):zipFilter efields pfields- entity = entityDef record---- | convert a PersistEntity into document fields.--- unlike 'toInsertFields', nulls are included.-entityToFields :: forall record. (PersistEntity record) => record -> [DB.Field]-entityToFields record = zipIt (entityFields entity) (toPersistFields record)- where- zipIt [] _ = []- zipIt _ [] = []- zipIt (e:efields) (p:pfields) =- let pv = toPersistValue p- in (toLabel e DB.:= DB.val pv):zipIt efields pfields- entity = entityDef record--toLabel :: FieldDef -> Text-toLabel = unDBName . fieldDB--saveWithKey :: forall m record keyEntity. -- (Applicative m, Functor m, MonadBaseControl IO m,- (PersistEntity keyEntity, PersistEntity record)- => (record -> [DB.Field])- -> (DB.Collection -> DB.Document -> DB.Action m () )- -> Key DB.Action keyEntity- -> record- -> DB.Action m ()-saveWithKey entToFields dbSave key record =- dbSave (unDBName $ entityDB entity) ((keyToMongoIdField key):(entToFields record))- where- entity = entityDef record--instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore DB.Action m where- insert record = do- DB.ObjId oid <- DB.insert (unDBName $ entityDB entity) (toInsertFields record)- return $ oidToKey oid - where- entity = entityDef record-- insertKey k record = saveWithKey toInsertFields DB.insert_ k record-- repsert k record = saveWithKey entityToFields DB.save k record-- replace k record = do- DB.replace (selectByKey k t) (toInsertFields record)- return ()- where- t = entityDef record-- delete k =- DB.deleteOne DB.Select {- DB.coll = (unDBName $ entityDB t)- , DB.selector = filterByKey k- }- where- t = entityDef $ dummyFromKey k-- get k = do- d <- DB.findOne (queryByKey k t)- case d of- Nothing -> return Nothing- Just doc -> do- Entity _ ent <- fromPersistValuesThrow t doc- return $ Just ent- where- t = entityDef $ dummyFromKey k--instance MonadThrow m => MonadThrow (DB.Action m) where- monadThrow = lift . monadThrow--instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistUnique DB.Action m where- getBy uniq = do- mdoc <- DB.findOne $- (DB.select (uniqSelector uniq) (unDBName $ entityDB t))- case mdoc of- Nothing -> return Nothing- Just doc -> fmap Just $ fromPersistValuesThrow t doc- where- t = entityDef $ dummyFromUnique uniq-- deleteBy uniq =- DB.delete DB.Select {- DB.coll = unDBName $ entityDB t- , DB.selector = uniqSelector uniq- }- where- t = entityDef $ dummyFromUnique uniq--_id :: T.Text-_id = "_id"--keyToMongoIdField :: PersistEntity val => Key DB.Action val -> DB.Field-keyToMongoIdField k = _id DB.:= (DB.ObjId $ keyToOid k)---findAndModifyOne :: (Applicative m, Trans.MonadIO m)- => DB.Collection- -> DB.ObjectId -- ^ _id for query- -> [DB.Field] -- ^ updates- -> DB.Action m (Either String DB.Document)-findAndModifyOne coll objectId updates = do- result <- DB.runCommand [- "findAndModify" DB.:= DB.String coll,- "new" DB.:= DB.Bool True, -- return updated document, not original document- "query" DB.:= DB.Doc [_id DB.:= DB.ObjId objectId],- "update" DB.:= DB.Doc updates- ]- return $ case DB.lookup "err" (DB.at "lastErrorObject" result) result of- Just e -> Left e- Nothing -> case DB.lookup "value" result of- Nothing -> Left "no value field"- Just doc -> Right doc--instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistQuery DB.Action m where- update _ [] = return ()- update key upds =- DB.modify - (DB.Select [keyToMongoIdField key] (unDBName $ entityDB t))- $ updateFields upds- where- t = entityDef $ dummyFromKey key-- updateGet key upds = do- result <- findAndModifyOne (unDBName $ entityDB t)- (keyToOid key) (updateFields upds)- case result of- Left e -> err e- Right doc -> do- Entity _ ent <- fromPersistValuesThrow t doc- return ent- where- err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg- t = entityDef $ dummyFromKey key--- updateWhere _ [] = return ()- updateWhere filts upds =- DB.modify DB.Select {- DB.coll = (unDBName $ entityDB t)- , DB.selector = filtersToSelector filts- } $ updateFields upds- where- t = entityDef $ dummyFromFilts filts-- deleteWhere filts = do- DB.delete DB.Select {- DB.coll = (unDBName $ entityDB t)- , DB.selector = filtersToSelector filts- }- where- t = entityDef $ dummyFromFilts filts-- count filts = do- i <- DB.count query- return $ fromIntegral i- where- query = DB.select (filtersToSelector filts) (unDBName $ entityDB t)- t = entityDef $ dummyFromFilts filts-- selectSource filts opts = do- cursor <- lift $ lift $ DB.find $ makeQuery filts opts- pull cursor- where- pull cursor = do- mdoc <- lift $ lift $ DB.next cursor- case mdoc of- Nothing -> return ()- Just doc -> do- entity <- fromPersistValuesThrow t doc- yield entity- pull cursor- t = entityDef $ dummyFromFilts filts-- selectFirst filts opts = do- mdoc <- DB.findOne $ makeQuery filts opts- case mdoc of- Nothing -> return Nothing- Just doc -> fmap Just $ fromPersistValuesThrow t doc- where- t = entityDef $ dummyFromFilts filts-- selectKeys filts opts = do- cursor <- lift $ lift $ DB.find $ (makeQuery filts opts) {- DB.project = [_id DB.=: (1 :: Int)]- }- pull cursor- where- pull cursor = do- mdoc <- lift $ lift $ DB.next cursor- case mdoc of- Nothing -> return ()- Just [_id DB.:= DB.ObjId oid] -> do- yield $ oidToKey oid- pull 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 val => [Filter val] -> [SelectOpt val] -> DB.Query-makeQuery filts opts =- (DB.select (filtersToSelector filts) (unDBName $ entityDB t)) {- DB.limit = fromIntegral limit- , DB.skip = fromIntegral offset- , DB.sort = orders- }- where- t = entityDef $ dummyFromFilts filts- (limit, offset, orders') = limitOffsetOrder opts- orders = map orderClause orders'--filtersToSelector :: PersistEntity val => [Filter val] -> DB.Document-filtersToSelector filts = -#ifdef DEBUG- debug $-#endif- if null filts then [] else concatMap filterToDocument filts--multiFilter :: forall record. PersistEntity record => String -> [Filter record] -> [DB.Field]-multiFilter multi fs = [T.pack multi DB.:= DB.Array (map (DB.Doc . filterToDocument) fs)]--filterToDocument :: PersistEntity val => Filter val -> DB.Document-filterToDocument f =- case f of- Filter field v filt -> return $ case filt of- Eq -> fieldName field DB.:= toValue v- _ -> fieldName field DB.=: [(showFilter filt) DB.:= toValue v]- FilterOr [] -> -- Michael decided to follow Haskell's semantics, which seems reasonable to me.- -- in Haskell an empty or is a False- -- Perhaps there is a less hacky way of creating a query that always returns false?- ["$not" DB.=: ["$exists" DB.=: _id]]- FilterOr fs -> multiFilter "$or" fs- -- $and is usually unecessary but makes query construction easier in special cases- FilterAnd [] -> []- FilterAnd fs -> multiFilter "$and" fs- where- toValue :: forall a. PersistField a => Either a [a] -> DB.Value- toValue val =- case val of- Left v -> DB.val $ toPersistValue v- Right vs -> DB.val $ map toPersistValue vs-- 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---fieldName :: forall record typ. (PersistEntity record) => EntityField record typ -> DB.Label-fieldName = idfix . unDBName . fieldDB . persistFieldDef- where idfix f = if f == "id" then _id else f---docToEntityEither :: forall record. (PersistEntity record) => DB.Document -> Either T.Text (Entity record)-docToEntityEither doc = entity- where- entDef = entityDef (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) => 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) => EntityDef -> [DB.Field] -> m (Entity record)-fromPersistValuesThrow entDef doc = - case eitherFromPersistValues entDef doc of- Left s -> Trans.liftIO . throwIO $ PersistMarshalError $ s- Right entity -> return entity--eitherFromPersistValues :: (PersistEntity record) => EntityDef -> [DB.Field] -> Either T.Text (Entity record)-eitherFromPersistValues entDef doc =- -- normally the id is the first field: this is probably best even if worst case is worse- let mKey = lookup _id castDoc- in case mKey of- Nothing -> Left "could not find _id field"- Just key -> case fromPersistValues reorder of- Right body -> Right $ Entity (Key key) body- Left e -> Left e- where- castDoc = mapFromDoc doc- castColumns = map (unDBName . fieldDB) $ (entityFields entDef)- -- 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- --- -- TODO: the above 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.- reorder :: [PersistValue] - reorder = match castColumns castDoc []- where- match :: [T.Text] -> [(T.Text, PersistValue)] -> [PersistValue] -> [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- -- TODO: instead use a projection to avoid network overhead- match [] _ values = values- match (c:cs) fields values =- let (found, unused) = matchOne fields []- in match cs unused (values ++ [snd found])- where- matchOne (f:fs) tried =- if c == fst f then (f, tried ++ fs) else matchOne fs (f:tried)- -- a Nothing will not be inserted into the document as a null- -- so if we don't find our column it is a- -- this keeps the document size down- matchOne [] tried = ((c, PersistNull), tried)--mapFromDoc :: DB.Document -> [(Text, PersistValue)]-mapFromDoc = Prelude.map (\f -> ( (DB.label f), (fromJust . DB.cast') (DB.value f) ) )--oidToPersistValue :: DB.ObjectId -> PersistValue-oidToPersistValue = PersistObjectId . Serialize.encode--oidToKey :: (PersistEntity val) => DB.ObjectId -> Key DB.Action val-oidToKey = Key . oidToPersistValue--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 :: (PersistEntity val) => Key DB.Action val -> DB.ObjectId-keyToOid (Key k) = persistObjectIdToDbOid k--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- val (PersistUTCTime x) = DB.UTC x- val (PersistZonedTime (ZT x)) = DB.String $ T.pack $ show x- 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 (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"- val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"- 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 $ mapFromDoc 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"--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) --dummyFromKey :: Key DB.Action v -> v-dummyFromKey _ = error "dummyFromKey"-dummyFromUnique :: Unique v DB.Action -> v-dummyFromUnique _ = error "dummyFromUnique"-dummyFromFilts :: [Filter v] -> v-dummyFromFilts _ = error "dummyFromFilts"--data MongoAuth = MongoAuth DB.Username DB.Password--- | Information required to connect to a mongo database-data MongoConf = MongoConf- { mgDatabase :: Text- , mgHost :: Text- , mgAuth :: Maybe MongoAuth- , mgAccessMode :: DB.AccessMode- , mgPoolStripes :: Int- , mgStripeConnections :: Int- , mgConnectionIdleTime :: NominalDiffTime- }--instance PersistConfig MongoConf where- type PersistConfigBackend MongoConf = DB.Action- type PersistConfigPool MongoConf = ConnectionPool-- createPoolConfig c =- createMongoDBPool - (mgDatabase c) (T.unpack (mgHost c))- (mgAuth c)- (mgPoolStripes c) (mgStripeConnections c) (mgConnectionIdleTime c)-- runPool c = runMongoDBPool (mgAccessMode c)- loadConfig (Object o) = do- db <- o .: "database"- host <- o .:? "host" .!= "127.0.0.1"- poolStripes <- o .:? "poolstripes" .!= 1- stripeConnections <- o .: "connections"- (NoOrphanNominalDiffTime connectionIdleTime) <- o .:? "connectionIdleTime" .!= 20- mUser <- o .:? "user"- mPass <- o .:? "password"- accessString <- o .:? "accessMode" .!= "ConfirmWrites"-- 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 $ DB.ConfirmWrites ["j" DB.=: True]- badAccess -> fail $ "unknown accessMode: " ++ (T.unpack badAccess)-- return $ MongoConf {- mgDatabase = db- , mgHost = host- , mgAuth =- (case (mUser, mPass) of- (Just user, Just pass) -> Just (MongoAuth user pass)- _ -> Nothing- )- , mgPoolStripes = poolStripes- , mgStripeConnections = stripeConnections- , mgAccessMode = accessMode- , mgConnectionIdleTime = connectionIdleTime- }- where- {-- safeRead :: String -> T.Text -> MEither String Int- safeRead name t = case reads s of- (i, _):_ -> MRight i- [] -> MLeft $ concat ["Invalid value for ", name, ": ", s]- where- s = T.unpack t- -}- loadConfig _ = mzero+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# 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, (>=>), void)+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 = 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++-- | ToPathPiece is used to convert a key to/from text+instance PathPiece (BackendKey DB.MongoContext) where+ toPathPiece = toUrlPiece+ fromPathPiece = parseUrlPieceMaybe++keyToText :: BackendKey DB.MongoContext -> Text+keyToText = T.pack . show . unMongoKey++-- | Convert a Text to a Key+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 -- ^ 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 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 -- ^ 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 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++-- | 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 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++-- | run a pool created with 'createMongoDBPipePool'+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+++-- | use default 'AccessMode'+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}++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"+ -- Obviously this could be supported for floats by multiplying with 1/x+ (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+++-- | convert a unique key into a MongoDB document+toUniquesDoc :: forall record. (PersistEntity record) => Unique record -> [DB.Field]+toUniquesDoc uniq = zipWith (DB.:=)+ (map (unFieldNameDB . snd) $ NEL.toList $ persistUniqueToFieldNames uniq)+ (map DB.val (persistUniqueToValues 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 =+ zipFilter+ (embeddedFields $ toEmbedEntityDef entDef)+ (map toPersistValue $ toPersistFields record)+ where+ entDef = entityDef $ Just record+ zipFilter xs ys =+ map (\(fd, pv) ->+ fieldToLabel fd+ DB.:=+ embeddedVal pv+ )+ $ filter (\(_, pv) -> not $ isNull pv)+ $ zip xs ys+ where+ isNull PersistNull = True+ isNull (PersistMap m) = null m+ isNull (PersistList l) = null l+ isNull _ = 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 (PersistMap m) =+ DB.Doc $ fmap (\(k, v) -> k DB.:= DB.val v) $ m+ -- zipFilter fields $ map snd m+ embeddedVal (PersistList l) =+ DB.Array $ map embeddedVal 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 = unEntityNameDB . getEntityDBName . entityDef . Just++-- | convert a PersistEntity into document fields.+-- unlike 'toInsertDoc', nulls are included.+recordToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext)+ => record -> DB.Document+recordToDocument record = zipToDoc (map fieldDB $ getEntityFields 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 => [FieldNameDB] -> [a] -> [DB.Field]+zipToDoc [] _ = []+zipToDoc _ [] = []+zipToDoc (e:efields) (p:pfields) =+ let pv = toPersistValue p+ in (unFieldNameDB e DB.:= DB.val pv):zipToDoc efields pfields++fieldToLabel :: EmbedFieldDef -> Text+fieldToLabel = unFieldNameDB . 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]++-- | 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 (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+ -- should these be exported from Types/Base.hs ?+ headMay [] = Nothing+ headMay (x:_) = Just 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 l i = BS.unfoldr (\l' -> if l' < 0 then Nothing else Just (fromIntegral (i `shiftR` l'), l' - 8)) (l-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 { 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 =+ void $ DB.updateMany+ (collectionName record)+ [(keyToMongoDoc k, documentFromEntity (Entity k record), [DB.Upsert])]++ replace k record =+ -- replace a single matching document+ void $ DB.updateMany+ (collectionNameFromKey k)+ [(keyToMongoDoc k, recordToDocument record, [])]++ delete k =+ void $ DB.deleteMany+ (collectionNameFromKey k)+ [(keyToMongoDoc k, [DB.SingleRemove])]++ update _ [] = return ()+ update key upds =+ void $ DB.updateMany+ (collectionNameFromKey key)+ [(keyToMongoDoc key, updatesToDoc upds, [DB.MultiUpdate])]++ updateGet key upds = do+ context <- ask+ result <- liftIO $ runReaderT (DB.findAndModify (queryByKey key) (updatesToDoc upds)) context+ either err instantiate result+ where+ instantiate doc = do+ rec <- entityVal <$> 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+ ent <- entityVal <$> 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 =+ void $ DB.deleteMany+ (collectionName $ dummyFromUnique uniq)+ [(toUniquesDoc uniq, [DB.SingleRemove])]++ upsert newRecord upds = do+ uniq <- onlyUnique newRecord+ upsertBy uniq newRecord 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 uniq newRecord upds = do+ let uniqueDoc = toUniquesDoc uniq :: [DB.Field]+ let uniqKeys = map DB.label uniqueDoc :: [DB.Label]+ mdoc <- getBy uniq+ let updateOrUpsert = case mdoc of+ Nothing ->+ let insDoc = DB.exclude uniqKeys $ toInsertDoc newRecord :: DB.Document+ in [(uniqueDoc, ["$setOnInsert" DB.=: insDoc], [DB.Upsert])]+ Just _ ->+ [(uniqueDoc, DB.exclude uniqKeys $ updatesToDoc upds, [DB.MultiUpdate])]+ unless (null upds) . void $ DB.updateMany (collectionName newRecord) updateOrUpsert+ newMdoc <- getBy uniq+ case newMdoc of+ Nothing -> err "possible race condition: getBy found Nothing"+ Just doc -> return doc+ where+ err = Trans.liftIO . throwIO . 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_ = "_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 k = case entityPrimary $ entityDefFromKey k of+ Nothing -> zipToDoc [FieldNameDB id_] values+ Just pdef -> [id_ DB.=: zipToDoc (primaryNames pdef) values]+ where+ primaryNames = map fieldDB . NEL.toList . 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 (getEntityFields eDef)+ where+ toField :: FieldDef -> DB.Field+ toField fDef = (unFieldNameDB (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 =+ void $ DB.updateMany+ (collectionName $ dummyFromFilts filts)+ [(filtersToDoc filts, updatesToDoc upds, [DB.MultiUpdate])]++ deleteWhere filts =+ void $ DB.deleteMany+ (collectionName $ dummyFromFilts filts)+ [ (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++ exists filts = do+ cnt <- count filts+ pure (cnt > 0)++ -- | uses cursor option NoCursorTimeout+ -- and explicitly closes the cursor when done+ 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.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++ 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+ -- 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 fs -> multiFilter OrDollar 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 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+ -- a $or must have at least 2 items+ (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 == FieldNameHS "Id" = id_+ | otherwise = unFieldNameDB $ 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 $+ unEntityNameHS (getEntityHaskellName 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+ -- normally _id is the first field+ mKey = lookup id_ 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 entDef castDoc =+ match castColumns castDoc []+ where+ castColumns =+ map nameAndEmbed (embeddedFields entDef)+ nameAndEmbed fdef =+ (fieldToLabel fdef, emFieldEmbed 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 [] _ values = values+ match ((fName, medef) : columns) fields values =+ let+ ((_, pv) , unused) =+ matchOne fields []+ in+ match columns unused $+ values ++ [(fName, nestedOrder medef 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 (Just em) (PersistList l) = PersistList $ map (nestedOrder (Just em)) l+ nestedOrder _ found = found++ matchOne (field:fs) tried =+ if fName == fst field+ then (field, tried ++ fs)+ else matchOne fs (field: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 [] tried = ((fName, 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+ -- this is just millisecond precision: https://jira.mongodb.org/browse/SERVER-1460+ 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"+ val (PersistLiteral_ _ _) = throw $ PersistMongoDBUnsupported "PersistLiteral 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+-- 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 = 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++-- | Information required to connect to a mongo database+data MongoConf = MongoConf+ { mgDatabase :: Text+ , mgHost :: Text+ , mgPort :: DB.PortID+ , mgAuth :: Maybe MongoAuth+ , mgAccessMode :: DB.AccessMode+ , mgPoolStripes :: Int+ , mgStripeConnections :: Int+ , mgConnectionIdleTime :: NominalDiffTime+ -- | YAML fields for this are @rsName@ and @rsSecondaries@+ -- mgHost is assumed to be the primary+ , 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++-- | docker integration: change the host to the mongodb link+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 }+++-- ---------------------------+-- * 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+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)++-- | 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+(->.) = 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+(~>.) = 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+(&->.) = 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+(?&->.) = 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+(&~>.) = 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+(?&~>.) = 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 = 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++-- | 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+nf `nestBsonEq` val = BackendFilter $+ NestedFilter nf $ MongoFilterOperator 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+fld `anyEq` val = BackendFilter $+ ArrayFilter fld $ PersistFilterOperator (FilterValue val) 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+fld `nestAnyEq` val = BackendFilter $+ NestedArrayFilter fld $ PersistFilterOperator (FilterValue val) 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+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)++-- | 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 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)++-- | Intersection of lists: if any value in the field is found in the list.+inList :: PersistField typ => EntityField v [typ] -> [typ] -> Filter v+f `inList` a = Filter (unsafeCoerce f) (FilterValues a) 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+f `ninList` a = Filter (unsafeCoerce f) (FilterValues a) NotIn+infix 4 `ninList`
persistent-mongoDB.cabal view
@@ -1,39 +1,78 @@ name: persistent-mongoDB-version: 1.0.1.0+version: 2.13.1.0 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>-maintainer: Greg Weber <greg@gregweber.info>+maintainer: Andres Schmois <andres@itpro.tv> synopsis: Backend for the persistent library using mongoDB. category: Database stability: Experimental-cabal-version: >= 1.6+cabal-version: >= 1.10 build-type: Simple homepage: http://www.yesodweb.com/book/persistent-description: Backend for the persistent library using mongoDB.+bug-reports: https://github.com/yesodweb/persistent/issues+description: MongoDB backend for the persistent library.+extra-source-files: ChangeLog.md +Flag high_precision_date+ Description: for MongoDB use a time storage with nano second precision.+ Default: False+ library- build-depends: base >= 4 && < 5- , persistent >= 1.0 && < 1.1- , text >= 0.8- , transformers >= 0.2.1- , containers >= 0.2- , bytestring >= 0.9- , conduit >= 0.5 && < 0.6- , resourcet >= 0.3 && < 0.5- , mongoDB >= 1.3 && < 1.4- , bson >= 0.2 && < 0.3- , network >= 2.2.1.7 && < 3- , cereal >= 0.3.0.0- , path-pieces >= 0.1 && < 0.2- , monad-control >= 0.3 && < 0.4- , aeson >= 0.5- , attoparsec- , pool-conduit >= 0.1 && < 0.2+ build-depends: base >= 4.8 && < 5+ , persistent >= 2.12 && < 3+ , aeson >= 1.0+ , bson >= 0.3.2 && < 0.5+ , bytestring+ , cereal >= 0.5+ , conduit >= 1.2+ , http-api-data >= 0.3.7 && < 0.7+ , mongoDB >= 2.7.1.2 && < 2.8+ , network >= 2.6+ , path-pieces >= 0.2+ , resource-pool >= 0.2 && < 0.5+ , resourcet >= 1.1+ , text >= 1.2 , time+ , transformers >= 0.5+ , unliftio-core exposed-modules: Database.Persist.MongoDB ghc-options: -Wall+ default-language: Haskell2010++ if flag(high_precision_date)+ cpp-options: -DHIGH_PRECISION_DATE++test-suite test+ type: exitcode-stdio-1.0+ main-is: main.hs+ hs-source-dirs: test+ other-modules: MongoInit+ EmbedTestMongo+ EntityEmbedTestMongo+ RawMongoHelpers+ ghc-options: -Wall++ build-depends: base >= 4.6 && < 5+ , persistent+ , persistent-mongoDB+ , persistent-qq+ , persistent-test+ , blaze-html+ , bytestring+ , containers+ , hspec >= 2.4.0+ , HUnit+ , mongoDB+ , process+ , QuickCheck+ , template-haskell+ , text+ , time+ , transformers+ , unliftio-core+ default-language: Haskell2010 source-repository head type: git
+ test/EmbedTestMongo.hs view
@@ -0,0 +1,437 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DataKinds, ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# OPTIONS_GHC -Wno-unused-top-binds -Wno-orphans -O0 #-}+module EmbedTestMongo (specs) where++import MongoInit++import Control.Exception (Exception, throw)+import Data.List.NonEmpty hiding (insert, length)+import qualified Data.Map as M+import qualified Data.Set as S+import qualified Data.Text as T+import Database.MongoDB (genObjectId)+import Database.MongoDB (Value(String))+import System.Process (readProcess)++import EntityEmbedTestMongo+import Database.Persist.MongoDB++data TestException = TestException+ deriving (Show, Eq)+instance Exception TestException++instance PersistFieldSql a => PersistFieldSql (NonEmpty a) where+ sqlType _ = SqlString++instance PersistField a => PersistField (NonEmpty a) where+ toPersistValue = toPersistValue . toList+ fromPersistValue pv = do+ list <- fromPersistValue pv+ case list of+ [] -> Left "PersistField: NonEmpty found unexpected Empty List"+ (l:ls) -> Right (l:|ls)+++mkPersist persistSettings [persistUpperCase|+ HasObjectId+ oid ObjectId+ name Text+ deriving Show Eq Read Ord++ HasArrayWithObjectIds+ name Text+ arrayWithObjectIds [HasObjectId]+ deriving Show Eq Read Ord++ HasArrayWithEntities+ hasEntity (Entity ARecord)+ arrayWithEntities [AnEntity]+ deriving Show Eq Read Ord++ OnlyName+ name Text+ deriving Show Eq Read Ord++ HasEmbed+ name Text+ embed OnlyName+ deriving Show Eq Read Ord++ HasEmbeds+ name Text+ embed OnlyName+ double HasEmbed+ deriving Show Eq Read Ord++ HasListEmbed+ name Text+ list [HasEmbed]+ deriving Show Eq Read Ord++ HasSetEmbed+ name Text+ set (S.Set HasEmbed)+ deriving Show Eq Read Ord++ HasMap+ name Text+ map (M.Map T.Text T.Text)+ deriving Show Eq Read Ord++ HasList+ list [HasListId]+ deriving Show Eq Read Ord++ EmbedsHasMap+ name Text Maybe+ embed HasMap+ deriving Show Eq Read Ord++ InList+ one Int+ two Int+ deriving Show Eq++ ListEmbed+ nested [InList]+ one Int+ two Int+ deriving Show Eq++ User+ ident Text+ password Text Maybe+ profile Profile+ deriving Show Eq Read Ord++ Profile+ firstName Text+ lastName Text+ contact Contact Maybe+ deriving Show Eq Read Ord++ Contact+ phone Int+ email T.Text+ deriving Show Eq Read Ord++ Account+ userIds (NonEmpty (Key User))+ name Text Maybe+ customDomains [Text] -- we may want to allow multiple cust domains. use [] instead of maybe++ deriving Show Eq Read Ord++ HasNestedList+ list [IntList]+ deriving Show Eq++ IntList+ ints [Int]+ deriving Show Eq++ -- We would like to be able to use OnlyNameId+ -- But (Key OnlyName) works+ MapIdValue+ map (M.Map T.Text (Key OnlyName))+ deriving Show Eq Read Ord+++ -- Self refrences are only allowed as a nullable type:+ -- a Maybe or a List+ SelfList+ reference [SelfList]++ SelfMaybe+ reference SelfMaybe Maybe++ -- This failes+ -- SelfDirect+ -- reference SelfDirect+|]++cleanDB :: (PersistQuery backend, PersistEntityBackend HasMap ~ backend, MonadIO m) => ReaderT backend m ()+cleanDB = do+ deleteWhere ([] :: [Filter HasEmbed])+ deleteWhere ([] :: [Filter HasEmbeds])+ deleteWhere ([] :: [Filter HasListEmbed])+ deleteWhere ([] :: [Filter HasSetEmbed])+ deleteWhere ([] :: [Filter User])+ deleteWhere ([] :: [Filter HasMap])+ deleteWhere ([] :: [Filter HasList])+ deleteWhere ([] :: [Filter EmbedsHasMap])+ deleteWhere ([] :: [Filter ListEmbed])+ deleteWhere ([] :: [Filter ARecord])+ deleteWhere ([] :: [Filter Account])+ deleteWhere ([] :: [Filter HasNestedList])++db :: Action IO () -> Assertion+db = db' cleanDB++unlessM :: MonadIO m => IO Bool -> m () -> m ()+unlessM predicate body = do+ b <- liftIO predicate+ unless b body++specs :: Spec+specs = describe "embedded entities" $ do++ it "simple entities" $ db $ do+ let container = HasEmbeds "container" (OnlyName "2")+ (HasEmbed "embed" (OnlyName "1"))+ contK <- insert container+ Just res <- selectFirst [HasEmbedsName ==. "container"] []+ res @== Entity contK container++ it "query for equality of embeded entity" $ db $ do+ let container = HasEmbed "container" (OnlyName "2")+ contK <- insert container+ Just res <- selectFirst [HasEmbedEmbed ==. OnlyName "2"] []+ res @== Entity contK container++ it "Set" $ db $ do+ let container = HasSetEmbed "set" $ S.fromList+ [ HasEmbed "embed" (OnlyName "1")+ , HasEmbed "embed" (OnlyName "2")+ ]+ contK <- insert container+ Just res <- selectFirst [HasSetEmbedName ==. "set"] []+ res @== Entity contK container++ it "Set empty" $ db $ do+ let container = HasSetEmbed "set empty" $ S.fromList []+ contK <- insert container+ Just res <- selectFirst [HasSetEmbedName ==. "set empty"] []+ res @== Entity contK container++ it "exception" $ flip shouldThrow (== TestException) $ db $ do+ let container = HasSetEmbed "set" $ S.fromList+ [ HasEmbed "embed" (OnlyName "1")+ , HasEmbed "embed" (OnlyName "2")+ ]+ contK <- insert container+ Just res <- selectFirst [HasSetEmbedName ==. throw TestException] []+ res @== Entity contK container++ it "ListEmbed" $ db $ do+ let container = HasListEmbed "list"+ [ HasEmbed "embed" (OnlyName "1")+ , HasEmbed "embed" (OnlyName "2")+ ]+ contK <- insert container+ Just res <- selectFirst [HasListEmbedName ==. "list"] []+ res @== Entity contK container++ it "ListEmbed empty" $ db $ do+ let container = HasListEmbed "list empty" []+ contK <- insert container+ Just res <- selectFirst [HasListEmbedName ==. "list empty"] []+ res @== Entity contK container++ it "List empty" $ db $ do+ let container = HasList []+ contK <- insert container+ Just res <- selectFirst [] []+ res @== Entity contK container++ it "NonEmpty List wrapper" $ db $ do+ let con = Contact 123456 "foo@bar.com"+ let prof = Profile "fstN" "lstN" (Just con)+ uid <- insert $ User "foo" (Just "pswd") prof+ let container = Account (uid:|[]) (Just "Account") []+ contK <- insert container+ Just res <- selectFirst [AccountUserIds ==. (uid:|[])] []+ res @== Entity contK container++ it "Map" $ db $ do+ let container = HasMap "2 items" $ M.fromList [+ ("k1","v1")+ , ("k2","v2")+ ]+ contK <- insert container+ Just res <- selectFirst [HasMapName ==. "2 items"] []+ res @== Entity contK container++ it "Map empty" $ db $ do+ let container = HasMap "empty" $ M.fromList []+ contK <- insert container+ Just res <- selectFirst [HasMapName ==. "empty"] []+ res @== Entity contK container++ it "Embeds a Map" $ db $ do+ let container = EmbedsHasMap (Just "non-empty map") $ HasMap "2 items" $ M.fromList [+ ("k1","v1")+ , ("k2","v2")+ ]+ contK <- insert container+ Just res <- selectFirst [EmbedsHasMapName ==. Just "non-empty map"] []+ res @== Entity contK container++ it "Embeds a Map empty" $ db $ do+ let container = EmbedsHasMap (Just "empty map") $ HasMap "empty" $ M.fromList []+ contK <- insert container+ Just res <- selectFirst [EmbedsHasMapName ==. Just "empty map"] []+ res @== Entity contK container++ it "Embeds a Map with ids as values" $ db $ do+ onId <- insert $ OnlyName "nombre"+ onId2 <- insert $ OnlyName "nombre2"+ let midValue = MapIdValue $ M.fromList [("foo", onId),("bar",onId2)]+ mK <- insert midValue+ Just mv <- get mK+ mv @== midValue++ it "List" $ db $ do+ k1 <- insert $ HasList []+ k2 <- insert $ HasList [k1]+ let container = HasList [k1, k2]+ contK <- insert container+ Just res <- selectFirst [HasListList `anyEq` k2] []+ res @== Entity contK container++ it "can embed an Entity" $ db $ do+ let foo = ARecord "foo"+ bar = ARecord "bar"+ insertMany_ [foo, bar]+ arecords <- selectList ([ARecordName ==. "foo"] ||. [ARecordName ==. "bar"]) []+ length arecords @== 2++ kfoo <- insert foo+ let hasEnts = HasArrayWithEntities (Entity kfoo foo) arecords+ kEnts <- insert hasEnts+ Just retrievedHasEnts <- get kEnts+ retrievedHasEnts @== hasEnts++ it "can embed objects with ObjectIds" $ db $ do+ oid <- liftIO $ genObjectId+ let hoid = HasObjectId oid "oid"+ hasArr = HasArrayWithObjectIds "array" [hoid]++ k <- insert hasArr+ Just v <- get k+ v @== hasArr++ describe "mongoDB filters" $ do+ it "mongo single nesting filters" $ db $ do+ let usr = User "foo" (Just "pswd") prof+ prof = Profile "fstN" "lstN" (Just con)+ con = Contact 123456 "foo@bar.com"+ uId <- insert usr+ Just r1 <- selectFirst [UserProfile &->. ProfileFirstName `nestEq` "fstN"] []+ r1 @== (Entity uId usr)+ Just r2 <- selectFirst [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestEq` "foo@bar.com", UserIdent ==. "foo"] []+ r2 @== (Entity uId usr)++ it "mongo embedded array filters" $ db $ do+ let container = HasListEmbed "list" [+ (HasEmbed "embed" (OnlyName "1"))+ , (HasEmbed "embed" (OnlyName "2"))+ ]+ contK <- insert container+ let contEnt = Entity contK container+ Just meq <- selectFirst [HasListEmbedList `anyEq` HasEmbed "embed" (OnlyName "1")] []+ meq @== contEnt++ Just neq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestEq` "embed"] []+ neq1 @== contEnt++ Just nne1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestNe` "notEmbed"] []+ nne1 @== contEnt++ Just neq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestEq` "1"] []+ neq2 @== contEnt++ Just nbq1 <- selectFirst [HasListEmbedList ->. HasEmbedName `nestBsonEq` String "embed"] []+ nbq1 @== contEnt++ Just nbq2 <- selectFirst [HasListEmbedList ~>. HasEmbedEmbed &->. OnlyNameName `nestBsonEq` String "1"] []+ nbq2 @== contEnt++ it "regexp match" $ db $ do+ let container = HasListEmbed "list" [+ (HasEmbed "embed" (OnlyName "abcd"))+ , (HasEmbed "embed" (OnlyName "efgh"))+ ]+ contK <- insert container+ let mkReg t = (t, "ims")+ Just res <- selectFirst [HasListEmbedName =~. mkReg "ist"] []+ res @== (Entity contK container)++ it "nested anyEq" $ db $ do+ let top = HasNestedList [IntList [1,2]]+ k <- insert top+ Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestEq` ([]::[Int])] []+ Nothing <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 3] []+ Just res <- selectFirst [HasNestedListList ->. IntListInts `nestAnyEq` 2] []+ res @== (Entity k top)++ describe "mongoDB updates" $ do+ it "mongo single nesting updates" $ db $ do+ let usr = User "foo" (Just "pswd") prof+ prof = Profile "fstN" "lstN" (Just con)+ con = Contact 123456 "foo@bar.com"+ uid <- insert usr+ let newName = "fstN2"+ usr1 <- updateGet uid [UserProfile &->. ProfileFirstName `nestSet` newName]+ (profileFirstName $ userProfile usr1) @== newName++ let newEmail = "foo@example.com"+ let newIdent = "bar"+ usr2 <- updateGet uid [UserProfile &~>. ProfileContact ?&->. ContactEmail `nestSet` newEmail, UserIdent =. newIdent]+ (userIdent usr2) @== newIdent+ (fmap contactEmail . profileContact . userProfile $ usr2) @== Just newEmail+++ it "mongo embedded array updates" $ db $ do+ let container = HasListEmbed "list" [+ (HasEmbed "embed" (OnlyName "1"))+ , (HasEmbed "embed" (OnlyName "2"))+ ]+ contk <- insert container+ let _contEnt = Entity contk container++ pushed <- updateGet contk [HasListEmbedList `push` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pushed) @== ["1","2","3"]++ -- same, don't add anything+ addedToSet <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet) @== ["1","2","3"]+ pulled <- updateGet contk [HasListEmbedList `pull` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList pulled) @== ["1","2"]++ -- now it is new+ addedToSet2 <- updateGet contk [HasListEmbedList `addToSet` HasEmbed "embed" (OnlyName "3")]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList addedToSet2) @== ["1","2","3"]++ allPulled <- updateGet contk [eachOp pull HasListEmbedList+ [ HasEmbed "embed" (OnlyName "3")+ , HasEmbed "embed" (OnlyName "2")+ ] ]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPulled) @== ["1"]+ allPushed <- updateGet contk [eachOp push HasListEmbedList+ [ HasEmbed "embed" (OnlyName "4")+ , HasEmbed "embed" (OnlyName "5")+ ] ]+ (Prelude.map (onlyNameName . hasEmbedEmbed) $ hasListEmbedList allPushed) @== ["1","4","5"]+++ it "re-orders json inserted from another source" $ db $ do+ liftIO $ pendingWith "mongoimport fails on GitHub CI"+ let cname = T.unpack $ collectionName (error "ListEmbed" :: ListEmbed)+ liftIO $ putStrLn =<< readProcess "mongoimport" ["-d", T.unpack dbName, "-c", cname] "{ \"nested\": [{ \"one\": 1, \"two\": 2 }, { \"two\": 2, \"one\": 1}], \"two\": 2, \"one\": 1, \"_id\" : { \"$oid\" : \"50184f5a92d7ae0000001e89\" } }"++ lists <- selectList [] []+ fmap entityVal lists @== [ListEmbed [InList 1 2, InList 1 2] 1 2]
+ test/EntityEmbedTestMongo.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE DataKinds, ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StandaloneDeriving #-}+module EntityEmbedTestMongo where++-- because we are using a type alias we need to declare in a separate module+-- this is used in EmbedTest+import MongoInit++mkPersist persistSettings [persistUpperCase|+ ARecord+ name Text+ deriving Show Eq Read Ord+|]++type AnEntity = Entity ARecord
+ test/MongoInit.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- We create an orphan instance for GenerateKey here to avoid a circular+-- dependency between:+--+-- a) persistent-mongoDB:test depends on+-- b) persistent-test:lib depends on+-- c) persistent-mongODB:lib+--+-- This kind of cycle is all kinds of bad news.++module MongoInit (+ BackendMonad+ , runConn+ , MonadIO+ , persistSettings+ , MkPersistSettings (..)+ , dbName+ , db'+ , setup+ , mkPersistSettings+ , Action+ , Context+ , BackendKey(MongoKey)++ -- re-exports+ , module Database.Persist+ , module Database.Persist.Sql.Raw.QQ+ , module Test.Hspec+ , module Test.HUnit+ , liftIO+ , mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase+ , Int32, Int64+ , Text+ , module Control.Monad.Trans.Reader+ , module Control.Monad+ , PersistFieldSql(..)+ , BS.ByteString+ , SomeException+ , module Init+ ) where++-- we have to be careful with this import becuase CPP is still a problem+import Init+ ( TestFn(..), truncateTimeOfDay, truncateUTCTime+ , truncateToMicro, arbText, liftA2, GenerateKey(..)+ , (@/=), (@==), (==@)+ , assertNotEqual, assertNotEmpty, assertEmpty, asIO+ , isTravis+ )++-- re-exports+import Control.Exception (SomeException)+import Control.Monad (void, replicateM, liftM, when, forM_)+import Control.Monad.Trans.Reader+import Database.Persist.TH (mkPersist, mkMigrate, share, sqlSettings, persistLowerCase, persistUpperCase, MkPersistSettings(..))+import Database.Persist.Sql.Raw.QQ+import Test.Hspec++-- testing+import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool)++import Control.Monad (unless, (>=>))+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO)+import qualified Data.ByteString as BS+import Data.Int (Int32, Int64)+import Data.Text (Text)+import qualified Database.MongoDB as MongoDB+import Database.Persist.MongoDB (Action, withMongoPool, runMongoDBPool, defaultMongoConf, applyDockerEnv, BackendKey(..))+import Language.Haskell.TH.Syntax (Type(..))++import Database.Persist+import Database.Persist.Sql (PersistFieldSql(..))+import Database.Persist.TH (mkPersistSettings)++setup :: Action IO ()+setup = setupMongo+type Context = MongoDB.MongoContext++_debugOn :: Bool+_debugOn = True++persistSettings :: MkPersistSettings+persistSettings = (mkPersistSettings $ ConT ''Context) { mpsGeneric = True }++dbName :: Text+dbName = "persistent"++type BackendMonad = Context++runConn :: MonadUnliftIO m => Action m backend -> m ()+runConn f = do+ conf <- liftIO $ applyDockerEnv $ defaultMongoConf dbName -- { mgRsPrimary = Just "replicaset" }+ void $ withMongoPool conf $ runMongoDBPool MongoDB.master f++setupMongo :: Action IO ()+setupMongo = void $ MongoDB.dropDatabase dbName++db' :: Action IO () -> Action IO () -> Assertion+db' actions cleanDB = do+ r <- runConn (actions >> cleanDB)+ return r++instance GenerateKey MongoDB.MongoContext where+ generateKey = MongoKey `liftM` MongoDB.genObjectId
+ test/RawMongoHelpers.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE OverloadedStrings #-}+module RawMongoHelpers where++import qualified Database.MongoDB as MongoDB+import Database.Persist.MongoDB (toInsertDoc, docToEntityThrow, collectionName, recordToDocument)++import MongoInit+import PersistentTest (cleanDB)+import PersistentTestModels+++db :: ReaderT MongoDB.MongoContext IO () -> IO ()+db = db' cleanDB++specs :: Spec+specs = do+ describe "raw MongoDB helpers" $ do+ it "collectionName" $ do+ collectionName (Person "Duder" 0 Nothing) @?= "Person"++ it "toInsertFields, entityFields, & docToEntityThrow" $ db $ do+ let p1 = Person "Duder" 0 Nothing+ let doc = toInsertDoc p1+ MongoDB.ObjId _id <- MongoDB.insert "Person" $ doc+ let idSelector = "_id" MongoDB.=: _id+ Entity _ ent1 <- docToEntityThrow $ idSelector:doc+ liftIO $ p1 @?= ent1++ let p2 = p1 {personColor = Just "blue"}+ let doc2 = idSelector:recordToDocument p2+ MongoDB.save "Person" doc2+ Entity _ ent2 <- docToEntityThrow doc2+ liftIO $ p2 @?= ent2
+ test/main.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++import qualified Data.ByteString as BS+import Data.IntMap (IntMap)+import qualified Data.Text as T+import Data.Time+import Database.MongoDB (runCommand1)+import Test.QuickCheck+import Text.Blaze.Html++-- FIXME: should this be added? (RawMongoHelpers module wasn't used)+-- import qualified RawMongoHelpers+import MongoInit++-- These tests are noops with the NoSQL flags set.+--+-- import qualified CompositeTest+-- import qualified CustomPrimaryKeyReferenceTest+-- import qualified InsertDuplicateUpdate+-- import qualified PersistUniqueTest+-- import qualified PrimaryTest+-- import qualified UniqueTest+-- import qualified MigrationColumnLengthTest+-- import qualified EquivalentTypeTest++-- These modules were quite complicated. Instead of fully extracting the+-- relevant common functionality, I just copied and de-CPPed manually.+import qualified EmbedTestMongo++-- These are done.+import qualified CustomPersistFieldTest+import qualified DataTypeTest+import qualified EmbedOrderTest+import qualified EmptyEntityTest+import qualified HtmlTest+import qualified LargeNumberTest+import qualified MaxLenTest+import qualified MaybeFieldDefsTest+import qualified MigrationOnlyTest+import qualified PersistentTest+import qualified Recursive+import qualified RenameTest+import qualified SumTypeTest+import qualified TypeLitFieldDefsTest+import qualified UpsertTest++type Tuple = (,)++dbNoCleanup :: Action IO () -> Assertion+dbNoCleanup = db' (pure ())++-- FIXME: This isn't actually used?+share [mkPersist persistSettings, mkMigrate "htmlMigrate"] [persistLowerCase|+HtmlTable+ html Html+ deriving+|]++mkPersist persistSettings [persistUpperCase|+DataTypeTable no-json+ text Text+ textMaxLen Text maxlen=100+ bytes ByteString+ bytesTextTuple (Tuple ByteString Text)+ bytesMaxLen ByteString maxlen=100+ int Int+ intList [Int]+ intMap (IntMap Int)+ double Double+ bool Bool+ day Day+ utc UTCTime+|]++instance Arbitrary DataTypeTable where+ arbitrary = DataTypeTable+ <$> arbText -- text+ <*> (T.take 100 <$> arbText) -- textManLen+ <*> arbitrary -- bytes+ <*> liftA2 (,) arbitrary arbText -- bytesTextTuple+ <*> (BS.take 100 <$> arbitrary) -- bytesMaxLen+ <*> arbitrary -- int+ <*> arbitrary -- intList+ <*> arbitrary -- intMap+ <*> arbitrary -- double+ <*> arbitrary -- bool+ <*> arbitrary -- day+ <*> (truncateUTCTime =<< arbitrary) -- utc++mkPersist persistSettings [persistUpperCase|+EmptyEntity+|]++main :: IO ()+main = do+ hspec $ afterAll dropDatabase $ do+ RenameTest.specsWith (db' RenameTest.cleanDB)+ DataTypeTest.specsWith+ dbNoCleanup+ Nothing+ [ TestFn "Text" dataTypeTableText+ , TestFn "Text" dataTypeTableTextMaxLen+ , TestFn "Bytes" dataTypeTableBytes+ , TestFn "Bytes" dataTypeTableBytesTextTuple+ , TestFn "Bytes" dataTypeTableBytesMaxLen+ , TestFn "Int" dataTypeTableInt+ , TestFn "Int" dataTypeTableIntList+ , TestFn "Int" dataTypeTableIntMap+ , TestFn "Double" dataTypeTableDouble+ , TestFn "Bool" dataTypeTableBool+ , TestFn "Day" dataTypeTableDay+ ]+ []+ dataTypeTableDouble+ HtmlTest.specsWith (db' HtmlTest.cleanDB) Nothing+ EmbedTestMongo.specs+ EmbedOrderTest.specsWith (db' EmbedOrderTest.cleanDB)+ LargeNumberTest.specsWith+ (db' (deleteWhere ([] :: [Filter (LargeNumberTest.NumberGeneric backend)])))+ MaxLenTest.specsWith dbNoCleanup+ MaybeFieldDefsTest.specsWith dbNoCleanup+ TypeLitFieldDefsTest.specsWith dbNoCleanup+ Recursive.specsWith (db' Recursive.cleanup)++ SumTypeTest.specsWith (dbNoCleanup) Nothing+ MigrationOnlyTest.specsWith+ dbNoCleanup+ Nothing+ PersistentTest.specsWith (db' PersistentTest.cleanDB)+ UpsertTest.specsWith+ (db' PersistentTest.cleanDB)+ UpsertTest.AssumeNullIsZero+ UpsertTest.UpsertGenerateNewKey+ EmptyEntityTest.specsWith+ (db' EmptyEntityTest.cleanDB)+ Nothing+ CustomPersistFieldTest.specsWith+ dbNoCleanup+ -- FIXME: should this be added? (RawMongoHelpers module wasn't used)+ -- RawMongoHelpers.specs++ where+ dropDatabase () = dbNoCleanup (void (runCommand1 $ T.pack "dropDatabase()"))