Merge branch 'master' of github.com:yesodweb/persistent

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
@@ -118,7 +121,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)) 
@@ -161,38 +164,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) ((persistKeyToMongoId 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
@@ -237,17 +261,50 @@ instance (Applicative m, Functor m, Trans.MonadIO m, MonadBaseControl IO m) => P
       where
         t = entityDef $ dummyFromUnique uniq
 
-persistKeyToMongoId :: PersistEntity val => Key DB.Action val -> DB.Field
-persistKeyToMongoId k = "_id" DB.:= (DB.ObjId $ keyToOid k)
+_id :: T.Text
+_id = "_id"
+
+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.ObjectId -- ^ _id for query
+                 -> [DB.Field]  -- ^ updates
+                 -> DB.Action m (Either String DB.Document)
+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 objectId],
+     "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 k upds =
+    update key upds =
         DB.modify 
-           (DB.Select [persistKeyToMongoId k]  (unDBName $ entityDB t)) 
+           (DB.Select [keyToMongoIdField key] (unDBName $ entityDB t))
            $ updateFields upds
       where
-        t = entityDef $ dummyFromKey k
+        t = entityDef $ dummyFromKey key
+
+    updateGet key upds = do
+        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
+
 
     updateWhere _ [] = return ()
     updateWhere filts upds =
@@ -312,7 +369,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
 
@@ -354,7 +411,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 [] -> []
@@ -378,7 +435,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

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

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")

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

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

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

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

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

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

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"

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