From 55cc233afe7b71859fd68af02092a63bce09f8e2 Mon Sep 17 00:00:00 2001 From: Taylor Fausak Date: Thu, 27 Jul 2023 15:47:08 -0500 Subject: [PATCH 01/15] Allow http-api-data 0.6 (#1507) --- persistent-mongoDB/persistent-mongoDB.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/persistent-mongoDB/persistent-mongoDB.cabal b/persistent-mongoDB/persistent-mongoDB.cabal index 4cf47732e..dcefd7d78 100644 --- a/persistent-mongoDB/persistent-mongoDB.cabal +++ b/persistent-mongoDB/persistent-mongoDB.cabal @@ -26,7 +26,7 @@ library , bytestring , cereal >= 0.5 , conduit >= 1.2 - , http-api-data >= 0.3.7 && < 0.6 + , http-api-data >= 0.3.7 && < 0.7 , mongoDB >= 2.3 && < 2.8 , network >= 2.6 , path-pieces >= 0.2 From c3c0145947f20e79e2f1548d763c193d3dc1c791 Mon Sep 17 00:00:00 2001 From: Mike Pilgrem Date: Thu, 7 Sep 2023 18:21:26 +0100 Subject: [PATCH 02/15] Patch for aeson-2.2.0.0 and template-haskell-2.21 (#1513) --- persistent/Database/Persist/TH.hs | 13 ++++++++++++- persistent/persistent.cabal | 23 ++++++++++++----------- 2 files changed, 24 insertions(+), 12 deletions(-) diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index 189261d7b..ddf226580 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -121,6 +121,9 @@ import Data.Foldable (asum, toList) import qualified Data.Set as Set import Language.Haskell.TH.Lib (appT, conE, conK, conT, litT, strTyLit, varE, varP, varT) +#if MIN_VERSION_template_haskell(2,21,0) +import Language.Haskell.TH.Lib (defaultBndrFlag) +#endif import Language.Haskell.TH.Quote import Language.Haskell.TH.Syntax import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) @@ -2325,7 +2328,15 @@ mkLenses mps entityMap ent = fmap mconcat $ forM (getUnboundFieldDefs ent `zip` where fieldNames = fieldDefToRecordName mps ent <$> getUnboundFieldDefs ent -#if MIN_VERSION_template_haskell(2,17,0) +#if MIN_VERSION_template_haskell(2,21,0) +mkPlainTV + :: Name + -> TyVarBndr BndrVis +mkPlainTV n = PlainTV n defaultBndrFlag + +mkForallTV :: Name -> TyVarBndr Specificity +mkForallTV n = PlainTV n SpecifiedSpec +#elif MIN_VERSION_template_haskell(2,17,0) mkPlainTV :: Name -> TyVarBndr () diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index 857cd8b47..ee1d9edde 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -15,10 +15,11 @@ bug-reports: https://github.com/yesodweb/persistent/issues extra-source-files: ChangeLog.md README.md library - build-depends: + build-depends: base >= 4.11.1.0 && < 5 - , aeson >= 1.0 && < 2.2 + , aeson >= 1.0 && < 2.3 , attoparsec + , attoparsec-aeson >= 2.1.0.0 && < 2.3 , base64-bytestring , blaze-html >= 0.9 , bytestring >= 0.10 @@ -29,13 +30,13 @@ library , http-api-data >= 0.3 , lift-type >= 0.1.0.0 && < 0.2.0.0 , monad-logger >= 0.3.28 - , mtl + , mtl , path-pieces >= 0.2 , resource-pool >= 0.2.3 , resourcet >= 1.1.10 , scientific , silently - , template-haskell >= 2.13 && < 2.20 + , template-haskell >= 2.13 && < 2.22 , text >= 1.2 , th-lift-instances >= 0.1.14 && < 0.2 , time >= 1.6 @@ -46,13 +47,13 @@ library , vault , vector - default-extensions: + default-extensions: FlexibleContexts , MultiParamTypeClasses , OverloadedStrings , TypeFamilies - exposed-modules: + exposed-modules: Database.Persist Database.Persist.Types Database.Persist.Names @@ -92,7 +93,7 @@ library Database.Persist.Class.PersistField Database.Persist.Class.PersistStore - other-modules: + other-modules: Database.Persist.Types.Base Database.Persist.Sql.Internal @@ -106,9 +107,9 @@ library -- These modules only make sense for compilers with access to DerivingVia if impl(ghc >= 8.6.1) - exposed-modules: + exposed-modules: Database.Persist.Compatible - other-modules: + other-modules: Database.Persist.Compatible.Types Database.Persist.Compatible.TH @@ -119,7 +120,7 @@ test-suite test type: exitcode-stdio-1.0 main-is: main.hs - build-depends: + build-depends: base >= 4.9 && < 5 , aeson , attoparsec @@ -164,7 +165,7 @@ test-suite test , TypeFamilies , TypeOperators - other-modules: + other-modules: Database.Persist.ClassSpec Database.Persist.PersistValueSpec Database.Persist.QuasiSpec From 815dfafee58626d3bf3b9421e24ffbc5f04c33cd Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 7 Sep 2023 12:11:21 -0600 Subject: [PATCH 03/15] persistent-2.14.5.2 --- persistent/ChangeLog.md | 5 +++++ persistent/persistent.cabal | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 2de90fae7..017c1788d 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.14.5.2 + +* [#1513](https://github.com/yesodweb/persistent/pull/1513) + * Support GHC 9.8 and `aeson-2.2` + ## 2.14.5.1 * [#1496](https://github.com/yesodweb/persistent/pull/1496) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index ee1d9edde..b6eafff4e 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.5.1 +version: 2.14.5.2 license: MIT license-file: LICENSE author: Michael Snoyman From 98ee5443886a731c3069c8135d8fd7bea39f3b8e Mon Sep 17 00:00:00 2001 From: Daniel Trowbridge Date: Mon, 18 Sep 2023 22:40:41 +0100 Subject: [PATCH 04/15] Create Haddocks from entity documentation comments (#1503) * Include Haddock documentation in entity data type declarations * Mention partial Haddock support in Quasi module documentation * Configure Haddock generation using MkPersistSettings flag * Determine withDecDoc availability using MIN_VERSION_template_haskell * Generate Haddocks from field documentation comments * Add spec testing Haddock generation * Remove th-lift dependency * Process field Haddocks independently of model Haddocks Previously, field Haddocks would only be processed if a documentation comment was present on the model. This commit also uses putDoc for both field and model Haddocks, removing the withDecDoc import. * Add changelog entry and bump persistent version to 2.14.6.0 --- persistent/ChangeLog.md | 5 +++ persistent/Database/Persist/Quasi.hs | 4 +-- persistent/Database/Persist/TH.hs | 30 +++++++++++++--- persistent/persistent.cabal | 3 +- .../test/Database/Persist/TH/CommentSpec.hs | 9 +++-- .../Database/Persist/TH/EntityHaddockSpec.hs | 36 +++++++++++++++++++ persistent/test/Database/Persist/THSpec.hs | 2 ++ 7 files changed, 80 insertions(+), 9 deletions(-) create mode 100644 persistent/test/Database/Persist/TH/EntityHaddockSpec.hs diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 2de90fae7..688392e15 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for persistent +## 2.14.6.0 + +* [#1503](https://github.com/yesodweb/persistent/pull/1503) + * Create Haddocks from entity documentation comments + ## 2.14.5.1 * [#1496](https://github.com/yesodweb/persistent/pull/1496) diff --git a/persistent/Database/Persist/Quasi.hs b/persistent/Database/Persist/Quasi.hs index e020401ae..a245b8ff6 100644 --- a/persistent/Database/Persist/Quasi.hs +++ b/persistent/Database/Persist/Quasi.hs @@ -612,8 +612,8 @@ Likewise, the field documentation is present in the @fieldComments@ field on the "A user can be old, or young, and we care about\nthis for some reason." @ -Unfortunately, we can't use this to create Haddocks for you, because . -@persistent@ backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. +Since @persistent-2.14.6.0@, documentation comments are included in documentation generated using Haddock if `mpsEntityHaddocks` is enabled (defaults to False). +@persistent@ backends can also use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the library to render a Markdown document of the entity definitions. = Sum types diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index ddf226580..db04e3fb3 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -45,6 +45,7 @@ module Database.Persist.TH , mpsPrefixFields , mpsFieldLabelModifier , mpsConstraintLabelModifier + , mpsEntityHaddocks , mpsEntityJSON , mpsGenerateLenses , mpsDeriveInstances @@ -1070,6 +1071,10 @@ data MkPersistSettings = MkPersistSettings -- Note: this setting is ignored if mpsPrefixFields is set to False. -- -- @since 2.11.0.0 + , mpsEntityHaddocks :: Bool + -- ^ Generate Haddocks from entity documentation comments. Default: False. + -- + -- @since 2.14.6.0 , mpsEntityJSON :: Maybe EntityJSON -- ^ Generate @ToJSON@/@FromJSON@ instances for each model types. If it's -- @Nothing@, no instances will be generated. Default: @@ -1161,6 +1166,7 @@ mkPersistSettings backend = MkPersistSettings , mpsPrefixFields = True , mpsFieldLabelModifier = (++) , mpsConstraintLabelModifier = (++) + , mpsEntityHaddocks = False , mpsEntityJSON = Just EntityJSON { entityToJSON = 'entityIdToJSON , entityFromJSON = 'entityIdFromJSON @@ -1203,10 +1209,24 @@ dataTypeDec mps entityMap entDef = do pure (DerivClause (Just AnyclassStrategy) (fmap ConT anyclasses)) unless (null anyclassDerives) $ do requireExtensions [[DeriveAnyClass]] - pure $ DataD [] nameFinal paramsFinal + let dec = DataD [] nameFinal paramsFinal Nothing constrs (stockDerives <> anyclassDerives) +#if MIN_VERSION_template_haskell(2,18,0) + when (mpsEntityHaddocks mps) $ do + forM_ cols $ \((name, _, _), maybeComments) -> do + case maybeComments of + Just comment -> addModFinalizer $ + putDoc (DeclDoc name) (unpack comment) + Nothing -> pure () + case entityComments (unboundEntityDef entDef) of + Just doc -> do + addModFinalizer $ putDoc (DeclDoc nameFinal) (unpack doc) + _ -> pure () +#endif + pure dec + where stratFor n = if n `elem` stockClasses then @@ -1231,7 +1251,7 @@ dataTypeDec mps entityMap entDef = do | otherwise = (mkEntityDefName entDef, []) - cols :: [VarBangType] + cols :: [(VarBangType, Maybe Text)] cols = do fieldDef <- getUnboundFieldDefs entDef let @@ -1243,11 +1263,13 @@ dataTypeDec mps entityMap entDef = do else notStrict fieldIdType = maybeIdType mps entityMap fieldDef Nothing Nothing - pure (recordNameE, strictness, fieldIdType) + fieldComments = + unboundFieldComments fieldDef + pure ((recordNameE, strictness, fieldIdType), fieldComments) constrs | unboundEntitySum entDef = fmap sumCon $ getUnboundFieldDefs entDef - | otherwise = [RecC (mkEntityDefName entDef) cols] + | otherwise = [RecC (mkEntityDefName entDef) (map fst cols)] sumCon fieldDef = NormalC (sumConstrName mps entDef fieldDef) diff --git a/persistent/persistent.cabal b/persistent/persistent.cabal index ee1d9edde..605401cb9 100644 --- a/persistent/persistent.cabal +++ b/persistent/persistent.cabal @@ -1,5 +1,5 @@ name: persistent -version: 2.14.5.1 +version: 2.14.6.0 license: MIT license-file: LICENSE author: Michael Snoyman @@ -173,6 +173,7 @@ test-suite test Database.Persist.TH.CompositeKeyStyleSpec Database.Persist.TH.DiscoverEntitiesSpec Database.Persist.TH.EmbedSpec + Database.Persist.TH.EntityHaddockSpec Database.Persist.TH.ForeignRefSpec Database.Persist.TH.ImplicitIdColSpec Database.Persist.TH.JsonEncodingSpec diff --git a/persistent/test/Database/Persist/TH/CommentSpec.hs b/persistent/test/Database/Persist/TH/CommentSpec.hs index ea98c8474..9663ac956 100644 --- a/persistent/test/Database/Persist/TH/CommentSpec.hs +++ b/persistent/test/Database/Persist/TH/CommentSpec.hs @@ -12,14 +12,19 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -module Database.Persist.TH.CommentSpec where +{-# OPTIONS_GHC -haddock #-} + +module Database.Persist.TH.CommentSpec + ( CommentModel (..) + , spec + ) where import TemplateTestImports import Database.Persist.EntityDef.Internal (EntityDef(..)) import Database.Persist.FieldDef.Internal (FieldDef(..)) -mkPersist sqlSettings [persistLowerCase| +mkPersist (sqlSettings {mpsEntityHaddocks = True}) [persistLowerCase| -- | Doc comments work. -- | Has multiple lines. diff --git a/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs b/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs new file mode 100644 index 000000000..c7088c7a4 --- /dev/null +++ b/persistent/test/Database/Persist/TH/EntityHaddockSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Database.Persist.TH.EntityHaddockSpec (spec) where + +import TemplateTestImports + +#if MIN_VERSION_template_haskell(2,18,0) +import Database.Persist.TH.CommentSpec (CommentModel (..)) +import Language.Haskell.TH (DocLoc (DeclDoc), getDoc) +import Language.Haskell.TH.Syntax (lift) + +[d| + commentModelDoc :: Maybe String + commentModelDoc = $(lift =<< getDoc (DeclDoc ''CommentModel)) + + commentFieldDoc :: Maybe String + commentFieldDoc = $(lift =<< getDoc (DeclDoc 'commentModelName)) + |] + +spec :: Spec +spec = describe "EntityHaddockSpec" $ do + it "generates entity Haddock" $ do + let expected = unlines [ "Doc comments work." + , "Has multiple lines." + ] + commentModelDoc `shouldBe` Just expected + it "generates field Haddock" $ do + let expected = unlines [ "First line of comment on column." + , "Second line of comment on column." + ] + commentFieldDoc `shouldBe` Just expected +#else +spec :: Spec +spec = pure () +#endif diff --git a/persistent/test/Database/Persist/THSpec.hs b/persistent/test/Database/Persist/THSpec.hs index 0ea783206..2d84727b1 100644 --- a/persistent/test/Database/Persist/THSpec.hs +++ b/persistent/test/Database/Persist/THSpec.hs @@ -53,6 +53,7 @@ import qualified Database.Persist.TH.CommentSpec as CommentSpec import qualified Database.Persist.TH.CompositeKeyStyleSpec as CompositeKeyStyleSpec import qualified Database.Persist.TH.DiscoverEntitiesSpec as DiscoverEntitiesSpec import qualified Database.Persist.TH.EmbedSpec as EmbedSpec +import qualified Database.Persist.TH.EntityHaddockSpec as EntityHaddockSpec import qualified Database.Persist.TH.ForeignRefSpec as ForeignRefSpec import qualified Database.Persist.TH.ImplicitIdColSpec as ImplicitIdColSpec import qualified Database.Persist.TH.JsonEncodingSpec as JsonEncodingSpec @@ -204,6 +205,7 @@ spec = describe "THSpec" $ do ToFromPersistValuesSpec.spec JsonEncodingSpec.spec CommentSpec.spec + EntityHaddockSpec.spec CompositeKeyStyleSpec.spec describe "TestDefaultKeyCol" $ do let EntityIdField FieldDef{..} = From 428c89f4ec2c733d920266d0e5d7fb8505574620 Mon Sep 17 00:00:00 2001 From: Parnell Springmeyer Date: Mon, 18 Sep 2023 16:44:38 -0500 Subject: [PATCH 05/15] persistent-postgresql: add `createPostgresqlPoolTailored` function (#1511) * persistent-postgresql: add `createPostgresqlPoolTailored` function This change adds a connection pool creation function that is just like the `createPostgresqlPoolModifiedWithVersion` function but that can take a custom `open'`-like connection-creation function. The motivation for this change is that we need to be able to customize the resource creation action dynamically at run-time. * persistent-postgresql: version `2.13.5.2` -> `2.13.6` This change alters the API surface (via addition) and, as-per `CONTRIBUTING.md`, requires a `C` bump. * persistent-postgresql: update `@since` decl for bumped version * persistent-postgresql: run `stylish-haskell` on `Postgresql.hs` * persistent-postgresql: update `ChangeLog.md` * persistent-postgresql: follow the same comment style * persistent-postgresql: remove comment that offends haddock parser * persistent-postgresql: expose `createBackend` ... so that users can construct their own `open'`-like function. * persistent-postgresql: expose `getServerVersion` ... so users don't have to write their own. * Update `Changelog.md` to reflect b03fc4f and 9788fad * Minor improvement to CHANGELOG.md to also trigger CI As requested by @parsonsmatt. --- persistent-postgresql/ChangeLog.md | 7 ++++ .../Database/Persist/Postgresql.hs | 42 ++++++++++++++++--- .../persistent-postgresql.cabal | 2 +- 3 files changed, 44 insertions(+), 7 deletions(-) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 780d4559a..0a8d9bc49 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for persistent-postgresql +## 2.13.6 (unreleased) + +* [#1511](https://github.com/yesodweb/persistent/pull/1511) + * Add the `createPostgresqlPoolTailored` function to support creating + connection pools with a custom connection creation function. + * Expose `getServerVersion` and `createBackend` for user's convenience. + ## 2.13.5.2 * [#1471](https://github.com/yesodweb/persistent/pull/1471) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 4dd2dcad5..5a513c806 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -37,6 +37,7 @@ module Database.Persist.Postgresql , createPostgresqlPool , createPostgresqlPoolModified , createPostgresqlPoolModifiedWithVersion + , createPostgresqlPoolTailored , createPostgresqlPoolWithConf , module Database.Persist.Sql , ConnectionString @@ -52,6 +53,7 @@ module Database.Persist.Postgresql , upsertManyWhere , openSimpleConn , openSimpleConnWithVersion + , getServerVersion , getSimpleConn , tableName , fieldName @@ -65,6 +67,7 @@ module Database.Persist.Postgresql , createRawPostgresqlPoolModified , createRawPostgresqlPoolModifiedWithVersion , createRawPostgresqlPoolWithConf + , createBackend ) where import qualified Database.PostgreSQL.LibPQ as LibPQ @@ -82,8 +85,8 @@ import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift (MonadIO(..), MonadUnliftIO) import Control.Monad.Logger (MonadLoggerIO, runNoLoggingT) -import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT) import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT(..), asks, runReaderT) #if !MIN_VERSION_base(4,12,0) import Control.Monad.Trans.Reader (withReaderT) #endif @@ -102,8 +105,8 @@ import qualified Data.Conduit.List as CL import Data.Data (Data) import Data.Either (partitionEithers) import Data.Function (on) -import Data.IORef import Data.Int (Int64) +import Data.IORef import Data.List (find, foldl', groupBy, sort) import qualified Data.List as List import Data.List.NonEmpty (NonEmpty) @@ -122,12 +125,13 @@ import System.Environment (getEnvironment) #if MIN_VERSION_base(4,12,0) import Database.Persist.Compatible #endif +import qualified Data.Vault.Strict as Vault import Database.Persist.Postgresql.Internal import Database.Persist.Sql import qualified Database.Persist.Sql.Util as Util import Database.Persist.SqlBackend -import Database.Persist.SqlBackend.StatementCache (StatementCache, mkSimpleStatementCache, mkStatementCache) -import qualified Data.Vault.Strict as Vault +import Database.Persist.SqlBackend.StatementCache + (StatementCache, mkSimpleStatementCache, mkStatementCache) import System.IO.Unsafe (unsafePerformIO) -- | A @libpq@ connection string. A simple example of connection @@ -270,9 +274,31 @@ createPostgresqlPoolModifiedWithVersion -> ConnectionString -- ^ Connection string to the database. -> Int -- ^ Number of connections to be kept open in the pool. -> m (Pool SqlBackend) -createPostgresqlPoolModifiedWithVersion getVerDouble modConn ci = do +createPostgresqlPoolModifiedWithVersion = createPostgresqlPoolTailored open' + +-- | Same as 'createPostgresqlPoolModifiedWithVersion', but takes a custom connection-creation +-- function. +-- +-- The only time you should reach for this function is if you need to write custom logic for creating +-- a connection to the database. +-- +-- @since 2.13.6 +createPostgresqlPoolTailored + :: (MonadUnliftIO m, MonadLoggerIO m) + => + ( (PG.Connection -> IO ()) + -> (PG.Connection -> IO (NonEmpty Word)) + -> ((PG.Connection -> SqlBackend) -> PG.Connection -> SqlBackend) + -> ConnectionString -> LogFunc -> IO SqlBackend + ) -- ^ Action that creates a postgresql connection (please see documentation on the un-exported @open'@ function in this same module. + -> (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 SqlBackend) +createPostgresqlPoolTailored createConnection getVerDouble modConn ci = do let getVer = oldGetVersionToNew getVerDouble - createSqlPool $ open' modConn getVer id ci + createSqlPool $ createConnection modConn getVer id ci -- | Same as 'createPostgresqlPool', but can be configured with 'PostgresConf' and 'PostgresConfHooks'. -- @@ -333,6 +359,8 @@ open' modConn getVer constructor cstr logFunc = do return $ constructor (createBackend logFunc ver smap) conn -- | Gets the PostgreSQL server version +-- +-- @since 2.13.6 getServerVersion :: PG.Connection -> IO (Maybe Double) getServerVersion conn = do [PG.Only version] <- PG.query_ conn "show server_version"; @@ -415,6 +443,8 @@ getSimpleConn = Vault.lookup underlyingConnectionKey <$> getConnVault -- | Create the backend given a logging function, server version, mutable statement cell, -- and connection. +-- +-- @since 2.13.6 createBackend :: LogFunc -> NonEmpty Word -> IORef (Map.Map Text Statement) -> PG.Connection -> SqlBackend createBackend logFunc serverVersion smap conn = diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 05d4dbb4c..7247d5f56 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.13.5.2 +version: 2.13.6 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman From eec3a32f9d4b8e3023051b779dd18f8493865bf0 Mon Sep 17 00:00:00 2001 From: Chris Martin Date: Mon, 18 Sep 2023 15:56:21 -0600 Subject: [PATCH 06/15] typo: perist -> persist (#1514) --- persistent-postgresql/Database/Persist/Postgresql.hs | 2 +- persistent-sqlite/cbits/sqlite3.c | 2 +- persistent/Database/Persist/Class/PersistStore.hs | 2 +- persistent/Database/Persist/Sql/Orphan/PersistStore.hs | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 5a513c806..056e6391a 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1369,7 +1369,7 @@ showAlter table (DropReference cname) = T.concat , escapeC cname ] --- | Get the SQL string for the table that a PeristEntity represents. +-- | Get the SQL string for the table that a PersistEntity represents. -- Useful for raw SQL queries. tableName :: (PersistEntity record) => record -> Text tableName = escapeE . tableDBName diff --git a/persistent-sqlite/cbits/sqlite3.c b/persistent-sqlite/cbits/sqlite3.c index a82744931..50b5acdd9 100644 --- a/persistent-sqlite/cbits/sqlite3.c +++ b/persistent-sqlite/cbits/sqlite3.c @@ -53429,7 +53429,7 @@ static int writeSuperJournal(Pager *pPager, const char *zSuper){ } pPager->journalOff += (nSuper+20); - /* If the pager is in peristent-journal mode, then the physical + /* If the pager is in persistent-journal mode, then the physical ** journal-file may extend past the end of the super-journal name ** and 8 bytes of magic data just written to the file. This is ** dangerous because the code to rollback a hot-journal file diff --git a/persistent/Database/Persist/Class/PersistStore.hs b/persistent/Database/Persist/Class/PersistStore.hs index 6ef8d626c..85b9eab40 100644 --- a/persistent/Database/Persist/Class/PersistStore.hs +++ b/persistent/Database/Persist/Class/PersistStore.hs @@ -79,7 +79,7 @@ class (HasPersistBackend backend) => IsPersistBackend backend where -- @ -- foo :: -- ( 'PersistEntity' record --- , 'PeristEntityBackend' record ~ 'BaseBackend' backend +-- , 'PersistEntityBackend' record ~ 'BaseBackend' backend -- , 'IsSqlBackend' backend -- ) -- @ diff --git a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs index f0334efb1..ce89b8f2c 100644 --- a/persistent/Database/Persist/Sql/Orphan/PersistStore.hs +++ b/persistent/Database/Persist/Sql/Orphan/PersistStore.hs @@ -80,7 +80,7 @@ whereStmtForKey conn k = whereStmtForKeys :: PersistEntity record => SqlBackend -> [Key record] -> Text whereStmtForKeys conn ks = T.intercalate " OR " $ whereStmtForKey conn `fmap` ks --- | get the SQL string for the table that a PeristEntity represents +-- | get the SQL string for the table that a PersistEntity represents -- Useful for raw SQL queries -- -- Your backend may provide a more convenient tableName function From a3a25ebc3b22cacab7977d8b8088baa0b78f5a8d Mon Sep 17 00:00:00 2001 From: Vekhir <134215107+Vekhir@users.noreply.github.com> Date: Tue, 19 Sep 2023 02:03:27 +0200 Subject: [PATCH 07/15] Bump versions for postgresql-simple and postgresql-libpq (#1516) * Bump versions for postgresql-simple and postgresql-libpq Builds and tests fine * Update ChangeLog.md * Bump version to 2.13.5.3 --------- Co-authored-by: Matt Parsons --- persistent-postgresql/ChangeLog.md | 2 ++ persistent-postgresql/persistent-postgresql.cabal | 4 ++-- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 0a8d9bc49..28b856476 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -6,6 +6,8 @@ * Add the `createPostgresqlPoolTailored` function to support creating connection pools with a custom connection creation function. * Expose `getServerVersion` and `createBackend` for user's convenience. +* [#1516](https://github.com/yesodweb/persistent/pull/1516) + * Support postgresql-simple 0.7 and postgresql-libpq 0.10 ## 2.13.5.2 diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index 7247d5f56..e995b0c19 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -25,8 +25,8 @@ library , containers >= 0.5 , monad-logger >= 0.3.25 , mtl - , postgresql-simple >= 0.6.1 && < 0.7 - , postgresql-libpq >= 0.9.4.2 && < 0.10 + , postgresql-simple >= 0.6.1 && < 0.8 + , postgresql-libpq >= 0.9.4.2 && < 0.11 , resourcet >= 1.1.9 , resource-pool , string-conversions From dfd87cc53fb61e9085cc9f17a08a71d8dc7f8937 Mon Sep 17 00:00:00 2001 From: HugoPeters1024 Date: Thu, 21 Sep 2023 19:20:01 +0200 Subject: [PATCH 08/15] postgres(normalize types to eliminate noop migrations) (#1518) * postgres(normalize types to eliminate noop migrations) * add test and update changelog --- persistent-postgresql/Database/Persist/Postgresql.hs | 10 +++++++++- .../test/EquivalentTypeTestPostgres.hs | 4 ++-- persistent/ChangeLog.md | 7 ++++++- 3 files changed, 17 insertions(+), 4 deletions(-) diff --git a/persistent-postgresql/Database/Persist/Postgresql.hs b/persistent-postgresql/Database/Persist/Postgresql.hs index 056e6391a..dc97abdbc 100644 --- a/persistent-postgresql/Database/Persist/Postgresql.hs +++ b/persistent-postgresql/Database/Persist/Postgresql.hs @@ -1103,7 +1103,15 @@ getColumn _ _ columnName _ = -- | Intelligent comparison of SQL types, to account for SqlInt32 vs SqlOther integer sqlTypeEq :: SqlType -> SqlType -> Bool sqlTypeEq x y = - T.toCaseFold (showSqlType x) == T.toCaseFold (showSqlType y) + let + -- Non exhaustive helper to map postgres aliases to the same name. Based on + -- https://www.postgresql.org/docs/9.5/datatype.html. + -- This prevents needless `ALTER TYPE`s when the type is the same. + normalize "int8" = "bigint" + normalize "serial8" = "bigserial" + normalize v = v + in + normalize (T.toCaseFold (showSqlType x)) == normalize (T.toCaseFold (showSqlType y)) findAlters :: [EntityDef] diff --git a/persistent-postgresql/test/EquivalentTypeTestPostgres.hs b/persistent-postgresql/test/EquivalentTypeTestPostgres.hs index 51b21930c..b23c3606a 100644 --- a/persistent-postgresql/test/EquivalentTypeTestPostgres.hs +++ b/persistent-postgresql/test/EquivalentTypeTestPostgres.hs @@ -21,7 +21,7 @@ import PgInit share [mkPersist sqlSettings, mkMigrate "migrateAll1"] [persistLowerCase| EquivalentType sql=equivalent_types - field1 Int + field1 Int sqltype=bigint field2 T.Text sqltype=text field3 T.Text sqltype=us_postal_code deriving Eq Show @@ -29,7 +29,7 @@ EquivalentType sql=equivalent_types share [mkPersist sqlSettings, mkMigrate "migrateAll2"] [persistLowerCase| EquivalentType2 sql=equivalent_types - field1 Int + field1 Int sqltype=int8 field2 T.Text field3 T.Text sqltype=us_postal_code deriving Eq Show diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index d92f06331..107e405a1 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,4 +1,9 @@ -# Changelog for persistent +# Changelog for persistentChan + +## 2.14.6.1 (unreleased) + +* [#1518](https://github.com/yesodweb/persistent/pull/1518) + * Normalize postgres type aliases to prevent noop migrations ## 2.14.6.0 From ad5585f0328fea212e8e7fbc3f692f450786b35b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Thu, 21 Sep 2023 11:21:14 -0600 Subject: [PATCH 09/15] persistent-postgresql-2.13.6.1 --- persistent-postgresql/ChangeLog.md | 7 ++++++- persistent-postgresql/persistent-postgresql.cabal | 2 +- persistent/ChangeLog.md | 5 ----- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/persistent-postgresql/ChangeLog.md b/persistent-postgresql/ChangeLog.md index 28b856476..086b12fae 100644 --- a/persistent-postgresql/ChangeLog.md +++ b/persistent-postgresql/ChangeLog.md @@ -1,6 +1,11 @@ # Changelog for persistent-postgresql -## 2.13.6 (unreleased) +## 2.13.6.1 + +* [#1518](https://github.com/yesodweb/persistent/pull/1518) + * Normalize postgres type aliases to prevent noop migrations + +## 2.13.6 * [#1511](https://github.com/yesodweb/persistent/pull/1511) * Add the `createPostgresqlPoolTailored` function to support creating diff --git a/persistent-postgresql/persistent-postgresql.cabal b/persistent-postgresql/persistent-postgresql.cabal index e995b0c19..b3f957801 100644 --- a/persistent-postgresql/persistent-postgresql.cabal +++ b/persistent-postgresql/persistent-postgresql.cabal @@ -1,5 +1,5 @@ name: persistent-postgresql -version: 2.13.6 +version: 2.13.6.1 license: MIT license-file: LICENSE author: Felipe Lessa, Michael Snoyman diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 107e405a1..4b322e419 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,10 +1,5 @@ # Changelog for persistentChan -## 2.14.6.1 (unreleased) - -* [#1518](https://github.com/yesodweb/persistent/pull/1518) - * Normalize postgres type aliases to prevent noop migrations - ## 2.14.6.0 * [#1503](https://github.com/yesodweb/persistent/pull/1503) From 7a05b485a0e33ea11640604d45e5ece186121842 Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Mon, 2 Oct 2023 12:08:52 -0600 Subject: [PATCH 10/15] clarify changelog --- persistent/ChangeLog.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 4b322e419..74787b577 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -1,6 +1,6 @@ -# Changelog for persistentChan +# Changelog for persistent -## 2.14.6.0 +## 2.14.6.0 (unreleased) * [#1503](https://github.com/yesodweb/persistent/pull/1503) * Create Haddocks from entity documentation comments From 6ec4de141cdd1084c72cdd0e072e68fe5ac00cef Mon Sep 17 00:00:00 2001 From: Daniel Trowbridge Date: Tue, 3 Oct 2023 23:03:36 +0100 Subject: [PATCH 11/15] Optionally derive `PathMultiPiece` for composite keys (#1509) * Move derivation strategy choice to `where` clause * Create PersistPathMultiPiece typeclass * Create spec and derive PersistPathMultiPiece instance in dataTypeDec * Revert changes to mkKeyTypeDec This reverts part of commit 500febaf400fccc280f3db540c6e3a8c9fecda68. * Fix and test instance derivation using mpsDeriveInstances This reverts part of commit 7b9e76f25998617fa19212f8ab55d322028f1c49. * Move PersistPathMultiPiece into PersistEntity module This avoids creating an orphan instance of PathMultiPiece. * Document feature in Database.Persist.Quasi * Add top-level `describe` to CompositeKeyPathMultiPieceSpec * Only derive PathMultiPiece for composite keys As mentioned in the MkPersistSettings Haddock change, specifying PersistPathMultiPiece directly overrides this behaviour. * Fix PersistPathMultiPiece override and add tests for it * Use DerivingVia with newtype wrapper This reverts commit 5bc57993b5a9a344165c8e5b4e264a6c5c8b894d. * Only use DerivingVia on GHC versions with support for it * Add CPP language pragma to spec * Revert changes to Database.Persist.TH and remove associated spec --- persistent/Database/Persist/Class/PersistEntity.hs | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/persistent/Database/Persist/Class/PersistEntity.hs b/persistent/Database/Persist/Class/PersistEntity.hs index 7e32f5007..81d019339 100644 --- a/persistent/Database/Persist/Class/PersistEntity.hs +++ b/persistent/Database/Persist/Class/PersistEntity.hs @@ -24,6 +24,7 @@ module Database.Persist.Class.PersistEntity , FilterValue (..) , BackendSpecificFilter , Entity (.., Entity, entityKey, entityVal) + , ViaPersistEntity (..) , recordName , entityValues @@ -56,6 +57,7 @@ import Data.Aeson.Text (encodeToTextBuilder) import Data.Aeson.Types (Parser, Result(Error, Success)) import Data.Attoparsec.ByteString (parseOnly) import Data.Functor.Identity +import Web.PathPieces (PathMultiPiece(..), PathPiece(..)) #if MIN_VERSION_aeson(2,0,0) import qualified Data.Aeson.KeyMap as AM @@ -180,6 +182,18 @@ class ( PersistField (Key record), ToJSON (Key record), FromJSON (Key record) keyFromRecordM :: Maybe (record -> Key record) keyFromRecordM = Nothing +-- | Newtype wrapper for optionally deriving typeclass instances on +-- 'PersistEntity' keys. +-- +-- @since 2.14.6.0 +newtype ViaPersistEntity record = ViaPersistEntity (Key record) + +instance PersistEntity record => PathMultiPiece (ViaPersistEntity record) where + fromPathMultiPiece pieces = do + Right key <- keyFromValues <$> mapM fromPathPiece pieces + pure $ ViaPersistEntity key + toPathMultiPiece (ViaPersistEntity key) = map toPathPiece $ keyToValues key + -- | Construct an @'Entity' record@ by providing a value for each of the -- record's fields. -- From c88f5ceb5040de3bde0b3d14ee75a5dc369ce2d7 Mon Sep 17 00:00:00 2001 From: Haisheng <109395773+hw202207@users.noreply.github.com> Date: Tue, 3 Oct 2023 15:35:58 -0700 Subject: [PATCH 12/15] Always creates `SymbolToField "id"` instance (#1497) * Always create SymbolToField for "id" - given there is always a {EntityName}Id type * Update changelog --------- Co-authored-by: Matt Parsons --- persistent/ChangeLog.md | 2 + persistent/Database/Persist/TH.hs | 6 +-- .../Persist/TH/OverloadedLabelSpec.hs | 38 ++++++++++++------- 3 files changed, 27 insertions(+), 19 deletions(-) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 74787b577..567222fa0 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -4,6 +4,8 @@ * [#1503](https://github.com/yesodweb/persistent/pull/1503) * Create Haddocks from entity documentation comments +* [1497](https://github.com/yesodweb/persistent/pull/1497) + * Always generates `SymbolToField "id"` instance ## 2.14.5.2 diff --git a/persistent/Database/Persist/TH.hs b/persistent/Database/Persist/TH.hs index db04e3fb3..2d76e6ce7 100644 --- a/persistent/Database/Persist/TH.hs +++ b/persistent/Database/Persist/TH.hs @@ -3013,11 +3013,7 @@ mkSymbolToFieldInstances mps entityMap (fixEntityDef -> ed) = do mkEntityFieldConstr fieldHaskellName mkInstance fieldNameT fieldTypeT entityFieldConstr - mkey <- - case unboundPrimarySpec ed of - NaturalKey _ -> - pure [] - _ -> do + mkey <- do let fieldHaskellName = FieldNameHS "Id" diff --git a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs index b81453160..363375ef5 100644 --- a/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs +++ b/persistent/test/Database/Persist/TH/OverloadedLabelSpec.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedLabels #-} -{-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wname-shadowing -Werror=name-shadowing #-} module Database.Persist.TH.OverloadedLabelSpec where -import TemplateTestImports +import TemplateTestImports mkPersist sqlSettings [persistUpperCase| @@ -33,6 +33,10 @@ Dog Organization name String +Student + userId UserId + departmentName String + Primary userId |] spec :: Spec @@ -60,5 +64,11 @@ spec = describe "OverloadedLabels" $ do compiles + it "works for Primary labels" $ do + let StudentId = #id + studentId = #id :: EntityField Student StudentId + + compiles + compiles :: IO () compiles = pure () From 43d9cd32e322e5b5b2618d6ee8f45ae28cf1d53b Mon Sep 17 00:00:00 2001 From: parsonsmatt Date: Tue, 3 Oct 2023 15:36:54 -0700 Subject: [PATCH 13/15] persistent-2.15.6.0 --- persistent/ChangeLog.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/persistent/ChangeLog.md b/persistent/ChangeLog.md index 567222fa0..a10c89e8b 100644 --- a/persistent/ChangeLog.md +++ b/persistent/ChangeLog.md @@ -6,6 +6,8 @@ * Create Haddocks from entity documentation comments * [1497](https://github.com/yesodweb/persistent/pull/1497) * Always generates `SymbolToField "id"` instance +* [#1509](https://github.com/yesodweb/persistent/pull/1509) + * Provide `ViaPersistEntity` for defining `PathMultiPiece` for entity keys. ## 2.14.5.2 From 6194b1fafa096282fb42d9fe922dfee35fc0f3f8 Mon Sep 17 00:00:00 2001 From: Isaac van Bakel Date: Wed, 4 Oct 2023 00:59:58 +0200 Subject: [PATCH 14/15] persistent-sqlite: Add `openRawSqliteConn` (#1488) * Add openRawSqliteConn to Database.Persist.Sqlite This new function allows for creating a `RawSqlite SqlBackend` manually (without exposing the `RawSqlite` constructor) for code that wants to open such a connection without having to opt-in to the resource management of `withRawSqliteConnInfo` and co. This is useful in my particular use case for creating a custom pool, since I am not constrained by the `resource-pool` API re-exposed by `persistent-sqlite`. * Bump persistent-sqlite version, add @since tags * Run stylish-haskell on Database.Persist.Sqlite * Add openRawSqliteConn to persistent-sqlite ChangeLog.md --- persistent-sqlite/ChangeLog.md | 6 ++++++ persistent-sqlite/Database/Persist/Sqlite.hs | 19 ++++++++++++++++++- persistent-sqlite/persistent-sqlite.cabal | 2 +- 3 files changed, 25 insertions(+), 2 deletions(-) diff --git a/persistent-sqlite/ChangeLog.md b/persistent-sqlite/ChangeLog.md index fcfbcf3b7..feb1edf49 100644 --- a/persistent-sqlite/ChangeLog.md +++ b/persistent-sqlite/ChangeLog.md @@ -1,5 +1,11 @@ # Changelog for persistent-sqlite +## 2.13.2 + +* [#1488](https://github.com/yesodweb/persistent/pull/1488) + * Add `openRawSqliteConn` for creating `RawSqlite SqlBackend` connections + that aren't automatically cleaned-up. + ## 2.13.1.1 * [#1459](https://github.com/yesodweb/persistent/pull/1459) diff --git a/persistent-sqlite/Database/Persist/Sqlite.hs b/persistent-sqlite/Database/Persist/Sqlite.hs index ccfecd605..e5b1a3701 100644 --- a/persistent-sqlite/Database/Persist/Sqlite.hs +++ b/persistent-sqlite/Database/Persist/Sqlite.hs @@ -48,6 +48,7 @@ module Database.Persist.Sqlite , ForeignKeyViolation(..) , checkForeignKeys , RawSqlite + , openRawSqliteConn , persistentBackend , rawSqliteConnection , withRawSqliteConnInfo @@ -94,8 +95,8 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.List as CL import Data.Foldable (toList) import qualified Data.HashMap.Lazy as HashMap -import Data.Int (Int64) import Data.IORef (newIORef) +import Data.Int (Int64) import Data.Maybe import Data.Pool (Pool) import Data.Text (Text) @@ -938,6 +939,22 @@ data RawSqlite backend = RawSqlite , _rawSqliteConnection :: Sqlite.Connection -- ^ The underlying `Sqlite.Connection` } +-- | Open a @'RawSqlite' 'SqlBackend'@ connection from a 'SqliteConnectionInfo'. +-- +-- When using this function, the caller has to accept the responsibility of +-- cleaning up the resulting connection. To do this, use 'close' with the +-- 'rawSqliteConnection' - it's enough to simply drop the 'persistBackend' +-- afterwards. +-- +-- @since 2.13.2 +openRawSqliteConn + :: (MonadUnliftIO m, MonadLoggerIO m) + => SqliteConnectionInfo + -> m (RawSqlite SqlBackend) +openRawSqliteConn connInfo = do + logFunc <- askLoggerIO + liftIO $ openWith RawSqlite connInfo logFunc + instance BackendCompatible b (RawSqlite b) where projectBackend = _persistentBackend diff --git a/persistent-sqlite/persistent-sqlite.cabal b/persistent-sqlite/persistent-sqlite.cabal index 8b36b1e18..4ec7f20b5 100644 --- a/persistent-sqlite/persistent-sqlite.cabal +++ b/persistent-sqlite/persistent-sqlite.cabal @@ -1,5 +1,5 @@ name: persistent-sqlite -version: 2.13.1.1 +version: 2.13.2.0 license: MIT license-file: LICENSE author: Michael Snoyman From 38654d9ec3249b7acd69d57073890fde9dbf5406 Mon Sep 17 00:00:00 2001 From: josephsumabat Date: Tue, 3 Oct 2023 16:07:21 -0700 Subject: [PATCH 15/15] Add keyAndEntityFieldsDatabase function to return key with migration only fields (#1519) * Add keyAndEntityFieldsDatabase function to return key with migration only fields * Update persistent/Database/Persist/Types/Base.hs --------- Co-authored-by: Matt Parsons --- persistent/Database/Persist/Types/Base.hs | 25 ++++++++++++++++++++--- 1 file changed, 22 insertions(+), 3 deletions(-) diff --git a/persistent/Database/Persist/Types/Base.hs b/persistent/Database/Persist/Types/Base.hs index b17def38b..cd45d8b3c 100644 --- a/persistent/Database/Persist/Types/Base.hs +++ b/persistent/Database/Persist/Types/Base.hs @@ -201,7 +201,28 @@ entityKeyFields = -- columns for an 'EntityDef'. keyAndEntityFields :: EntityDef -> NonEmpty FieldDef keyAndEntityFields ent = - case entityId ent of + keyWithFields (entityId ent) fields + where + fields = filter isHaskellField $ entityFields ent + +-- | Returns a 'NonEmpty' list of 'FieldDef' that correspond with the key +-- columns for an 'EntityDef' including those fields that are marked as +-- 'MigrationOnly' (and therefore only present in the database) or +-- 'SafeToRemove' (and a migration will drop the column if it exists in the +-- database). +-- +-- For fields on the Haskell type use 'keyAndEntityFieldsDatabase' +-- +-- @since 2.14.6.0 +keyAndEntityFieldsDatabase :: EntityDef -> NonEmpty FieldDef +keyAndEntityFieldsDatabase ent = + keyWithFields (entityId ent) fields + where + fields = entityFields ent + +keyWithFields :: EntityIdDef -> [FieldDef] -> NonEmpty FieldDef +keyWithFields entId fields = + case entId of EntityIdField fd -> fd :| fields EntityIdNaturalKey _ -> @@ -214,8 +235,6 @@ keyAndEntityFields ent = ] Just xs -> xs - where - fields = filter isHaskellField $ entityFields ent type ExtraLine = [Text]