persistent-mongoDB 2.12.0.0 → 2.13.0.0
raw patch · 4 files changed
+104/−82 lines, 4 filesdep −semigroupsdep ~persistentnew-uploaderPVP ok
version bump matches the API change (PVP)
Dependencies removed: semigroups
Dependency ranges changed: persistent
API changes (from Hackage documentation)
- Database.Persist.MongoDB: instance Data.Bson.Val Database.Persist.Types.Base.PersistValue
+ Database.Persist.MongoDB: instance Data.Bson.Val Database.Persist.PersistValue.PersistValue
Files
- ChangeLog.md +4/−0
- Database/Persist/MongoDB.hs +93/−68
- persistent-mongoDB.cabal +2/−5
- test/main.hs +5/−9
ChangeLog.md view
@@ -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)
Database/Persist/MongoDB.hs view
@@ -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
persistent-mongoDB.cabal view
@@ -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 <greg@gregweber.info>-maintainer: Greg Weber <greg@gregweber.info>+maintainer: Andres Schmois <andres@itpro.tv> synopsis: Backend for the persistent library using mongoDB. category: Database stability: Experimental@@ -72,9 +72,6 @@ , time , transformers , unliftio-core- if impl(ghc < 8)- build-depends:- semigroups default-language: Haskell2010 source-repository head
test/main.hs view
@@ -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