persistent-mongoDB 2.1.4 → 2.5
raw patch · 3 files changed
+52/−33 lines, 3 filesdep ~networkdep ~persistent
Dependency ranges changed: network, persistent
Files
- ChangeLog.md +4/−0
- Database/Persist/MongoDB.hs +46/−31
- persistent-mongoDB.cabal +2/−2
ChangeLog.md view
@@ -1,3 +1,7 @@+## 2.5++* changes for read/write typeclass split+ ## 2.1.4 * support http-api-data for url serialization
Database/Persist/MongoDB.hs view
@@ -7,7 +7,7 @@ -- 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. +-- 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.@@ -173,7 +173,8 @@ return $ lookup key env #endif -instance HasPersistBackend DB.MongoContext DB.MongoContext where+instance HasPersistBackend DB.MongoContext where+ type BaseBackend DB.MongoContext = DB.MongoContext persistBackend = id recordTypeFromKey :: Key record -> record@@ -187,21 +188,21 @@ parseJSON (Number x) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x -#else +#else parseJSON (Number (I x)) = (return . NoOrphanNominalDiffTime . fromInteger) x parseJSON (Number (D x)) = (return . NoOrphanNominalDiffTime . fromRational . toRational) x -#endif +#endif parseJSON _ = fail "couldn't parse diff time" newtype NoOrphanPortID = NoOrphanPortID PortID deriving (Show, Eq) instance FromJSON NoOrphanPortID where-#if MIN_VERSION_aeson(0, 7, 0) +#if MIN_VERSION_aeson(0, 7, 0) parseJSON (Number x) = (return . NoOrphanPortID . PortNumber . fromIntegral ) cnvX where cnvX :: Word16- cnvX = round x + cnvX = round x #else parseJSON (Number (I x)) = (return . NoOrphanPortID . PortNumber . fromInteger) x@@ -376,7 +377,7 @@ queryByKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => Key record -> DB.Query-queryByKey k = DB.select (keyToMongoDoc k) (collectionNameFromKey k)+queryByKey k = (DB.select (keyToMongoDoc k) (collectionNameFromKey k)) {DB.project = projectionFromKey k} selectByKey :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => Key record -> DB.Selection@@ -540,10 +541,11 @@ -- | older versions versions of haddock (like that on hackage) do not show that this defines -- @BackendKey DB.MongoContext = MongoKey { unMongoKey :: DB.ObjectId }@-instance PersistStore DB.MongoContext where+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 @@ -571,16 +573,6 @@ , DB.selector = keyToMongoDoc k } - get k = do- d <- DB.findOne (queryByKey k)- case d of- Nothing -> return Nothing- Just doc -> do- Entity _ ent <- fromPersistValuesThrow t doc- return $ Just ent- where- t = entityDefFromKey k- update _ [] = return () update key upds = DB.modify@@ -588,9 +580,7 @@ $ updatesToDoc upds updateGet key upds = do- result <- DB.findAndModify (DB.select (keyToMongoDoc key)- (collectionNameFromKey key)- ) (updatesToDoc upds)+ result <- DB.findAndModify (queryByKey key) (updatesToDoc upds) either err instantiate result where instantiate doc = do@@ -599,11 +589,21 @@ err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg t = entityDefFromKey key +instance PersistStoreRead DB.MongoContext where+ get k = do+ d <- DB.findOne (queryByKey k)+ case d of+ Nothing -> return Nothing+ Just doc -> do+ Entity _ ent <- fromPersistValuesThrow t doc+ return $ Just ent+ where+ t = entityDefFromKey k -instance PersistUnique DB.MongoContext where+instance PersistUniqueRead DB.MongoContext where getBy uniq = do mdoc <- DB.findOne $- DB.select (toUniquesDoc uniq) (collectionName rec)+ (DB.select (toUniquesDoc uniq) (collectionName rec)) {DB.project = projectionFromRecord rec} case mdoc of Nothing -> return Nothing Just doc -> liftM Just $ fromPersistValuesThrow t doc@@ -611,6 +611,7 @@ t = entityDef $ Just rec rec = dummyFromUnique uniq +instance PersistUniqueWrite DB.MongoContext where deleteBy uniq = DB.delete DB.Select { DB.coll = collectionName $ dummyFromUnique uniq@@ -649,8 +650,8 @@ 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"@@ -673,8 +674,21 @@ => Key record -> Text collectionNameFromKey = collectionName . recordTypeFromKey +projectionFromEntityDef :: EntityDef -> DB.Projector+projectionFromEntityDef eDef =+ map toField (entityFields eDef)+ where+ toField :: FieldDef -> DB.Field+ toField fDef = (unDBName (fieldDB fDef)) DB.=: (1 :: Int) -instance PersistQuery DB.MongoContext where+projectionFromKey :: PersistEntity record => Key record -> DB.Projector+projectionFromKey = projectionFromEntityDef . entityDefFromKey++projectionFromRecord :: PersistEntity record => record -> DB.Projector+projectionFromRecord = projectionFromEntityDef . entityDef . Just+++instance PersistQueryWrite DB.MongoContext where updateWhere _ [] = return () updateWhere filts upds = DB.modify DB.Select {@@ -688,6 +702,7 @@ , DB.selector = filtersToDoc filts } +instance PersistQueryRead DB.MongoContext where count filts = do i <- DB.count query return $ fromIntegral i@@ -758,6 +773,7 @@ DB.limit = fromIntegral limit , DB.skip = fromIntegral offset , DB.sort = orders+ , DB.project = projectionFromRecord (dummyFromFilts filts) } where (limit, offset, orders') = limitOffsetOrder opts@@ -914,7 +930,7 @@ fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => EntityDef -> [DB.Field] -> m (Entity record)-fromPersistValuesThrow entDef doc = +fromPersistValuesThrow entDef doc = case eitherFromPersistValues entDef doc of Left t -> Trans.liftIO . throwIO $ PersistMarshalError $ unHaskellName (entityHaskell entDef) `mappend` ": " `mappend` t@@ -960,14 +976,14 @@ -- reorder = map (fromJust . (flip Prelude.lookup $ castDoc)) castColumns -- -- this is O(n * log(n))- -- reorder = map (\c -> (M.fromList castDoc) M.! c) castColumns + -- 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 --- reorder :: [(Text, PersistValue)] + reorder :: [(Text, PersistValue)] reorder = match castColumns castDoc [] where match :: [(Text, Maybe EmbedEntityDef)]@@ -979,7 +995,6 @@ -- 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 (column:columns) fields values = let (found, unused) = matchOne fields []@@ -1060,7 +1075,7 @@ 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.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"@@ -1078,7 +1093,7 @@ get = do w1 <- Serialize.get w2 <- Serialize.get- return (DB.Oid w1 w2) + return (DB.Oid w1 w2) dummyFromUnique :: Unique v -> v dummyFromUnique _ = error "dummyFromUnique"
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 2.1.4+version: 2.5 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -20,7 +20,7 @@ library build-depends: base >= 4.6 && < 5- , persistent >= 2.1.1 && < 3+ , persistent >= 2.5 && < 3 , text >= 0.8 , transformers >= 0.2.1 , containers >= 0.2