persistent 2.8.0 → 2.8.1
raw patch · 9 files changed
+281/−116 lines, 9 files
Files
- ChangeLog.md +13/−2
- Database/Persist/Class/PersistStore.hs +32/−4
- Database/Persist/Class/PersistUnique.hs +64/−2
- Database/Persist/Sql/Orphan/PersistQuery.hs +4/−18
- Database/Persist/Sql/Orphan/PersistStore.hs +77/−55
- Database/Persist/Sql/Orphan/PersistUnique.hs +23/−32
- Database/Persist/Sql/Types/Internal.hs +25/−0
- Database/Persist/Sql/Util.hs +42/−2
- persistent.cabal +1/−1
ChangeLog.md view
@@ -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`
Database/Persist/Class/PersistStore.hs view
@@ -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
Database/Persist/Class/PersistUnique.hs view
@@ -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
Database/Persist/Sql/Orphan/PersistQuery.hs view
@@ -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?
Database/Persist/Sql/Orphan/PersistStore.hs view
@@ -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
Database/Persist/Sql/Orphan/PersistUnique.hs view
@@ -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"
Database/Persist/Sql/Types/Internal.hs view
@@ -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
Database/Persist/Sql/Util.hs view
@@ -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, ")"]
persistent.cabal view
@@ -1,5 +1,5 @@ name: persistent-version: 2.8.0+version: 2.8.1 license: MIT license-file: LICENSE author: Michael Snoyman <michael@snoyman.com>