diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -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" diff --git a/persistent-mongoDB.cabal b/persistent-mongoDB.cabal --- a/persistent-mongoDB.cabal +++ b/persistent-mongoDB.cabal @@ -1,5 +1,5 @@ name: persistent-mongoDB -version: 1.1.6 +version: 1.2.0 license: MIT license-file: LICENSE author: Greg Weber @@ -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 +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