Merge branch 'master' into derive-pathmultipiece

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

persistent-postgresql/ChangeLog.md

@@ -1,5 +1,19 @@
 # Changelog for persistent-postgresql
 
+## 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
+     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
 
 * [#1471](https://github.com/yesodweb/persistent/pull/1471)

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 =
@@ -1073,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]
@@ -1339,7 +1377,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

persistent-postgresql/persistent-postgresql.cabal

@@ -1,5 +1,5 @@
 name:            persistent-postgresql
-version:         2.13.5.2
+version:         2.13.6.1
 license:         MIT
 license-file:    LICENSE
 author:          Felipe Lessa, Michael Snoyman <[email protected]>
@@ -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

persistent-postgresql/test/EquivalentTypeTestPostgres.hs

@@ -21,15 +21,15 @@ 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
 |]
 
 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

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

persistent/ChangeLog.md

@@ -1,4 +1,14 @@
-# Changelog for persistent
+# Changelog for persistentChan
+
+## 2.14.6.0
+
+* [#1503](https://github.com/yesodweb/persistent/pull/1503)
+    * Create Haddocks from entity documentation comments
+
+## 2.14.5.2
+
+* [#1513](https://github.com/yesodweb/persistent/pull/1513)
+    * Support GHC 9.8 and `aeson-2.2`
 
 ## 2.14.5.1
 

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
 --   )
 -- @

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 <https://gitlab.haskell.org/ghc/ghc/issues/5467 Template Haskell does not support Haddock yet>.
-@persistent@ backends *can* use this to generate SQL @COMMENT@s, which are useful for a database perspective, and you can use the <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> 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 <https://hackage.haskell.org/package/persistent-documentation @persistent-documentation@> library to render a Markdown document of the entity definitions.
 
 = Sum types
 

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

persistent/Database/Persist/TH.hs

@@ -45,6 +45,7 @@ module Database.Persist.TH
     , mpsPrefixFields
     , mpsFieldLabelModifier
     , mpsConstraintLabelModifier
+    , mpsEntityHaddocks
     , mpsEntityJSON
     , mpsGenerateLenses
     , mpsDeriveInstances
@@ -121,6 +122,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(..))
@@ -1067,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:
@@ -1158,6 +1166,7 @@ mkPersistSettings backend = MkPersistSettings
     , mpsPrefixFields = True
     , mpsFieldLabelModifier = (++)
     , mpsConstraintLabelModifier = (++)
+    , mpsEntityHaddocks = False
     , mpsEntityJSON = Just EntityJSON
         { entityToJSON = 'entityIdToJSON
         , entityFromJSON = 'entityIdFromJSON
@@ -1200,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
         | n `elem` stockClasses = Left n
@@ -1226,7 +1249,7 @@ dataTypeDec mps entityMap entDef = do
         | otherwise =
             (mkEntityDefName entDef, [])
 
-    cols :: [VarBangType]
+    cols :: [(VarBangType, Maybe Text)]
     cols = do
         fieldDef <- getUnboundFieldDefs entDef
         let
@@ -1238,11 +1261,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)
@@ -2337,7 +2362,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 ()