![](https://seccdn.libravatar.org/avatar/e2145bc5cf53dda95c308a3c75e8fef3.jpg?s=120&d=mm&r=g)
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