From cf65a2cdb1e8086cf71e49afc2c2764c02b790e1 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Sun, 22 Jul 2012 20:46:20 -0700 Subject: [PATCH 1/3] updateGet for MongoDB. closes #86 also fix test errors & warnings --- .../Database/Persist/MongoDB.hs | 40 +++++++++++++++---- persistent-test/EmbedTest.hs | 5 ++- persistent-test/HtmlTest.hs | 2 +- persistent-test/JoinTest.hs | 2 +- persistent-test/LargeNumberTest.hs | 6 ++- persistent-test/PersistentTest.hs | 14 +++---- persistent-test/RenameTest.hs | 4 +- persistent-test/SumTypeTest.hs | 11 ++--- persistent-test/persistent-test.cabal | 10 ++--- persistent-test/test/main.hs | 4 +- 10 files changed, 61 insertions(+), 37 deletions(-) diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index 573d61998..b327f7979 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -117,7 +117,7 @@ rightPersistVals ent vals = case wrapFromPersistValues ent vals of Right v -> v filterByKey :: (PersistEntity val) => Key DB.Action val -> DB.Document -filterByKey k = ["_id" DB.=: keyToOid k] +filterByKey k = [_id DB.=: keyToOid k] queryByKey :: (PersistEntity val) => Key DB.Action val -> EntityDef -> DB.Query queryByKey k entity = (DB.select (filterByKey k) (unDBName $ entityDB entity)) @@ -236,17 +236,41 @@ instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => P where t = entityDef $ dummyFromUnique uniq +_id :: T.Text +_id = "_id" + persistKeyToMongoId :: PersistEntity val => Key DB.Action val -> DB.Field -persistKeyToMongoId k = "_id" DB.:= (DB.ObjId $ keyToOid k) +persistKeyToMongoId k = _id DB.:= (DB.ObjId $ keyToOid k) + + +findAndModifyOne :: (Applicative m, Trans.MonadIO m) => DB.Collection -> DB.Field -> [DB.Field] -> DB.Action m DB.Document +findAndModifyOne coll idMatch updates = DB.runCommand [ + "findAndModify" DB.:= DB.String coll, + "new" DB.:= DB.Bool True, -- return updated document, not original document + "query" DB.:= DB.Doc [idMatch], + "update" DB.:= DB.Doc updates + ] instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistQuery DB.Action m where update _ [] = return () - update k upds = + update key upds = DB.modify - (DB.Select [persistKeyToMongoId k] (unDBName $ entityDB t)) + (DB.Select [persistKeyToMongoId key] (unDBName $ entityDB t)) $ updateFields upds where - t = entityDef $ dummyFromKey k + t = entityDef $ dummyFromKey key + + updateGet key upds = do + result <- findAndModifyOne (unDBName $ entityDB t) (persistKeyToMongoId key) $ updateFields upds + case DB.lookup "err" (DB.at "lastErrorObject" result) result of + Just e -> err e + Nothing -> case DB.lookup "value" result of + Nothing -> err "no value field" + Just doc -> return $ rightPersistVals t (tail doc) + where + err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg + t = entityDef $ dummyFromKey key + updateWhere _ [] = return () updateWhere filts upds = @@ -311,7 +335,7 @@ instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => P pull cursor Just y -> liftIO $ throwIO $ PersistMarshalError $ T.pack $ "Unexpected in selectKeys: " ++ show y query = (DB.select (filtersToSelector filts) (unDBName $ entityDB t)) { - DB.project = ["_id" DB.=: (1 :: Int)] + DB.project = [_id DB.=: (1 :: Int)] } t = entityDef $ dummyFromFilts filts @@ -353,7 +377,7 @@ filterToDocument f = FilterOr [] -> -- Michael decided to follow Haskell's semantics, which seems reasonable to me. -- in Haskell an empty or is a False -- Perhaps there is a less hacky way of creating a query that always returns false? - ["$not" DB.=: ["$exists" DB.=: ("_id" :: T.Text)]] + ["$not" DB.=: ["$exists" DB.=: _id]] FilterOr fs -> multiFilter "$or" fs -- $and is usually unecessary but makes query construction easier in special cases FilterAnd [] -> [] @@ -377,7 +401,7 @@ filterToDocument f = fieldName :: forall v typ. (PersistEntity v) => EntityField v typ -> DB.Label fieldName = idfix . unDBName . fieldDB . persistFieldDef - where idfix f = if f == "id" then "_id" else f + where idfix f = if f == "id" then _id else f wrapFromPersistValues :: (PersistEntity val) => EntityDef -> [DB.Field] -> Either T.Text val diff --git a/persistent-test/EmbedTest.hs b/persistent-test/EmbedTest.hs index c447b97d5..6789f0877 100644 --- a/persistent-test/EmbedTest.hs +++ b/persistent-test/EmbedTest.hs @@ -15,6 +15,7 @@ embedMigrate ) where import Init +import Test.HUnit (Assertion) import qualified Data.Text as T import qualified Data.Set as S @@ -64,10 +65,12 @@ cleanDB = do deleteWhere ([] :: [Filter HasListEmbed]) deleteWhere ([] :: [Filter HasSetEmbed]) deleteWhere ([] :: [Filter HasMapEmbed]) + +db :: Action IO () -> Assertion db = db' cleanDB #endif -specs :: Specs +specs :: Spec specs = describe "embedded entities" $ do it "simple entities" $ db $ do let container = HasEmbeds "container" (OnlyName "2") diff --git a/persistent-test/HtmlTest.hs b/persistent-test/HtmlTest.hs index dc290dc54..8f9479015 100644 --- a/persistent-test/HtmlTest.hs +++ b/persistent-test/HtmlTest.hs @@ -37,7 +37,7 @@ cleanDB :: PersistQuery b m => b m () cleanDB = do deleteWhere ([] :: [Filter HtmlTable]) -specs :: Specs +specs :: Spec specs = describe "html" $ do it "works" $ asIO $ runConn $ do #ifndef WITH_MONGODB diff --git a/persistent-test/JoinTest.hs b/persistent-test/JoinTest.hs index eb6507ba7..ee4e48445 100644 --- a/persistent-test/JoinTest.hs +++ b/persistent-test/JoinTest.hs @@ -53,7 +53,7 @@ db = db' cleanDB #endif -specs :: Specs +specs :: Spec specs = describe "joins" $ do it "NoSql" $ db $ joinGeneric Database.Persist.Query.Join.runJoin False #ifndef WITH_MONGODB diff --git a/persistent-test/LargeNumberTest.hs b/persistent-test/LargeNumberTest.hs index ae491e452..109a5e970 100644 --- a/persistent-test/LargeNumberTest.hs +++ b/persistent-test/LargeNumberTest.hs @@ -11,6 +11,7 @@ module LargeNumberTest where import Init import Data.Word +import Test.HUnit (Assertion) #ifdef WITH_MONGODB mkPersist persistSettings [persist| @@ -26,13 +27,14 @@ share [mkPersist sqlSettings, mkMigrate "numberMigrate"] [persist| deriving Show Eq |] #ifdef WITH_MONGODB -db = db' cleanDB cleanDB :: PersistQuery b m => b m () cleanDB = do deleteWhere ([] :: [Filter Number]) +db :: Action IO () -> Assertion +db = db' cleanDB #endif -specs :: Specs +specs :: Spec specs = describe "persistent" $ do it "large numbers" $ db $ do let go x = do diff --git a/persistent-test/PersistentTest.hs b/persistent-test/PersistentTest.hs index 8176cdbfb..59fe37e93 100644 --- a/persistent-test/PersistentTest.hs +++ b/persistent-test/PersistentTest.hs @@ -153,7 +153,7 @@ maybeOwnedPetOwner = belongsTo maybeOwnedPetOwnerId -specs :: Specs +specs :: Spec specs = describe "persistent" $ do it "FilterOr []" $ db $ do let p = Person "z" 1 Nothing @@ -200,8 +200,7 @@ specs = describe "persistent" $ do results' <- selectList [PersonAge <. 28] [] results' @== [(Entity micK mic26)] - update micK [PersonAge =. 28] - Just p28 <- get micK + p28 <- updateGet micK [PersonAge =. 28] personAge p28 @== 28 updateWhere [PersonName ==. "Michael"] [PersonAge =. 29] @@ -397,18 +396,15 @@ specs = describe "persistent" $ do it "update" $ db $ do let p25 = Person "Michael" 25 Nothing key25 <- insert p25 - update key25 [PersonAge =. 28, PersonName =. "Updated"] - Just pBlue28 <- get key25 + pBlue28 <- updateGet key25 [PersonAge =. 28, PersonName =. "Updated"] pBlue28 @== Person "Updated" 28 Nothing - update key25 [PersonAge +=. 2] - Just pBlue30 <- get key25 + pBlue30 <- updateGet key25 [PersonAge +=. 2] pBlue30 @== Person "Updated" 30 Nothing it "maybe update" $ db $ do let noAge = PersonMaybeAge "Michael" Nothing keyNoAge <- insert noAge - update keyNoAge [PersonMaybeAgeAge +=. Just 2] - Just noAge2 <- get keyNoAge + noAge2 <- updateGet keyNoAge [PersonMaybeAgeAge +=. Just 2] -- the correct answer is very debatable #ifdef WITH_MONGODB personMaybeAgeAge noAge2 @== Just 2 diff --git a/persistent-test/RenameTest.hs b/persistent-test/RenameTest.hs index 3eb131837..88916abde 100644 --- a/persistent-test/RenameTest.hs +++ b/persistent-test/RenameTest.hs @@ -16,10 +16,10 @@ import Test.HUnit import Database.Persist.Sqlite import Database.Persist.TH import Database.Persist.EntityDef -import Database.Persist.GenericSql.Raw #ifndef WITH_MONGODB import qualified Data.Conduit as C import qualified Data.Conduit.List as CL +import Database.Persist.GenericSql.Raw #endif #if WITH_POSTGRESQL import Database.Persist.Postgresql @@ -49,7 +49,7 @@ RefTable UniqueRefTable someVal |] -specs :: Specs +specs :: Spec specs = describe "rename specs" $ do #ifndef WITH_MONGODB it "handles lower casing" $ asIO $ do diff --git a/persistent-test/SumTypeTest.hs b/persistent-test/SumTypeTest.hs index a9e4e7576..6313a8fa3 100644 --- a/persistent-test/SumTypeTest.hs +++ b/persistent-test/SumTypeTest.hs @@ -15,16 +15,16 @@ import Test.Hspec.HUnit () import Test.HUnit import Database.Persist.Sqlite import Database.Persist.TH -import Database.Persist.EntityDef -import Database.Persist.GenericSql.Raw #ifndef WITH_MONGODB import qualified Data.Conduit as C import qualified Data.Conduit.List as CL +import Database.Persist.EntityDef +import Database.Persist.GenericSql.Raw +import qualified Data.Map as Map #endif #if WITH_POSTGRESQL import Database.Persist.Postgresql #endif -import qualified Data.Map as Map import qualified Data.Text as T import Init @@ -45,11 +45,12 @@ Car deriving Show Eq |] -specs :: Specs +specs :: Spec specs = describe "sum types" $ do it "works" $ asIO $ runConn $ do +#ifndef WITH_MONGODB _ <- runMigrationSilent sumTypeMigrate - +#endif car1 <- insert $ Car "Ford" "Thunderbird" car2 <- insert $ Car "Kia" "Rio" bike1 <- insert $ Bicycle "Shwinn" diff --git a/persistent-test/persistent-test.cabal b/persistent-test/persistent-test.cabal index 4a138ff8c..3a895598a 100644 --- a/persistent-test/persistent-test.cabal +++ b/persistent-test/persistent-test.cabal @@ -120,14 +120,12 @@ library , cereal , bson + cpp-options: -DWITH_MONGODB -DDEBUG exposed-modules: Database.Persist.MongoDB -- older versions of cabal have a bug with these flags -- you can use: --ghc-option=-DWITH_POSTGRESQL --- if flag(mongodb) --- cpp-options: -DWITH_MONGODB -DDEBUG --- else -- if flag(postgresql) -- cpp-options: -DWITH_POSTGRESQL -- else @@ -143,11 +141,11 @@ test-suite test , persistent-test , hspec + if flag(mongodb) + cpp-options: -DWITH_MONGODB -DDEBUG + -- older versions of cabal have a bug with these flags -- you can use: --ghc-option=-DWITH_POSTGRESQL --- if flag(mongodb) --- cpp-options: -DWITH_MONGODB -DDEBUG --- else -- if flag(postgresql) -- cpp-options: -DWITH_POSTGRESQL -- else diff --git a/persistent-test/test/main.hs b/persistent-test/test/main.hs index 606c7c5e0..38e1f022e 100644 --- a/persistent-test/test/main.hs +++ b/persistent-test/test/main.hs @@ -9,7 +9,7 @@ import qualified EmbedTest import qualified LargeNumberTest import qualified MaxLenTest import qualified SumTypeTest -import Test.Hspec.Monadic (hspecX) +import Test.Hspec.Monadic (hspec) import Init import System.Exit import Control.Monad (unless) @@ -45,7 +45,7 @@ main = do runConn (setup MaxLenTest.maxlenMigrate) #endif - hspecX $ + hspec $ RenameTest.specs >> DataTypeTest.specs >> HtmlTest.specs >> From b66586998a8c63d2f65ac1118bcb07bb45eb7846 Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Sun, 22 Jul 2012 21:20:33 -0700 Subject: [PATCH 2/3] findAndModifyOne independent of Persistent --- .../Database/Persist/MongoDB.hs | 35 ++++++++++++------- 1 file changed, 22 insertions(+), 13 deletions(-) diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index b327f7979..775376378 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -175,7 +175,7 @@ saveWithKey :: forall m ent record. (Applicative m, Functor m, MonadBaseControl => (DB.Collection -> DB.Document -> DB.Action m () ) -> Key DB.Action ent -> record -> DB.Action m () saveWithKey dbSave k record = - dbSave (unDBName $ entityDB t) ((persistKeyToMongoId k):(insertFields t record)) + dbSave (unDBName $ entityDB t) ((keyToMongoIdField k):(insertFields t record)) where t = entityDef record @@ -239,34 +239,43 @@ instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => P _id :: T.Text _id = "_id" -persistKeyToMongoId :: PersistEntity val => Key DB.Action val -> DB.Field -persistKeyToMongoId k = _id DB.:= (DB.ObjId $ keyToOid k) +keyToMongoIdField :: PersistEntity val => Key DB.Action val -> DB.Field +keyToMongoIdField k = _id DB.:= (DB.ObjId $ keyToOid k) -findAndModifyOne :: (Applicative m, Trans.MonadIO m) => DB.Collection -> DB.Field -> [DB.Field] -> DB.Action m DB.Document -findAndModifyOne coll idMatch updates = DB.runCommand [ +findAndModifyOne :: (Applicative m, Trans.MonadIO m) + => DB.Collection + -> DB.ObjectId -- ^ _id for query + -> [DB.Field] -- ^ updates + -> DB.Action m (Either String DB.Document) +findAndModifyOne coll id updates = do + result <- DB.runCommand [ "findAndModify" DB.:= DB.String coll, "new" DB.:= DB.Bool True, -- return updated document, not original document - "query" DB.:= DB.Doc [idMatch], + "query" DB.:= DB.Doc [_id DB.:= DB.ObjId id], "update" DB.:= DB.Doc updates ] + return $ case DB.lookup "err" (DB.at "lastErrorObject" result) result of + Just e -> Left e + Nothing -> case DB.lookup "value" result of + Nothing -> Left "no value field" + Just doc -> Right doc instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistQuery DB.Action m where update _ [] = return () update key upds = DB.modify - (DB.Select [persistKeyToMongoId key] (unDBName $ entityDB t)) + (DB.Select [keyToMongoIdField key] (unDBName $ entityDB t)) $ updateFields upds where t = entityDef $ dummyFromKey key updateGet key upds = do - result <- findAndModifyOne (unDBName $ entityDB t) (persistKeyToMongoId key) $ updateFields upds - case DB.lookup "err" (DB.at "lastErrorObject" result) result of - Just e -> err e - Nothing -> case DB.lookup "value" result of - Nothing -> err "no value field" - Just doc -> return $ rightPersistVals t (tail doc) + result <- findAndModifyOne (unDBName $ entityDB t) + (keyToOid key) (updateFields upds) + case result of + Left e -> err e + Right doc -> return $ (rightPersistVals t) $ tail doc where err msg = Trans.liftIO $ throwIO $ KeyNotFound $ show key ++ msg t = entityDef $ dummyFromKey key From c384fce2b44acbf3617b7d73dbd1f241eb71928e Mon Sep 17 00:00:00 2001 From: Greg Weber Date: Mon, 23 Jul 2012 07:15:07 -0700 Subject: [PATCH 3/3] add entityToFields, expose it and toInsertFields --- .../Database/Persist/MongoDB.hs | 58 +++++++++++++------ persistent-test/DataTypeTest.hs | 2 +- persistent-test/MaxLenTest.hs | 4 +- 3 files changed, 45 insertions(+), 19 deletions(-) diff --git a/persistent-mongoDB/Database/Persist/MongoDB.hs b/persistent-mongoDB/Database/Persist/MongoDB.hs index 775376378..1ed374b92 100644 --- a/persistent-mongoDB/Database/Persist/MongoDB.hs +++ b/persistent-mongoDB/Database/Persist/MongoDB.hs @@ -17,6 +17,9 @@ module Database.Persist.MongoDB -- * Key conversion helpers , keyToOid , oidToKey + -- * Entity conversion + , entityToFields + , toInsertFields -- * network type , HostName -- * MongoDB driver types @@ -160,38 +163,59 @@ pairFromDocument ent document = pairFromPersistValues document Right xs' -> Right (Entity (oidToKey . fromJust . DB.cast' . value $ x) xs') pairFromPersistValues _ = Left "error in fromPersistValues'" -insertFields :: forall val. (PersistEntity val) => EntityDef -> val -> [DB.Field] -insertFields t record = zipFilter (entityFields t) (toPersistFields record) +-- | convert a PersistEntity into document fields. +-- for inserts only: nulls are ignored so they will be unset in the document. +-- 'entityToFields' includes nulls +toInsertFields :: forall val. (PersistEntity val) => val -> [DB.Field] +toInsertFields record = zipFilter (entityFields entity) (toPersistFields record) where zipFilter [] _ = [] zipFilter _ [] = [] 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 - toLabel = unDBName . fieldDB - -saveWithKey :: forall m ent record. (Applicative m, Functor m, MonadBaseControl IO m, PersistEntity ent, PersistEntity record) - => (DB.Collection -> DB.Document -> DB.Action m () ) - -> Key DB.Action ent -> record -> DB.Action m () -saveWithKey dbSave k record = - dbSave (unDBName $ entityDB t) ((keyToMongoIdField k):(insertFields t record)) +-- | convert a PersistEntity into document fields. +-- unlike 'toInsertFields', nulls are included. +entityToFields :: forall val. (PersistEntity val) => val -> [DB.Field] +entityToFields record = zipIt (entityFields entity) (toPersistFields record) + where + zipIt [] _ = [] + zipIt _ [] = [] + zipIt (e:efields) (p:pfields) = + let pv = toPersistValue p + in (toLabel e DB.:= DB.val pv):zipIt efields pfields + entity = entityDef record + +toLabel :: FieldDef -> Text +toLabel = unDBName . fieldDB + +saveWithKey :: forall m record keyEntity. -- (Applicative m, Functor m, MonadBaseControl IO m, + (PersistEntity keyEntity, PersistEntity record) + => (record -> [DB.Field]) + -> (DB.Collection -> DB.Document -> DB.Action m () ) + -> Key DB.Action keyEntity + -> record + -> DB.Action m () +saveWithKey entToFields dbSave key record = + dbSave (unDBName $ entityDB entity) ((keyToMongoIdField key):(entToFields record)) where - t = entityDef record + entity = entityDef record instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => PersistStore DB.Action m where insert record = do - (DB.ObjId oid) <- DB.insert (unDBName $ entityDB t) (insertFields t record) + DB.ObjId oid <- DB.insert (unDBName $ entityDB entity) (toInsertFields record) return $ oidToKey oid where - t = entityDef record + entity = entityDef record - insertKey k record = saveWithKey DB.insert_ k record + insertKey k record = saveWithKey toInsertFields DB.insert_ k record - repsert k record = saveWithKey DB.save k record + repsert k record = saveWithKey entityToFields DB.save k record replace k record = do - DB.replace (selectByKey k t) (insertFields t record) + DB.replace (selectByKey k t) (toInsertFields record) return () where t = entityDef record @@ -248,11 +272,11 @@ findAndModifyOne :: (Applicative m, Trans.MonadIO m) -> DB.ObjectId -- ^ _id for query -> [DB.Field] -- ^ updates -> DB.Action m (Either String DB.Document) -findAndModifyOne coll id updates = do +findAndModifyOne coll objectId updates = do result <- DB.runCommand [ "findAndModify" DB.:= DB.String coll, "new" DB.:= DB.Bool True, -- return updated document, not original document - "query" DB.:= DB.Doc [_id DB.:= DB.ObjId id], + "query" DB.:= DB.Doc [_id DB.:= DB.ObjId objectId], "update" DB.:= DB.Doc updates ] return $ case DB.lookup "err" (DB.at "lastErrorObject" result) result of diff --git a/persistent-test/DataTypeTest.hs b/persistent-test/DataTypeTest.hs index 1f70d4808..9237c4f41 100644 --- a/persistent-test/DataTypeTest.hs +++ b/persistent-test/DataTypeTest.hs @@ -52,7 +52,7 @@ cleanDB :: PersistQuery b m => b m () cleanDB = do deleteWhere ([] :: [Filter DataTypeTable]) -specs :: Specs +specs :: Spec specs = describe "data type specs" $ do it "handles all types" $ asIO $ runConn $ do #ifndef WITH_MONGODB diff --git a/persistent-test/MaxLenTest.hs b/persistent-test/MaxLenTest.hs index 083a95ac0..8853928c4 100644 --- a/persistent-test/MaxLenTest.hs +++ b/persistent-test/MaxLenTest.hs @@ -19,8 +19,10 @@ import Init import Data.Text (Text) import Data.String (IsString) import Data.ByteString (ByteString) +import Test.HUnit (Assertion) #ifdef WITH_MONGODB +db :: Action IO () -> Assertion db = db' (return ()) mkPersist persistSettings [persist| #else @@ -36,7 +38,7 @@ share [mkPersist sqlSettings, mkMigrate "maxlenMigrate"] [persist| deriving Show Eq |] -specs :: Specs +specs :: Spec specs = describe "Maximum length attribute" $ do it "" $ db $ do let t1 = MaxLen a a a a a a