persistent-postgresql 2.13.0.3 → 2.13.1.0
raw patch · 4 files changed
+219/−27 lines, 4 files
Files
- ChangeLog.md +6/−0
- Database/Persist/Postgresql.hs +192/−11
- persistent-postgresql.cabal +1/−1
- test/main.hs +20/−15
ChangeLog.md view
@@ -1,5 +1,11 @@ # Changelog for persistent-postgresql +## 2.13.1.0++* [#1305](https://github.com/yesodweb/persistent/pull/1305)+ * Add `RawPostgresql` wrapper, which exposes the underlying Postgres connection used+ to construct a `SqlBackend`.+ ## 2.13.0.3 * [#1290](https://github.com/yesodweb/persistent/pull/1290)
Database/Persist/Postgresql.hs view
@@ -1,16 +1,27 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +#if MIN_VERSION_base(4,12,0)+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE UndecidableInstances #-}+#endif+ -- | A postgresql backend for persistent. module Database.Persist.Postgresql ( withPostgresqlPool@@ -42,6 +53,12 @@ , migrateEnableExtension , PostgresConfHooks(..) , defaultPostgresConfHooks++ , RawPostgresql(..)+ , createRawPostgresqlPool+ , createRawPostgresqlPoolModified+ , createRawPostgresqlPoolModifiedWithVersion+ , createRawPostgresqlPoolWithConf ) where import qualified Database.PostgreSQL.LibPQ as LibPQ@@ -55,8 +72,6 @@ import qualified Database.PostgreSQL.Simple.TypeInfo.Static as PS import qualified Database.PostgreSQL.Simple.Types as PG -import Data.Proxy (Proxy(..))-import qualified Data.List.NonEmpty as NEL import Control.Arrow import Control.Exception (Exception, throw, throwIO) import Control.Monad@@ -64,7 +79,12 @@ import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT)+#if !MIN_VERSION_base(4,12,0)+import Control.Monad.Trans.Reader (withReaderT)+#endif import Control.Monad.Trans.Writer (WriterT(..), runWriterT)+import qualified Data.List.NonEmpty as NEL+import Data.Proxy (Proxy(..)) import qualified Blaze.ByteString.Builder.Char8 as BBB import Data.Acquire (Acquire, mkAcquire, with)@@ -104,9 +124,12 @@ import Data.Time (NominalDiffTime, localTimeToUTC, utc) import System.Environment (getEnvironment) +#if MIN_VERSION_base(4,12,0)+import Database.Persist.Compatible+#endif import Database.Persist.Sql-import Database.Persist.SqlBackend import qualified Database.Persist.Sql.Util as Util+import Database.Persist.SqlBackend -- | A @libpq@ connection string. A simple example of connection -- string would be @\"host=localhost port=5432 user=test@@ -161,7 +184,7 @@ -> m a withPostgresqlPoolWithVersion getVerDouble ci = do let getVer = oldGetVersionToNew getVerDouble- withSqlPool $ open' (const $ return ()) getVer ci+ withSqlPool $ open' (const $ return ()) getVer id ci -- | Same as 'withPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. --@@ -176,7 +199,7 @@ withPostgresqlPoolWithConf conf hooks = do let getVer = pgConfHooksGetServerVersion hooks modConn = pgConfHooksAfterCreate hooks- let logFuncToBackend = open' modConn getVer (pgConnStr conf)+ let logFuncToBackend = open' modConn getVer id (pgConnStr conf) withSqlPoolWithConfig logFuncToBackend (postgresConfToConnectionPoolConfig conf) -- | Create a PostgreSQL connection pool. Note that it's your@@ -222,7 +245,7 @@ -> m (Pool SqlBackend) createPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do let getVer = oldGetVersionToNew getVerDouble- createSqlPool $ open' modConn getVer ci+ createSqlPool $ open' modConn getVer id ci -- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. --@@ -235,7 +258,7 @@ createPostgresqlPoolWithConf conf hooks = do let getVer = pgConfHooksGetServerVersion hooks modConn = pgConfHooksAfterCreate hooks- createSqlPoolWithConfig (open' modConn getVer (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf)+ createSqlPoolWithConfig (open' modConn getVer id (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf) postgresConfToConnectionPoolConfig :: PostgresConf -> ConnectionPoolConfig postgresConfToConnectionPoolConfig conf =@@ -264,18 +287,23 @@ -> m a withPostgresqlConnWithVersion getVerDouble = do let getVer = oldGetVersionToNew getVerDouble- withSqlConn . open' (const $ return ()) getVer+ withSqlConn . open' (const $ return ()) getVer id open' :: (PG.Connection -> IO ()) -> (PG.Connection -> IO (NonEmpty Word))- -> ConnectionString -> LogFunc -> IO SqlBackend-open' modConn getVer cstr logFunc = do+ -> ((PG.Connection -> SqlBackend) -> PG.Connection -> backend)+ -- ^ How to construct the actual backend type desired. For most uses,+ -- this is just 'id', since the desired backend type is 'SqlBackend'.+ -- But some callers want a @'RawPostgresql' 'SqlBackend'@, and will+ -- pass in 'withRawConnection'.+ -> ConnectionString -> LogFunc -> IO backend+open' modConn getVer constructor cstr logFunc = do conn <- PG.connectPostgreSQL cstr modConn conn ver <- getVer conn smap <- newIORef $ Map.empty- return $ createBackend logFunc ver smap conn+ return $ constructor (createBackend logFunc ver smap) conn -- | Gets the PostgreSQL server version getServerVersion :: PG.Connection -> IO (Maybe Double)@@ -2039,3 +2067,156 @@ postgresMkColumns allDefs t = mkColumns allDefs t $ setBackendSpecificForeignKeyName refName emptyBackendSpecificOverrides++-- | Wrapper for persistent SqlBackends that carry the corresponding+-- `Postgresql.Connection`.+--+-- @since 2.13.1.0+data RawPostgresql backend = RawPostgresql+ { persistentBackend :: backend + -- ^ The persistent backend+ --+ -- @since 2.13.1.0+ , rawPostgresqlConnection :: PG.Connection + -- ^ The underlying `PG.Connection`+ -- + -- @since 2.13.1.0+ }++instance BackendCompatible b (RawPostgresql b) where+ projectBackend = persistentBackend++withRawConnection+ :: (PG.Connection -> SqlBackend)+ -> PG.Connection+ -> RawPostgresql SqlBackend+withRawConnection f conn = RawPostgresql+ { persistentBackend = f conn+ , rawPostgresqlConnection = conn+ }++-- | Create a PostgreSQL connection pool which also exposes the+-- raw connection. The raw counterpart to 'createPostgresqlPool'.+--+-- @since 2.13.1.0+createRawPostgresqlPool :: (MonadUnliftIO m, MonadLoggerIO m)+ => ConnectionString+ -- ^ Connection string to the database.+ -> Int+ -- ^ Number of connections to be kept open+ -- in the pool.+ -> m (Pool (RawPostgresql SqlBackend))+createRawPostgresqlPool = createRawPostgresqlPoolModified (const $ return ())++-- | The raw counterpart to 'createPostgresqlPoolModified'.+--+-- @since 2.13.1.0+createRawPostgresqlPoolModified+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => (PG.Connection -> IO ()) -- ^ Action to perform after connection is created.+ -> ConnectionString -- ^ Connection string to the database.+ -> Int -- ^ Number of connections to be kept open in the pool.+ -> m (Pool (RawPostgresql SqlBackend))+createRawPostgresqlPoolModified = createRawPostgresqlPoolModifiedWithVersion getServerVersion++-- | The raw counterpart to 'createPostgresqlPoolModifiedWithVersion'.+--+-- @since 2.13.1.0+createRawPostgresqlPoolModifiedWithVersion+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => (PG.Connection -> IO (Maybe Double)) -- ^ Action to perform to get the server version.+ -> (PG.Connection -> IO ()) -- ^ Action to perform after connection is created.+ -> ConnectionString -- ^ Connection string to the database.+ -> Int -- ^ Number of connections to be kept open in the pool.+ -> m (Pool (RawPostgresql SqlBackend))+createRawPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do+ let getVer = oldGetVersionToNew getVerDouble+ createSqlPool $ open' modConn getVer withRawConnection ci++-- | The raw counterpart to 'createPostgresqlPoolWithConf'.+--+-- @since 2.13.1.0+createRawPostgresqlPoolWithConf+ :: (MonadUnliftIO m, MonadLoggerIO m)+ => PostgresConf -- ^ Configuration for connecting to Postgres+ -> PostgresConfHooks -- ^ Record of callback functions+ -> m (Pool (RawPostgresql SqlBackend))+createRawPostgresqlPoolWithConf conf hooks = do+ let getVer = pgConfHooksGetServerVersion hooks+ modConn = pgConfHooksAfterCreate hooks+ createSqlPoolWithConfig (open' modConn getVer withRawConnection (pgConnStr conf)) (postgresConfToConnectionPoolConfig conf)++#if MIN_VERSION_base(4,12,0)+instance (PersistCore b) => PersistCore (RawPostgresql b) where+ newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (Compatible b (RawPostgresql b)) }++makeCompatibleKeyInstances [t| forall b. Compatible b (RawPostgresql b) |]+#else+instance (PersistCore b) => PersistCore (RawPostgresql b) where+ newtype BackendKey (RawPostgresql b) = RawPostgresqlKey { unRawPostgresqlKey :: BackendKey (RawPostgresql b) }++deriving instance (Show (BackendKey b)) => Show (BackendKey (RawPostgresql b))+deriving instance (Read (BackendKey b)) => Read (BackendKey (RawPostgresql b))+deriving instance (Eq (BackendKey b)) => Eq (BackendKey (RawPostgresql b))+deriving instance (Ord (BackendKey b)) => Ord (BackendKey (RawPostgresql b))+deriving instance (Num (BackendKey b)) => Num (BackendKey (RawPostgresql b))+deriving instance (Integral (BackendKey b)) => Integral (BackendKey (RawPostgresql b))+deriving instance (PersistField (BackendKey b)) => PersistField (BackendKey (RawPostgresql b))+deriving instance (PersistFieldSql (BackendKey b)) => PersistFieldSql (BackendKey (RawPostgresql b))+deriving instance (Real (BackendKey b)) => Real (BackendKey (RawPostgresql b))+deriving instance (Enum (BackendKey b)) => Enum (BackendKey (RawPostgresql b))+deriving instance (Bounded (BackendKey b)) => Bounded (BackendKey (RawPostgresql b))+deriving instance (ToJSON (BackendKey b)) => ToJSON (BackendKey (RawPostgresql b))+deriving instance (FromJSON (BackendKey b)) => FromJSON (BackendKey (RawPostgresql b))+#endif+++#if MIN_VERSION_base(4,12,0)+$(pure [])++makeCompatibleInstances [t| forall b. Compatible b (RawPostgresql b) |]+#else+instance HasPersistBackend b => HasPersistBackend (RawPostgresql b) where+ type BaseBackend (RawPostgresql b) = BaseBackend b+ persistBackend = persistBackend . persistentBackend++instance (PersistStoreRead b) => PersistStoreRead (RawPostgresql b) where+ get = withReaderT persistentBackend . get+ getMany = withReaderT persistentBackend . getMany++instance (PersistQueryRead b) => PersistQueryRead (RawPostgresql b) where+ selectSourceRes filts opts = withReaderT persistentBackend $ selectSourceRes filts opts+ selectFirst filts opts = withReaderT persistentBackend $ selectFirst filts opts+ selectKeysRes filts opts = withReaderT persistentBackend $ selectKeysRes filts opts+ count = withReaderT persistentBackend . count+ exists = withReaderT persistentBackend . exists++instance (PersistQueryWrite b) => PersistQueryWrite (RawPostgresql b) where+ updateWhere filts updates = withReaderT persistentBackend $ updateWhere filts updates+ deleteWhere = withReaderT persistentBackend . deleteWhere++instance (PersistUniqueRead b) => PersistUniqueRead (RawPostgresql b) where+ getBy = withReaderT persistentBackend . getBy++instance (PersistStoreWrite b) => PersistStoreWrite (RawPostgresql b) where+ insert = withReaderT persistentBackend . insert+ insert_ = withReaderT persistentBackend . insert_+ insertMany = withReaderT persistentBackend . insertMany+ insertMany_ = withReaderT persistentBackend . insertMany_+ insertEntityMany = withReaderT persistentBackend . insertEntityMany+ insertKey k = withReaderT persistentBackend . insertKey k+ repsert k = withReaderT persistentBackend . repsert k+ repsertMany = withReaderT persistentBackend . repsertMany+ replace k = withReaderT persistentBackend . replace k+ delete = withReaderT persistentBackend . delete+ update k = withReaderT persistentBackend . update k+ updateGet k = withReaderT persistentBackend . updateGet k++instance (PersistUniqueWrite b) => PersistUniqueWrite (RawPostgresql b) where+ deleteBy = withReaderT persistentBackend . deleteBy+ insertUnique = withReaderT persistentBackend . insertUnique+ upsert rec = withReaderT persistentBackend . upsert rec+ upsertBy uniq rec = withReaderT persistentBackend . upsertBy uniq rec+ putMany = withReaderT persistentBackend . putMany+#endif+
persistent-postgresql.cabal view
@@ -1,5 +1,5 @@ name: persistent-postgresql-version: 2.13.0.3+version: 2.13.1.0 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman <michael@snoyman.com>
test/main.hs view
@@ -1,29 +1,29 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DataKinds, FlexibleInstances #-}-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -Wno-unused-top-binds #-} import PgInit import Data.Aeson import qualified Data.ByteString as BS-import Data.IntMap (IntMap) import Data.Fixed+import Data.IntMap (IntMap) import qualified Data.Text as T import Data.Time import Test.QuickCheck -import qualified ImplicitUuidSpec import qualified ArrayAggTest import qualified CompositeTest-import qualified ForeignKey+import qualified CustomConstraintTest import qualified CustomPersistFieldTest import qualified CustomPrimaryKeyReferenceTest import qualified DataTypeTest@@ -31,17 +31,24 @@ import qualified EmbedTest import qualified EmptyEntityTest import qualified EquivalentTypeTestPostgres+import qualified ForeignKey+import qualified GeneratedColumnTestSQL import qualified HtmlTest+import qualified ImplicitUuidSpec import qualified JSONTest import qualified LargeNumberTest+import qualified LongIdentifierTest import qualified MaxLenTest+import qualified MaybeFieldDefsTest import qualified MigrationColumnLengthTest-import qualified MigrationTest import qualified MigrationOnlyTest-import qualified MpsNoPrefixTest+import qualified MigrationReferenceSpec+import qualified MigrationTest import qualified MpsCustomPrefixTest-import qualified PersistentTest+import qualified MpsNoPrefixTest import qualified PersistUniqueTest+import qualified PersistentTest+import qualified PgIntervalTest import qualified PrimaryTest import qualified RawSqlTest import qualified ReadWriteTest@@ -53,11 +60,7 @@ import qualified UniqueTest import qualified UpsertTest import qualified UpsertWhere-import qualified CustomConstraintTest-import qualified LongIdentifierTest import qualified PgIntervalTest-import qualified GeneratedColumnTestSQL-import qualified MigrationReferenceSpec type Tuple = (,) @@ -117,6 +120,7 @@ , LargeNumberTest.numberMigrate , UniqueTest.uniqueMigrate , MaxLenTest.maxlenMigrate+ , MaybeFieldDefsTest.maybeFieldDefMigrate , Recursive.recursiveMigrate , CompositeTest.compositeMigrate , TreeTest.treeMigrate@@ -169,6 +173,7 @@ ForeignKey.specsWith runConnAssert UniqueTest.specsWith runConnAssert MaxLenTest.specsWith runConnAssert+ MaybeFieldDefsTest.specsWith runConnAssert Recursive.specsWith runConnAssert SumTypeTest.specsWith runConnAssert (Just (runMigrationSilent SumTypeTest.sumTypeMigrate)) MigrationTest.specsWith runConnAssert