persistent 2.6.1 → 2.7.0
raw patch · 4 files changed
+170/−111 lines, 4 filesnew-uploader
Files
- ChangeLog.md +6/−0
- Database/Persist/Class/PersistUnique.hs +105/−72
- Database/Persist/Sql/Orphan/PersistUnique.hs +58/−38
- persistent.cabal +1/−1
ChangeLog.md view
@@ -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]`
Database/Persist/Class/PersistUnique.hs view
@@ -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+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+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
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -1,9 +1,12 @@ {-# 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) import Control.Monad.Trans.Reader (ReaderT)@@ -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"
persistent.cabal view
@@ -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>