persistent-mongoDB 2.1 → 2.1.1
raw patch · 2 files changed
+109/−48 lines, 2 filesdep ~persistent
Dependency ranges changed: persistent
Files
- Database/Persist/MongoDB.hs +107/−46
- persistent-mongoDB.cabal +2/−2
Database/Persist/MongoDB.hs view
@@ -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)
persistent-mongoDB.cabal view
@@ -1,5 +1,5 @@ name: persistent-mongoDB-version: 2.1+version: 2.1.1 license: MIT license-file: LICENSE author: Greg Weber <greg@gregweber.info>@@ -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