diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -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` diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -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: +-- +-- +-- 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: +-- 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` diff --git a/persistent-mongoDB.cabal b/persistent-mongoDB.cabal --- a/persistent-mongoDB.cabal +++ b/persistent-mongoDB.cabal @@ -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 -maintainer: Greg Weber +maintainer: Andres Schmois 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 diff --git a/test/EmbedTestMongo.hs b/test/EmbedTestMongo.hs new file mode 100644 --- /dev/null +++ b/test/EmbedTestMongo.hs @@ -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] diff --git a/test/EntityEmbedTestMongo.hs b/test/EntityEmbedTestMongo.hs new file mode 100644 --- /dev/null +++ b/test/EntityEmbedTestMongo.hs @@ -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 diff --git a/test/MongoInit.hs b/test/MongoInit.hs new file mode 100644 --- /dev/null +++ b/test/MongoInit.hs @@ -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 diff --git a/test/RawMongoHelpers.hs b/test/RawMongoHelpers.hs new file mode 100644 --- /dev/null +++ b/test/RawMongoHelpers.hs @@ -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 diff --git a/test/main.hs b/test/main.hs new file mode 100644 --- /dev/null +++ b/test/main.hs @@ -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()"))