Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2016-10-18 10:41:03 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent" Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2016-07-21 08:16:03.000000000 +0200 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new/ghc-persistent.changes 2016-10-18 10:41:03.000000000 +0200 @@ -1,0 +2,10 @@ +Fri Sep 30 08:18:50 UTC 2016 - [email protected] + +- Update to version 2.6 revision 2 with cabal2obs. + +------------------------------------------------------------------- +Thu Sep 15 07:09:44 UTC 2016 - [email protected] + +- Update to version 2.6 revision 1 with cabal2obs. + +------------------------------------------------------------------- Old: ---- persistent-2.2.4.1.tar.gz New: ---- persistent-2.6.tar.gz persistent.cabal ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.43DcLl/_old 2016-10-18 10:41:05.000000000 +0200 +++ /var/tmp/diff_new_pack.43DcLl/_new 2016-10-18 10:41:05.000000000 +0200 @@ -19,15 +19,15 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.2.4.1 +Version: 2.6 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT -Group: System/Libraries +Group: Development/Languages/Other Url: https://hackage.haskell.org/package/%{pkg_name} Source0: https://hackage.haskell.org/package/%{pkg_name}-%{version}/%{pkg_name}-%{version}.tar.gz +Source1: https://hackage.haskell.org/package/%{pkg_name}-%{version}/revision/2.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel -# Begin cabal-rpm deps: BuildRequires: ghc-aeson-devel BuildRequires: ghc-attoparsec-devel BuildRequires: ghc-base64-bytestring-devel @@ -62,7 +62,6 @@ %if %{with tests} BuildRequires: ghc-hspec-devel %endif -# End cabal-rpm deps %description Hackage documentation generation is not reliable. For up to date documentation, @@ -81,21 +80,16 @@ %prep %setup -q -n %{pkg_name}-%{version} - +cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build - %install %ghc_lib_install - %check -%if %{with tests} -%{cabal} test -%endif - +%cabal_test %post devel %ghc_pkg_recache @@ -109,6 +103,5 @@ %files devel -f %{name}-devel.files %defattr(-,root,root,-) -%doc ChangeLog.md README.md %changelog ++++++ persistent-2.2.4.1.tar.gz -> persistent-2.6.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/ChangeLog.md new/persistent-2.6/ChangeLog.md --- old/persistent-2.2.4.1/ChangeLog.md 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/ChangeLog.md 2016-08-10 05:29:36.000000000 +0200 @@ -1,3 +1,12 @@ +## 2.6 + +* Add `connUpsertSql` type for providing backend-specific upsert sql support. + +## 2.5 + +* read/write typeclass split +* add insertOrGet convenience function to PersistUnique + ## 2.2.4.1 * Documentation updates [#515](https://github.com/yesodweb/persistent/pull/515) @@ -14,6 +23,7 @@ ## 2.2.2 * Add liftSqlPersistMPool function +* support http-api-data for url serialization ## 2.2.1 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Class/DeleteCascade.hs new/persistent-2.6/Database/Persist/Class/DeleteCascade.hs --- old/persistent-2.2.4.1/Database/Persist/Class/DeleteCascade.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Class/DeleteCascade.hs 2016-07-17 04:15:37.000000000 +0200 @@ -18,7 +18,7 @@ -- | For combinations of backends and entities that support -- cascade-deletion. “Cascade-deletion” means that entries that depend on -- other entries to be deleted will be deleted as well. -class (PersistStore backend, PersistEntity record, backend ~ PersistEntityBackend record) +class (PersistStoreWrite backend, PersistEntity record, BaseBackend backend ~ PersistEntityBackend record) => DeleteCascade record backend where -- | Perform cascade-deletion of single database @@ -26,7 +26,7 @@ deleteCascade :: MonadIO m => Key record -> ReaderT backend m () -- | Cascade-deletion of entries satisfying given filters. -deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQuery backend) +deleteCascadeWhere :: (MonadIO m, DeleteCascade record backend, PersistQueryWrite backend) => [Filter record] -> ReaderT backend m () deleteCascadeWhere filts = do srcRes <- selectKeysRes filts [] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Class/PersistQuery.hs new/persistent-2.6/Database/Persist/Class/PersistQuery.hs --- old/persistent-2.2.4.1/Database/Persist/Class/PersistQuery.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Class/PersistQuery.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,7 +1,10 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE FlexibleContexts #-} module Database.Persist.Class.PersistQuery - ( PersistQuery (..) + ( PersistQueryRead (..) + , PersistQueryWrite (..) , selectSource , selectKeys , selectList @@ -19,51 +22,53 @@ import Control.Monad.Trans.Resource (MonadResource, release) import Data.Acquire (Acquire, allocateAcquire, with) --- | Backends supporting conditional operations. -class PersistStore backend => PersistQuery backend where - -- | Update individual fields on any record matching the given criterion. - updateWhere :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) - => [Filter val] -> [Update val] -> ReaderT backend m () - - -- | Delete all records matching the given criterion. - deleteWhere :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) - => [Filter val] -> ReaderT backend m () - +-- | Backends supporting conditional read operations. +class (PersistCore backend, PersistStoreRead backend) => PersistQueryRead backend where -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSourceRes - :: (PersistEntity val, PersistEntityBackend val ~ backend, MonadIO m1, MonadIO m2) - => [Filter val] - -> [SelectOpt val] - -> ReaderT backend m1 (Acquire (C.Source m2 (Entity val))) + :: (PersistRecordBackend record backend, MonadIO m1, MonadIO m2) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m1 (Acquire (C.Source m2 (Entity record))) -- | Get just the first record for the criterion. - selectFirst :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) - => [Filter val] - -> [SelectOpt val] - -> ReaderT backend m (Maybe (Entity val)) + selectFirst :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m (Maybe (Entity record)) selectFirst filts opts = do srcRes <- selectSourceRes filts (LimitTo 1 : opts) liftIO $ with srcRes (C.$$ CL.head) -- | Get the 'Key's of all records matching the given criterion. selectKeysRes - :: (MonadIO m1, MonadIO m2, PersistEntity val, backend ~ PersistEntityBackend val) - => [Filter val] - -> [SelectOpt val] - -> ReaderT backend m1 (Acquire (C.Source m2 (Key val))) + :: (MonadIO m1, MonadIO m2, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m1 (Acquire (C.Source m2 (Key record))) -- | The total number of records fulfilling the given criterion. - count :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) - => [Filter val] -> ReaderT backend m Int + count :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> ReaderT backend m Int + +-- | Backends supporting conditional write operations +class (PersistQueryRead backend, PersistStoreWrite backend) => PersistQueryWrite backend where + -- | Update individual fields on any record matching the given criterion. + updateWhere :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> [Update record] -> ReaderT backend m () + + -- | Delete all records matching the given criterion. + deleteWhere :: (MonadIO m, PersistRecordBackend record backend) + => [Filter record] -> ReaderT backend m () -- | Get all records matching the given criterion in the specified order. -- Returns also the identifiers. selectSource - :: (PersistQuery backend, MonadResource m, PersistEntity val, PersistEntityBackend val ~ backend, MonadReader env m, HasPersistBackend env backend) - => [Filter val] - -> [SelectOpt val] - -> C.Source m (Entity val) + :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, PersistEntityBackend record ~ BaseBackend (BaseBackend backend), MonadReader backend m, HasPersistBackend backend) + => [Filter record] + -> [SelectOpt record] + -> C.Source m (Entity record) selectSource filts opts = do srcRes <- liftPersist $ selectSourceRes filts opts (releaseKey, src) <- allocateAcquire srcRes @@ -71,10 +76,10 @@ release releaseKey -- | Get the 'Key's of all records matching the given criterion. -selectKeys :: (PersistQuery backend, MonadResource m, PersistEntity val, backend ~ PersistEntityBackend val, MonadReader env m, HasPersistBackend env backend) - => [Filter val] - -> [SelectOpt val] - -> C.Source m (Key val) +selectKeys :: (PersistQueryRead (BaseBackend backend), MonadResource m, PersistEntity record, BaseBackend (BaseBackend backend) ~ PersistEntityBackend record, MonadReader backend m, HasPersistBackend backend) + => [Filter record] + -> [SelectOpt record] + -> C.Source m (Key record) selectKeys filts opts = do srcRes <- liftPersist $ selectKeysRes filts opts (releaseKey, src) <- allocateAcquire srcRes @@ -82,19 +87,19 @@ release releaseKey -- | Call 'selectSource' but return the result as a list. -selectList :: (MonadIO m, PersistEntity val, PersistQuery backend, PersistEntityBackend val ~ backend) - => [Filter val] - -> [SelectOpt val] - -> ReaderT backend m [Entity val] +selectList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m [Entity record] selectList filts opts = do srcRes <- selectSourceRes filts opts liftIO $ with srcRes (C.$$ CL.consume) -- | Call 'selectKeys' but return the result as a list. -selectKeysList :: (MonadIO m, PersistEntity val, PersistQuery backend, PersistEntityBackend val ~ backend) - => [Filter val] - -> [SelectOpt val] - -> ReaderT backend m [Key val] +selectKeysList :: (MonadIO m, PersistQueryRead backend, PersistRecordBackend record backend) + => [Filter record] + -> [SelectOpt record] + -> ReaderT backend m [Key record] selectKeysList filts opts = do srcRes <- selectKeysRes filts opts liftIO $ with srcRes (C.$$ CL.consume) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Class/PersistStore.hs new/persistent-2.6/Database/Persist/Class/PersistStore.hs --- old/persistent-2.2.4.1/Database/Persist/Class/PersistStore.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Class/PersistStore.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,10 +1,15 @@ {-# LANGUAGE TypeFamilies, FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE ConstraintKinds #-} module Database.Persist.Class.PersistStore ( HasPersistBackend (..) + , IsPersistBackend (..) + , PersistRecordBackend , liftPersist - , PersistStore (..) + , PersistCore (..) + , PersistStoreRead (..) + , PersistStoreWrite (..) , getJust , belongsTo , belongsToJust @@ -22,12 +27,30 @@ import Database.Persist.Types import qualified Data.Aeson as A -class HasPersistBackend env backend | env -> backend where - persistBackend :: env -> backend - -liftPersist :: (MonadReader env m, HasPersistBackend env backend, MonadIO m) - => ReaderT backend IO a - -> m a +-- | Class which allows the plucking of a @BaseBackend backend@ from some larger type. +-- For example, +-- @ +-- instance HasPersistBackend (SqlReadBackend, Int) where +-- type BaseBackend (SqlReadBackend, Int) = SqlBackend +-- persistBackend = unSqlReadBackend . fst +-- @ +class HasPersistBackend backend where + type BaseBackend backend + persistBackend :: backend -> BaseBackend backend +-- | Class which witnesses that @backend@ is essentially the same as @BaseBackend backend@. +-- That is, they're isomorphic and @backend@ is just some wrapper over @BaseBackend backend@. +class (HasPersistBackend backend) => IsPersistBackend backend where + -- | This function is how we actually construct and tag a backend as having read or write capabilities. + -- It should be used carefully and only when actually constructing a @backend@. Careless use allows us + -- to accidentally run a write query against a read-only database. + mkPersistBackend :: BaseBackend backend -> backend + +-- | A convenient alias for common type signatures +type PersistRecordBackend record backend = (PersistEntity record, PersistEntityBackend record ~ BaseBackend backend) + +liftPersist + :: (MonadIO m, MonadReader backend m, HasPersistBackend backend) + => ReaderT (BaseBackend backend) IO b -> m b liftPersist f = do env <- ask liftIO $ runReaderT f (persistBackend env) @@ -43,31 +66,40 @@ -- 'ToBackendKey'. class ( PersistEntity record , PersistEntityBackend record ~ backend - , PersistStore backend + , PersistCore backend ) => ToBackendKey backend record where toBackendKey :: Key record -> BackendKey backend fromBackendKey :: BackendKey backend -> Key record +class PersistCore backend where + data BackendKey backend + class ( Show (BackendKey backend), Read (BackendKey backend) , Eq (BackendKey backend), Ord (BackendKey backend) + , PersistCore backend , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend) - ) => PersistStore backend where - data BackendKey backend - + ) => PersistStoreRead backend where -- | Get a record by identifier, if available. - get :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => Key val -> ReaderT backend m (Maybe val) + get :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> ReaderT backend m (Maybe record) + +class + ( Show (BackendKey backend), Read (BackendKey backend) + , Eq (BackendKey backend), Ord (BackendKey backend) + , PersistStoreRead backend + , PersistField (BackendKey backend), A.ToJSON (BackendKey backend), A.FromJSON (BackendKey backend) + ) => PersistStoreWrite backend where -- | Create a new record in the database, returning an automatically created -- key (in SQL an auto-increment id). - insert :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => val -> ReaderT backend m (Key val) + insert :: (MonadIO m, PersistRecordBackend record backend) + => record -> ReaderT backend m (Key record) -- | Same as 'insert', but doesn't return a @Key@. - insert_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => val -> ReaderT backend m () - insert_ val = insert val >> return () + insert_ :: (MonadIO m, PersistRecordBackend record backend) + => record -> ReaderT backend m () + insert_ record = insert record >> return () -- | Create multiple records in the database and return their 'Key's. -- @@ -78,16 +110,16 @@ -- -- The SQLite and MySQL backends use the slow, default implementation of -- @mapM insert@. - insertMany :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => [val] -> ReaderT backend m [Key val] + insertMany :: (MonadIO m, PersistRecordBackend record backend) + => [record] -> ReaderT backend m [Key record] insertMany = mapM insert -- | Same as 'insertMany', but doesn't return any 'Key's. -- -- The MongoDB, PostgreSQL, SQLite and MySQL backends insert all records in -- one database query. - insertMany_ :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => [val] -> ReaderT backend m () + insertMany_ :: (MonadIO m, PersistRecordBackend record backend) + => [record] -> ReaderT backend m () insertMany_ x = insertMany x >> return () -- | Same as 'insertMany_', but takes an 'Entity' instead of just a record. @@ -99,43 +131,43 @@ -- -- The SQL backends use the slow, default implementation of -- @mapM_ insertKey@. - insertEntityMany :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => [Entity val] -> ReaderT backend m () + insertEntityMany :: (MonadIO m, PersistRecordBackend record backend) + => [Entity record] -> ReaderT backend m () insertEntityMany = mapM_ (\(Entity k record) -> insertKey k record) -- | Create a new record in the database using the given key. - insertKey :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => Key val -> val -> ReaderT backend m () + insertKey :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> record -> ReaderT backend m () -- | Put the record in the database with the given key. -- Unlike 'replace', if a record with the given key does not -- exist then a new record will be inserted. - repsert :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => Key val -> val -> ReaderT backend m () + repsert :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> record -> ReaderT backend m () -- | Replace the record in the database with the given -- key. Note that the result is undefined if such record does -- not exist, so you must use 'insertKey or 'repsert' in -- these cases. - replace :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => Key val -> val -> ReaderT backend m () + replace :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> record -> ReaderT backend m () -- | Delete a specific record by identifier. Does nothing if record does -- not exist. - delete :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) - => Key val -> ReaderT backend m () + delete :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> ReaderT backend m () -- | Update individual fields on a specific record. - update :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) - => Key val -> [Update val] -> ReaderT backend m () + update :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> [Update record] -> ReaderT backend m () -- | Update individual fields on a specific record, and retrieve the -- updated value from the database. -- -- Note that this function will throw an exception if the given key is not -- found in the database. - updateGet :: (MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val) - => Key val -> [Update val] -> ReaderT backend m val + updateGet :: (MonadIO m, PersistRecordBackend record backend) + => Key record -> [Update record] -> ReaderT backend m record updateGet key ups = do update key ups get key >>= maybe (liftIO $ throwIO $ KeyNotFound $ show key) return @@ -143,12 +175,11 @@ -- | Same as get, but for a non-null (not Maybe) foreign key -- Unsafe unless your database is enforcing that the foreign key is valid. -getJust :: ( PersistStore backend - , PersistEntity val - , Show (Key val) - , backend ~ PersistEntityBackend val +getJust :: ( PersistStoreRead backend + , Show (Key record) + , PersistRecordBackend record backend , MonadIO m - ) => Key val -> ReaderT backend m val + ) => Key record -> ReaderT backend m record getJust key = get key >>= maybe (liftIO $ throwIO $ PersistForeignConstraintUnmet $ T.pack $ show key) return @@ -157,10 +188,9 @@ -- -- > foreign = belongsTo foreignId belongsTo :: - ( PersistStore backend + ( PersistStoreRead backend , PersistEntity ent1 - , PersistEntity ent2 - , backend ~ PersistEntityBackend ent2 + , PersistRecordBackend ent2 backend , MonadIO m ) => (ent1 -> Maybe (Key ent2)) -> ent1 -> ReaderT backend m (Maybe ent2) belongsTo foreignKeyField model = case foreignKeyField model of @@ -169,10 +199,9 @@ -- | Same as 'belongsTo', but uses @getJust@ and therefore is similarly unsafe. belongsToJust :: - ( PersistStore backend + ( PersistStoreRead backend , PersistEntity ent1 - , PersistEntity ent2 - , backend ~ PersistEntityBackend ent2 + , PersistRecordBackend ent2 backend , MonadIO m ) => (ent1 -> Key ent2) -> ent1 -> ReaderT backend m ent2 @@ -180,9 +209,8 @@ -- | Like @insert@, but returns the complete @Entity@. insertEntity :: - ( PersistStore backend - , PersistEntity e - , backend ~ PersistEntityBackend e + ( PersistStoreWrite backend + , PersistRecordBackend e backend , MonadIO m ) => e -> ReaderT backend m (Entity e) insertEntity e = do diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Class/PersistUnique.hs new/persistent-2.6/Database/Persist/Class/PersistUnique.hs --- old/persistent-2.2.4.1/Database/Persist/Class/PersistUnique.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Class/PersistUnique.hs 2016-08-01 15:46:55.000000000 +0200 @@ -1,7 +1,8 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE TypeFamilies, FlexibleContexts #-} +{-# LANGUAGE TypeFamilies, FlexibleContexts, ConstraintKinds #-} module Database.Persist.Class.PersistUnique - ( PersistUnique (..) + ( PersistUniqueRead (..) + , PersistUniqueWrite (..) , getByValue , insertBy , replaceUnique @@ -35,7 +36,11 @@ -- you must manually place a unique index on a field to have a uniqueness -- constraint. -- --- Some functions in this module ('insertUnique', 'insertBy', and +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)) + +-- | Some functions in this module ('insertUnique', 'insertBy', and -- 'replaceUnique') first query the unique indexes to check for -- conflicts. You could instead optimistically attempt to perform the -- operation (e.g. 'replace' instead of 'replaceUnique'). However, @@ -44,17 +49,15 @@ -- determing the column of failure; -- -- * an exception will automatically abort the current SQL transaction. -class PersistStore backend => PersistUnique backend where - -- | Get a record by unique key, if available. Returns also the identifier. - getBy :: (MonadIO m, backend ~ PersistEntityBackend val, PersistEntity val) => Unique val -> ReaderT backend m (Maybe (Entity val)) +class (PersistUniqueRead backend, PersistStoreWrite backend) => PersistUniqueWrite backend where -- | Delete a specific record by unique key. Does nothing if no record -- matches. - deleteBy :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val) => Unique val -> 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, PersistEntityBackend val ~ backend, PersistEntity val) => val -> ReaderT backend m (Maybe (Key val)) + insertUnique :: (MonadIO m, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Key record)) insertUnique datum = do conflict <- checkUnique datum case conflict of @@ -67,16 +70,32 @@ -- * update the existing record that matches the uniqueness contraint. -- -- Throws an exception if there is more than 1 uniqueness contraint. - upsert :: (MonadIO m, PersistEntityBackend val ~ backend, PersistEntity val) - => val -- ^ new record to insert - -> [Update val] + 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 val) + -> 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 uniqueKey record updates = do mExists <- getBy uniqueKey k <- case mExists of Just (Entity k _) -> do @@ -89,22 +108,33 @@ -- | 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, PersistEntity val, PersistUnique backend, PersistEntityBackend val ~ backend) - => val -> ReaderT backend m (Either (Entity val) (Key val)) +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 +-- | 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 +-- existing or new entry is returned +insertOrGet :: (MonadIO m, PersistUniqueWrite backend, PersistRecordBackend record backend) + => record -> ReaderT backend m (Key record) +insertOrGet val = do + res <- getByValue val + case res of + Nothing -> insert val + Just (Entity key _) -> return key + -- | Return the single unique key for a record. -onlyUnique :: (MonadIO m, PersistEntity val, PersistUnique backend, PersistEntityBackend val ~ backend) - => val -> ReaderT backend m (Unique val) +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 val) => val -> Either [Unique val] (Unique val) +onlyUniqueEither :: (PersistEntity record) => record -> Either [Unique record] (Unique record) onlyUniqueEither record = case persistUniqueKeys record of [u] -> Right u us -> Left us @@ -113,7 +143,7 @@ -- 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, PersistEntity record, PersistUnique backend, PersistEntityBackend record ~ backend) +getByValue :: (MonadIO m, PersistUniqueRead backend, PersistRecordBackend record backend) => record -> ReaderT backend m (Maybe (Entity record)) getByValue record = checkUniques =<< requireUniques record (persistUniqueKeys record) where @@ -142,7 +172,7 @@ -- If uniqueness is violated, return a 'Just' with the 'Unique' violation -- -- Since 1.2.2.0 -replaceUnique :: (MonadIO m, Eq record, Eq (Unique record), PersistEntityBackend record ~ backend, PersistEntity record, PersistUnique backend) +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 @@ -161,11 +191,11 @@ -- -- Returns 'Nothing' if the entity would be unique, and could thus safely be inserted. -- on a conflict returns the conflicting key -checkUnique :: (MonadIO m, PersistEntityBackend record ~ backend, PersistEntity record, PersistUnique backend) +checkUnique :: (MonadIO m, PersistRecordBackend record backend, PersistUniqueRead backend) => record -> ReaderT backend m (Maybe (Unique record)) checkUnique = checkUniqueKeys . persistUniqueKeys -checkUniqueKeys :: (MonadIO m, PersistEntity record, PersistUnique backend, PersistEntityBackend record ~ backend) +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 diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Class.hs new/persistent-2.6/Database/Persist/Class.hs --- old/persistent-2.2.4.1/Database/Persist/Class.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Class.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,15 +1,24 @@ +{-# LANGUAGE ConstraintKinds #-} + module Database.Persist.Class ( ToBackendKey (..) -- * PersistStore - , PersistStore (..) + , PersistCore (..) + , PersistStore + , PersistStoreRead (..) + , PersistStoreWrite (..) + , BaseBackend(..) + , PersistRecordBackend , getJust , belongsTo , belongsToJust , insertEntity -- * PersistUnique - , PersistUnique (..) + , PersistUnique + , PersistUniqueRead (..) + , PersistUniqueWrite (..) , getByValue , insertBy , replaceUnique @@ -17,7 +26,9 @@ , onlyUnique -- * PersistQuery - , PersistQuery (..) + , PersistQuery + , PersistQueryRead (..) + , PersistQueryWrite (..) , selectSource , selectKeys , selectList @@ -37,6 +48,7 @@ -- * Lifting , HasPersistBackend (..) + , IsPersistBackend () , liftPersist -- * JSON utilities @@ -52,3 +64,16 @@ import Database.Persist.Class.PersistConfig import Database.Persist.Class.PersistField import Database.Persist.Class.PersistStore + + +-- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. +-- It signifies the assumption that, by default, a backend can write as well as read. +type PersistUnique a = PersistUniqueWrite a + +-- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. +-- It signifies the assumption that, by default, a backend can write as well as read. +type PersistQuery a = PersistQueryWrite a + +-- | A backwards-compatible alias for those that don't care about distinguishing between read and write queries. +-- It signifies the assumption that, by default, a backend can write as well as read. +type PersistStore a = PersistStoreWrite a diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Quasi.hs new/persistent-2.6/Database/Persist/Quasi.hs --- old/persistent-2.2.4.1/Database/Persist/Quasi.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Quasi.hs 2016-07-17 04:15:37.000000000 +0200 @@ -456,8 +456,10 @@ (_, attrs) = break ("!" `T.isPrefixOf`) pkcols getDef [] t = error $ "Unknown column in primary key constraint: " ++ show t getDef (d:ds) t - | nullable (fieldAttrs d) /= NotNullable = error $ "primary key column cannot be nullable: " ++ show t - | fieldHaskell d == HaskellName t = d + | fieldHaskell d == HaskellName t = + if nullable (fieldAttrs d) /= NotNullable + then error $ "primary key column cannot be nullable: " ++ show t + else d | otherwise = getDef ds t -- Unique UppercaseConstraintName list of lowercasefields diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Class.hs new/persistent-2.6/Database/Persist/Sql/Class.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Class.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Class.hs 2016-07-17 04:15:37.000000000 +0200 @@ -4,7 +4,9 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE UndecidableInstances #-} #ifndef NO_OVERLAP {-# LANGUAGE OverlappingInstances #-} #endif @@ -58,15 +60,18 @@ rawSqlProcessRow [pv] = Single <$> fromPersistValue pv rawSqlProcessRow _ = Left $ pack "RawSql (Single a): wrong number of columns." -instance (PersistEntity a, PersistEntityBackend a ~ SqlBackend) => RawSql (Key a) where - rawSqlCols _ key = (length $ keyToValues key, []) - rawSqlColCountReason key = "The primary key is composed of " - ++ (show $ length $ keyToValues key) - ++ " columns" - rawSqlProcessRow = keyFromValues - -instance (PersistEntity record, PersistEntityBackend record ~ SqlBackend) - => RawSql (Entity record) where +instance + (PersistEntity a, PersistEntityBackend a ~ backend, IsPersistBackend backend) => + RawSql (Key a) where + rawSqlCols _ key = (length $ keyToValues key, []) + rawSqlColCountReason key = "The primary key is composed of " + ++ (show $ length $ keyToValues key) + ++ " columns" + rawSqlProcessRow = keyFromValues + +instance + (PersistEntity record, PersistEntityBackend record ~ backend, IsPersistBackend backend) => + RawSql (Entity record) where rawSqlCols escape ent = (length sqlFields, [intercalate ", " sqlFields]) where sqlFields = map (((name <> ".") <>) . escape) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Orphan/PersistQuery.hs new/persistent-2.6/Database/Persist/Sql/Orphan/PersistQuery.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Orphan/PersistQuery.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Orphan/PersistQuery.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} @@ -20,7 +21,7 @@ import Data.Monoid (Monoid (..), (<>)) import Data.Int (Int64) import Control.Monad.IO.Class -import Control.Monad.Trans.Reader (ReaderT, ask) +import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Control.Exception (throwIO) import qualified Data.Conduit.List as CL import Data.Conduit @@ -29,7 +30,7 @@ import Data.List (transpose, inits, find) -- orphaned instance for convenience of modularity -instance PersistQuery SqlBackend where +instance PersistQueryRead SqlBackend where count filts = do conn <- ask let wher = if null filts @@ -45,7 +46,7 @@ case mm of Just [PersistInt64 i] -> return $ fromIntegral i Just [PersistDouble i] ->return $ fromIntegral (truncate i :: Int64) -- gb oracle - Just [PersistByteString i] -> case readInteger i of -- gb mssql + Just [PersistByteString i] -> case readInteger i of -- gb mssql Just (ret,"") -> return $ fromIntegral ret xs -> error $ "invalid number i["++show i++"] xs[" ++ show xs ++ "]" Just xs -> error $ "count:invalid sql return xs["++show xs++"] sql["++show sql++"]" @@ -88,7 +89,7 @@ where t = entityDef $ dummyFromFilts filts cols conn = T.intercalate "," $ dbIdColumns conn t - + wher conn = if null filts then "" @@ -111,36 +112,45 @@ parse xs = do keyvals <- case entityPrimary t of - Nothing -> + Nothing -> case xs of [PersistInt64 x] -> return [PersistInt64 x] - [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double + [PersistDouble x] -> return [PersistInt64 (truncate x)] -- oracle returns Double _ -> liftIO $ throwIO $ PersistMarshalError $ "Unexpected in selectKeys False: " <> T.pack (show xs) - Just pdef -> + Just pdef -> let pks = map fieldHaskell $ compositeFields pdef keyvals = map snd $ filter (\(a, _) -> let ret=isJust (find (== a) pks) in ret) $ zip (map fieldHaskell $ entityFields t) xs in return keyvals case keyFromValues keyvals of Right k -> return k Left _ -> error "selectKeysImpl: keyFromValues failed" +instance PersistQueryRead SqlReadBackend where + count filts = withReaderT persistBackend $ count filts + selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts + selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts +instance PersistQueryRead SqlWriteBackend where + count filts = withReaderT persistBackend $ count filts + selectSourceRes filts opts = withReaderT persistBackend $ selectSourceRes filts opts + selectKeysRes filts opts = withReaderT persistBackend $ selectKeysRes filts opts - - +instance PersistQueryWrite SqlBackend where deleteWhere filts = do _ <- deleteWhereCount filts return () - updateWhere filts upds = do _ <- updateWhereCount filts upds return () +instance PersistQueryWrite SqlWriteBackend where + deleteWhere filts = withReaderT persistBackend $ deleteWhere filts + updateWhere filts upds = withReaderT persistBackend $ updateWhere filts upds -- | Same as 'deleteWhere', but returns the number of rows affected. -- -- Since 1.1.5 -deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend) +deleteWhereCount :: (PersistEntity val, MonadIO m, PersistEntityBackend val ~ SqlBackend, IsSqlBackend backend) => [Filter val] - -> ReaderT SqlBackend m Int64 -deleteWhereCount filts = do + -> ReaderT backend m Int64 +deleteWhereCount filts = withReaderT persistBackend $ do conn <- ask let t = entityDef $ dummyFromFilts filts let wher = if null filts @@ -156,12 +166,12 @@ -- | Same as 'updateWhere', but returns the number of rows affected. -- -- Since 1.1.5 -updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val) +updateWhereCount :: (PersistEntity val, MonadIO m, SqlBackend ~ PersistEntityBackend val, IsSqlBackend backend) => [Filter val] -> [Update val] - -> ReaderT SqlBackend m Int64 + -> ReaderT backend m Int64 updateWhereCount _ [] = return 0 -updateWhereCount filts upds = do +updateWhereCount filts upds = withReaderT persistBackend $ do conn <- ask let wher = if null filts then "" @@ -228,7 +238,7 @@ go (FilterAnd fs) = combineAND fs go (FilterOr []) = ("1=0", []) go (FilterOr fs) = combine " OR " fs - go (Filter field value pfilter) = + go (Filter field value pfilter) = let t = entityDef $ dummyFromFilts [Filter field value pfilter] in case (isIdField field, entityPrimary t, allVals) of (True, Just pdef, PersistList ys:_) -> @@ -236,21 +246,21 @@ then error $ "wrong number of entries in compositeFields vs PersistList allVals=" ++ show allVals else case (allVals, pfilter, isCompFilter pfilter) of - ([PersistList xs], Eq, _) -> + ([PersistList xs], Eq, _) -> let sqlcl=T.intercalate " and " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) - ([PersistList xs], Ne, _) -> + ([PersistList xs], Ne, _) -> let sqlcl=T.intercalate " or " (map (\a -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "? ") (compositeFields pdef)) in (wrapSql sqlcl,xs) - (_, In, _) -> + (_, In, _) -> let xxs = transpose (map fromPersistList allVals) sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) in (wrapSql (T.intercalate " and " (map wrapSql sqls)), concat xxs) - (_, NotIn, _) -> + (_, NotIn, _) -> let xxs = transpose (map fromPersistList allVals) sqls=map (\(a,xs) -> connEscapeName conn (fieldDB a) <> showSqlFilter pfilter <> "(" <> T.intercalate "," (replicate (length xs) " ?") <> ") ") (zip (compositeFields pdef) xxs) in (wrapSql (T.intercalate " or " (map wrapSql sqls)), concat xxs) - ([PersistList xs], _, True) -> + ([PersistList xs], _, True) -> let zs = tail (inits (compositeFields pdef)) sql1 = map (\b -> wrapSql (T.intercalate " and " (map (\(i,a) -> sql2 (i==length b) a) (zip [1..] b)))) zs sql2 islast a = connEscapeName conn (fieldDB a) <> (if islast then showSqlFilter pfilter else showSqlFilter Eq) <> "? " @@ -258,7 +268,10 @@ in (wrapSql sqlcl, concat (tail (inits xs))) (_, BackendSpecificFilter _, _) -> error "unhandled type BackendSpecificFilter for composite/non id primary keys" _ -> error $ "unhandled type/filter for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList="++show allVals - (True, Just pdef, _) -> error $ "unhandled error for composite/non id primary keys pfilter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef + (True, Just pdef, []) -> + error $ "empty list given as filter value filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef + (True, Just pdef, _) -> + error $ "unhandled error for composite/non id primary keys filter=" ++ show pfilter ++ " persistList=" ++ show allVals ++ " pdef=" ++ show pdef _ -> case (isNull, pfilter, varCount) of (True, Eq, _) -> (name <> " IS NULL", []) @@ -304,7 +317,7 @@ , qmarks , ")" ], notNullVals) - _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) + _ -> (name <> showSqlFilter pfilter <> "?" <> orNullSuffix, allVals) where isCompFilter Lt = True @@ -312,11 +325,11 @@ isCompFilter Gt = True isCompFilter Ge = True isCompFilter _ = False - + wrapSql sqlcl = "(" <> sqlcl <> ")" fromPersistList (PersistList xs) = xs fromPersistList other = error $ "expected PersistList but found " ++ show other - + filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue] filterValueToPersistValues v = map toPersistValue $ either return id v @@ -389,8 +402,8 @@ $ connEscapeName conn $ fieldName x -- | Generates sql for limit and offset for postgres, sqlite and mysql. -decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text -decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = +decorateSQLWithLimitOffset::Text -> (Int,Int) -> Bool -> Text -> Text +decorateSQLWithLimitOffset nolimit (limit,offset) _ sql = let lim = case (limit, offset) of (0, 0) -> "" @@ -403,4 +416,4 @@ [ sql , lim , off - ] + ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Orphan/PersistStore.hs new/persistent-2.6/Database/Persist/Sql/Orphan/PersistStore.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Orphan/PersistStore.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Orphan/PersistStore.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,3 +1,4 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -30,7 +31,7 @@ import Data.ByteString.Char8 (readInteger) import Data.Maybe (isJust) import Data.List (find) -import Control.Monad.Trans.Reader (ReaderT, ask) +import Control.Monad.Trans.Reader (ReaderT, ask, withReaderT) import Data.Acquire (with) import Data.Int (Int64) import Web.PathPieces (PathPiece) @@ -68,20 +69,18 @@ -- -- Your backend may provide a more convenient tableName function -- which does not operate in a Monad -getTableName :: forall record m. +getTableName :: forall record m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend + , IsSqlBackend backend , Monad m - ) => record -> ReaderT SqlBackend m Text -getTableName rec = do + ) => record -> ReaderT backend m Text +getTableName rec = withReaderT persistBackend $ do conn <- ask return $ connEscapeName conn $ tableDBName rec -- | useful for a backend to implement tableName by adding escaping -tableDBName :: forall record. - ( PersistEntity record - , PersistEntityBackend record ~ SqlBackend - ) => record -> DBName +tableDBName :: (PersistEntity record) => record -> DBName tableDBName rec = entityDB $ entityDef (Just rec) -- | get the SQL string for the field that an EntityField represents @@ -89,13 +88,14 @@ -- -- Your backend may provide a more convenient fieldName function -- which does not operate in a Monad -getFieldName :: forall record typ m. +getFieldName :: forall record typ m backend. ( PersistEntity record , PersistEntityBackend record ~ SqlBackend + , IsSqlBackend backend , Monad m ) - => EntityField record typ -> ReaderT SqlBackend m Text -getFieldName rec = do + => EntityField record typ -> ReaderT backend m Text +getFieldName rec = withReaderT persistBackend $ do conn <- ask return $ connEscapeName conn $ fieldDBName rec @@ -104,10 +104,17 @@ fieldDBName = fieldDB . persistFieldDef -instance PersistStore SqlBackend where +instance PersistCore SqlBackend where newtype BackendKey SqlBackend = SqlBackendKey { unSqlBackendKey :: Int64 } deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) +instance PersistCore SqlReadBackend where + newtype BackendKey SqlReadBackend = SqlReadBackendKey { unSqlReadBackendKey :: Int64 } + deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) +instance PersistCore SqlWriteBackend where + newtype BackendKey SqlWriteBackend = SqlWriteBackendKey { unSqlWriteBackendKey :: Int64 } + deriving (Show, Read, Eq, Ord, Num, Integral, PersistField, PersistFieldSql, PathPiece, ToHttpApiData, FromHttpApiData, Real, Enum, Bounded, A.ToJSON, A.FromJSON) +instance PersistStoreWrite SqlBackend where update _ [] = return () update k upds = do conn <- ask @@ -247,6 +254,29 @@ Nothing -> insertKey key value Just _ -> replace key value + delete k = do + conn <- ask + rawExecute (sql conn) (keyToValues k) + where + wher conn = whereStmtForKey conn k + sql conn = T.concat + [ "DELETE FROM " + , connEscapeName conn $ tableDBName $ recordTypeFromKey k + , " WHERE " + , wher conn + ] +instance PersistStoreWrite SqlWriteBackend where + insert v = withReaderT persistBackend $ insert v + insertMany vs = withReaderT persistBackend $ insertMany vs + insertMany_ vs = withReaderT persistBackend $ insertMany_ 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 + + +instance PersistStoreRead SqlBackend where get k = do conn <- ask let t = entityDef $ dummyFromKey k @@ -271,18 +301,10 @@ case fromPersistValues $ if noColumns then [] else vals of Left e -> error $ "get " ++ show k ++ ": " ++ unpack e Right v -> return $ Just v - - delete k = do - conn <- ask - rawExecute (sql conn) (keyToValues k) - where - wher conn = whereStmtForKey conn k - sql conn = T.concat - [ "DELETE FROM " - , connEscapeName conn $ tableDBName $ recordTypeFromKey k - , " WHERE " - , wher conn - ] +instance PersistStoreRead SqlReadBackend where + get k = withReaderT persistBackend $ get k +instance PersistStoreRead SqlWriteBackend where + get k = withReaderT persistBackend $ get k dummyFromKey :: Key record -> Maybe record dummyFromKey = Just . recordTypeFromKey diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Orphan/PersistUnique.hs new/persistent-2.6/Database/Persist/Sql/Orphan/PersistUnique.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Orphan/PersistUnique.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Orphan/PersistUnique.hs 2016-08-10 05:20:24.000000000 +0200 @@ -1,20 +1,60 @@ +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Sql.Orphan.PersistUnique () where import Control.Exception (throwIO) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Monad.Trans.Reader (ReaderT) import Database.Persist 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 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) +import Control.Monad.Trans.Reader (ask, withReaderT) +import Control.Monad (when, liftM) + +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 + +instance PersistUniqueWrite SqlBackend where + + upsert record updates = do + conn <- ask + uniqueKey <- onlyUnique record + case connUpsertSql conn of + Just upsertSql -> case updates of + [] -> defaultUpsert record updates + xs -> do + let upds = T.intercalate "," $ map (go' . go) 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, "=", 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" `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 + Nothing -> defaultUpsert record updates + where + t = entityDef $ Just record + unqs uniqueKey = concat $ map (persistUniqueToValues) [uniqueKey] -instance PersistUnique SqlBackend where deleteBy uniq = do conn <- ask let sql' = sql conn @@ -30,7 +70,10 @@ , " 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 @@ -56,6 +99,19 @@ 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 (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 -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Raw.hs new/persistent-2.6/Database/Persist/Sql/Raw.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Raw.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Raw.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,5 +1,7 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Raw where import Database.Persist @@ -9,6 +11,7 @@ import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Reader (ReaderT, ask, MonadReader) import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) +import Data.Functor ((<$>)) import Data.IORef (writeIORef, readIORef, newIORef) import Control.Exception (throwIO) import Control.Monad (when, liftM) @@ -19,7 +22,7 @@ import Data.Conduit import Control.Monad.Trans.Resource (MonadResource,release) -rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env SqlBackend) +rawQuery :: (MonadResource m, MonadReader env m, HasPersistBackend env, BaseBackend env ~ SqlBackend) => Text -> [PersistValue] -> Source m [PersistValue] @@ -30,12 +33,12 @@ release releaseKey rawQueryRes - :: (MonadIO m1, MonadIO m2) + :: (MonadIO m1, MonadIO m2, IsSqlBackend env) => Text -> [PersistValue] - -> ReaderT SqlBackend m1 (Acquire (Source m2 [PersistValue])) + -> ReaderT env m1 (Acquire (Source m2 [PersistValue])) rawQueryRes sql vals = do - conn <- ask + conn <- persistBackend `liftM` ask let make = do runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) @@ -53,12 +56,12 @@ -- | Execute a raw SQL statement and return the number of -- rows it has modified. -rawExecuteCount :: MonadIO m +rawExecuteCount :: (MonadIO m, IsSqlBackend backend) => Text -- ^ SQL statement, possibly with placeholders. -> [PersistValue] -- ^ Values to fill the placeholders. - -> ReaderT SqlBackend m Int64 + -> ReaderT backend m Int64 rawExecuteCount sql vals = do - conn <- ask + conn <- persistBackend `liftM` ask runLoggingT (logDebugNS (pack "SQL") $ T.append sql $ pack $ "; " ++ show vals) (connLogFunc conn) stmt <- getStmt sql @@ -66,9 +69,11 @@ liftIO $ stmtReset stmt return res -getStmt :: MonadIO m => Text -> ReaderT SqlBackend m Statement +getStmt + :: (MonadIO m, IsSqlBackend backend) + => Text -> ReaderT backend m Statement getStmt sql = do - conn <- ask + conn <- persistBackend `liftM` ask liftIO $ getStmtConn conn sql getStmtConn :: SqlBackend -> Text -> IO Statement diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Run.hs new/persistent-2.6/Database/Persist/Sql/Run.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Run.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Run.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,7 +1,10 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} module Database.Persist.Sql.Run where +import Database.Persist.Class.PersistStore import Database.Persist.Sql.Types import Database.Persist.Sql.Raw import Control.Monad.Trans.Control @@ -24,7 +27,9 @@ -- Note: This function previously timed out after 2 seconds, but this behavior -- was buggy and caused more problems than it solved. Since version 2.1.2, it -- performs no timeout checks. -runSqlPool :: MonadBaseControl IO m => SqlPersistT m a -> Pool SqlBackend -> m a +runSqlPool + :: (MonadBaseControl IO m, IsSqlBackend backend) + => ReaderT backend m a -> Pool backend -> m a runSqlPool r pconn = withResource pconn $ runSqlConn r -- | Like 'withResource', but times out the operation if resource @@ -49,37 +54,46 @@ return ret {-# INLINABLE withResourceTimeout #-} -runSqlConn :: MonadBaseControl IO m => SqlPersistT m a -> SqlBackend -> m a +runSqlConn :: (MonadBaseControl IO m, IsSqlBackend backend) => ReaderT backend m a -> backend -> m a runSqlConn r conn = control $ \runInIO -> mask $ \restore -> do - let getter = getStmtConn conn - restore $ connBegin conn getter + let conn' = persistBackend conn + getter = getStmtConn conn' + restore $ connBegin conn' getter x <- onException (restore $ runInIO $ runReaderT r conn) - (restore $ connRollback conn getter) - restore $ connCommit conn getter + (restore $ connRollback conn' getter) + restore $ connCommit conn' getter return x -runSqlPersistM :: SqlPersistM a -> SqlBackend -> IO a +runSqlPersistM + :: (IsSqlBackend backend) + => ReaderT backend (NoLoggingT (ResourceT IO)) a -> backend -> IO a runSqlPersistM x conn = runResourceT $ runNoLoggingT $ runSqlConn x conn -runSqlPersistMPool :: SqlPersistM a -> Pool SqlBackend -> IO a +runSqlPersistMPool + :: (IsSqlBackend backend) + => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> IO a runSqlPersistMPool x pool = runResourceT $ runNoLoggingT $ runSqlPool x pool -liftSqlPersistMPool :: MonadIO m => SqlPersistM a -> Pool SqlBackend -> m a +liftSqlPersistMPool + :: (MonadIO m, IsSqlBackend backend) + => ReaderT backend (NoLoggingT (ResourceT IO)) a -> Pool backend -> m a liftSqlPersistMPool x pool = liftIO (runSqlPersistMPool x pool) -withSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) - => (LogFunc -> IO SqlBackend) -- ^ create a new connection - -> Int -- ^ connection count - -> (Pool SqlBackend -> m a) - -> m a -withSqlPool mkConn connCount f = do +withSqlPool + :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend) + => (LogFunc -> IO backend) -- ^ create a new connection + -> Int -- ^ connection count + -> (Pool backend -> m a) + -> m a +withSqlPool mkConn connCount f = bracket (createSqlPool mkConn connCount) (liftIO . destroyAllResources) f -createSqlPool :: (MonadIO m, MonadLogger m, MonadBaseControl IO m) - => (LogFunc -> IO SqlBackend) - -> Int - -> m (Pool SqlBackend) +createSqlPool + :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, IsSqlBackend backend) + => (LogFunc -> IO backend) + -> Int + -> m (Pool backend) createSqlPool mkConn size = do logFunc <- askLogFunc liftIO $ createPool (mkConn logFunc) close' 1 20 size @@ -99,13 +113,14 @@ _ <- runInBase (monadLoggerLog a b c d) return () -withSqlConn :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) - => (LogFunc -> IO SqlBackend) -> (SqlBackend -> m a) -> m a +withSqlConn + :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, IsSqlBackend backend) + => (LogFunc -> IO backend) -> (backend -> m a) -> m a withSqlConn open f = do logFunc <- askLogFunc bracket (liftIO $ open logFunc) (liftIO . close') f -close' :: SqlBackend -> IO () +close' :: (IsSqlBackend backend) => backend -> IO () close' conn = do - readIORef (connStmtMap conn) >>= mapM_ stmtFinalize . Map.elems - connClose conn + readIORef (connStmtMap $ persistBackend conn) >>= mapM_ stmtFinalize . Map.elems + connClose $ persistBackend conn diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Types/Internal.hs new/persistent-2.6/Database/Persist/Sql/Types/Internal.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Types/Internal.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Types/Internal.hs 2016-08-10 05:20:24.000000000 +0200 @@ -0,0 +1,141 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} + +module Database.Persist.Sql.Types.Internal + ( HasPersistBackend (..) + , IsPersistBackend (..) + , SqlReadBackend (unSqlReadBackend) + , SqlWriteBackend (unSqlWriteBackend) + , readToUnknown + , readToWrite + , writeToUnknown + , LogFunc + , InsertSqlResult (..) + , Statement (..) + , SqlBackend (..) + , SqlBackendCanRead + , SqlBackendCanWrite + , SqlReadT + , SqlWriteT + , IsSqlBackend + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Control.Monad.Logger (LogSource, LogLevel) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) +import Data.Acquire (Acquire) +import Data.Conduit (Source) +import Data.Int (Int64) +import Data.IORef (IORef) +import Data.Map (Map) +import Data.Text (Text) +import Data.Typeable (Typeable) +import Database.Persist.Class + ( HasPersistBackend (..) + , PersistQueryRead, PersistQueryWrite + , PersistStoreRead, PersistStoreWrite + , PersistUniqueRead, PersistUniqueWrite + ) +import Database.Persist.Class.PersistStore (IsPersistBackend (..)) +import Database.Persist.Types +import Language.Haskell.TH.Syntax (Loc) +import System.Log.FastLogger (LogStr) + +type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () + +data InsertSqlResult = ISRSingle Text + | ISRInsertGet Text Text + | ISRManyKeys Text [PersistValue] + +data Statement = Statement + { stmtFinalize :: IO () + , stmtReset :: IO () + , stmtExecute :: [PersistValue] -> IO Int64 + , stmtQuery :: forall m. MonadIO m + => [PersistValue] + -> Acquire (Source m [PersistValue]) + } + +data SqlBackend = SqlBackend + { connPrepare :: Text -> IO Statement + -- | table name, column names, id name, either 1 or 2 statements to run + , 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) + , connStmtMap :: IORef (Map Text Statement) + , connClose :: IO () + , connMigrateSql + :: [EntityDef] + -> (Text -> IO Statement) + -> EntityDef + -> IO (Either [Text] [(Bool, Text)]) + , connBegin :: (Text -> IO Statement) -> IO () + , connCommit :: (Text -> IO Statement) -> IO () + , connRollback :: (Text -> IO Statement) -> IO () + , connEscapeName :: DBName -> Text + , connNoLimit :: Text + , connRDBMS :: Text + , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text + , connLogFunc :: LogFunc + } + deriving Typeable +instance HasPersistBackend SqlBackend where + type BaseBackend SqlBackend = SqlBackend + persistBackend = id +instance IsPersistBackend SqlBackend where + mkPersistBackend = id + +-- | An SQL backend which can only handle read queries +newtype SqlReadBackend = SqlReadBackend { unSqlReadBackend :: SqlBackend } deriving Typeable +instance HasPersistBackend SqlReadBackend where + type BaseBackend SqlReadBackend = SqlBackend + persistBackend = unSqlReadBackend +instance IsPersistBackend SqlReadBackend where + mkPersistBackend = SqlReadBackend + +-- | An SQL backend which can handle read or write queries +newtype SqlWriteBackend = SqlWriteBackend { unSqlWriteBackend :: SqlBackend } deriving Typeable +instance HasPersistBackend SqlWriteBackend where + type BaseBackend SqlWriteBackend = SqlBackend + persistBackend = unSqlWriteBackend +instance IsPersistBackend SqlWriteBackend where + mkPersistBackend = SqlWriteBackend + +-- | Useful for running a write query against an untagged backend with unknown capabilities. +writeToUnknown :: Monad m => ReaderT SqlWriteBackend m a -> ReaderT SqlBackend m a +writeToUnknown ma = do + unknown <- ask + lift . runReaderT ma $ SqlWriteBackend unknown + +-- | Useful for running a read query against a backend with read and write capabilities. +readToWrite :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlWriteBackend m a +readToWrite ma = do + write <- ask + lift . runReaderT ma . SqlReadBackend $ unSqlWriteBackend write + +-- | Useful for running a read query against a backend with unknown capabilities. +readToUnknown :: Monad m => ReaderT SqlReadBackend m a -> ReaderT SqlBackend m a +readToUnknown ma = do + unknown <- ask + lift . runReaderT ma $ SqlReadBackend unknown + +-- | A constraint synonym which witnesses that a backend is SQL and can run read queries. +type SqlBackendCanRead backend = + ( IsSqlBackend backend + , PersistQueryRead backend, PersistStoreRead backend, PersistUniqueRead backend + ) +-- | A constraint synonym which witnesses that a backend is SQL and can run read and write queries. +type SqlBackendCanWrite backend = + ( SqlBackendCanRead backend + , PersistQueryWrite backend, PersistStoreWrite backend, PersistUniqueWrite backend + ) +-- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read queries. +type SqlReadT m a = forall backend. (SqlBackendCanRead backend) => ReaderT backend m a +-- | Like @SqlPersistT@ but compatible with any SQL backend which can handle read and write queries. +type SqlWriteT m a = forall backend. (SqlBackendCanWrite backend) => ReaderT backend m a +-- | A backend which is a wrapper around @SqlBackend@. +type IsSqlBackend backend = (IsPersistBackend backend, BaseBackend backend ~ SqlBackend) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Sql/Types.hs new/persistent-2.6/Database/Persist/Sql/Types.hs --- old/persistent-2.2.4.1/Database/Persist/Sql/Types.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Sql/Types.hs 2016-07-17 04:15:37.000000000 +0200 @@ -1,13 +1,21 @@ +{-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} -module Database.Persist.Sql.Types where +module Database.Persist.Sql.Types + ( module Database.Persist.Sql.Types + , SqlBackend (..), SqlReadBackend (..), SqlWriteBackend (..) + , Statement (..), LogFunc, InsertSqlResult (..) + , readToUnknown, readToWrite, writeToUnknown + , SqlBackendCanRead, SqlBackendCanWrite, SqlReadT, SqlWriteT, IsSqlBackend + ) where import Control.Exception (Exception) import Control.Monad.Trans.Resource (ResourceT) @@ -18,7 +26,7 @@ import Control.Monad.Trans.Writer (WriterT) import Data.Typeable (Typeable) import Database.Persist.Types -import Database.Persist.Class (HasPersistBackend (..)) +import Database.Persist.Sql.Types.Internal import Data.IORef (IORef) import Data.Map (Map) import Data.Int (Int64) @@ -29,50 +37,10 @@ import System.Log.FastLogger (LogStr) import Data.Text (Text) -data InsertSqlResult = ISRSingle Text - | ISRInsertGet Text Text - | ISRManyKeys Text [PersistValue] - -- | Deprecated synonym for @SqlBackend@. type Connection = SqlBackend {-# DEPRECATED Connection "Please use SqlBackend instead" #-} -data SqlBackend = SqlBackend - { connPrepare :: Text -> IO Statement - -- | table name, column names, id name, either 1 or 2 statements to run - , 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'. - , connStmtMap :: IORef (Map Text Statement) - , connClose :: IO () - , connMigrateSql - :: [EntityDef] - -> (Text -> IO Statement) - -> EntityDef - -> IO (Either [Text] [(Bool, Text)]) - , connBegin :: (Text -> IO Statement) -> IO () - , connCommit :: (Text -> IO Statement) -> IO () - , connRollback :: (Text -> IO Statement) -> IO () - , connEscapeName :: DBName -> Text - , connNoLimit :: Text - , connRDBMS :: Text - , connLimitOffset :: (Int,Int) -> Bool -> Text -> Text - , connLogFunc :: LogFunc - } - deriving Typeable -instance HasPersistBackend SqlBackend SqlBackend where - persistBackend = id - -type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () - -data Statement = Statement - { stmtFinalize :: IO () - , stmtReset :: IO () - , stmtExecute :: [PersistValue] -> IO Int64 - , stmtQuery :: forall m. MonadIO m - => [PersistValue] - -> Acquire (Source m [PersistValue]) - } - data Column = Column { cName :: !DBName , cNull :: !Bool diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/Database/Persist/Types/Base.hs new/persistent-2.6/Database/Persist/Types/Base.hs --- old/persistent-2.2.4.1/Database/Persist/Types/Base.hs 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/Database/Persist/Types/Base.hs 2016-08-10 05:20:24.000000000 +0200 @@ -218,8 +218,20 @@ _ -> Nothing } +-- Type for storing the Uniqueness constraint in the Schema. +-- Assume you have the following schema with a uniqueness +-- constraint: +-- Person +-- name String +-- age Int +-- UniqueAge age +-- +-- This will be represented as: +-- UniqueDef (HaskellName (packPTH "UniqueAge")) +-- (DBName (packPTH "unique_age")) [(HaskellName (packPTH "age"), DBName (packPTH "age"))] [] +-- data UniqueDef = UniqueDef - { uniqueHaskell :: !HaskellName + { uniqueHaskell :: !HaskellName , uniqueDBName :: !DBName , uniqueFields :: ![(HaskellName, DBName)] , uniqueAttrs :: ![Attr] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.2.4.1/persistent.cabal new/persistent-2.6/persistent.cabal --- old/persistent-2.2.4.1/persistent.cabal 2016-03-08 09:18:27.000000000 +0100 +++ new/persistent-2.6/persistent.cabal 2016-08-10 05:28:57.000000000 +0200 @@ -1,5 +1,5 @@ name: persistent -version: 2.2.4.1 +version: 2.6 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> @@ -60,6 +60,7 @@ Database.Persist.Class Database.Persist.Sql Database.Persist.Sql.Util + Database.Persist.Sql.Types.Internal other-modules: Database.Persist.Types.Base Database.Persist.Class.DeleteCascade ++++++ persistent.cabal ++++++ name: persistent version: 2.6 x-revision: 2 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> maintainer: Michael Snoyman <[email protected]>, Greg Weber <[email protected]> synopsis: Type-safe, multi-backend data serialization. description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/persistent>. category: Database, Yesod stability: Stable cabal-version: >= 1.8 build-type: Simple homepage: http://www.yesodweb.com/book/persistent bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md flag nooverlap default: False description: test out our assumption that OverlappingInstances is just for String library if flag(nooverlap) cpp-options: -DNO_OVERLAP build-depends: base >= 4.6 && < 5 , bytestring >= 0.9 , transformers >= 0.2.1 , time >= 1.1.4 , old-locale , text >= 0.8 , containers >= 0.2 , conduit >= 1.0 , resourcet >= 1.1 , exceptions >= 0.6 , monad-control >= 0.3 , lifted-base >= 0.1 , resource-pool >= 0.2.2.0 , path-pieces >= 0.1 , http-api-data >= 0.2 && < 0.4 , aeson >= 0.5 , monad-logger >= 0.3 , transformers-base , base64-bytestring , unordered-containers , vector , attoparsec , template-haskell , blaze-html >= 0.5 , blaze-markup >= 0.5.1 , silently , mtl , fast-logger >= 2.1 , scientific , tagged exposed-modules: Database.Persist Database.Persist.Quasi Database.Persist.Types Database.Persist.Class Database.Persist.Sql Database.Persist.Sql.Util Database.Persist.Sql.Types.Internal other-modules: Database.Persist.Types.Base Database.Persist.Class.DeleteCascade Database.Persist.Class.PersistEntity Database.Persist.Class.PersistQuery Database.Persist.Class.PersistUnique Database.Persist.Class.PersistConfig Database.Persist.Class.PersistField Database.Persist.Class.PersistStore Database.Persist.Sql.Migration Database.Persist.Sql.Internal Database.Persist.Sql.Types Database.Persist.Sql.Raw Database.Persist.Sql.Run Database.Persist.Sql.Class Database.Persist.Sql.Orphan.PersistQuery Database.Persist.Sql.Orphan.PersistStore Database.Persist.Sql.Orphan.PersistUnique ghc-options: -Wall test-suite test type: exitcode-stdio-1.0 main-is: test/main.hs build-depends: base >= 4.6 && < 5 , hspec >= 1.3 , containers , text , unordered-containers , time , old-locale , bytestring , vector , base64-bytestring , attoparsec , transformers , path-pieces , http-api-data >= 0.2 && < 0.4 , aeson , resourcet , monad-logger , conduit , monad-control , blaze-html , scientific , tagged , fast-logger >= 2.1 , lifted-base >= 0.1 , mtl , template-haskell , resource-pool cpp-options: -DTEST source-repository head type: git location: git://github.com/yesodweb/persistent.git
