Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2017-08-31 20:57:51 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Package is "ghc-persistent" Thu Aug 31 20:57:51 2017 rev:8 rq:513449 version:2.7.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2017-04-11 09:43:03.230959323 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new/ghc-persistent.changes 2017-08-31 20:57:52.371535331 +0200 @@ -1,0 +2,5 @@ +Thu Jul 27 14:07:37 UTC 2017 - psimons@suse.com + +- Update to version 2.7.0. + +------------------------------------------------------------------- Old: ---- persistent-2.6.1.tar.gz New: ---- persistent-2.7.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.tIXxDr/_old 2017-08-31 20:57:53.123429689 +0200 +++ /var/tmp/diff_new_pack.tIXxDr/_new 2017-08-31 20:57:53.127429126 +0200 @@ -19,7 +19,7 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.6.1 +Version: 2.7.0 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT ++++++ persistent-2.6.1.tar.gz -> persistent-2.7.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/ChangeLog.md new/persistent-2.7.0/ChangeLog.md --- old/persistent-2.6.1/ChangeLog.md 2017-03-06 13:58:44.000000000 +0100 +++ new/persistent-2.7.0/ChangeLog.md 2017-04-10 20:11:23.000000000 +0200 @@ -1,3 +1,9 @@ +## 2.7.0 + +* Fix upsert behavior [#613](https://github.com/yesodweb/persistent/issues/613) +* Atomic upsert query fixed for arithmatic operations [#662](https://github.com/yesodweb/persistent/issues/662) +* Haddock and test coverage improved for upsert + ## 2.6.1 * Fix edge case for `\<-. [Nothing]` diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/Database/Persist/Class/PersistUnique.hs new/persistent-2.7.0/Database/Persist/Class/PersistUnique.hs --- old/persistent-2.6.1/Database/Persist/Class/PersistUnique.hs 2017-03-01 07:48:55.000000000 +0100 +++ new/persistent-2.7.0/Database/Persist/Class/PersistUnique.hs 2017-04-10 20:00:24.000000000 +0200 @@ -1,18 +1,19 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} + module Database.Persist.Class.PersistUnique - ( PersistUniqueRead (..) - , PersistUniqueWrite (..) - , getByValue - , insertBy - , replaceUnique - , checkUnique - , onlyUnique - ) where + (PersistUniqueRead(..) + ,PersistUniqueWrite(..) + ,getByValue + ,insertBy + ,replaceUnique + ,checkUnique + ,onlyUnique) + where import Database.Persist.Types import Control.Exception (throwIO) -import Control.Monad (liftM, when) +import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO, MonadIO) import Data.List ((\\)) import Control.Monad.Trans.Reader (ReaderT) @@ -36,9 +37,12 @@ -- you must manually place a unique index on a field to have a uniqueness -- constraint. -- -class (PersistCore backend, PersistStoreRead backend) => PersistUniqueRead backend where +class (PersistCore backend, PersistStoreRead backend) => + PersistUniqueRead backend where -- | Get a record by unique key, if available. Returns also the identifier. - getBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m (Maybe (Entity record)) + getBy + :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -> ReaderT backend m (Maybe (Entity record)) -- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for @@ -49,72 +53,71 @@ -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction. -class (PersistUniqueRead backend, PersistStoreWrite backend) => PersistUniqueWrite backend where - +class (PersistUniqueRead backend, PersistStoreWrite backend) => + PersistUniqueWrite backend where -- | Delete a specific record by unique key. Does nothing if no record -- matches. - deleteBy :: (MonadIO m, PersistRecordBackend record backend) => Unique record -> ReaderT backend m () - + deleteBy + :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -> ReaderT backend m () -- | Like 'insert', but returns 'Nothing' when the record -- couldn't be inserted because of a uniqueness constraint. - insertUnique :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Key record)) + insertUnique + :: (MonadIO m, PersistRecordBackend record backend) + => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum case conflict of - Nothing -> Just `liftM` insert datum - Just _ -> return Nothing - + Nothing -> Just `liftM` insert datum + Just _ -> return Nothing -- | Update based on a uniqueness constraint or insert: -- -- * insert the new record if it does not exist; - -- * update the existing record that matches the uniqueness contraint. + -- * If the record exists (matched via it's uniqueness constraint), then update the existing record with the parameters which is passed on as list to the function. -- -- Throws an exception if there is more than 1 uniqueness contraint. - upsert :: (MonadIO m, PersistRecordBackend record backend) - => record -- ^ new record to insert - -> [Update record] - -- ^ updates to perform if the record already exists (leaving - -- this empty is the equivalent of performing a 'repsert' on a - -- unique key) - -> ReaderT backend m (Entity record) - -- ^ the record in the database after the operation + upsert + :: (MonadIO m, PersistRecordBackend record backend) + => record -- ^ new record to insert + -> [Update record] -- ^ updates to perform if the record already exists (leaving + -- this empty is the equivalent of performing a 'repsert' on a + -- unique key) + -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsert record updates = do uniqueKey <- onlyUnique record upsertBy uniqueKey record updates - -- | Update based on a given uniqueness constraint or insert: -- -- * insert the new record if it does not exist; -- * update the existing record that matches the given uniqueness contraint. - upsertBy :: (MonadIO m, PersistRecordBackend record backend) - => Unique record -- ^ uniqueness constraint to find by - -> record -- ^ new record to insert - -> [Update record] - -- ^ updates to perform if the record already exists (leaving - -- this empty is the equivalent of performing a 'repsert' on a - -- unique key) - -> ReaderT backend m (Entity record) - -- ^ the record in the database after the operation + upsertBy + :: (MonadIO m, PersistRecordBackend record backend) + => Unique record -- ^ uniqueness constraint to find by + -> record -- ^ new record to insert + -> [Update record] -- ^ updates to perform if the record already exists (leaving + -- this empty is the equivalent of performing a 'repsert' on a + -- unique key) + -> ReaderT backend m (Entity record) -- ^ the record in the database after the operation upsertBy uniqueKey record updates = do - mExists <- getBy uniqueKey - k <- case mExists of - Just (Entity k _) -> do - when (null updates) (replace k record) - return k - Nothing -> insert record - Entity k `liftM` updateGet k updates - + mrecord <- getBy uniqueKey + maybe (insertEntity record) (`updateGetEntity` updates) mrecord + where + updateGetEntity (Entity k _) upds = + (Entity k) `liftM` (updateGet k upds) -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is returned as 'Left'. Otherwise, the -- new 'Key is returned as 'Right'. -insertBy :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Either (Entity record) (Key record)) +insertBy + :: (MonadIO m + ,PersistUniqueWrite backend + ,PersistRecordBackend record backend) + => record -> ReaderT backend m (Either (Entity record) (Key record)) insertBy val = do res <- getByValue val case res of - Nothing -> Right `liftM` insert val - Just z -> return $ Left z + Nothing -> Right `liftM` insert val + Just z -> return $ Left z -- | Insert a value, checking for conflicts with any unique constraints. If a -- duplicate exists in the database, it is left untouched. The key of the @@ -128,24 +131,37 @@ Just (Entity key _) -> return key -- | Return the single unique key for a record. -onlyUnique :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Unique record) -onlyUnique record = case onlyUniqueEither record of - Right u -> return u - Left us -> requireUniques record us >>= liftIO . throwIO . OnlyUniqueException . show . length - -onlyUniqueEither :: (PersistEntity record) => record -> Either [Unique record] (Unique record) -onlyUniqueEither record = case persistUniqueKeys record of - [u] -> Right u - us -> Left us +onlyUnique + :: (MonadIO m + ,PersistUniqueWrite backend + ,PersistRecordBackend record backend) + => record -> ReaderT backend m (Unique record) +onlyUnique record = + case onlyUniqueEither record of + Right u -> return u + Left us -> + requireUniques record us >>= + liftIO . throwIO . OnlyUniqueException . show . length + +onlyUniqueEither + :: (PersistEntity record) + => record -> Either [Unique record] (Unique record) +onlyUniqueEither record = + case persistUniqueKeys record of + [u] -> Right u + us -> Left us -- | A modification of 'getBy', which takes the 'PersistEntity' itself instead -- of a 'Unique' record. Returns a record matching /one/ of the unique keys. This -- function makes the most sense on entities with a single 'Unique' -- constructor. -getByValue :: (MonadIO m, PersistUniqueRead backend, PersistRecordBackend record backend) - => record -> ReaderT backend m (Maybe (Entity record)) -getByValue record = checkUniques =<< requireUniques record (persistUniqueKeys record) +getByValue + :: (MonadIO m + ,PersistUniqueRead backend + ,PersistRecordBackend record backend) + => record -> ReaderT backend m (Maybe (Entity record)) +getByValue record = + checkUniques =<< requireUniques record (persistUniqueKeys record) where checkUniques [] = return Nothing checkUniques (x:xs) = do @@ -154,14 +170,19 @@ Nothing -> checkUniques xs Just z -> return $ Just z -requireUniques :: (MonadIO m, PersistEntity record) => record -> [Unique record] -> m [Unique record] +requireUniques + :: (MonadIO m, PersistEntity record) + => record -> [Unique record] -> m [Unique record] requireUniques record [] = liftIO $ throwIO $ userError errorMsg where errorMsg = "getByValue: " `Data.Monoid.mappend` unpack (recordName record) `mappend` " does not have any Unique" + requireUniques _ xs = return xs -- TODO: expose this to users -recordName :: (PersistEntity record) => record -> Text +recordName + :: (PersistEntity record) + => record -> Text recordName = unHaskellName . entityHaskell . entityDef . Just -- | Attempt to replace the record of the given key with the given new record. @@ -172,16 +193,21 @@ -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- Since 1.2.2.0 -replaceUnique :: (MonadIO m, Eq record, Eq (Unique record), PersistRecordBackend record backend, PersistUniqueWrite backend) - => Key record -> record -> ReaderT backend m (Maybe (Unique record)) +replaceUnique + :: (MonadIO m + ,Eq record + ,Eq (Unique record) + ,PersistRecordBackend record backend + ,PersistUniqueWrite backend) + => Key record -> record -> ReaderT backend m (Maybe (Unique record)) replaceUnique key datumNew = getJust key >>= replaceOriginal where uniqueKeysNew = persistUniqueKeys datumNew replaceOriginal original = do conflict <- checkUniqueKeys changedKeys case conflict of - Nothing -> replace key datumNew >> return Nothing - (Just conflictingKey) -> return $ Just conflictingKey + Nothing -> replace key datumNew >> return Nothing + (Just conflictingKey) -> return $ Just conflictingKey where changedKeys = uniqueKeysNew \\ uniqueKeysOriginal uniqueKeysOriginal = persistUniqueKeys original @@ -191,12 +217,19 @@ -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key -checkUnique :: (MonadIO m, PersistRecordBackend record backend, PersistUniqueRead backend) - => record -> ReaderT backend m (Maybe (Unique record)) +checkUnique + :: (MonadIO m + ,PersistRecordBackend record backend + ,PersistUniqueRead backend) + => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys -checkUniqueKeys :: (MonadIO m, PersistEntity record, PersistUniqueRead backend, PersistRecordBackend record backend) - => [Unique record] -> ReaderT backend m (Maybe (Unique record)) +checkUniqueKeys + :: (MonadIO m + ,PersistEntity record + ,PersistUniqueRead backend + ,PersistRecordBackend record backend) + => [Unique record] -> ReaderT backend m (Maybe (Unique record)) checkUniqueKeys [] = return Nothing checkUniqueKeys (x:xs) = do y <- getBy x diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/Database/Persist/Sql/Orphan/PersistUnique.hs new/persistent-2.7.0/Database/Persist/Sql/Orphan/PersistUnique.hs --- old/persistent-2.6.1/Database/Persist/Sql/Orphan/PersistUnique.hs 2017-03-01 07:48:55.000000000 +0100 +++ new/persistent-2.7.0/Database/Persist/Sql/Orphan/PersistUnique.hs 2017-04-10 19:42:16.000000000 +0200 @@ -1,8 +1,11 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Database.Persist.Sql.Orphan.PersistUnique () where +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Sql.Orphan.PersistUnique + () + where import Control.Exception (throwIO) import Control.Monad.IO.Class (liftIO, MonadIO) @@ -17,15 +20,24 @@ import qualified Data.Conduit.List as CL import Control.Monad.Trans.Reader (ask, withReaderT) -defaultUpsert :: (MonadIO m, PersistEntity record, PersistUniqueWrite backend - , PersistEntityBackend record ~ BaseBackend backend) - => record -> [Update record] -> ReaderT backend m (Entity record) +defaultUpsert + :: (MonadIO m + ,PersistEntity record + ,PersistUniqueWrite backend + ,PersistEntityBackend record ~ BaseBackend backend) + => record -> [Update record] -> ReaderT backend m (Entity record) defaultUpsert record updates = do - uniqueKey <- onlyUnique record - upsertBy uniqueKey record updates + uniqueKey <- onlyUnique record + upsertBy uniqueKey record updates -instance PersistUniqueWrite SqlBackend where +escape :: DBName -> T.Text +escape (DBName s) = T.pack $ '"' : escapeQuote (T.unpack s) ++ "\"" + where + escapeQuote "" = "" + escapeQuote ('"':xs) = "\"\"" ++ escapeQuote xs + escapeQuote (x:xs) = x : escapeQuote xs +instance PersistUniqueWrite SqlBackend where upsert record updates = do conn <- ask uniqueKey <- onlyUnique record @@ -38,10 +50,10 @@ vals = (map toPersistValue $ toPersistFields record) ++ (map updatePersistValue updates) ++ (unqs uniqueKey) go'' n Assign = n <> "=?" - go'' n Add = T.concat [n, "=", n, "+?"] - go'' n Subtract = T.concat [n, "=", n, "-?"] - go'' n Multiply = T.concat [n, "=", n, "*?"] - go'' n Divide = T.concat [n, "=", n, "/?"] + go'' n Add = T.concat [n, "=", escape (entityDB t) <> ".", n, "+?"] + go'' n Subtract = T.concat [n, "=", escape (entityDB t) <> ".", n, "-?"] + go'' n Multiply = T.concat [n, "=", escape (entityDB t) <> ".", n, "*?"] + go'' n Divide = T.concat [n, "=", escape (entityDB t) <> ".", n, "/?"] go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported" go' (x, pu) = go'' (connEscapeName conn x) pu @@ -63,54 +75,62 @@ t = entityDef $ dummyFromUnique uniq go = map snd . persistUniqueToFieldNames go' conn x = connEscapeName conn x `mappend` "=?" - sql conn = T.concat - [ "DELETE FROM " - , connEscapeName conn $ entityDB t - , " WHERE " - , T.intercalate " AND " $ map (go' conn) $ go uniq - ] + sql conn = + T.concat + [ "DELETE FROM " + , connEscapeName conn $ entityDB t + , " WHERE " + , T.intercalate " AND " $ map (go' conn) $ go uniq] + instance PersistUniqueWrite SqlWriteBackend where deleteBy uniq = withReaderT persistBackend $ deleteBy uniq instance PersistUniqueRead SqlBackend where getBy uniq = do conn <- ask - let sql = T.concat - [ "SELECT " - , T.intercalate "," $ dbColumns conn t - , " FROM " - , connEscapeName conn $ entityDB t - , " WHERE " - , sqlClause conn - ] + let sql = + T.concat + [ "SELECT " + , T.intercalate "," $ dbColumns conn t + , " FROM " + , connEscapeName conn $ entityDB t + , " WHERE " + , sqlClause conn] uvals = persistUniqueToValues uniq - withRawQuery sql uvals $ do - row <- CL.head - case row of - Nothing -> return Nothing - Just [] -> error "getBy: empty row" - Just vals -> case parseEntityValues t vals of - Left err -> liftIO $ throwIO $ PersistMarshalError err - Right r -> return $ Just r + withRawQuery sql uvals $ + do row <- CL.head + case row of + Nothing -> return Nothing + Just [] -> error "getBy: empty row" + Just vals -> + case parseEntityValues t vals of + Left err -> + liftIO $ throwIO $ PersistMarshalError err + Right r -> return $ Just r where sqlClause conn = T.intercalate " AND " $ map (go conn) $ toFieldNames' uniq go conn x = connEscapeName conn x `mappend` "=?" t = entityDef $ dummyFromUnique uniq toFieldNames' = map snd . persistUniqueToFieldNames + instance PersistUniqueRead SqlReadBackend where getBy uniq = withReaderT persistBackend $ getBy uniq + instance PersistUniqueRead SqlWriteBackend where getBy uniq = withReaderT persistBackend $ getBy uniq dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing - -updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef + :: PersistEntity v + => Update v -> FieldDef updateFieldDef (Update f _ _) = persistFieldDef f -updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate" +updateFieldDef (BackendUpdate{}) = + error "updateFieldDef did not expect BackendUpdate" updatePersistValue :: Update v -> PersistValue updatePersistValue (Update _ v _) = toPersistValue v -updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate" +updatePersistValue (BackendUpdate{}) = + error "updatePersistValue did not expect BackendUpdate" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.6.1/persistent.cabal new/persistent-2.7.0/persistent.cabal --- old/persistent-2.6.1/persistent.cabal 2017-03-03 10:45:56.000000000 +0100 +++ new/persistent-2.7.0/persistent.cabal 2017-04-10 20:12:20.000000000 +0200 @@ -1,5 +1,5 @@ name: persistent -version: 2.6.1 +version: 2.7.0 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>