Script 'mail_helper' called by obssrc Hello community, here is the log from the commit of package ghc-persistent for openSUSE:Factory checked in at 2022-02-11 23:07:57 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Comparing /work/SRC/openSUSE:Factory/ghc-persistent (Old) and /work/SRC/openSUSE:Factory/.ghc-persistent.new.1956 (New) ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Package is "ghc-persistent" Fri Feb 11 23:07:57 2022 rev:33 rq:953398 version:2.13.3.0 Changes: -------- --- /work/SRC/openSUSE:Factory/ghc-persistent/ghc-persistent.changes 2021-11-11 21:37:03.896916786 +0100 +++ /work/SRC/openSUSE:Factory/.ghc-persistent.new.1956/ghc-persistent.changes 2022-02-11 23:09:52.187025845 +0100 @@ -1,0 +2,17 @@ +Sat Jan 29 00:08:22 UTC 2022 - Peter Simons <[email protected]> + +- Update persistent to version 2.13.3.0. + ## 2.13.3.0 + + * [#1341](https://github.com/yesodweb/persistent/pull/1341) + * Add `SqlBackendHooks` to allow for instrumentation of queries. + * [#1327](https://github.com/yesodweb/persistent/pull/1327) + * Update `SqlBackend` to use new `StatementCache` interface + instead of `IORef (Map Text Statement)` + + ## 2.13.2.2 + + * [#1351](https://github.com/yesodweb/persistent/pull/1351/) + * `aeson-2.0` support + +------------------------------------------------------------------- Old: ---- persistent-2.13.2.1.tar.gz persistent.cabal New: ---- persistent-2.13.3.0.tar.gz ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Other differences: ------------------ ++++++ ghc-persistent.spec ++++++ --- /var/tmp/diff_new_pack.Bv9ahr/_old 2022-02-11 23:09:52.767027523 +0100 +++ /var/tmp/diff_new_pack.Bv9ahr/_new 2022-02-11 23:09:52.779027558 +0100 @@ -1,7 +1,7 @@ # # spec file for package ghc-persistent # -# Copyright (c) 2021 SUSE LLC +# Copyright (c) 2022 SUSE LLC # # All modifications and additions to the file contributed by third parties # remain the property of their copyright owners, unless otherwise agreed @@ -19,13 +19,12 @@ %global pkg_name persistent %bcond_with tests Name: ghc-%{pkg_name} -Version: 2.13.2.1 +Version: 2.13.3.0 Release: 0 Summary: Type-safe, multi-backend data serialization License: MIT 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/1.cabal#/%{pkg_name}.cabal BuildRequires: ghc-Cabal-devel BuildRequires: ghc-aeson-devel BuildRequires: ghc-attoparsec-devel @@ -53,6 +52,7 @@ BuildRequires: ghc-unliftio-core-devel BuildRequires: ghc-unliftio-devel BuildRequires: ghc-unordered-containers-devel +BuildRequires: ghc-vault-devel BuildRequires: ghc-vector-devel ExcludeArch: %{ix86} %if %{with tests} @@ -78,7 +78,6 @@ %prep %autosetup -n %{pkg_name}-%{version} -cp -p %{SOURCE1} %{pkg_name}.cabal %build %ghc_lib_build ++++++ persistent-2.13.2.1.tar.gz -> persistent-2.13.3.0.tar.gz ++++++ diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/ChangeLog.md new/persistent-2.13.3.0/ChangeLog.md --- old/persistent-2.13.2.1/ChangeLog.md 2021-10-13 21:16:31.000000000 +0200 +++ new/persistent-2.13.3.0/ChangeLog.md 2022-01-29 01:08:02.000000000 +0100 @@ -1,5 +1,18 @@ # Changelog for persistent +## 2.13.3.0 + +* [#1341](https://github.com/yesodweb/persistent/pull/1341) + * Add `SqlBackendHooks` to allow for instrumentation of queries. +* [#1327](https://github.com/yesodweb/persistent/pull/1327) + * Update `SqlBackend` to use new `StatementCache` interface + instead of `IORef (Map Text Statement)` + +## 2.13.2.2 + +* [#1351](https://github.com/yesodweb/persistent/pull/1351/) + * `aeson-2.0` support + ## 2.13.2.1 * [#1329](https://github.com/yesodweb/persistent/pull/1329) diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/Class/PersistConfig.hs new/persistent-2.13.3.0/Database/Persist/Class/PersistConfig.hs --- old/persistent-2.13.2.1/Database/Persist/Class/PersistConfig.hs 2021-05-24 17:18:53.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/Class/PersistConfig.hs 2022-01-21 00:23:09.000000000 +0100 @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP #-} + module Database.Persist.Class.PersistConfig ( PersistConfig (..) ) where @@ -5,7 +7,13 @@ import Control.Monad.IO.Unlift (MonadUnliftIO) import Data.Aeson (Value (Object)) import Data.Aeson.Types (Parser) -import qualified Data.HashMap.Strict as HashMap + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as AM +#else +import qualified Data.HashMap.Strict as AM +#endif + import Data.Kind (Type) -- | Represents a value containing all the configuration options for a specific @@ -43,10 +51,10 @@ type PersistConfigPool (Either c1 c2) = PersistConfigPool c1 loadConfig (Object o) = - case HashMap.lookup "left" o of + case AM.lookup "left" o of Just v -> Left <$> loadConfig v Nothing -> - case HashMap.lookup "right" o of + case AM.lookup "right" o of Just v -> Right <$> loadConfig v Nothing -> fail "PersistConfig for Either: need either a left or right" loadConfig _ = fail "PersistConfig for Either: need an object" diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/Class/PersistEntity.hs new/persistent-2.13.3.0/Database/Persist/Class/PersistEntity.hs --- old/persistent-2.13.2.1/Database/Persist/Class/PersistEntity.hs 2021-05-24 17:18:53.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/Class/PersistEntity.hs 2022-01-21 00:23:09.000000000 +0100 @@ -10,6 +10,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE CPP #-} module Database.Persist.Class.PersistEntity ( PersistEntity (..) @@ -46,7 +47,13 @@ import Data.Aeson.Text (encodeToTextBuilder) import Data.Aeson.Types (Parser, Result(Error, Success)) import Data.Attoparsec.ByteString (parseOnly) -import qualified Data.HashMap.Strict as HM + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as AM +#else +import qualified Data.HashMap.Strict as AM +#endif + import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (isJust) import Data.Text (Text) @@ -288,7 +295,7 @@ -- @ entityIdToJSON :: (PersistEntity record, ToJSON record) => Entity record -> Value entityIdToJSON (Entity key value) = case toJSON value of - Object o -> Object $ HM.insert "id" (toJSON key) o + Object o -> Object $ AM.insert "id" (toJSON key) o x -> x -- | Predefined @parseJSON@. The input JSON looks like diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/PersistValue.hs new/persistent-2.13.3.0/Database/Persist/PersistValue.hs --- old/persistent-2.13.2.1/Database/Persist/PersistValue.hs 2021-05-05 23:10:13.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/PersistValue.hs 2022-01-21 00:23:09.000000000 +0100 @@ -1,12 +1,14 @@ {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE CPP #-} -- | This module contains an intermediate representation of values before the -- backends serialize them into explicit database types. -- -- @since 2.13.0.0 module Database.Persist.PersistValue - ( module Database.Persist.PersistValue - , PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific) + ( PersistValue(.., PersistLiteral, PersistLiteralEscaped, PersistDbSpecific) + , fromPersistValueText + , LiteralType(..) ) where import qualified Data.ByteString.Base64 as B64 @@ -17,7 +19,6 @@ import qualified Data.Scientific import Data.Text.Encoding.Error (lenientDecode) import Data.Bits (shiftL, shiftR) -import Control.Arrow (second) import Numeric (readHex, showHex) import qualified Data.Text as Text import Data.Text (Text) @@ -26,7 +27,14 @@ import Web.PathPieces (PathPiece(..)) import qualified Data.Aeson as A import qualified Data.ByteString as BS -import qualified Data.HashMap.Strict as HM + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as K +import qualified Data.Aeson.KeyMap as AM +#else +import qualified Data.HashMap.Strict as AM +#endif + import Web.HttpApiData ( FromHttpApiData(..) , ToHttpApiData(..) @@ -124,6 +132,18 @@ {-# DEPRECATED PersistDbSpecific "Deprecated since 2.11 because of inconsistent escaping behavior across backends. The Postgres backend escapes these values, while the MySQL backend does not. If you are using this, please switch to 'PersistLiteral_' and provide a relevant 'LiteralType' for your conversion." #-} +keyToText :: Key -> Text +keyFromText :: Text -> Key +#if MIN_VERSION_aeson(2,0,0) +type Key = K.Key +keyToText = K.toText +keyFromText = K.fromText +#else +type Key = Text +keyToText = id +keyFromText = id +#endif + instance ToHttpApiData PersistValue where toUrlPiece val = case fromPersistValueText val of @@ -174,7 +194,8 @@ toJSON (PersistDay d) = A.String $ Text.pack $ 'd' : show d toJSON PersistNull = A.Null toJSON (PersistList l) = A.Array $ V.fromList $ map A.toJSON l - toJSON (PersistMap m) = A.object $ map (second A.toJSON) m + toJSON (PersistMap m) = A.object $ map go m + where go (k, v) = (keyFromText k, A.toJSON v) toJSON (PersistLiteral_ litTy b) = let encoded = TE.decodeUtf8 $ B64.encode b prefix = @@ -247,7 +268,7 @@ parseJSON A.Null = return PersistNull parseJSON (A.Array a) = fmap PersistList (mapM A.parseJSON $ V.toList a) parseJSON (A.Object o) = - fmap PersistMap $ mapM go $ HM.toList o + fmap PersistMap $ mapM go $ AM.toList o where - go (k, v) = (,) k <$> A.parseJSON v + go (k, v) = (,) (keyToText k) <$> A.parseJSON v diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/Sql/Raw.hs new/persistent-2.13.3.0/Database/Persist/Sql/Raw.hs --- old/persistent-2.13.2.1/Database/Persist/Sql/Raw.hs 2021-05-05 23:10:13.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/Sql/Raw.hs 2022-01-29 01:01:38.000000000 +0100 @@ -1,23 +1,23 @@ module Database.Persist.Sql.Raw where import Control.Exception (throwIO) -import Control.Monad (when, liftM) +import Control.Monad (liftM, when) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Logger (logDebugNS, runLoggingT) -import Control.Monad.Reader (ReaderT, ask, MonadReader) -import Control.Monad.Trans.Resource (MonadResource,release) -import Data.Acquire (allocateAcquire, Acquire, mkAcquire, with) +import Control.Monad.Reader (MonadReader, ReaderT, ask) +import Control.Monad.Trans.Resource (MonadResource, release) +import Data.Acquire (Acquire, allocateAcquire, mkAcquire, with) import Data.Conduit -import Data.IORef (writeIORef, readIORef, newIORef) -import qualified Data.Map as Map +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Int (Int64) import Data.Text (Text, pack) import qualified Data.Text as T import Database.Persist +import Database.Persist.Sql.Class import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal -import Database.Persist.Sql.Class +import Database.Persist.SqlBackend.Internal.StatementCache rawQuery :: (MonadResource m, MonadReader env m, BackendCompatible SqlBackend env) => Text @@ -75,9 +75,10 @@ getStmtConn :: SqlBackend -> Text -> IO Statement getStmtConn conn sql = do - smap <- liftIO $ readIORef $ connStmtMap conn - case Map.lookup sql smap of - Just stmt -> return stmt + let cacheK = mkCacheKeyFromQuery sql + mstmt <- statementCacheLookup (connStmtMap conn) cacheK + stmt <- case mstmt of + Just stmt -> pure stmt Nothing -> do stmt' <- liftIO $ connPrepare conn sql iactive <- liftIO $ newIORef True @@ -100,8 +101,10 @@ then stmtQuery stmt' x else liftIO $ throwIO $ StatementAlreadyFinalized sql } - liftIO $ writeIORef (connStmtMap conn) $ Map.insert sql stmt smap - return stmt + + liftIO $ statementCacheInsert (connStmtMap conn) cacheK stmt + pure stmt + (hookGetStatement $ connHooks conn) conn sql stmt -- | Execute a raw SQL statement and return its results as a -- list. If you do not expect a return value, use of diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/Sql/Run.hs new/persistent-2.13.3.0/Database/Persist/Sql/Run.hs --- old/persistent-2.13.2.1/Database/Persist/Sql/Run.hs 2021-05-24 17:18:53.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/Sql/Run.hs 2022-01-29 01:01:38.000000000 +0100 @@ -1,23 +1,25 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} module Database.Persist.Sql.Run where import Control.Monad.IO.Unlift -import qualified UnliftIO.Exception as UE import Control.Monad.Logger.CallStack -import Control.Monad.Reader (MonadReader) +import Control.Monad.Reader (MonadReader, void) import qualified Control.Monad.Reader as MonadReader import Control.Monad.Trans.Reader hiding (local) import Control.Monad.Trans.Resource import Data.Acquire (Acquire, ReleaseType(..), mkAcquireType, with) -import Data.IORef (readIORef) import Data.Pool as P -import qualified Data.Map as Map import qualified Data.Text as T +import qualified UnliftIO.Exception as UE import Database.Persist.Class.PersistStore +import Database.Persist.Sql.Raw import Database.Persist.Sql.Types import Database.Persist.Sql.Types.Internal -import Database.Persist.Sql.Raw +import Database.Persist.SqlBackend.Internal.StatementCache +import Database.Persist.SqlBackend.Internal.SqlPoolHooks -- | Get a connection from the pool, run the given action, and then return the -- connection to the pool. @@ -93,15 +95,36 @@ -- cleanup function is complete. -> m a runSqlPoolWithHooks r pconn i before after onException = + runSqlPoolWithExtensibleHooks r pconn i $ SqlPoolHooks + { alterBackend = pure + , runBefore = \conn _ -> void $ before conn + , runAfter = \conn _ -> void $ after conn + , runOnException = \b _ e -> void $ onException b e + } + +-- | This function is how 'runSqlPoolWithHooks' is defined. +-- +-- It's currently the most general function for using a SQL pool. +-- +-- @since 2.13.0.0 +runSqlPoolWithExtensibleHooks + :: forall backend m a. (MonadUnliftIO m, BackendCompatible SqlBackend backend) + => ReaderT backend m a + -> Pool backend + -> Maybe IsolationLevel + -> SqlPoolHooks m backend + -> m a +runSqlPoolWithExtensibleHooks r pconn i SqlPoolHooks{..} = withRunInIO $ \runInIO -> withResource pconn $ \conn -> UE.mask $ \restore -> do - _ <- restore $ runInIO $ before conn - a <- restore (runInIO (runReaderT r conn)) + conn' <- restore $ runInIO $ alterBackend conn + _ <- restore $ runInIO $ runBefore conn' i + a <- restore (runInIO (runReaderT r conn')) `UE.catchAny` \e -> do - _ <- restore $ runInIO $ onException conn e + _ <- restore $ runInIO $ runOnException conn' i e UE.throwIO e - _ <- restore $ runInIO $ after conn + _ <- restore $ runInIO $ runAfter conn' i pure a rawAcquireSqlConn @@ -296,5 +319,6 @@ close' :: (BackendCompatible SqlBackend backend) => backend -> IO () close' conn = do - readIORef (connStmtMap $ projectBackend conn) >>= mapM_ stmtFinalize . Map.elems - connClose $ projectBackend conn + let backend = projectBackend conn + statementCacheClear $ connStmtMap backend + connClose backend diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/Sql/Types/Internal.hs new/persistent-2.13.3.0/Database/Persist/Sql/Types/Internal.hs --- old/persistent-2.13.2.1/Database/Persist/Sql/Types/Internal.hs 2021-05-24 17:18:53.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/Sql/Types/Internal.hs 2022-01-29 01:01:38.000000000 +0100 @@ -1,7 +1,7 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} -{-# language RecordWildCards #-} -{-# language DuplicateRecordFields #-} +{-# LANGUAGE RecordWildCards #-} -- | Breaking changes to this module are not reflected in the major version -- number. Prefer to import from "Database.Persist.Sql" instead. If you neeed @@ -25,24 +25,28 @@ , SqlReadT , SqlWriteT , IsSqlBackend + , SqlBackendHooks (..) ) where import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Database.Persist.Class - ( HasPersistBackend (..) - , PersistQueryRead, PersistQueryWrite - , PersistStoreRead, PersistStoreWrite - , PersistUniqueRead, PersistUniqueWrite - , BackendCompatible(..) - ) -import Database.Persist.Class.PersistStore (IsPersistBackend (..)) + ( BackendCompatible(..) + , HasPersistBackend(..) + , PersistQueryRead + , PersistQueryWrite + , PersistStoreRead + , PersistStoreWrite + , PersistUniqueRead + , PersistUniqueWrite + ) +import Database.Persist.Class.PersistStore (IsPersistBackend(..)) import Database.Persist.SqlBackend.Internal import Database.Persist.SqlBackend.Internal.InsertSqlResult +import Database.Persist.SqlBackend.Internal.IsolationLevel import Database.Persist.SqlBackend.Internal.MkSqlBackend import Database.Persist.SqlBackend.Internal.Statement -import Database.Persist.SqlBackend.Internal.IsolationLevel -- | An SQL backend which can only handle read queries -- diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/Sql/Types.hs new/persistent-2.13.3.0/Database/Persist/Sql/Types.hs --- old/persistent-2.13.2.1/Database/Persist/Sql/Types.hs 2021-09-01 23:59:49.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/Sql/Types.hs 2022-01-29 01:01:38.000000000 +0100 @@ -12,9 +12,8 @@ import Control.Monad.Logger (NoLoggingT) import Control.Monad.Trans.Reader (ReaderT(..)) import Control.Monad.Trans.Resource (ResourceT) -import Control.Monad.Trans.Writer (WriterT) import Data.Pool (Pool) -import Data.Text (Text, unpack) +import Data.Text (Text) import Data.Time (NominalDiffTime) import Database.Persist.Sql.Types.Internal diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs 2021-10-13 21:16:29.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal/MkSqlBackend.hs 2022-01-29 01:01:38.000000000 +0100 @@ -3,14 +3,14 @@ module Database.Persist.SqlBackend.Internal.MkSqlBackend where import Control.Monad.Logger (Loc, LogLevel, LogSource, LogStr) -import Data.IORef -import Data.Map (Map) import Data.Text (Text) -import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.Names import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.SqlBackend.Internal.Statement import Database.Persist.Types.Base -import Database.Persist.Names +import Data.Map (Map) +import Data.IORef (IORef) -- | This type shares many of the same field names as the 'SqlBackend' type. -- It's useful for library authors to use this when migrating from using the diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal/SqlPoolHooks.hs 2022-01-29 01:01:38.000000000 +0100 @@ -0,0 +1,21 @@ +module Database.Persist.SqlBackend.Internal.SqlPoolHooks + ( SqlPoolHooks(..) + ) where +import Control.Exception (SomeException) +import Database.Persist.SqlBackend.Internal.IsolationLevel + +-- | A set of hooks that may be used to alter the behaviour +-- of @runSqlPoolWithExtensibleHooks@ in a backwards-compatible +-- fashion. +data SqlPoolHooks m backend = SqlPoolHooks + { alterBackend :: backend -> m backend + -- ^ Alter the backend prior to executing any actions with it. + , runBefore :: backend -> Maybe IsolationLevel -> m () + -- ^ Run this action immediately before the action is performed. + , runAfter :: backend -> Maybe IsolationLevel -> m () + -- ^ Run this action immediately after the action is completed. + , runOnException :: backend -> Maybe IsolationLevel -> SomeException -> m () + -- ^ This action is performed when an exception is received. The + -- exception is provided as a convenience - it is rethrown once this + -- cleanup function is complete. + } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal/StatementCache.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal/StatementCache.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal/StatementCache.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal/StatementCache.hs 2022-01-29 01:01:38.000000000 +0100 @@ -0,0 +1,23 @@ +module Database.Persist.SqlBackend.Internal.StatementCache where + +import Data.Text (Text) +import Database.Persist.SqlBackend.Internal.Statement + +-- | A statement cache used to lookup statements that have already been prepared +-- for a given query. +-- +-- @since 2.13.3 +data StatementCache = StatementCache + { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) + , statementCacheInsert :: StatementCacheKey -> Statement -> IO () + , statementCacheClear :: IO () + , statementCacheSize :: IO Int + } + +newtype StatementCacheKey = StatementCacheKey { cacheKey :: Text } +-- Wrapping around this to allow for more efficient keying mechanisms +-- in the future, perhaps. + +-- | Construct a `StatementCacheKey` from a raw SQL query. +mkCacheKeyFromQuery :: Text -> StatementCacheKey +mkCacheKeyFromQuery = StatementCacheKey diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend/Internal.hs 2021-10-13 21:16:29.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend/Internal.hs 2022-01-29 01:01:38.000000000 +0100 @@ -1,19 +1,21 @@ -{-# language RecordWildCards #-} -{-# language RankNTypes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} module Database.Persist.SqlBackend.Internal where -import Data.Map (Map) import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) +import Data.Vault.Strict (Vault) +import qualified Data.Vault.Strict as Vault import Database.Persist.Class.PersistStore -import Database.Persist.Types.Base import Database.Persist.Names -import Data.IORef -import Database.Persist.SqlBackend.Internal.MkSqlBackend -import Database.Persist.SqlBackend.Internal.Statement import Database.Persist.SqlBackend.Internal.InsertSqlResult import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.SqlBackend.Internal.MkSqlBackend +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.StatementCache (StatementCache) +import Database.Persist.SqlBackend.StatementCache +import Database.Persist.Types.Base -- | A 'SqlBackend' represents a handle or connection to a database. It -- contains functions and values that allow databases to have more @@ -69,7 +71,7 @@ -- When left as 'Nothing', we default to using 'defaultPutMany'. -- -- @since 2.8.1 - , connStmtMap :: IORef (Map Text Statement) + , connStmtMap :: StatementCache -- ^ A reference to the cache of statements. 'Statement's are keyed by -- the 'Text' queries that generated them. , connClose :: IO () @@ -132,6 +134,21 @@ -- When left as 'Nothing', we default to using 'defaultRepsertMany'. -- -- @since 2.9.0 + , connVault :: Vault + -- ^ Carry arbitrary payloads for the connection that + -- may be used to propagate information into hooks. + , connHooks :: SqlBackendHooks + -- ^ Instrumentation hooks that may be used to track the + -- behaviour of a backend. + } + +newtype SqlBackendHooks = SqlBackendHooks + { hookGetStatement :: SqlBackend -> Text -> Statement -> IO Statement + } + +emptySqlBackendHooks :: SqlBackendHooks +emptySqlBackendHooks = SqlBackendHooks + { hookGetStatement = \_ _ s -> pure s } -- | A function for creating a value of the 'SqlBackend' type. You should prefer @@ -148,6 +165,9 @@ , connPutManySql = Nothing , connUpsertSql = Nothing , connInsertManySql = Nothing + , connVault = Vault.empty + , connHooks = emptySqlBackendHooks + , connStmtMap = mkStatementCache $ mkSimpleStatementCache connStmtMap , .. } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend/SqlPoolHooks.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend/SqlPoolHooks.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend/SqlPoolHooks.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend/SqlPoolHooks.hs 2022-01-29 01:01:38.000000000 +0100 @@ -0,0 +1,92 @@ +module Database.Persist.SqlBackend.SqlPoolHooks + ( SqlPoolHooks + , defaultSqlPoolHooks + , getAlterBackend + , modifyAlterBackend + , setAlterBackend + , getRunBefore + , modifyRunBefore + , setRunBefore + , getRunAfter + , modifyRunAfter + , setRunAfter + , getRunOnException + ) + where + +import Control.Exception +import Control.Monad.IO.Class +import Database.Persist.Sql.Raw +import Database.Persist.SqlBackend.Internal +import Database.Persist.SqlBackend.Internal.SqlPoolHooks +import Database.Persist.SqlBackend.Internal.IsolationLevel +import Database.Persist.Class.PersistStore + +-- | Lifecycle hooks that may be altered to extend SQL pool behavior +-- in a backwards compatible fashion. +-- +-- By default, the hooks have the following semantics: +-- +-- - 'alterBackend' has no effect +-- - 'runBefore' begins a transaction +-- - 'runAfter' commits the current transaction +-- - 'runOnException' rolls back the current transaction +-- +-- @since 2.13.3.0 +defaultSqlPoolHooks :: (MonadIO m, BackendCompatible SqlBackend backend) => SqlPoolHooks m backend +defaultSqlPoolHooks = SqlPoolHooks + { alterBackend = pure + , runBefore = \conn mi -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + liftIO $ connBegin sqlBackend getter mi + , runAfter = \conn _ -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + liftIO $ connCommit sqlBackend getter + , runOnException = \conn _ _ -> do + let sqlBackend = projectBackend conn + let getter = getStmtConn sqlBackend + liftIO $ connRollback sqlBackend getter + } + +getAlterBackend :: SqlPoolHooks m backend -> (backend -> m backend) +getAlterBackend = alterBackend + +modifyAlterBackend :: SqlPoolHooks m backend -> ((backend -> m backend) -> (backend -> m backend)) -> SqlPoolHooks m backend +modifyAlterBackend hooks f = hooks { alterBackend = f $ alterBackend hooks } + +setAlterBackend :: SqlPoolHooks m backend -> (backend -> m backend) -> SqlPoolHooks m backend +setAlterBackend hooks f = hooks { alterBackend = f } + + +getRunBefore :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) +getRunBefore = runBefore + +modifyRunBefore :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> m ()) -> (backend -> Maybe IsolationLevel -> m ())) -> SqlPoolHooks m backend +modifyRunBefore hooks f = hooks { runBefore = f $ runBefore hooks } + +setRunBefore :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) -> SqlPoolHooks m backend +setRunBefore h f = h { runBefore = f } + + +getRunAfter :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) +getRunAfter = runAfter + +modifyRunAfter :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> m ()) -> (backend -> Maybe IsolationLevel -> m ())) -> SqlPoolHooks m backend +modifyRunAfter hooks f = hooks { runAfter = f $ runAfter hooks } + +setRunAfter :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> m ()) -> SqlPoolHooks m backend +setRunAfter hooks f = hooks { runAfter = f } + + +getRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) +getRunOnException = runOnException + +modifyRunOnException :: SqlPoolHooks m backend -> ((backend -> Maybe IsolationLevel -> SomeException -> m ()) -> (backend -> Maybe IsolationLevel -> SomeException -> m ())) -> SqlPoolHooks m backend +modifyRunOnException hooks f = hooks { runOnException = f $ runOnException hooks } + +setRunOnException :: SqlPoolHooks m backend -> (backend -> Maybe IsolationLevel -> SomeException -> m ()) -> SqlPoolHooks m backend +setRunOnException hooks f = hooks { runOnException = f } + + diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend/StatementCache.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend/StatementCache.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend/StatementCache.hs 1970-01-01 01:00:00.000000000 +0100 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend/StatementCache.hs 2022-01-29 01:01:38.000000000 +0100 @@ -0,0 +1,66 @@ +{-# LANGUAGE RecordWildCards #-} +module Database.Persist.SqlBackend.StatementCache + ( StatementCache + , StatementCacheKey + , mkCacheKeyFromQuery + , MkStatementCache(..) + , mkSimpleStatementCache + , mkStatementCache + ) where + +import Data.Foldable +import Data.IORef +import qualified Data.Map as Map +import Database.Persist.SqlBackend.Internal.Statement +import Database.Persist.SqlBackend.Internal.StatementCache +import Data.Map (Map) +import Data.Text (Text) + +-- | Configuration parameters for creating a custom statement cache +-- +-- @since 2.13.3 +data MkStatementCache = MkStatementCache + { statementCacheLookup :: StatementCacheKey -> IO (Maybe Statement) + -- ^ Retrieve a statement from the cache, or return nothing if it is not found. + -- + -- @since 2.13.3 + , statementCacheInsert :: StatementCacheKey -> Statement -> IO () + -- ^ Put a new statement into the cache. An immediate lookup of + -- the statement MUST return the inserted statement for the given + -- cache key. Depending on the implementation, the statement cache MAY + -- choose to evict other statements from the cache within this function. + -- + -- @since 2.13.3 + , statementCacheClear :: IO () + -- ^ Remove all statements from the cache. Implementations of this + -- should be sure to call `stmtFinalize` on all statements removed + -- from the cache. + -- + -- @since 2.13.3 + , statementCacheSize :: IO Int + -- ^ Get the current size of the cache. + -- + -- @since 2.13.3 + } + + +-- | Make a simple statement cache that will cache statements if they are not currently cached. +-- +-- @since 2.13.3 +mkSimpleStatementCache :: IORef (Map Text Statement) -> MkStatementCache +mkSimpleStatementCache stmtMap = + MkStatementCache + { statementCacheLookup = \sql -> Map.lookup (cacheKey sql) <$> readIORef stmtMap + , statementCacheInsert = \sql stmt -> + modifyIORef' stmtMap (Map.insert (cacheKey sql) stmt) + , statementCacheClear = do + oldStatements <- atomicModifyIORef' stmtMap (\oldStatements -> (Map.empty, oldStatements)) + traverse_ stmtFinalize oldStatements + , statementCacheSize = Map.size <$> readIORef stmtMap + } + +-- | Create a statement cache. +-- +-- @since 2.13.0 +mkStatementCache :: MkStatementCache -> StatementCache +mkStatementCache MkStatementCache{..} = StatementCache { .. } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/SqlBackend.hs new/persistent-2.13.3.0/Database/Persist/SqlBackend.hs --- old/persistent-2.13.2.1/Database/Persist/SqlBackend.hs 2021-05-05 23:10:13.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/SqlBackend.hs 2022-01-29 01:01:38.000000000 +0100 @@ -6,35 +6,46 @@ SqlBackend , mkSqlBackend , MkSqlBackendArgs(..) + , SqlBackendHooks + , emptySqlBackendHooks -- * Utilities -- $utilities -- ** SqlBackend Getters + , getRDBMS , getEscapedFieldName , getEscapedRawName , getEscapeRawNameFunction , getConnLimitOffset , getConnUpsertSql + , getConnVault + , getConnHooks -- ** SqlBackend Setters , setConnMaxParams , setConnRepsertManySql , setConnInsertManySql , setConnUpsertSql , setConnPutManySql + , setConnVault + , modifyConnVault + , setConnHooks + -- ** SqlBackendHooks ) where import Control.Monad.Reader +import Data.List.NonEmpty (NonEmpty) import Data.Text (Text) +import Data.Vault.Strict (Vault) import Database.Persist.Class.PersistStore (BackendCompatible(..)) +import Database.Persist.Names import Database.Persist.SqlBackend.Internal import qualified Database.Persist.SqlBackend.Internal as SqlBackend (SqlBackend(..)) -import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk (MkSqlBackendArgs(..)) -import Database.Persist.Types.Base -import Database.Persist.Names import Database.Persist.SqlBackend.Internal.InsertSqlResult -import Data.List.NonEmpty (NonEmpty) +import Database.Persist.SqlBackend.Internal.MkSqlBackend as Mk + (MkSqlBackendArgs(..)) +import Database.Persist.Types.Base -- $utilities -- @@ -129,6 +140,34 @@ getConnUpsertSql = do asks (SqlBackend.connUpsertSql . projectBackend) +-- | Retrieve the vault from the provided database backend. +-- +-- @since 2.13.3.0 +getConnVault + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m Vault +getConnVault = do + asks (SqlBackend.connVault . projectBackend) + +-- | Retrieve instrumentation hooks from the provided database backend. +-- +-- @since 2.13.3.0 +getConnHooks + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m SqlBackendHooks +getConnHooks = do + asks (SqlBackend.connHooks . projectBackend) + +-- | Get a tag displaying what database the 'SqlBackend' is for. Can be +-- used to differentiate features in downstream libraries for different +-- database backends. +-- @since 2.13.3.0 +getRDBMS + :: (BackendCompatible SqlBackend backend, MonadReader backend m) + => m Text +getRDBMS = do + asks (SqlBackend.connRDBMS . projectBackend) + -- | Set the maximum parameters that may be issued in a given SQL query. This -- should be used only if the database backend have this limitation. @@ -188,3 +227,24 @@ -> SqlBackend setConnPutManySql mkQuery sb = sb { connPutManySql = Just mkQuery } + +-- | Set the vault on the provided database backend. +-- +-- @since 2.13.0 +setConnVault :: Vault -> SqlBackend -> SqlBackend +setConnVault vault sb = + sb { connVault = vault } + +-- | Modify the vault on the provided database backend. +-- +-- @since 2.13.0 +modifyConnVault :: (Vault -> Vault) -> SqlBackend -> SqlBackend +modifyConnVault f sb = + sb { connVault = f $ connVault sb } + +-- | Set hooks on the provided database backend. +-- +-- @since 2.13.0 +setConnHooks :: SqlBackendHooks -> SqlBackend -> SqlBackend +setConnHooks hooks sb = + sb { connHooks = hooks } diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/Database/Persist/TH.hs new/persistent-2.13.3.0/Database/Persist/TH.hs --- old/persistent-2.13.2.1/Database/Persist/TH.hs 2021-10-13 21:16:31.000000000 +0200 +++ new/persistent-2.13.3.0/Database/Persist/TH.hs 2022-01-27 00:52:36.000000000 +0100 @@ -82,6 +82,9 @@ , (.:?) , (.=) ) +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.Key as Key +#endif import qualified Data.ByteString as BS import Data.Char (toLower, toUpper) import Data.Coerce @@ -2636,7 +2639,11 @@ requireExtensions [[FlexibleInstances]] pureE <- [|pure|] apE' <- [|(<*>)|] - packE <- [|pack|] +#if MIN_VERSION_aeson(2,0,0) + toKeyE <- [|Key.fromString|] +#else + toKeyE <- [|pack|] +#endif dotEqualE <- [|(.=)|] dotColonE <- [|(.:)|] dotColonQE <- [|(.:?)|] @@ -2663,7 +2670,7 @@ where pairs = zipWith toPair fields xs toPair f x = InfixE - (Just (packE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f))) + (Just (toKeyE `AppE` LitE (StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f))) dotEqualE (Just $ VarE x) fromJSONI = @@ -2684,7 +2691,7 @@ toPull f = InfixE (Just $ VarE obj) (if maybeNullable f then dotColonQE else dotColonE) - (Just $ AppE packE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f) + (Just $ AppE toKeyE $ LitE $ StringL $ unpack $ unFieldNameHS $ unboundFieldNameHS f) case mpsEntityJSON mps of Nothing -> return [toJSONI, fromJSONI] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/persistent.cabal new/persistent-2.13.3.0/persistent.cabal --- old/persistent-2.13.2.1/persistent.cabal 2021-10-13 21:16:31.000000000 +0200 +++ new/persistent-2.13.3.0/persistent.cabal 2022-01-29 01:01:38.000000000 +0100 @@ -1,5 +1,5 @@ name: persistent -version: 2.13.2.1 +version: 2.13.3.0 license: MIT license-file: LICENSE author: Michael Snoyman <[email protected]> @@ -17,7 +17,7 @@ library build-depends: base >= 4.11.1.0 && < 5 - , aeson >= 1.0 + , aeson >= 1.0 && < 2.1 , attoparsec , base64-bytestring , blaze-html >= 0.9 @@ -42,6 +42,7 @@ , unliftio , unliftio-core , unordered-containers + , vault , vector default-extensions: @@ -72,10 +73,14 @@ Database.Persist.Sql.Util Database.Persist.SqlBackend + Database.Persist.SqlBackend.StatementCache + Database.Persist.SqlBackend.SqlPoolHooks Database.Persist.SqlBackend.Internal Database.Persist.SqlBackend.Internal.InsertSqlResult Database.Persist.SqlBackend.Internal.IsolationLevel + Database.Persist.SqlBackend.Internal.SqlPoolHooks Database.Persist.SqlBackend.Internal.Statement + Database.Persist.SqlBackend.Internal.StatementCache Database.Persist.SqlBackend.Internal.MkSqlBackend Database.Persist.Class diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/test/Database/Persist/TH/JsonEncodingSpec.hs new/persistent-2.13.3.0/test/Database/Persist/TH/JsonEncodingSpec.hs --- old/persistent-2.13.2.1/test/Database/Persist/TH/JsonEncodingSpec.hs 2021-05-05 23:10:13.000000000 +0200 +++ new/persistent-2.13.3.0/test/Database/Persist/TH/JsonEncodingSpec.hs 2022-01-21 00:23:09.000000000 +0100 @@ -19,7 +19,6 @@ import TemplateTestImports import Data.Aeson -import qualified Data.HashMap.Lazy as M import Data.Text (Text) import Test.QuickCheck.Instances () import Test.Hspec.QuickCheck @@ -73,15 +72,15 @@ it "encodes without an ID field" $ do toJSON subjectEntity `shouldBe` - Object (M.fromList + object [ ("name", String "Bob") , ("age", toJSON (32 :: Int)) , ("id", String "Bob") - ]) + ] it "decodes without an ID field" $ do let - json_ = encode . Object . M.fromList $ + json_ = encode . object $ [ ("name", String "Bob") , ("age", toJSON (32 :: Int)) ] @@ -103,11 +102,11 @@ Entity (JsonEncodingKey jsonEncodingName) j toJSON ent `shouldBe` - Object (M.fromList + object [ ("name", toJSON jsonEncodingName) , ("age", toJSON jsonEncodingAge) , ("id", toJSON jsonEncodingName) - ]) + ] prop "round trip works with composite key" $ \j@JsonEncoding2{..} -> do let @@ -125,9 +124,9 @@ Entity key j toJSON ent `shouldBe` - Object (M.fromList + object [ ("name", toJSON jsonEncoding2Name) , ("age", toJSON jsonEncoding2Age) , ("blood", toJSON jsonEncoding2Blood) , ("id", toJSON key) - ]) + ] diff -urN '--exclude=CVS' '--exclude=.cvsignore' '--exclude=.svn' '--exclude=.svnignore' old/persistent-2.13.2.1/test/Database/Persist/THSpec.hs new/persistent-2.13.3.0/test/Database/Persist/THSpec.hs --- old/persistent-2.13.2.1/test/Database/Persist/THSpec.hs 2021-06-29 19:52:18.000000000 +0200 +++ new/persistent-2.13.3.0/test/Database/Persist/THSpec.hs 2022-01-21 00:23:09.000000000 +0100 @@ -24,7 +24,7 @@ module Database.Persist.THSpec where import Control.Applicative (Const(..)) -import Data.Aeson +import Data.Aeson hiding (Key) import Data.ByteString.Lazy.Char8 () import Data.Coerce import Data.Functor.Identity (Identity(..))
