persistent-mongoDB 1.1.6 → 1.2.0
raw patch · 2 files changed
+96/−51 lines, 2 filesdep ~persistent
Dependency ranges changed: persistent
Files
- Database/Persist/MongoDB.hs +86/−48
- persistent-mongoDB.cabal +10/−3
Database/Persist/MongoDB.hs view
@@ -72,9 +72,6 @@ ) 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)@@ -97,6 +94,10 @@ import Control.Monad (mzero) import qualified Data.Conduit.Pool as Pool import Data.Time (NominalDiffTime)+#ifdef HIGH_PRECISION_DATE+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)+#endif+import Data.Time.Calendar (Day(..)) import Data.Attoparsec.Number import Data.Char (toUpper) @@ -206,10 +207,10 @@ filterByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> DB.Document filterByKey k = [_id DB.=: keyToOid k] -queryByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> EntityDef -> DB.Query +queryByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> EntityDef a -> DB.Query queryByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) -selectByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> EntityDef -> DB.Selection +selectByKey :: (PersistEntity val) => KeyBackend MongoBackend val -> EntityDef a -> DB.Selection selectByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) updateFields :: (PersistEntity val) => [Update val] -> [DB.Field]@@ -246,7 +247,7 @@ 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+ entity = entityDef $ Just record -- | convert a PersistEntity into document fields. -- unlike 'toInsertFields', nulls are included.@@ -258,9 +259,9 @@ zipIt (e:efields) (p:pfields) = let pv = toPersistValue p in (toLabel e DB.:= DB.val pv):zipIt efields pfields- entity = entityDef record+ entity = entityDef $ Just record -toLabel :: FieldDef -> Text+toLabel :: FieldDef a -> Text toLabel = unDBName . fieldDB saveWithKey :: forall m record keyEntity. -- (Applicative m, Functor m, MonadBaseControl IO m,@@ -273,7 +274,7 @@ saveWithKey entToFields dbSave key record = dbSave (unDBName $ entityDB entity) ((keyToMongoIdField key):(entToFields record)) where- entity = entityDef record+ entity = entityDef $ Just record data MongoBackend @@ -284,7 +285,7 @@ DB.ObjId oid <- DB.insert (unDBName $ entityDB entity) (toInsertFields record) return $ oidToKey oid where- entity = entityDef record+ entity = entityDef $ Just record insertKey k record = saveWithKey toInsertFields DB.insert_ k record @@ -294,7 +295,7 @@ DB.replace (selectByKey k t) (toInsertFields record) return () where- t = entityDef record+ t = entityDef $ Just record delete k = DB.deleteOne DB.Select {@@ -302,7 +303,7 @@ , DB.selector = filterByKey k } where- t = entityDef $ dummyFromKey k+ t = entityDef $ Just $ dummyFromKey k get k = do d <- DB.findOne (queryByKey k t)@@ -312,7 +313,7 @@ Entity _ ent <- fromPersistValuesThrow t doc return $ Just ent where- t = entityDef $ dummyFromKey k+ t = entityDef $ Just $ dummyFromKey k instance MonadThrow m => MonadThrow (DB.Action m) where monadThrow = lift . monadThrow@@ -325,7 +326,7 @@ Nothing -> return Nothing Just doc -> fmap Just $ fromPersistValuesThrow t doc where- t = entityDef $ dummyFromUnique uniq+ t = entityDef $ Just $ dummyFromUnique uniq deleteBy uniq = DB.delete DB.Select {@@ -333,7 +334,7 @@ , DB.selector = uniqSelector uniq } where- t = entityDef $ dummyFromUnique uniq+ t = entityDef $ Just $ dummyFromUnique uniq _id :: T.Text _id = "_id"@@ -369,7 +370,7 @@ (DB.Select [keyToMongoIdField key] (unDBName $ entityDB t)) $ updateFields upds where- t = entityDef $ dummyFromKey key+ t = entityDef $ Just $ dummyFromKey key updateGet key upds = do result <- findAndModifyOne (unDBName $ entityDB t)@@ -381,7 +382,7 @@ return ent where err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg- t = entityDef $ dummyFromKey key+ t = entityDef $ Just $ dummyFromKey key updateWhere _ [] = return ()@@ -391,7 +392,7 @@ , DB.selector = filtersToSelector filts } $ updateFields upds where- t = entityDef $ dummyFromFilts filts+ t = entityDef $ Just $ dummyFromFilts filts deleteWhere filts = do DB.delete DB.Select {@@ -399,14 +400,14 @@ , DB.selector = filtersToSelector filts } where- t = entityDef $ dummyFromFilts filts+ t = entityDef $ Just $ 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+ t = entityDef $ Just $ dummyFromFilts filts selectSource filts opts = do cursor <- lift $ DB.find $ makeQuery filts opts@@ -420,7 +421,7 @@ entity <- fromPersistValuesThrow t doc yield entity pull cursor- t = entityDef $ dummyFromFilts filts+ t = entityDef $ Just $ dummyFromFilts filts selectFirst filts opts = do mdoc <- DB.findOne $ makeQuery filts opts@@ -428,7 +429,7 @@ Nothing -> return Nothing Just doc -> fmap Just $ fromPersistValuesThrow t doc where- t = entityDef $ dummyFromFilts filts+ t = entityDef $ Just $ dummyFromFilts filts selectKeys filts opts = do cursor <- lift $ DB.find $ (makeQuery filts opts) {@@ -460,7 +461,7 @@ , DB.sort = orders } where- t = entityDef $ dummyFromFilts filts+ t = entityDef $ Just $ dummyFromFilts filts (limit, offset, orders') = limitOffsetOrder opts orders = map orderClause orders' @@ -514,7 +515,7 @@ docToEntityEither :: forall record. (PersistEntity record) => DB.Document -> Either T.Text (Entity record) docToEntityEither doc = entity where- entDef = entityDef (getType entity)+ entDef = entityDef $ Just (getType entity) entity = eitherFromPersistValues entDef doc getType :: Either err (Entity ent) -> ent getType = error "docToEntityEither/getType: never here"@@ -526,24 +527,39 @@ Right entity -> return entity -fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record) => EntityDef -> [DB.Field] -> m (Entity record)+fromPersistValuesThrow :: (Trans.MonadIO m, PersistEntity record) => EntityDef a -> [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 :: (PersistEntity record) => EntityDef a -> [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+ let castDoc = assocListFromDoc doc+ -- normally _id is the first field+ mKey = lookup _id castDoc in case mKey of Nothing -> Left "could not find _id field"- Just key -> case fromPersistValues reorder of+ Just key -> case fromPersistValues (map snd $ orderPersistValues entDef castDoc) of Right body -> Right $ Entity (Key key) body Left e -> Left e++-- | 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 :: EntityDef a -> [(Text, PersistValue)] -> [(Text, PersistValue)]+orderPersistValues entDef castDoc = reorder where- castDoc = mapFromDoc doc- castColumns = map (unDBName . fieldDB) $ (entityFields entDef)+ castColumns = map nameAndEmbedded (entityFields entDef)+ nameAndEmbedded fdef = ((unDBName . fieldDB) fdef, fieldEmbedded 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)@@ -557,12 +573,13 @@ -- * 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 :: [(Text, PersistValue)] reorder = match castColumns castDoc [] where- match :: [T.Text] -> [(T.Text, PersistValue)] -> [PersistValue] -> [PersistValue]+ match :: [(Text, Maybe (EntityDef ()) )]+ -> [(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@@ -570,20 +587,35 @@ -- 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 =+ match (column:columns) fields values = let (found, unused) = matchOne fields []- in match cs unused (values ++ [snd found])+ in match columns unused $ values +++ [(fst column, nestedOrder (snd column) (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)+ nestedOrder (Just ent) (PersistMap m) =+ PersistMap $ orderPersistValues ent m+ nestedOrder (Just ent) (PersistList l) =+ PersistList $ map (nestedOrder (Just ent)) l+ -- implied: nestedOrder Nothing found = found+ nestedOrder _ found = found -mapFromDoc :: DB.Document -> [(Text, PersistValue)]-mapFromDoc = Prelude.map (\f -> ( (DB.label f), (fromJust . DB.cast') (DB.value f) ) )+ 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+ 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) +assocListFromDoc :: DB.Document -> [(Text, PersistValue)]+assocListFromDoc = Prelude.map (\f -> ( (DB.label f), (fromJust . DB.cast') (DB.value f) ) )+ oidToPersistValue :: DB.ObjectId -> PersistValue oidToPersistValue = PersistObjectId . Serialize.encode @@ -604,15 +636,21 @@ 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 (PersistZonedTime (ZT x)) = DB.String $ T.pack $ show x+ 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 (PersistDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"- val (PersistTimeOfDay _) = throw $ PersistMongoDBUnsupported "only PersistUTCTime currently implemented"+ 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" cast' (DB.Float x) = Just (PersistDouble x) cast' (DB.Int32 x) = Just $ PersistInt64 $ fromIntegral x cast' (DB.Int64 x) = Just $ PersistInt64 x@@ -626,7 +664,7 @@ 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.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"
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 1.1.6+version: 1.2.0 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -10,11 +10,15 @@ cabal-version: >= 1.6 build-type: Simple homepage: http://www.yesodweb.com/book/persistent-description: Backend for the persistent library using mongoDB. The haddocks aren't building on hackage right now, but I put them up at <http://yesodweb.github.com/persistent/persistent-mongoDB/Database-Persist-MongoDB.html>+description: MongoDB backend for the persistent library. +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.1.2 && < 1.2+ , persistent >= 1.2 && < 1.3 , text >= 0.8 , transformers >= 0.2.1 , containers >= 0.2@@ -34,6 +38,9 @@ exposed-modules: Database.Persist.MongoDB ghc-options: -Wall++ if flag(high_precision_date)+ cpp-options: -DHIGH_PRECISION_DATE source-repository head type: git