diff --git a/Database/Persist/MongoDB.hs b/Database/Persist/MongoDB.hs --- a/Database/Persist/MongoDB.hs +++ b/Database/Persist/MongoDB.hs @@ -28,7 +28,10 @@ , docToEntityEither , docToEntityThrow , entityToDocument + , recordToDocument + , documentFromEntity , toInsertDoc + , entityToInsertDoc , updatesToDoc , filtersToDoc , toUniquesDoc @@ -48,7 +51,7 @@ -- ** Updates -- $updates - , nestSet, nestInc, nestDec, nestMul, push, pull, pullAll, addToSet + , nestSet, nestInc, nestDec, nestMul, push, pull, pullAll, addToSet, eachOp -- * Key conversion helpers , BackendKey(..) @@ -374,14 +377,21 @@ updateToBson :: Text -> PersistValue - -> PersistUpdate + -> Either PersistUpdate MongoUpdateOperation -> DB.Field updateToBson fname v up = +#ifdef DEBUG + debug ( +#endif opName DB.:= DB.Doc [fname DB.:= opValue] +#ifdef DEBUG + ) +#endif where inc = "$inc" mul = "$mul" - (opName, opValue) = case (up, v) of + (opName, opValue) = case up of + Left pup -> case (pup, v) of (Assign, PersistNull) -> ("$unset", DB.Int64 1) (Assign,a) -> ("$set", DB.val a) (Add, a) -> (inc, DB.val a) @@ -392,18 +402,20 @@ (Multiply, _) -> error "expected PersistInt64 or PersistDouble for a subtraction" -- Obviously this could be supported for floats by multiplying with 1/x (Divide, _) -> throw $ PersistMongoDBUnsupported "divide not supported" - (BackendSpecificUpdate op, x@(PersistList _)) -> case op of - "$pullAll" -> ("$pullAll", DB.val x) - bsup -> throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificUpdate " ++ T.unpack bsup - (BackendSpecificUpdate op, x) -> case op of - "$push" -> ("$push", DB.val x) - "$pull" -> ("$pull", DB.val x) - "$addToSet" -> ("$addToSet", DB.val x) - bsup -> throw $ PersistMongoDBError $ T.pack $ "did not expect BackendSpecificUpdate " ++ T.unpack bsup + (BackendSpecificUpdate bsup, _) -> throw $ PersistMongoDBError $ + T.pack $ "did not expect BackendSpecificUpdate " ++ T.unpack bsup + Right mup -> case mup of + MongoEach op -> case op of + MongoPull -> ("$pullAll", DB.val v) + _ -> (opToText op, DB.Doc ["$each" DB.:= DB.val v]) + MongoSimple x -> (opToText x, DB.val v) + + + updateToMongoField :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => Update record -> DB.Field -updateToMongoField (Update field v up) = updateToBson (fieldName field) (toPersistValue v) up +updateToMongoField (Update field v up) = updateToBson (fieldName field) (toPersistValue v) (Left up) updateToMongoField (BackendUpdate up) = mongoUpdateToDoc up @@ -444,18 +456,32 @@ embeddedVal je@(Just _) (PersistList l) = DB.Array $ map (embeddedVal je) l embeddedVal _ pv = DB.val pv +entityToInsertDoc :: forall record. (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) + => Entity record -> DB.Document +entityToInsertDoc (Entity key record) = keyToMongoDoc key ++ toInsertDoc record + collectionName :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => record -> Text collectionName = unDBName . entityDB . entityDef . Just -- | convert a PersistEntity into document fields. -- unlike 'toInsertDoc', nulls are included. -entityToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) +recordToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) => record -> DB.Document -entityToDocument record = zipToDoc (map fieldDB $ entityFields entity) (toPersistFields record) +recordToDocument record = zipToDoc (map fieldDB $ entityFields entity) (toPersistFields record) where entity = entityDef $ Just record +entityToDocument :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) + => record -> DB.Document +entityToDocument = recordToDocument +{-# DEPRECATED entityToDocument "use recordToDocument" #-} + +documentFromEntity :: (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) + => Entity record -> DB.Document +documentFromEntity (Entity key record) = + keyToMongoDoc key ++ entityToDocument record + zipToDoc :: PersistField a => [DBName] -> [a] -> [DB.Field] zipToDoc [] _ = [] zipToDoc _ [] = [] @@ -466,16 +492,6 @@ fieldToLabel :: EmbedFieldDef -> Text fieldToLabel = unDBName . emFieldDB -saveWithKey :: forall m record. - (PersistEntity record, PersistEntityBackend record ~ DB.MongoContext) - => (record -> [DB.Field]) - -> (Text -> [DB.Field] -> DB.Action m ()) - -> Key record - -> record - -> DB.Action m () -saveWithKey entToFields dbSave key record = - dbSave (collectionName record) ((keyToMongoDoc key) ++ (entToFields record)) - keyFrom_idEx :: (Trans.MonadIO m, PersistEntity record) => DB.Value -> m (Key record) keyFrom_idEx idVal = case keyFrom_id idVal of Right k -> return k @@ -521,15 +537,21 @@ >>= keyFrom_idEx insertMany [] = return [] - insertMany (r:records) = mapM keyFrom_idEx =<< - DB.insertMany (collectionName r) (map toInsertDoc (r:records)) + insertMany records@(r:_) = mapM keyFrom_idEx =<< + DB.insertMany (collectionName r) (map toInsertDoc records) - insertKey k record = saveWithKey toInsertDoc DB.insert_ k record + insertEntityMany [] = return () + insertEntityMany ents@(Entity _ r : _) = + DB.insertMany_ (collectionName r) (map entityToInsertDoc ents) - repsert k record = saveWithKey entityToDocument DB.save k record + insertKey k record = DB.insert_ (collectionName record) $ + entityToInsertDoc (Entity k record) + repsert k record = DB.save (collectionName record) $ + documentFromEntity (Entity k record) + replace k record = do - DB.replace (selectByKey k) (entityToDocument record) + DB.replace (selectByKey k) (recordToDocument record) return () delete k = @@ -826,11 +848,11 @@ mongoUpdateToBson :: forall typ. PersistField typ => Text - -> MongoUpdateOperator typ + -> UpdateValueOp typ -> DB.Field mongoUpdateToBson fname upd = case upd of - (PersistUpdateOperator (Left v) op) -> updateToBson fname (toPersistValue v) op - (PersistUpdateOperator (Right v) op) -> updateToBson fname (PersistList $ map toPersistValue v) op + UpdateValueOp (Left v) op -> updateToBson fname (toPersistValue v) op + UpdateValueOp (Right v) op -> updateToBson fname (PersistList $ map toPersistValue v) op mongoUpdateToDoc :: PersistEntity record => MongoUpdate record -> DB.Field mongoUpdateToDoc (NestedUpdate field op) = mongoUpdateToBson (nestedFieldName field) op @@ -1209,8 +1231,26 @@ data MongoFilterOperator typ = PersistFilterOperator (Either typ [typ]) PersistFilter | MongoFilterOperator DB.Value -data MongoUpdateOperator typ = PersistUpdateOperator (Either typ [typ]) PersistUpdate +data UpdateValueOp typ = + UpdateValueOp + (Either typ [typ]) + (Either PersistUpdate MongoUpdateOperation) + deriving Show +data MongoUpdateOperation = MongoEach MongoUpdateOperator + | MongoSimple MongoUpdateOperator + deriving Show +data MongoUpdateOperator = MongoPush + | MongoPull + | MongoAddToSet + deriving Show + +opToText :: MongoUpdateOperator -> Text +opToText MongoPush = "$push" +opToText MongoPull = "$pull" +opToText MongoAddToSet = "$addToSet" + + data MongoFilter record = forall typ. PersistField typ => NestedFilter @@ -1229,11 +1269,11 @@ forall typ. PersistField typ => NestedUpdate (NestedField record typ) - (MongoUpdateOperator typ) + (UpdateValueOp typ) | forall typ. PersistField typ => ArrayUpdate (EntityField record [typ]) - (MongoUpdateOperator typ) + (UpdateValueOp typ) -- | Point to an array field with an embedded object and give a deeper query into the embedded object. -- Use with 'nestEq'. @@ -1370,26 +1410,47 @@ ( PersistField typ , PersistEntityBackend record ~ DB.MongoContext ) => EntityField record [typ] -> typ -> Update record -fld `push` val = backendArrayOperation "$push" fld val -fld `pull` val = backendArrayOperation "$pull" fld val -fld `addToSet` val = backendArrayOperation "$addToSet" fld val +fld `push` val = backendArrayOperation MongoPush fld val +fld `pull` val = backendArrayOperation MongoPull fld val +fld `addToSet` val = backendArrayOperation MongoAddToSet fld val -backendArrayOperation :: forall record typ. (PersistField typ, BackendSpecificUpdate (PersistEntityBackend record) record ~ MongoUpdate record) - => Text -> EntityField record [typ] -> typ - -> Update record -backendArrayOperation name fld val = BackendUpdate $ - ArrayUpdate fld $ PersistUpdateOperator (Left val) (BackendSpecificUpdate name) +backendArrayOperation :: + forall record typ. + (PersistField typ, BackendSpecificUpdate (PersistEntityBackend record) record ~ MongoUpdate record) + => MongoUpdateOperator -> EntityField record [typ] -> typ + -> Update record +backendArrayOperation op fld val = BackendUpdate $ + ArrayUpdate fld $ UpdateValueOp (Left val) (Right $ MongoSimple op) +-- | equivalent to $each +-- +-- > eachOp push field [] +-- +-- @eachOp pull@ will get translated to @$pullAll@ +eachOp :: forall record typ. + ( PersistField typ, PersistEntityBackend record ~ DB.MongoContext) + => (EntityField record [typ] -> typ -> Update record) + -> EntityField record [typ] -> [typ] + -> Update record +eachOp haskellOp fld val = case haskellOp fld (error "eachOp: undefined") of + BackendUpdate (ArrayUpdate _ (UpdateValueOp (Left _) (Right (MongoSimple op)))) -> each op + BackendUpdate (ArrayUpdate{}) -> error "eachOp: unexpected ArrayUpdate" + BackendUpdate (NestedUpdate{}) -> error "eachOp: did not expect NestedUpdate" + Update{} -> error "eachOp: did not expect Update" + where + each op = BackendUpdate $ ArrayUpdate fld $ + UpdateValueOp (Right val) (Right $ MongoEach op) + pullAll :: forall record typ. ( PersistField typ , PersistEntityBackend record ~ DB.MongoContext ) => EntityField record [typ] -> [typ] -> Update record -fld `pullAll` val = BackendUpdate $ - ArrayUpdate fld $ PersistUpdateOperator (Right val) (BackendSpecificUpdate "$pullAll") +fld `pullAll` val = eachOp pull fld val + nestedUpdateOp :: forall record typ. ( PersistField typ , PersistEntityBackend record ~ DB.MongoContext ) => PersistUpdate -> NestedField record typ -> typ -> Update record nestedUpdateOp op nf v = BackendUpdate $ - NestedUpdate nf $ PersistUpdateOperator (Left v) op + NestedUpdate nf $ UpdateValueOp (Left v) (Left op) 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: 2.1 +version: 2.1.1 license: MIT license-file: LICENSE author: Greg Weber @@ -19,7 +19,7 @@ library build-depends: base >= 4 && < 5 - , persistent >= 2.1 && < 3 + , persistent >= 2.1.1 && < 3 , text >= 0.8 , transformers >= 0.2.1 , containers >= 0.2