diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,15 +1,26 @@ +## 2.8.1 + +* DRY-ed up and exposed several util functions in `Database.Persist.Sql.Util`. + * Upstream-ed `updatePersistValue`, `mkUpdateText`, and `commaSeparated` from `Database.Persist.MySQL`. + * De-duplicated `updatePersistValue` from various `Database.Persist.Sql.Orphan.*` modules. +* Batching enhancements to reduce db round-trips. + * Added `getMany` and `repsertMany` for batched `get` and `repsert`. + * Added `putMany` with a default/slow implementation. SqlBackend's that support native UPSERT should override this for batching enhancements. + * Updated `insertEntityMany` to replace slow looped usage with batched execution. +* See [#770](https://github.com/yesodweb/persistent/pull/770) + ## 2.8.0 * Switch from `MonadBaseControl` to `MonadUnliftIO` * Reapplies [#723](https://github.com/yesodweb/persistent/pull/723), which was reverted in version 2.7.3. ## 2.7.3.1 - + * Improve error messages when failing to parse database results into Persistent records. [#741](https://github.com/yesodweb/persistent/pull/741) * A handful of `fromPersistField` implementations called `error` instead of returning a `Left Text`. All of the implementations were changed to return `Left`. [#741](https://github.com/yesodweb/persistent/pull/741) * Improve error message when a SQL insert fails with a custom primary key [#757](https://github.com/yesodweb/persistent/pull/757) -## 2.7.3 +## 2.7.3 * Reverts [#723](https://github.com/yesodweb/persistent/pull/723), which generalized functions using the `BackendCompatible` class. These changes were an accidental breaking change. * Recommend the `PersistDbSpecific` docs if someone gets an error about converting from `PersistDbSpecific` diff --git a/Database/Persist/Class/PersistStore.hs b/Database/Persist/Class/PersistStore.hs --- a/Database/Persist/Class/PersistStore.hs +++ b/Database/Persist/Class/PersistStore.hs @@ -30,6 +30,9 @@ import Database.Persist.Class.PersistField import Database.Persist.Types import qualified Data.Aeson as A +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Maybe as Maybe -- | Class which allows the plucking of a @BaseBackend backend@ from some larger type. -- For example, @@ -132,6 +135,18 @@ get :: (MonadIO m, PersistRecordBackend record backend) => Key record -> ReaderT backend m (Maybe record) + -- | Get many records by their respective identifiers, if available. + -- @since 2.8.1 + getMany + :: (MonadIO m, PersistRecordBackend record backend) + => [Key record] -> ReaderT backend m (Map (Key record) record) + getMany [] = return Map.empty + getMany ks = do + vs <- mapM get ks + let kvs = zip ks vs + let kvs' = (fmap Maybe.fromJust) `fmap` filter (\(_,v) -> Maybe.isJust v) kvs + return $ Map.fromList kvs' + class ( Show (BackendKey backend), Read (BackendKey backend) , Eq (BackendKey backend), Ord (BackendKey backend) @@ -175,10 +190,8 @@ -- Useful when migrating data from one entity to another -- and want to preserve ids. -- - -- The MongoDB backend inserts all the entities in one database query. - -- - -- The SQL backends use the slow, default implementation of - -- @mapM_ insertKey@. + -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in + -- one database query. insertEntityMany :: (MonadIO m, PersistRecordBackend record backend) => [Entity record] -> ReaderT backend m () insertEntityMany = mapM_ (\(Entity k record) -> insertKey k record) @@ -192,6 +205,21 @@ -- exist then a new record will be inserted. repsert :: (MonadIO m, PersistRecordBackend record backend) => Key record -> record -> ReaderT backend m () + + -- | Put many entities into the database. + -- + -- Batch version of 'repsert' for SQL backends. + -- + -- Useful when migrating data from one entity to another + -- and want to preserve ids. + -- + -- Differs from @insertEntityMany@ by gracefully skipping + -- pre-existing records matching key(s). + -- @since 2.8.1 + repsertMany + :: (MonadIO m, PersistRecordBackend record backend) + => [(Key record, record)] -> ReaderT backend m () + repsertMany = mapM_ (uncurry repsert) -- | Replace the record in the database with the given -- key. Note that the result is undefined if such record does diff --git a/Database/Persist/Class/PersistUnique.hs b/Database/Persist/Class/PersistUnique.hs --- a/Database/Persist/Class/PersistUnique.hs +++ b/Database/Persist/Class/PersistUnique.hs @@ -9,19 +9,24 @@ ,insertUniqueEntity ,replaceUnique ,checkUnique - ,onlyUnique) + ,onlyUnique + ,defaultPutMany + ,persistUniqueKeyValues + ) where import Database.Persist.Types import Control.Exception (throwIO) import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO, MonadIO) -import Data.List ((\\)) +import Data.List ((\\), deleteFirstsBy, nubBy) +import Data.Function (on) import Control.Monad.Trans.Reader (ReaderT) import Database.Persist.Class.PersistStore import Database.Persist.Class.PersistEntity import Data.Monoid (mappend) import Data.Text (unpack, Text) +import Data.Maybe (catMaybes) -- | Queries against 'Unique' keys (other than the id 'Key'). -- @@ -106,6 +111,17 @@ updateGetEntity (Entity k _) upds = (Entity k) `liftM` (updateGet k upds) + -- | Put many records into db + -- + -- * insert new records that do not exist (or violate any unique constraints) + -- * replace existing records (matching any unique constraint) + -- @since 2.8.1 + putMany + :: (MonadIO m, PersistRecordBackend record backend) + => [record] -- ^ A list of the records you want to insert or replace. + -> ReaderT backend m () + putMany = defaultPutMany + -- | 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'. @@ -249,3 +265,49 @@ case y of Nothing -> checkUniqueKeys xs Just _ -> return (Just x) + +-- | The slow but generic 'putMany' implemetation for any 'PersistUniqueRead'. +-- * Lookup corresponding entities (if any) for each record using 'getByValue' +-- * For pre-existing records, issue a 'replace' for each old key and new record +-- * For new records, issue a bulk 'insertMany_' +defaultPutMany + ::( PersistEntityBackend record ~ BaseBackend backend + , PersistEntity record + , MonadIO m + , PersistStoreWrite backend + , PersistUniqueRead backend + ) + => [record] + -> ReaderT backend m () +defaultPutMany [] = return () +defaultPutMany rsD = do + let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD) + + -- lookup record(s) by their unique key + mEsOld <- mapM getByValue rs + + -- find pre-existing entities and corresponding (incoming) records + let merge (Just x) y = Just (x, y) + merge _ _ = Nothing + let mEsOldAndRs = zipWith merge mEsOld rs + let esOldAndRs = catMaybes mEsOldAndRs + + -- determine records to insert + let esOld = fmap fst esOldAndRs + let rsOld = fmap entityVal esOld + let rsNew = deleteFirstsBy ((==) `on` persistUniqueKeyValues) rs rsOld + + -- determine records to update + let rsUpd = fmap snd esOldAndRs + let ksOld = fmap entityKey esOld + let krs = zip ksOld rsUpd + + -- insert `new` records + insertMany_ rsNew + -- replace existing records + mapM_ (uncurry replace) krs + +-- | The _essence_ of a unique record. +-- useful for comaparing records in haskell land for uniqueness equality. +persistUniqueKeyValues :: PersistEntity record => record -> [PersistValue] +persistUniqueKeyValues r = concat $ map persistUniqueToValues $ persistUniqueKeys r diff --git a/Database/Persist/Sql/Orphan/PersistQuery.hs b/Database/Persist/Sql/Orphan/PersistQuery.hs --- a/Database/Persist/Sql/Orphan/PersistQuery.hs +++ b/Database/Persist/Sql/Orphan/PersistQuery.hs @@ -11,7 +11,8 @@ import Database.Persist hiding (updateField) import Database.Persist.Sql.Util ( - entityColumnNames, parseEntityValues, isIdField) + entityColumnNames, parseEntityValues, isIdField, updatePersistValue + , mkUpdateText, commaSeparated) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) @@ -72,7 +73,7 @@ case map (orderClause False conn) orders of [] -> "" ords -> " ORDER BY " <> T.intercalate "," ords - cols = T.intercalate ", " . entityColumnNames t + cols = commaSeparated . entityColumnNames t sql conn = connLimitOffset conn (limit,offset) (not (null orders)) $ mconcat [ "SELECT " , cols conn @@ -180,7 +181,7 @@ [ "UPDATE " , connEscapeName conn $ entityDB t , " SET " - , T.intercalate "," $ map (go' conn . go) upds + , T.intercalate "," $ map (mkUpdateText conn) upds , wher ] let dat = map updatePersistValue upds `Data.Monoid.mappend` @@ -188,18 +189,7 @@ rawExecuteCount sql dat where t = entityDef $ dummyFromFilts filts - go'' n Assign = n <> "=?" - go'' n Add = mconcat [n, "=", n, "+?"] - go'' n Subtract = mconcat [n, "=", n, "-?"] - go'' n Multiply = mconcat [n, "=", n, "*?"] - go'' n Divide = mconcat [n, "=", n, "/?"] - go'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `mappend` up `mappend` "not supported" - go' conn (x, pu) = go'' (connEscapeName conn x) pu - go x = (updateField x, updateUpdate x) - updateField (Update f _ _) = fieldName f - updateField _ = error "BackendUpdate not implemented" - fieldName :: forall record typ. (PersistEntity record, PersistEntityBackend record ~ SqlBackend) => EntityField record typ -> DBName fieldName f = fieldDB $ persistFieldDef f @@ -363,10 +353,6 @@ showSqlFilter In = " IN " showSqlFilter NotIn = " NOT IN " showSqlFilter (BackendSpecificFilter s) = s - -updatePersistValue :: Update v -> PersistValue -updatePersistValue (Update _ v _) = toPersistValue v -updatePersistValue _ = error "BackendUpdate not implemented" filterClause :: (PersistEntity val, PersistEntityBackend val ~ SqlBackend) => Bool -- ^ include table name? diff --git a/Database/Persist/Sql/Orphan/PersistStore.hs b/Database/Persist/Sql/Orphan/PersistStore.hs --- a/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/Database/Persist/Sql/Orphan/PersistStore.hs @@ -8,6 +8,8 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE Rank2Types #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} + module Database.Persist.Sql.Orphan.PersistStore ( withRawQuery , BackendKey(..) @@ -22,8 +24,10 @@ import Database.Persist import Database.Persist.Sql.Types import Database.Persist.Sql.Raw -import Database.Persist.Sql.Util (dbIdColumns, keyAndEntityColumnNames) -import Data.Conduit +import Database.Persist.Sql.Util ( + dbIdColumns, keyAndEntityColumnNames, parseEntityValues, entityColumnNames + , updatePersistValue, mkUpdateText, commaSeparated) +import Data.Conduit (ConduitM, (=$=), (.|), runConduit) import qualified Data.Conduit.List as CL import qualified Data.Text as T import Data.Text (Text, unpack) @@ -42,6 +46,8 @@ import qualified Data.Aeson as A import Control.Exception (throwIO) import Database.Persist.Class () +import qualified Data.Map as Map +import qualified Data.Foldable as Foldable withRawQuery :: MonadIO m => Text @@ -66,6 +72,8 @@ where entDef = entityDef $ dummyFromKey k +whereStmtForKeys :: PersistEntity record => SqlBackend -> [Key record] -> Text +whereStmtForKeys conn ks = T.intercalate " OR " $ whereStmtForKey conn `fmap` ks -- | get the SQL string for the table that a PeristEntity represents -- Useful for raw SQL queries @@ -130,26 +138,17 @@ update _ [] = return () update k upds = do conn <- ask - let 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'' _ (BackendSpecificUpdate up) = error $ T.unpack $ "BackendSpecificUpdate" `Data.Monoid.mappend` up `mappend` "not supported" - let go' (x, pu) = go'' (connEscapeName conn x) pu let wher = whereStmtForKey conn k let sql = T.concat [ "UPDATE " , connEscapeName conn $ tableDBName $ recordTypeFromKey k , " SET " - , T.intercalate "," $ map (go' . go) upds + , T.intercalate "," $ map (mkUpdateText conn) upds , " WHERE " , wher ] rawExecute sql $ map updatePersistValue upds `mappend` keyToValues k - where - go x = (fieldDB $ updateFieldDef x, updateUpdate x) insert val = do conn <- ask @@ -223,15 +222,9 @@ ent = entityDef vals valss = map (map toPersistValue . toPersistFields) vals - - - insertMany_ [] = return () - insertMany_ vals0 = do conn <- ask - case connMaxParams conn of - Nothing -> insertMany_' vals0 - Just maxParams -> let chunkSize = maxParams `div` length (entityFields t) in - mapM_ insertMany_' (chunksOf chunkSize vals0) + insertMany_ vals0 = runChunked (length $ entityFields t) insertMany_' vals0 where + t = entityDef vals0 insertMany_' vals = do conn <- ask let valss = map (map toPersistValue . toPersistFields) vals @@ -246,11 +239,6 @@ ] rawExecute sql (concat valss) - t = entityDef vals0 - -- Implement this here to avoid depending on the split package - chunksOf _ [] = [] - chunksOf size xs = let (chunk, rest) = splitAt size xs in chunk : chunksOf size rest - replace k val = do conn <- ask let t = entityDef $ Just val @@ -268,14 +256,31 @@ where go conn x = connEscapeName conn x `T.append` "=?" - insertKey = insrepHelper "INSERT" + insertKey k v = insrepHelper "INSERT" [Entity k v] + insertEntityMany es' = do + conn <- ask + let entDef = entityDef $ map entityVal es' + let columnNames = keyAndEntityColumnNames entDef conn + runChunked (length columnNames) go es' + where + go es = insrepHelper "INSERT" es + repsert key value = do mExisting <- get key case mExisting of Nothing -> insertKey key value Just _ -> replace key value + repsertMany krs = do + let es = (uncurry Entity) `fmap` krs + let ks = entityKey `fmap` es + let mEs = Map.fromList $ zip ks es + mRsExisting <- getMany ks + let mEsNew = Map.difference mEs mRsExisting + let esNew = snd `fmap` Map.toList mEsNew + insertEntityMany esNew + delete k = do conn <- ask rawExecute (sql conn) (keyToValues k) @@ -291,42 +296,48 @@ insert v = withReaderT persistBackend $ insert v insertMany vs = withReaderT persistBackend $ insertMany vs insertMany_ vs = withReaderT persistBackend $ insertMany_ vs + insertEntityMany vs = withReaderT persistBackend $ insertEntityMany vs insertKey k v = withReaderT persistBackend $ insertKey k v repsert k v = withReaderT persistBackend $ repsert k v replace k v = withReaderT persistBackend $ replace k v delete k = withReaderT persistBackend $ delete k update k upds = withReaderT persistBackend $ update k upds - + repsertMany krs = withReaderT persistBackend $ repsertMany krs instance PersistStoreRead SqlBackend where get k = do + mEs <- getMany [k] + return $ Map.lookup k mEs + + -- inspired by Database.Persist.Sql.Orphan.PersistQuery.selectSourceRes + getMany [] = return Map.empty + getMany ks@(k:_)= do conn <- ask - let t = entityDef $ dummyFromKey k - let cols = T.intercalate "," - $ map (connEscapeName conn . fieldDB) $ entityFields t - noColumns :: Bool - noColumns = null $ entityFields t - let wher = whereStmtForKey conn k + let t = entityDef . dummyFromKey $ k + let cols = commaSeparated . entityColumnNames t + let wher = whereStmtForKeys conn ks let sql = T.concat [ "SELECT " - , if noColumns then "*" else cols + , cols conn , " FROM " , connEscapeName conn $ entityDB t , " WHERE " , wher ] - withRawQuery sql (keyToValues k) $ do - res <- CL.head - case res of - Nothing -> return Nothing - Just vals -> - case fromPersistValues $ if noColumns then [] else vals of - Left e -> error $ "Error when calling `get` with key: " ++ show k ++ ". Failed to create `" ++ (unpack (unHaskellName $ entityHaskell t)) ++ "` because of error: " ++ unpack e ++ " Potential solution: If your field is using a custom PersistField instance, check that it's correct." - Right v -> return $ Just v + let parse vals + = case parseEntityValues t vals of + Left s -> liftIO $ throwIO $ PersistMarshalError s + Right row -> return row + withRawQuery sql (Foldable.foldMap keyToValues ks) $ do + es <- CL.mapM parse =$= CL.consume + return $ Map.fromList $ fmap (\e -> (entityKey e, entityVal e)) es + instance PersistStoreRead SqlReadBackend where get k = withReaderT persistBackend $ get k + getMany ks = withReaderT persistBackend $ getMany ks instance PersistStoreRead SqlWriteBackend where get k = withReaderT persistBackend $ get k + getMany ks = withReaderT persistBackend $ getMany ks dummyFromKey :: Key record -> Maybe record dummyFromKey = Just . recordTypeFromKey @@ -336,31 +347,42 @@ insrepHelper :: (MonadIO m, PersistEntity val) => Text - -> Key val - -> val + -> [Entity val] -> ReaderT SqlBackend m () -insrepHelper command k record = do +insrepHelper _ [] = return () +insrepHelper command es = do conn <- ask let columnNames = keyAndEntityColumnNames entDef conn rawExecute (sql conn columnNames) vals where - entDef = entityDef $ Just record + entDef = entityDef $ map entityVal es sql conn columnNames = T.concat [ command , " INTO " , connEscapeName conn (entityDB entDef) , "(" , T.intercalate "," columnNames - , ") VALUES(" - , T.intercalate "," (map (const "?") columnNames) + , ") VALUES (" + , T.intercalate "),(" $ replicate (length es) $ T.intercalate "," $ map (const "?") columnNames , ")" ] - vals = entityValues (Entity k record) + vals = Foldable.foldMap entityValues es -updateFieldDef :: PersistEntity v => Update v -> FieldDef -updateFieldDef (Update f _ _) = persistFieldDef f -updateFieldDef (BackendUpdate {}) = error "updateFieldDef did not expect BackendUpdate" +runChunked + :: (Monad m) + => Int + -> ([a] -> ReaderT SqlBackend m ()) + -> [a] + -> ReaderT SqlBackend m () +runChunked _ _ [] = return () +runChunked width m xs = do + conn <- ask + case connMaxParams conn of + Nothing -> m xs + Just maxParams -> let chunkSize = maxParams `div` width in + mapM_ m (chunksOf chunkSize xs) -updatePersistValue :: Update v -> PersistValue -updatePersistValue (Update _ v _) = toPersistValue v -updatePersistValue (BackendUpdate {}) = error "updatePersistValue did not expect BackendUpdate" +-- Implement this here to avoid depending on the split package +chunksOf :: Int -> [a] -> [[a]] +chunksOf _ [] = [] +chunksOf size xs = let (chunk, rest) = splitAt size xs in chunk : chunksOf size rest diff --git a/Database/Persist/Sql/Orphan/PersistUnique.hs b/Database/Persist/Sql/Orphan/PersistUnique.hs --- a/Database/Persist/Sql/Orphan/PersistUnique.hs +++ b/Database/Persist/Sql/Orphan/PersistUnique.hs @@ -2,6 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-unused-imports #-} module Database.Persist.Sql.Orphan.PersistUnique () @@ -11,14 +12,17 @@ import Control.Monad.IO.Class (liftIO, MonadIO) import Control.Monad.Trans.Reader (ReaderT) import Database.Persist +import Database.Persist.Class.PersistUnique (defaultPutMany, persistUniqueKeyValues) import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Database.Persist.Sql.Orphan.PersistStore (withRawQuery) -import Database.Persist.Sql.Util (dbColumns, parseEntityValues) +import Database.Persist.Sql.Util (dbColumns, parseEntityValues, updatePersistValue, mkUpdateText') import qualified Data.Text as T -import Data.Monoid (mappend, (<>)) +import Data.Monoid (mappend) import qualified Data.Conduit.List as CL import Control.Monad.Trans.Reader (ask, withReaderT) +import Data.List (nubBy) +import Data.Function (on) defaultUpsert :: (MonadIO m @@ -30,34 +34,20 @@ uniqueKey <- onlyUnique record upsertBy uniqueKey record updates -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 + let escape = connEscapeName conn + let refCol n = T.concat [escape (entityDB t), ".", n] + let mkUpdateText = mkUpdateText' escape refCol uniqueKey <- onlyUnique record case connUpsertSql conn of Just upsertSql -> case updates of [] -> defaultUpsert record updates _:_ -> do - let upds = T.intercalate "," $ map (go' . go) updates + let upds = T.intercalate "," $ map mkUpdateText updates sql = upsertSql t upds vals = (map toPersistValue $ toPersistFields record) ++ (map updatePersistValue updates) ++ (unqs uniqueKey) - - go'' n Assign = 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 - go x = (fieldDB $ updateFieldDef x, updateUpdate x) x <- rawSql sql vals return $ head x @@ -82,8 +72,21 @@ , " WHERE " , T.intercalate " AND " $ map (go' conn) $ go uniq] + putMany [] = return () + putMany rsD = do + conn <- ask + let rs = nubBy ((==) `on` persistUniqueKeyValues) (reverse rsD) + let ent = entityDef rs + let nr = length rs + let toVals r = (map toPersistValue $ toPersistFields r) + case connPutManySql conn of + (Just mkSql) -> rawExecute (mkSql ent nr) (concat (map toVals rs)) + Nothing -> defaultPutMany rs + instance PersistUniqueWrite SqlWriteBackend where deleteBy uniq = withReaderT persistBackend $ deleteBy uniq + upsert rs us = withReaderT persistBackend $ upsert rs us + putMany rs = withReaderT persistBackend $ putMany rs instance PersistUniqueRead SqlBackend where getBy uniq = do @@ -122,15 +125,3 @@ dummyFromUnique :: Unique v -> Maybe v dummyFromUnique _ = Nothing - -updateFieldDef - :: PersistEntity v - => Update v -> FieldDef -updateFieldDef (Update f _ _) = persistFieldDef f -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" diff --git a/Database/Persist/Sql/Types/Internal.hs b/Database/Persist/Sql/Types/Internal.hs --- a/Database/Persist/Sql/Types/Internal.hs +++ b/Database/Persist/Sql/Types/Internal.hs @@ -68,6 +68,31 @@ , connInsertSql :: EntityDef -> [PersistValue] -> InsertSqlResult , connInsertManySql :: Maybe (EntityDef -> [[PersistValue]] -> InsertSqlResult) -- ^ SQL for inserting many rows and returning their primary keys, for backends that support this functioanlity. If 'Nothing', rows will be inserted one-at-a-time using 'connInsertSql'. , connUpsertSql :: Maybe (EntityDef -> Text -> Text) + -- ^ Some databases support performing UPSERT _and_ RETURN entity + -- in a single call. + -- + -- This field when set will be used to generate the UPSERT+RETURN sql given + -- * an entity definition + -- * updates to be run on unique key(s) collision + -- + -- When left as 'Nothing', we find the unique key from entity def before + -- * trying to fetch an entity by said key + -- * perform an update when result found, else issue an insert + -- * return new entity from db + -- + -- @since 2.6 + , connPutManySql :: Maybe (EntityDef -> Int -> Text) + -- ^ Some databases support performing bulk UPSERT, specifically + -- "insert or replace many records" in a single call. + -- + -- This field when set, given + -- * an entity definition + -- * number of records to be inserted + -- should produce a PUT MANY sql with placeholders for records + -- + -- When left as 'Nothing', we default to using 'defaultPutMany'. + -- + -- @since 2.8.1 , connStmtMap :: IORef (Map Text Statement) , connClose :: IO () , connMigrateSql diff --git a/Database/Persist/Sql/Util.hs b/Database/Persist/Sql/Util.hs --- a/Database/Persist/Sql/Util.hs +++ b/Database/Persist/Sql/Util.hs @@ -9,18 +9,26 @@ , dbIdColumns , dbIdColumnsEsc , dbColumns + , updateFieldDef + , updatePersistValue + , mkUpdateText + , mkUpdateText' + , commaSeparated + , parenWrapped ) where import Data.Maybe (isJust) import Data.Monoid ((<>)) +import qualified Data.Text as T import Data.Text (Text, pack) import Database.Persist ( Entity(Entity), EntityDef, EntityField, HaskellName(HaskellName) , PersistEntity, PersistValue , keyFromValues, fromPersistValues, fieldDB, entityId, entityPrimary , entityFields, entityKeyFields, fieldHaskell, compositeFields, persistFieldDef - , keyAndEntityFields - , DBName) + , keyAndEntityFields, toPersistValue, DBName, Update(..), PersistUpdate(..) + , FieldDef + ) import Database.Persist.Sql.Types (Sql, SqlBackend, connEscapeName) entityColumnNames :: EntityDef -> SqlBackend -> [Sql] @@ -85,3 +93,35 @@ isIdField :: PersistEntity record => EntityField record typ -> Bool isIdField f = fieldHaskell (persistFieldDef f) == HaskellName "Id" + +-- | Gets the 'FieldDef' for an 'Update'. +updateFieldDef :: PersistEntity v => Update v -> FieldDef +updateFieldDef (Update f _ _) = persistFieldDef f +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" + +commaSeparated :: [Text] -> Text +commaSeparated = T.intercalate ", " + +mkUpdateText :: PersistEntity record => SqlBackend -> Update record -> Text +mkUpdateText conn = mkUpdateText' (connEscapeName conn) id + +mkUpdateText' :: PersistEntity record => (DBName -> Text) -> (Text -> Text) -> Update record -> Text +mkUpdateText' escapeName refColumn x = + case updateUpdate x of + Assign -> n <> "=?" + Add -> T.concat [n, "=", refColumn n, "+?"] + Subtract -> T.concat [n, "=", refColumn n, "-?"] + Multiply -> T.concat [n, "=", refColumn n, "*?"] + Divide -> T.concat [n, "=", refColumn n, "/?"] + BackendSpecificUpdate up -> + error . T.unpack $ "mkUpdateText: BackendSpecificUpdate " <> up <> " not supported" + where + n = escapeName . fieldDB . updateFieldDef $ x + +parenWrapped :: Text -> Text +parenWrapped t = T.concat ["(", t, ")"] diff --git a/persistent.cabal b/persistent.cabal --- a/persistent.cabal +++ b/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.8.0 +version: 2.8.1 license: MIT license-file: LICENSE author: Michael Snoyman