diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for persistent-mongoDB +## 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) diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -113,29 +113,39 @@ ) where import Control.Exception (throw, throwIO) -import Control.Monad (liftM, (>=>), forM_, unless) +import Control.Monad (forM_, liftM, unless, (>=>)) import Control.Monad.IO.Class (liftIO) import qualified Control.Monad.IO.Class as Trans import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Control.Monad.Trans.Reader (ask, runReaderT) +import qualified Data.List.NonEmpty as NEL import Data.Acquire (mkAcquire) -import Data.Aeson (Value (Number), (.:), (.:?), (.!=), FromJSON(..), ToJSON(..), withText, withObject) +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 (mapMaybe, fromJust) +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 qualified Data.Traversable as Traversable -import qualified Data.Pool as Pool 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 @@ -144,8 +154,14 @@ import Numeric (readHex) import System.Environment (lookupEnv) import Unsafe.Coerce (unsafeCoerce) +import Web.HttpApiData + ( FromHttpApiData(..) + , ToHttpApiData(..) + , parseUrlPieceMaybe + , parseUrlPieceWithPrefix + , readTextData + ) import Web.PathPieces (PathPiece(..)) -import Web.HttpApiData (ToHttpApiData(..), FromHttpApiData(..), parseUrlPieceMaybe, parseUrlPieceWithPrefix, readTextData) #ifdef DEBUG import FileLocation (debug) @@ -155,6 +171,7 @@ 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 @@ -408,7 +425,7 @@ -- | convert a unique key into a MongoDB document toUniquesDoc :: forall record. (PersistEntity record) => Unique record -> [DB.Field] toUniquesDoc uniq = zipWith (DB.:=) - (map (unFieldNameDB . snd) $ persistUniqueToFieldNames uniq) + (map (unFieldNameDB . snd) $ NEL.toList $ persistUniqueToFieldNames uniq) (map DB.val (persistUniqueToValues uniq)) -- | convert a PersistEntity into document fields. @@ -416,31 +433,38 @@ -- '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) +toInsertDoc record = + zipFilter + (embeddedFields $ toEmbedEntityDef entDef) + (map toPersistValue $ toPersistFields record) where entDef = entityDef $ Just record - zipFilter :: [EmbedFieldDef] -> [PersistValue] -> DB.Document - zipFilter [] _ = [] - zipFilter _ [] = [] - zipFilter (fd:efields) (pv:pvs) = - if isNull pv then recur else - (fieldToLabel fd DB.:= embeddedVal (emFieldEmbed fd) pv):recur - + zipFilter xs ys = + map (\(fd, pv) -> + fieldToLabel fd + DB.:= + embeddedVal pv + ) + $ filter (\(_, pv) -> not $ isNull pv) + $ zip xs ys where - recur = zipFilter efields pvs - isNull PersistNull = True isNull (PersistMap m) = null m isNull (PersistList l) = null l isNull _ = False - -- make sure to removed nulls from embedded entities also - embeddedVal :: Maybe EmbedEntityDef -> PersistValue -> DB.Value - embeddedVal (Just emDef) (PersistMap m) = DB.Doc $ - zipFilter (embeddedFields emDef) $ map snd m - embeddedVal je@(Just _) (PersistList l) = DB.Array $ map (embeddedVal je) l - embeddedVal _ pv = DB.val pv + -- 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 @@ -448,13 +472,13 @@ collectionName :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => record -> Text -collectionName = unEntityNameDB . entityDB . entityDef . Just +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 $ entityFields entity) (toPersistFields record) +recordToDocument record = zipToDoc (map fieldDB $ getEntityFields entity) (toPersistFields record) where entity = entityDef $ Just record @@ -646,7 +670,7 @@ Nothing -> zipToDoc [FieldNameDB id_] values Just pdef -> [id_ DB.=: zipToDoc (primaryNames pdef) values] where - primaryNames = map fieldDB . compositeFields + primaryNames = map fieldDB . NEL.toList . compositeFields values = keyToValues k entityDefFromKey :: PersistEntity record => Key record -> EntityDef @@ -658,7 +682,7 @@ projectionFromEntityDef :: EntityDef -> DB.Projector projectionFromEntityDef eDef = - map toField (entityFields eDef) + map toField (getEntityFields eDef) where toField :: FieldDef -> DB.Field toField fDef = (unFieldNameDB (fieldDB fDef)) DB.=: (1 :: Int) @@ -920,7 +944,7 @@ fromPersistValuesThrow entDef doc = case eitherFromPersistValues entDef doc of Left t -> Trans.liftIO . throwIO $ PersistMarshalError $ - unEntityNameHS (entityHaskell entDef) `mappend` ": " `mappend` t + unEntityNameHS (getEntityHaskellName entDef) `mappend` ": " `mappend` t Right entity -> return entity mapLeft :: (a -> c) -> Either a b -> Either c b @@ -949,10 +973,13 @@ -- 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 = reorder +orderPersistValues entDef castDoc = + match castColumns castDoc [] where - castColumns = map nameAndEmbed (embeddedFields entDef) - nameAndEmbed fdef = (fieldToLabel fdef, emFieldEmbed fdef) + 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. @@ -970,44 +997,43 @@ -- * 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 -- - reorder :: [(Text, PersistValue)] - reorder = match castColumns castDoc [] + 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 - match :: [(Text, Maybe EmbedEntityDef)] - -> [(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 (column:columns) fields values = - let (found, unused) = matchOne fields [] - in match columns unused $ values ++ - [(fst column, nestedOrder (snd column) (snd found))] - where - nestedOrder (Just em) (PersistMap m) = - PersistMap $ orderPersistValues em m - nestedOrder (Just em) (PersistList l) = - PersistList $ map (nestedOrder (Just em)) l - -- implied: nestedOrder Nothing found = found - nestedOrder _ found = found + -- 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 fst column == fst field - -- snd drops the name now that it has been used to make the match - -- persistent will add the field name later + 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 = ((fst column, PersistNull), 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) ) ) @@ -1048,8 +1074,7 @@ 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" - val (PersistLiteralEscaped _) = throw $ PersistMongoDBUnsupported "PersistLiteralEscaped 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 diff --git a/persistent-mongoDB.cabal b/persistent-mongoDB.cabal --- a/persistent-mongoDB.cabal +++ b/persistent-mongoDB.cabal @@ -1,9 +1,9 @@ name: persistent-mongoDB -version: 2.12.0.0 +version: 2.13.0.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 @@ -72,9 +72,6 @@ , time , transformers , unliftio-core - if impl(ghc < 8) - build-depends: - semigroups default-language: Haskell2010 source-repository head diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -103,8 +103,7 @@ main :: IO () main = do hspec $ afterAll dropDatabase $ do - xdescribe "This test is failing for Mongo by only embedding the first thing." $ do - RenameTest.specsWith (db' RenameTest.cleanDB) + RenameTest.specsWith (db' RenameTest.cleanDB) DataTypeTest.specsWith dbNoCleanup Nothing @@ -135,13 +134,10 @@ dbNoCleanup Nothing PersistentTest.specsWith (db' PersistentTest.cleanDB) - -- TODO: The upsert tests are currently failing. Find out why and fix - -- them. - xdescribe "UpsertTest is currently failing for Mongo due to differing behavior" $ do - UpsertTest.specsWith - (db' PersistentTest.cleanDB) - UpsertTest.AssumeNullIsZero - UpsertTest.UpsertGenerateNewKey + UpsertTest.specsWith + (db' PersistentTest.cleanDB) + UpsertTest.AssumeNullIsZero + UpsertTest.UpsertGenerateNewKey EmptyEntityTest.specsWith (db' EmptyEntityTest.cleanDB) Nothing