hpqtypes-extras 1.16.4.4 → 1.17.0.0

raw patch · 26 files changed

+5695/−3990 lines, 26 filessetup-changedPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +12/−0
• Setup.hs +0/−2
• benchmark/Main.hs +216/−44
• hpqtypes-extras.cabal +6/−3
• src/Database/PostgreSQL/PQTypes/Checks.hs +1611/−1253
• src/Database/PostgreSQL/PQTypes/Checks/Util.hs +152/−78
• src/Database/PostgreSQL/PQTypes/Deriving.hs +50/−32
• src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +28/−20
• src/Database/PostgreSQL/PQTypes/Migrate.hs +12/−13
• src/Database/PostgreSQL/PQTypes/Model.hs +4/−2
• src/Database/PostgreSQL/PQTypes/Model/Check.hs +25/−21
• src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +21/−21
• src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs +26/−23
• src/Database/PostgreSQL/PQTypes/Model/Domain.hs +23/−21
• src/Database/PostgreSQL/PQTypes/Model/EnumType.hs +32/−0
• src/Database/PostgreSQL/PQTypes/Model/Extension.hs +3/−3
• src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +54/−48
• src/Database/PostgreSQL/PQTypes/Model/Index.hs +140/−104
• src/Database/PostgreSQL/PQTypes/Model/Migration.hs +84/−87
• src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +22/−16
• src/Database/PostgreSQL/PQTypes/Model/Table.hs +77/−69
• src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +171/−98
• src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +447/−355
• src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +28/−27
• src/Database/PostgreSQL/PQTypes/Versions.hs +10/−9
• test/Main.hs +2441/−1641

@@ -1,3 +1,15 @@+# hpqtypes-extras-1.17.0.0 (2025-03-12)+* Grouped some parameters of `migrateDatabase` and `checkDatabase` into a+  `DatabaseDefinitions` record type.+* Add an optional check that all foreign keys have an index.+* Add support for NULLS NOT DISTINCT in unique indexes.+* Add `sqlAll` and `sqlAny` to allow creating `SQL` expressions with+  nested `AND` and `OR` conditions.+* Add `SqlWhereAll` and `SqlWhereAny` so they can be used in signatures.+* Add rudimentary support for enum types.+* Add support for some regular triggers, ie: `AFTER` triggers without constraints+  and `BEFORE` triggers.+ # hpqtypes-extras-1.16.4.4 (2023-08-23) * Switch from `cryptonite` to `crypton`. * Make `sqlWhereEqualsAny`, `sqlWhereIn` and `sqlWhereNotIn` prepared-query

@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain

@@ -7,22 +7,71 @@ import Database.PostgreSQL.PQTypes.Deriving  main :: IO ()-main = defaultMain-  [ bgroup "enum"-    [ bench "encode" $ nf (encodeEnum @T) T42-    , bench "decode" $ nf (decodeEnum @T) 42-    ]-  , bgroup "enum-text"-    [ bench "encode" $ nf (encodeEnumAsText @S) S42-    , bench "decode" $ nf (decodeEnumAsText @S) "text_42"+main =+  defaultMain+    [ bgroup+        "enum"+        [ bench "encode" $ nf (encodeEnum @T) T42+        , bench "decode" $ nf (decodeEnum @T) 42+        ]+    , bgroup+        "enum-text"+        [ bench "encode" $ nf (encodeEnumAsText @S) S42+        , bench "decode" $ nf (decodeEnumAsText @S) "text_42"+        ]     ]-  ] -data T = T01 | T02 | T03 | T04 | T05 | T06 | T07 | T08 | T09 | T10-       | T11 | T12 | T13 | T14 | T15 | T16 | T17 | T18 | T19 | T20-       | T21 | T22 | T23 | T24 | T25 | T26 | T27 | T28 | T29 | T30-       | T31 | T32 | T33 | T34 | T35 | T36 | T37 | T38 | T39 | T40-       | T41 | T42 | T43 | T44 | T45 | T46 | T47 | T48 | T49 | T50+data T+  = T01+  | T02+  | T03+  | T04+  | T05+  | T06+  | T07+  | T08+  | T09+  | T10+  | T11+  | T12+  | T13+  | T14+  | T15+  | T16+  | T17+  | T18+  | T19+  | T20+  | T21+  | T22+  | T23+  | T24+  | T25+  | T26+  | T27+  | T28+  | T29+  | T30+  | T31+  | T32+  | T33+  | T34+  | T35+  | T36+  | T37+  | T38+  | T39+  | T40+  | T41+  | T42+  | T43+  | T44+  | T45+  | T46+  | T47+  | T48+  | T49+  | T50   deriving (Eq, Show, Enum, Bounded)  instance NFData T where@@ -33,26 +82,112 @@ -- >>> isInjective (encodeEnum @T) -- True instance EnumEncoding T where-   type EnumBase T = Int16-   encodeEnum = \case-     T01 -> 1;  T02 -> 2;  T03 -> 3;  T04 -> 4;  T05 -> 5-     T06 -> 6;  T07 -> 7;  T08 -> 8;  T09 -> 9;  T10 -> 10-     T11 -> 11; T12 -> 12; T13 -> 13; T14 -> 14; T15 -> 15-     T16 -> 16; T17 -> 17; T18 -> 18; T19 -> 19; T20 -> 20-     T21 -> 21; T22 -> 22; T23 -> 23; T24 -> 24; T25 -> 25-     T26 -> 26; T27 -> 27; T28 -> 28; T29 -> 29; T30 -> 30-     T31 -> 31; T32 -> 32; T33 -> 33; T34 -> 34; T35 -> 35-     T36 -> 36; T37 -> 37; T38 -> 38; T39 -> 39; T40 -> 40-     T41 -> 41; T42 -> 42; T43 -> 43; T44 -> 44; T45 -> 45-     T46 -> 46; T47 -> 47; T48 -> 48; T49 -> 49; T50 -> 50+  type EnumBase T = Int16+  encodeEnum = \case+    T01 -> 1+    T02 -> 2+    T03 -> 3+    T04 -> 4+    T05 -> 5+    T06 -> 6+    T07 -> 7+    T08 -> 8+    T09 -> 9+    T10 -> 10+    T11 -> 11+    T12 -> 12+    T13 -> 13+    T14 -> 14+    T15 -> 15+    T16 -> 16+    T17 -> 17+    T18 -> 18+    T19 -> 19+    T20 -> 20+    T21 -> 21+    T22 -> 22+    T23 -> 23+    T24 -> 24+    T25 -> 25+    T26 -> 26+    T27 -> 27+    T28 -> 28+    T29 -> 29+    T30 -> 30+    T31 -> 31+    T32 -> 32+    T33 -> 33+    T34 -> 34+    T35 -> 35+    T36 -> 36+    T37 -> 37+    T38 -> 38+    T39 -> 39+    T40 -> 40+    T41 -> 41+    T42 -> 42+    T43 -> 43+    T44 -> 44+    T45 -> 45+    T46 -> 46+    T47 -> 47+    T48 -> 48+    T49 -> 49+    T50 -> 50  ---------------------------------------- -data S = S01 | S02 | S03 | S04 | S05 | S06 | S07 | S08 | S09 | S10-       | S11 | S12 | S13 | S14 | S15 | S16 | S17 | S18 | S19 | S20-       | S21 | S22 | S23 | S24 | S25 | S26 | S27 | S28 | S29 | S30-       | S31 | S32 | S33 | S34 | S35 | S36 | S37 | S38 | S39 | S40-       | S41 | S42 | S43 | S44 | S45 | S46 | S47 | S48 | S49 | S50+data S+  = S01+  | S02+  | S03+  | S04+  | S05+  | S06+  | S07+  | S08+  | S09+  | S10+  | S11+  | S12+  | S13+  | S14+  | S15+  | S16+  | S17+  | S18+  | S19+  | S20+  | S21+  | S22+  | S23+  | S24+  | S25+  | S26+  | S27+  | S28+  | S29+  | S30+  | S31+  | S32+  | S33+  | S34+  | S35+  | S36+  | S37+  | S38+  | S39+  | S40+  | S41+  | S42+  | S43+  | S44+  | S45+  | S46+  | S47+  | S48+  | S49+  | S50   deriving (Eq, Show, Enum, Bounded)  instance NFData S where@@ -64,16 +199,53 @@ -- True instance EnumAsTextEncoding S where   encodeEnumAsText = \case-    S01 -> "text_01"; S02 -> "text_02"; S03 -> "text_03"; S04 -> "text_04"-    S05 -> "text_05"; S06 -> "text_06"; S07 -> "text_07"; S08 -> "text_08"-    S09 -> "text_09"; S10 -> "text_10"; S11 -> "text_11"; S12 -> "text_12"-    S13 -> "text_13"; S14 -> "text_14"; S15 -> "text_15"; S16 -> "text_16"-    S17 -> "text_17"; S18 -> "text_18"; S19 -> "text_19"; S20 -> "text_20"-    S21 -> "text_21"; S22 -> "text_22"; S23 -> "text_23"; S24 -> "text_24"-    S25 -> "text_25"; S26 -> "text_26"; S27 -> "text_27"; S28 -> "text_28"-    S29 -> "text_29"; S30 -> "text_30"; S31 -> "text_31"; S32 -> "text_32"-    S33 -> "text_33"; S34 -> "text_34"; S35 -> "text_35"; S36 -> "text_36"-    S37 -> "text_37"; S38 -> "text_38"; S39 -> "text_39"; S40 -> "text_40"-    S41 -> "text_41"; S42 -> "text_42"; S43 -> "text_43"; S44 -> "text_44"-    S45 -> "text_45"; S46 -> "text_46"; S47 -> "text_47"; S48 -> "text_48"-    S49 -> "text_49"; S50 -> "text_50";+    S01 -> "text_01"+    S02 -> "text_02"+    S03 -> "text_03"+    S04 -> "text_04"+    S05 -> "text_05"+    S06 -> "text_06"+    S07 -> "text_07"+    S08 -> "text_08"+    S09 -> "text_09"+    S10 -> "text_10"+    S11 -> "text_11"+    S12 -> "text_12"+    S13 -> "text_13"+    S14 -> "text_14"+    S15 -> "text_15"+    S16 -> "text_16"+    S17 -> "text_17"+    S18 -> "text_18"+    S19 -> "text_19"+    S20 -> "text_20"+    S21 -> "text_21"+    S22 -> "text_22"+    S23 -> "text_23"+    S24 -> "text_24"+    S25 -> "text_25"+    S26 -> "text_26"+    S27 -> "text_27"+    S28 -> "text_28"+    S29 -> "text_29"+    S30 -> "text_30"+    S31 -> "text_31"+    S32 -> "text_32"+    S33 -> "text_33"+    S34 -> "text_34"+    S35 -> "text_35"+    S36 -> "text_36"+    S37 -> "text_37"+    S38 -> "text_38"+    S39 -> "text_39"+    S40 -> "text_40"+    S41 -> "text_41"+    S42 -> "text_42"+    S43 -> "text_43"+    S44 -> "text_44"+    S45 -> "text_45"+    S46 -> "text_46"+    S47 -> "text_47"+    S48 -> "text_48"+    S49 -> "text_49"+    S50 -> "text_50"

@@ -1,6 +1,6 @@-cabal-version:       2.2+cabal-version:       3.0 name:                hpqtypes-extras-version:             1.16.4.4+version:             1.17.0.0 synopsis:            Extra utilities for hpqtypes library description:         The following extras for hpqtypes library:                      .@@ -20,7 +20,7 @@ copyright:           Scrive AB category:            Database build-type:          Simple-tested-with:         GHC ==8.8.4 || ==8.10.7 || ==9.0.2 || ==9.2.8 || ==9.4.6 || ==9.6.2+tested-with:         GHC == { 8.10.7, 9.0.2, 9.2.8, 9.4.8, 9.6.6, 9.8.4, 9.10.1, 9.12.1 }  Source-repository head   Type:     git@@ -33,6 +33,7 @@                     , ExistentialQuantification                     , FlexibleContexts                     , GeneralizedNewtypeDeriving+                    , ImportQualifiedPost                     , LambdaCase                     , MultiWayIf                     , OverloadedStrings@@ -45,6 +46,7 @@                     , TypeFamilies                     , UndecidableInstances                     , ViewPatterns+  ghc-options: -Werror=prepositive-qualified-module  library   import: common-stanza@@ -62,6 +64,7 @@                  , Database.PostgreSQL.PQTypes.Model.ColumnType                  , Database.PostgreSQL.PQTypes.Model.CompositeType                  , Database.PostgreSQL.PQTypes.Model.Domain+                 , Database.PostgreSQL.PQTypes.Model.EnumType                  , Database.PostgreSQL.PQTypes.Model.Extension                  , Database.PostgreSQL.PQTypes.Model.ForeignKey                  , Database.PostgreSQL.PQTypes.Model.Index

@@ -1,1253 +1,1611 @@-module Database.PostgreSQL.PQTypes.Checks (-  -- * Checks-    checkDatabase-  , createTable-  , createDomain--  -- * Options-  , ExtrasOptions(..)-  , defaultExtrasOptions-  , ObjectsValidationMode(..)--  -- * Migrations-  , migrateDatabase-  ) where--import Control.Arrow ((&&&))-import Control.Concurrent (threadDelay)-import Control.Monad-import Control.Monad.Catch-import Control.Monad.Reader-import Data.Int-import Data.Function-import Data.List (partition)-import Data.Maybe-import Data.Monoid.Utils-import Data.Ord (comparing)-import Data.Typeable (cast)-import qualified Data.String-import Data.Text (Text)-import Database.PostgreSQL.PQTypes-import GHC.Stack (HasCallStack)-import Log-import TextShow-import qualified Data.List as L-import qualified Data.Map as M-import qualified Data.Set as S-import qualified Data.Text as T--import Database.PostgreSQL.PQTypes.ExtrasOptions-import Database.PostgreSQL.PQTypes.Checks.Util-import Database.PostgreSQL.PQTypes.Migrate-import Database.PostgreSQL.PQTypes.Model-import Database.PostgreSQL.PQTypes.SQL.Builder-import Database.PostgreSQL.PQTypes.Versions--headExc :: String -> [a] -> a-headExc s []    = error s-headExc _ (x:_) = x---------------------------------------------- | Run migrations and check the database structure.-migrateDatabase-  :: (MonadIO m, MonadDB m, MonadLog m, MonadMask m)-  => ExtrasOptions-  -> [Extension]-  -> [CompositeType]-  -> [Domain]-  -> [Table]-  -> [Migration m]-  -> m ()-migrateDatabase options-  extensions composites domains tables migrations = do-  setDBTimeZoneToUTC-  mapM_ checkExtension extensions-  tablesWithVersions <- getTableVersions (tableVersions : tables)-  -- 'checkDBConsistency' also performs migrations.-  checkDBConsistency options domains tablesWithVersions migrations-  resultCheck =<< checkCompositesStructure tablesWithVersions-                                           CreateCompositesIfDatabaseEmpty-                                           (eoObjectsValidationMode options)-                                           composites-  resultCheck =<< checkDomainsStructure domains-  resultCheck =<< checkDBStructure options tablesWithVersions-  resultCheck =<< checkTablesWereDropped migrations--  when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do-    resultCheck =<< checkUnknownTables tables-    resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)--  -- After migrations are done make sure the table versions are correct.-  resultCheck . checkVersions options =<< getTableVersions (tableVersions : tables)--  -- everything is OK, commit changes-  commit---- | Run checks on the database structure and whether the database needs to be--- migrated. Will do a full check of DB structure.-checkDatabase-  :: forall m . (MonadDB m, MonadLog m, MonadThrow m)-  => ExtrasOptions-  -> [CompositeType]-  -> [Domain]-  -> [Table]-  -> m ()-checkDatabase options composites domains tables = do-  tablesWithVersions <- getTableVersions (tableVersions : tables)-  resultCheck $ checkVersions options tablesWithVersions-  resultCheck =<< checkCompositesStructure tablesWithVersions-                                           DontCreateComposites-                                           (eoObjectsValidationMode options)-                                           composites-  resultCheck =<< checkDomainsStructure domains-  resultCheck =<< checkDBStructure options tablesWithVersions-  when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do-    resultCheck =<< checkUnknownTables tables-    resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)--  -- Check initial setups only after database structure is considered-  -- consistent as before that some of the checks may fail internally.-  resultCheck =<< checkInitialSetups tables--  where-    checkInitialSetups :: [Table] -> m ValidationResult-    checkInitialSetups tbls =-      liftM mconcat . mapM checkInitialSetup' $ tbls--    checkInitialSetup' :: Table -> m ValidationResult-    checkInitialSetup' t@Table{..} = case tblInitialSetup of-      Nothing -> return mempty-      Just is -> checkInitialSetup is >>= \case-        True  -> return mempty-        False -> return . validationError $ "Initial setup for table '"-                 <> tblNameText t <> "' is not valid"---- | Return SQL fragment of current catalog within quotes-currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())-currentCatalog = do-  runSQL_ "SELECT current_catalog::text"-  dbname <- fetchOne runIdentity-  return $ unsafeSQL $ "\"" ++ dbname ++ "\""---- | Check for a given extension. We need to read from 'pg_extension'--- table as Amazon RDS limits usage of 'CREATE EXTENSION IF NOT EXISTS'.-checkExtension :: (MonadDB m, MonadLog m, MonadThrow m) => Extension -> m ()-checkExtension (Extension extension) = do-  logInfo_ $ "Checking for extension '" <> txtExtension <> "'"-  extensionExists <- runQuery01 . sqlSelect "pg_extension" $ do-    sqlResult "TRUE"-    sqlWhereEq "extname" $ unRawSQL extension-  if not extensionExists-    then do-      logInfo_ $ "Creating extension '" <> txtExtension <> "'"-      runSQL_ $ "CREATE EXTENSION IF NOT EXISTS" <+> raw extension-    else logInfo_ $ "Extension '" <> txtExtension <> "' exists"-  where-    txtExtension = unRawSQL extension---- | Check whether the database returns timestamps in UTC, and set the--- timezone to UTC if it doesn't.-setDBTimeZoneToUTC :: (MonadDB m, MonadLog m, MonadThrow m) => m ()-setDBTimeZoneToUTC = do-  runSQL_ "SHOW timezone"-  timezone :: String <- fetchOne runIdentity-  when (timezone /= "UTC") $ do-    dbname <- currentCatalog-    logInfo_ $ "Setting '" <> unRawSQL dbname-      <> "' database to return timestamps in UTC"-    runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'"-    -- Setting the database timezone doesn't change the session timezone.-    runSQL_ $ "SET timezone = 'UTC'"---- | Get the names of all user-defined tables that actually exist in--- the DB.-getDBTableNames :: (MonadDB m) => m [Text]-getDBTableNames = do-  runQuery_ $ sqlSelect "information_schema.tables" $ do-    sqlResult "table_name::text"-    sqlWhere "table_name <> 'table_versions'"-    sqlWhere "table_type = 'BASE TABLE'"-    sqlWhereExists $ sqlSelect "unnest(current_schemas(false)) as cs" $ do-      sqlResult "TRUE"-      sqlWhere "cs = table_schema"--  dbTableNames <- fetchMany runIdentity-  return dbTableNames--checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult-checkVersions options = mconcat . map checkVersion-  where-    checkVersion :: (Table, Int32) -> ValidationResult-    checkVersion (t@Table{..}, v)-      | if eoAllowHigherTableVersions options-        then tblVersion <= v-        else tblVersion == v = mempty-      | v == 0    = validationError $-                    "Table '" <> tblNameText t <> "' must be created"-      | otherwise = validationError $-                    "Table '" <> tblNameText t-                    <> "' must be migrated" <+> showt v <+> "->"-                    <+> showt tblVersion---- | Check that there's a 1-to-1 correspondence between the list of--- 'Table's and what's actually in the database.-checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult-checkUnknownTables tables = do-  dbTableNames  <- getDBTableNames-  let tableNames = map (unRawSQL . tblName) tables-      absent     = dbTableNames L.\\ tableNames-      notPresent = tableNames   L.\\ dbTableNames--  if (not . null $ absent) || (not . null $ notPresent)-    then do-    mapM_ (logInfo_ . (<+>) "Unknown table:") absent-    mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent-    return $-      (validateIsNull "Unknown tables:" absent) <>-      (validateIsNull "Tables not present in the database:" notPresent)-    else return mempty--validateIsNull :: Text -> [Text] -> ValidationResult-validateIsNull _   [] = mempty-validateIsNull msg ts = validationError $ msg <+> T.intercalate ", " ts---- | Check that there's a 1-to-1 correspondence between the list of--- 'Table's and what's actually in the table 'table_versions'.-checkExistenceOfVersionsForTables-  :: (MonadDB m, MonadLog m)-  => [Table] -> m ValidationResult-checkExistenceOfVersionsForTables tables = do-  runQuery_ $ sqlSelect "table_versions" $ do-    sqlResult "name::text"-  (existingTableNames :: [Text]) <- fetchMany runIdentity--  let tableNames = map (unRawSQL . tblName) tables-      absent     = existingTableNames L.\\ tableNames-      notPresent = tableNames   L.\\ existingTableNames--  if (not . null $ absent) || (not . null $ notPresent)-    then do-    mapM_ (logInfo_ . (<+>) "Unknown entry in 'table_versions':") absent-    mapM_ (logInfo_ . (<+>) "Table not present in the 'table_versions':")-      notPresent-    return $-      (validateIsNull "Unknown entry in table_versions':"  absent ) <>-      (validateIsNull "Tables not present in the 'table_versions':" notPresent)-    else return mempty---checkDomainsStructure :: (MonadDB m, MonadThrow m)-                      => [Domain] -> m ValidationResult-checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do-  runQuery_ . sqlSelect "pg_catalog.pg_type t1" $ do-    sqlResult "t1.typname::text" -- name-    sqlResult "(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) \-              \FROM pg_catalog.pg_type t2 \-              \WHERE t2.oid = t1.typbasetype)" -- type-    sqlResult "NOT t1.typnotnull" -- nullable-    sqlResult "t1.typdefault" -- default value-    sqlResult "ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c \-              \WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint names-    sqlResult "ARRAY(SELECT regexp_replace(pg_get_constraintdef(c.oid, true), '\-              \CHECK \\((.*)\\)', '\\1') FROM pg_catalog.pg_constraint c \-              \WHERE c.contypid = t1.oid \-              \ORDER by c.oid)" -- constraint definitions-    sqlResult "ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c \-              \WHERE c.contypid = t1.oid \-              \ORDER by c.oid)" -- are constraints validated?-    sqlWhereEq "t1.typname" $ unRawSQL $ domName def-  mdom <- fetchMaybe $-    \(dname, dtype, nullable, defval, cnames, conds, valids) ->-      Domain-      { domName = unsafeSQL dname-      , domType = dtype-      , domNullable = nullable-      , domDefault = unsafeSQL <$> defval-      , domChecks =-          mkChecks $ zipWith3-          (\cname cond validated ->-             Check-             { chkName = unsafeSQL cname-             , chkCondition = unsafeSQL cond-             , chkValidated = validated-             }) (unArray1 cnames) (unArray1 conds) (unArray1 valids)-      }-  return $ case mdom of-    Just dom-      | dom /= def -> topMessage "domain" (unRawSQL $ domName dom) $ mconcat [-          compareAttr dom def "name" domName-        , compareAttr dom def "type" domType-        , compareAttr dom def "nullable" domNullable-        , compareAttr dom def "default" domDefault-        , compareAttr dom def "checks" domChecks-        ]-      | otherwise -> mempty-    Nothing -> validationError $ "Domain '" <> unRawSQL (domName def)-               <> "' doesn't exist in the database"-  where-    compareAttr :: (Eq a, Show a)-                => Domain -> Domain -> Text -> (Domain -> a) -> ValidationResult-    compareAttr dom def attrname attr-      | attr dom == attr def = mempty-      | otherwise            = validationError $-        "Attribute '" <> attrname-        <> "' does not match (database:" <+> T.pack (show $ attr dom)-        <> ", definition:" <+> T.pack (show $ attr def) <> ")"---- | Check that the tables that must have been dropped are actually--- missing from the DB.-checkTablesWereDropped :: (MonadDB m, MonadThrow m) =>-                          [Migration m] -> m ValidationResult-checkTablesWereDropped mgrs = do-  let droppedTableNames = [ mgrTableName mgr-                          | mgr <- mgrs, isDropTableMigration mgr ]-  fmap mconcat . forM droppedTableNames $-    \tblName -> do-      mver <- checkTableVersion (T.unpack . unRawSQL $ tblName)-      return $ if isNothing mver-               then mempty-               else validationError $ "The table '" <> unRawSQL tblName-                    <> "' that must have been dropped"-                    <> " is still present in the database."--data CompositesCreationMode-  = CreateCompositesIfDatabaseEmpty-  | DontCreateComposites-  deriving Eq---- | Check that there is 1 to 1 correspondence between composite types in the--- database and the list of their code definitions.-checkCompositesStructure-  :: MonadDB m-  => TablesWithVersions-  -> CompositesCreationMode-  -> ObjectsValidationMode-  -> [CompositeType]-  -> m ValidationResult-checkCompositesStructure tablesWithVersions ccm ovm compositeList = getDBCompositeTypes >>= \case-  [] | noTablesPresent tablesWithVersions && ccm == CreateCompositesIfDatabaseEmpty -> do-         -- DB is not initialized, create composites if there are any defined.-         mapM_ (runQuery_ . sqlCreateComposite) compositeList-         return mempty-  dbCompositeTypes -> pure $ mconcat-    [ checkNotPresentComposites-    , checkDatabaseComposites-    ]-    where-      compositeMap = M.fromList $-        map ((unRawSQL . ctName) &&& ctColumns) compositeList--      checkNotPresentComposites =-        let notPresent = S.toList $ M.keysSet compositeMap-              S.\\ S.fromList (map (unRawSQL . ctName) dbCompositeTypes)-        in validateIsNull "Composite types not present in the database:" notPresent--      checkDatabaseComposites = mconcat . (`map` dbCompositeTypes) $ \dbComposite ->-        let cname = unRawSQL $ ctName dbComposite-        in case cname `M.lookup` compositeMap of-          Just columns -> topMessage "composite type" cname $-            checkColumns 1 columns (ctColumns dbComposite)-          Nothing -> case ovm of-            AllowUnknownObjects     -> mempty-            DontAllowUnknownObjects -> validationError $ mconcat-              [ "Composite type '"-              , T.pack $ show dbComposite-              , "' from the database doesn't have a corresponding code definition"-              ]-        where-          checkColumns-            :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult-          checkColumns _ [] [] = mempty-          checkColumns _ rest [] = validationError $-            objectHasLess "Composite type" "columns" rest-          checkColumns _ [] rest = validationError $-            objectHasMore "Composite type" "columns" rest-          checkColumns !n (d:defs) (c:cols) = mconcat [-              validateNames $ ccName d == ccName c-            , validateTypes $ ccType d == ccType c-            , checkColumns (n+1) defs cols-            ]-            where-              validateNames True  = mempty-              validateNames False = validationError $-                errorMsg ("no. " <> showt n) "names" (unRawSQL . ccName)--              validateTypes True  = mempty-              validateTypes False = validationError $-                errorMsg (unRawSQL $ ccName d) "types" (T.pack . show . ccType)--              errorMsg ident attr f =-                "Column '" <> ident <> "' differs in"-                <+> attr <+> "(database:" <+> f c <> ", definition:" <+> f d <> ")."---- | Checks whether the database is consistent.-checkDBStructure-  :: forall m. (MonadDB m, MonadThrow m)-  => ExtrasOptions-  -> TablesWithVersions-  -> m ValidationResult-checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -> do-  result <- topMessage "table" (tblNameText table) <$> checkTableStructure table-  -- If we allow higher table versions in the database, show inconsistencies as-  -- info messages only.-  return $ if eoAllowHigherTableVersions options && tblVersion table < version-           then validationErrorsToInfos result-           else result-  where-    checkTableStructure :: Table -> m ValidationResult-    checkTableStructure table@Table{..} = do-      -- get table description from pg_catalog as describeTable-      -- mechanism from HDBC doesn't give accurate results-      runQuery_ $ sqlSelect "pg_catalog.pg_attribute a" $ do-        sqlResult "a.attname::text"-        sqlResult "pg_catalog.format_type(a.atttypid, a.atttypmod)"-        sqlResult . parenthesize . toSQLCommand $-          sqlSelect "pg_catalog.pg_collation c, pg_catalog.pg_type t" $ do-            sqlResult "c.collname::text"-            -- `typcollation` specifies the default collation of the type (if-            -- any), and `attcollation` is the collation of the column.-            sqlWhere "c.oid = a.attcollation AND t.oid = a.atttypid AND a.attcollation <> t.typcollation"-        sqlResult "NOT a.attnotnull"-        sqlResult . parenthesize . toSQLCommand $-          sqlSelect "pg_catalog.pg_attrdef d" $ do-            sqlResult "pg_catalog.pg_get_expr(d.adbin, d.adrelid)"-            sqlWhere "d.adrelid = a.attrelid"-            sqlWhere "d.adnum = a.attnum"-            sqlWhere "a.atthasdef"-        sqlWhere "a.attnum > 0"-        sqlWhere "NOT a.attisdropped"-        sqlWhereEqSql "a.attrelid" $ sqlGetTableID table-        sqlOrderBy "a.attnum"-      desc <- fetchMany fetchTableColumn-      -- get info about constraints from pg_catalog-      pk <- sqlGetPrimaryKey table-      runQuery_ $ sqlGetChecks table-      checks <- fetchMany fetchTableCheck-      runQuery_ $ sqlGetIndexes table-      indexes <- fetchMany fetchTableIndex-      runQuery_ $ sqlGetForeignKeys table-      fkeys <- fetchMany fetchForeignKey-      triggers <- getDBTriggers tblName-      return $ mconcat [-          checkColumns 1 tblColumns desc-        , checkPrimaryKey tblPrimaryKey pk-        , checkChecks tblChecks checks-        , checkIndexes tblIndexes indexes-        , checkForeignKeys tblForeignKeys fkeys-        , checkTriggers tblTriggers triggers-        ]-      where-        fetchTableColumn-          :: (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn-        fetchTableColumn (name, ctype, collation, nullable, mdefault) = TableColumn {-            colName = unsafeSQL name-          , colType = ctype-          , colCollation = flip rawSQL () <$> collation-          , colNullable = nullable-          , colDefault = unsafeSQL `liftM` mdefault-          }--        checkColumns-          :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult-        checkColumns _ [] [] = mempty-        checkColumns _ rest [] = validationError $-          objectHasLess "Table" "columns" rest-        checkColumns _ [] rest = validationError $-          objectHasMore "Table" "columns" rest-        checkColumns !n (d:defs) (c:cols) = mconcat [-            validateNames $ colName d == colName c-          -- bigserial == bigint + autoincrement and there is no-          -- distinction between them after table is created.-          , validateTypes $ colType d == colType c ||-            (colType d == BigSerialT && colType c == BigIntT)-          -- There is a problem with default values determined by-          -- sequences as they're implicitly specified by db, so-          -- let's omit them in such case.-          , validateDefaults $ colDefault d == colDefault c ||-            (colDefault d == Nothing-             && ((T.isPrefixOf "nextval('" . unRawSQL) `liftM` colDefault c)-                == Just True)-          , validateNullables $ colNullable d == colNullable c-          , checkColumns (n+1) defs cols-          ]-          where-            validateNames True  = mempty-            validateNames False = validationError $-              errorMsg ("no. " <> showt n) "names" (unRawSQL . colName)--            validateTypes True  = mempty-            validateTypes False = validationError $-              errorMsg cname "types" (T.pack . show . colType)-              <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d))--            validateNullables True  = mempty-            validateNullables False = validationError $-              errorMsg cname "nullables" (showt . colNullable)-              <+> sqlHint ((if colNullable d then "DROP" else "SET")-                            <+> "NOT NULL")--            validateDefaults True  = mempty-            validateDefaults False = validationError $-              (errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault))-              <+> sqlHint set_default-              where-                set_default = case colDefault d of-                  Just v  -> "SET DEFAULT" <+> v-                  Nothing -> "DROP DEFAULT"--            cname = unRawSQL $ colName d-            errorMsg ident attr f =-              "Column '" <> ident <> "' differs in"-              <+> attr <+> "(table:" <+> f c <> ", definition:" <+> f d <> ")."-            sqlHint sql =-              "(HINT: SQL for making the change is: ALTER TABLE"-              <+> tblNameText table <+> "ALTER COLUMN" <+> unRawSQL (colName d)-              <+> unRawSQL sql <> ")"--        checkPrimaryKey :: Maybe PrimaryKey -> Maybe (PrimaryKey, RawSQL ())-                        -> ValidationResult-        checkPrimaryKey mdef mpk = mconcat [-            checkEquality "PRIMARY KEY" def (map fst pk)-          , checkNames (const (pkName tblName)) pk-          , if (eoEnforcePKs options)-            then checkPKPresence tblName mdef mpk-            else mempty-          ]-          where-            def = maybeToList mdef-            pk = maybeToList mpk--        checkChecks :: [Check] -> [Check] -> ValidationResult-        checkChecks defs checks =-          mapValidationResult id mapErrs (checkEquality "CHECKs" defs checks)-          where-            mapErrs []      = []-            mapErrs errmsgs = errmsgs <>-              [ " (HINT: If checks are equal modulo number of \-                \ parentheses/whitespaces used in conditions, \-                \ just copy and paste expected output into source code)"-              ]--        checkIndexes :: [TableIndex] -> [(TableIndex, RawSQL ())]-                     -> ValidationResult-        checkIndexes defs allIndexes = mconcat-          $ checkEquality "INDEXes" defs (map fst indexes)-          : checkNames (indexName tblName) indexes-          : map localIndexInfo localIndexes-          where-            localIndexInfo (index, name) = validationInfo $ T.concat-              [ "Found a local index '"-              , unRawSQL name-              , "': "-              , T.pack (show index)-              ]--            (localIndexes, indexes) = (`partition` allIndexes) $ \(_, name) ->-              -- Manually created indexes for ad-hoc improvements.-                 "local_" `T.isPrefixOf` unRawSQL name-              -- Indexes related to the REINDEX operation, see-              -- https://www.postgresql.org/docs/15/sql-reindex.html-              || "_ccnew" `T.isSuffixOf` unRawSQL name-              || "_ccold" `T.isSuffixOf` unRawSQL name--        checkForeignKeys :: [ForeignKey] -> [(ForeignKey, RawSQL ())]-                         -> ValidationResult-        checkForeignKeys defs fkeys = mconcat [-            checkEquality "FOREIGN KEYs" defs (map fst fkeys)-          , checkNames (fkName tblName) fkeys-          ]--        checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult-        checkTriggers defs triggers =-          mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs' triggers-          where-            defs' = map (\t -> (t, triggerFunctionMakeName $ triggerName t)) defs-            mapErrs []      = []-            mapErrs errmsgs = errmsgs <>-              [ "(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \-                \case of variables or type casts used in conditions, just copy and paste \-                \expected output into source code.)"-              ]---- | Checks whether database is consistent, performing migrations if--- necessary. Requires all table names to be in lower case.------ The migrations list must have the following properties:---   * consecutive 'mgrFrom' numbers---   * no duplicates---   * all 'mgrFrom' are less than table version number of the table in---     the 'tables' list-checkDBConsistency-  :: forall m. (MonadIO m, MonadDB m, MonadLog m, MonadMask m)-  => ExtrasOptions -> [Domain] -> TablesWithVersions -> [Migration m]-  -> m ()-checkDBConsistency options domains tablesWithVersions migrations = do-  autoTransaction <- tsAutoTransaction <$> getTransactionSettings-  unless autoTransaction $ do-    error "checkDBConsistency: tsAutoTransaction setting needs to be True"-  -- Check the validity of the migrations list.-  validateMigrations-  validateDropTableMigrations--  -- Load version numbers of the tables that actually exist in the DB.-  dbTablesWithVersions <- getDBTableVersions--  if noTablesPresent tablesWithVersions--    -- No tables are present, create everything from scratch.-    then do-      createDBSchema-      initializeDB--    -- Migration mode.-    else do-      -- Additional validity checks for the migrations list.-      validateMigrationsAgainstDB [ (tblName table, tblVersion table, actualVer)-                                  | (table, actualVer) <- tablesWithVersions ]-      validateDropTableMigrationsAgainstDB dbTablesWithVersions-      -- Run migrations, if necessary.-      runMigrations dbTablesWithVersions--  where-    tables = map fst tablesWithVersions--    errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a-    errorInvalidMigrations tblNames =-      error $ "checkDBConsistency: invalid migrations for tables"-              <+> (L.intercalate ", " $ map (T.unpack . unRawSQL) tblNames)--    checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()-    checkMigrationsListValidity table presentMigrationVersions-      expectedMigrationVersions = do-      when (presentMigrationVersions /= expectedMigrationVersions) $ do-        logAttention "Migrations are invalid" $ object [-            "table"                       .= tblNameText table-          , "migration_versions"          .= presentMigrationVersions-          , "expected_migration_versions" .= expectedMigrationVersions-          ]-        errorInvalidMigrations [tblName $ table]--    validateMigrations :: m ()-    validateMigrations = forM_ tables $ \table -> do-      -- FIXME: https://github.com/scrive/hpqtypes-extras/issues/73-      let presentMigrationVersions-            = [ mgrFrom | Migration{..} <- migrations-                        , mgrTableName == tblName table ]-          expectedMigrationVersions-            = reverse $ take (length presentMigrationVersions) $-              reverse  [0 .. tblVersion table - 1]-      checkMigrationsListValidity table presentMigrationVersions-        expectedMigrationVersions--    validateDropTableMigrations :: m ()-    validateDropTableMigrations = do-      let droppedTableNames =-            [ mgrTableName $ mgr | mgr <- migrations-                                 , isDropTableMigration mgr ]-          tableNames =-            [ tblName tbl | tbl <- tables ]--      -- Check that the intersection between the 'tables' list and-      -- dropped tables is empty.-      let intersection = L.intersect droppedTableNames tableNames-      when (not . null $ intersection) $ do-          logAttention ("The intersection between tables "-                        <> "and dropped tables is not empty")-            $ object-            [ "intersection" .= map unRawSQL intersection ]-          errorInvalidMigrations [ tblName tbl-                                 | tbl <- tables-                                 , tblName tbl `elem` intersection ]--      -- Check that if a list of migrations for a given table has a-      -- drop table migration, it is unique and is the last migration-      -- in the list.-      let migrationsByTable     = L.groupBy ((==) `on` mgrTableName)-                                  migrations-          dropMigrationLists    = [ mgrs | mgrs <- migrationsByTable-                                         , any isDropTableMigration mgrs ]-          invalidMigrationLists =-            [ mgrs | mgrs <- dropMigrationLists-                   , (not . isDropTableMigration . last $ mgrs) ||-                     (length . filter isDropTableMigration $ mgrs) > 1 ]--      when (not . null $ invalidMigrationLists) $ do-        let tablesWithInvalidMigrationLists =-              [ mgrTableName mgr | mgrs <- invalidMigrationLists-                                 , let mgr = head mgrs ]-        logAttention ("Migration lists for some tables contain "-                      <> "either multiple drop table migrations or "-                      <> "a drop table migration in non-tail position.")-          $ object [ "tables" .=-                     [ unRawSQL tblName-                     | tblName <- tablesWithInvalidMigrationLists ] ]-        errorInvalidMigrations tablesWithInvalidMigrationLists--    createDBSchema :: m ()-    createDBSchema = do-      logInfo_ "Creating domains..."-      mapM_ createDomain domains-      -- Create all tables with no constraints first to allow cyclic references.-      logInfo_ "Creating tables..."-      mapM_ (createTable False) tables-      logInfo_ "Creating table constraints..."-      mapM_ createTableConstraints tables-      logInfo_ "Done."--    initializeDB :: m ()-    initializeDB = do-      logInfo_ "Running initial setup for tables..."-      forM_ tables $ \t -> case tblInitialSetup t of-        Nothing -> return ()-        Just tis -> do-          logInfo_ $ "Initializing" <+> tblNameText t <> "..."-          initialSetup tis-      logInfo_ "Done."--    -- | Input is a list of (table name, expected version, actual-    -- version) triples.-    validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()-    validateMigrationsAgainstDB tablesWithVersions_-      = forM_ tablesWithVersions_ $ \(tableName, expectedVer, actualVer) ->-        when (expectedVer /= actualVer) $-        case [ m | m@Migration{..} <- migrations-                 , mgrTableName == tableName ] of-          [] ->-            error $ "checkDBConsistency: no migrations found for table '"-              ++ (T.unpack . unRawSQL $ tableName) ++ "', cannot migrate "-              ++ show actualVer ++ " -> " ++ show expectedVer-          (m:_) | mgrFrom m > actualVer ->-                  error $ "checkDBConsistency: earliest migration for table '"-                    ++ (T.unpack . unRawSQL $ tableName) ++ "' is from version "-                    ++ show (mgrFrom m) ++ ", cannot migrate "-                    ++ show actualVer ++ " -> " ++ show expectedVer-                | otherwise -> return ()--    validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()-    validateDropTableMigrationsAgainstDB dbTablesWithVersions = do-      let dbTablesToDropWithVersions =-            [ (tblName, mgrFrom mgr, fromJust mver)-            | mgr <- migrations-            , isDropTableMigration mgr-            , let tblName = mgrTableName mgr-            , let mver = lookup (unRawSQL tblName) $ dbTablesWithVersions-            , isJust mver ]-      forM_ dbTablesToDropWithVersions $ \(tblName, fromVer, ver) ->-        when (fromVer /= ver) $-          -- In case when the table we're going to drop is an old-          -- version, check that there are migrations that bring it to-          -- a new one.-          validateMigrationsAgainstDB [(tblName, fromVer, ver)]--    findMigrationsToRun :: [(Text, Int32)] -> [Migration m]-    findMigrationsToRun dbTablesWithVersions =-      let tableNamesToDrop = [ mgrTableName mgr | mgr <- migrations-                                                , isDropTableMigration mgr ]-          droppedEventually :: Migration m -> Bool-          droppedEventually mgr = mgrTableName mgr `elem` tableNamesToDrop--          lookupVer :: Migration m -> Maybe Int32-          lookupVer mgr = lookup (unRawSQL $ mgrTableName mgr)-                          dbTablesWithVersions--          tableDoesNotExist = isNothing . lookupVer--          -- The idea here is that we find the first migration we need-          -- to run and then just run all migrations in order after-          -- that one.-          migrationsToRun' = dropWhile-            (\mgr ->-               case lookupVer mgr of-                 -- Table doesn't exist in the DB. If it's a create-                 -- table migration and we're not going to drop the-                 -- table afterwards, this is our starting point.-                 Nothing -> not $-                            (mgrFrom mgr == 0) &&-                            (not . droppedEventually $ mgr)-                 -- Table exists in the DB. Run only those migrations-                 -- that have mgrFrom >= table version in the DB.-                 Just ver -> not $-                             mgrFrom mgr >= ver)-            migrations--          -- Special case: also include migrations for tables that do-          -- not exist in the DB and ARE going to be dropped if they-          -- come as a consecutive list before the starting point that-          -- we've found.-          ---          -- Case in point: createTable t, doSomethingTo t,-          -- doSomethingTo t1, dropTable t. If our starting point is-          -- 'doSomethingTo t1', and that step depends on 't',-          -- 'doSomethingTo t1' will fail. So we include 'createTable-          -- t' and 'doSomethingTo t' as well.-          l                     = length migrationsToRun'-          initialMigrations     = drop l $ reverse migrations-          additionalMigrations' = takeWhile-            (\mgr -> droppedEventually mgr && tableDoesNotExist mgr)-            initialMigrations-          -- Check that all extra migration chains we've chosen begin-          -- with 'createTable', otherwise skip adding them (to-          -- prevent raising an exception during the validation step).-          additionalMigrations  =-            let ret  = reverse additionalMigrations'-                grps = L.groupBy ((==) `on` mgrTableName) ret-            in if any ((/=) 0 . mgrFrom . head) grps-               then []-               else ret-          -- Also there's no point in adding these extra migrations if-          -- we're not running any migrations to begin with.-          migrationsToRun       = if not . null $ migrationsToRun'-                                  then additionalMigrations ++ migrationsToRun'-                                  else []-      in migrationsToRun--    runMigration :: (Migration m) -> m ()-    runMigration Migration{..} = do-      case mgrAction of-        StandardMigration mgrDo -> do-          logMigration-          mgrDo-          updateTableVersion--        DropTableMigration mgrDropTableMode -> do-          logInfo_ $ arrListTable mgrTableName <> "drop table"-          runQuery_ $ sqlDropTable mgrTableName-            mgrDropTableMode-          runQuery_ $ sqlDelete "table_versions" $ do-            sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName)--        CreateIndexConcurrentlyMigration tname idx -> do-          logMigration-          -- We're in auto transaction mode (as ensured at the beginning of-          -- 'checkDBConsistency'), so we need to issue explicit SQL commit,-          -- because using 'commit' function automatically starts another-          -- transaction. We don't want that as concurrent creation of index-          -- won't run inside a transaction.-          bracket_ (runSQL_ "COMMIT") (runSQL_ "BEGIN") $ do-            -- If migration was run before but creation of an index failed, index-            -- will be left in the database in an inactive state, so when we-            -- rerun, we need to remove it first (see-            -- https://www.postgresql.org/docs/9.6/sql-createindex.html for more-            -- information).-            runQuery_ $ "DROP INDEX CONCURRENTLY IF EXISTS" <+> indexName tname idx-            runQuery_ (sqlCreateIndexConcurrently tname idx)-          updateTableVersion--        DropIndexConcurrentlyMigration tname idx -> do-          logMigration-          -- We're in auto transaction mode (as ensured at the beginning of-          -- 'checkDBConsistency'), so we need to issue explicit SQL commit,-          -- because using 'commit' function automatically starts another-          -- transaction. We don't want that as concurrent dropping of index-          -- won't run inside a transaction.-          bracket_ (runSQL_ "COMMIT") (runSQL_ "BEGIN") $ do-            runQuery_ (sqlDropIndexConcurrently tname idx)-          updateTableVersion--        ModifyColumnMigration tableName cursorSql updateSql batchSize -> do-          logMigration-          when (batchSize < 1000) $ do-            error "Batch size cannot be less than 1000"-          withCursorSQL "migration_cursor" NoScroll Hold cursorSql $ \cursor -> do-            -- Vacuum should be done approximately once every 5% of the table-            -- has been updated, or every 1000 rows as a minimum.-            ---            -- In PostgreSQL, when a record is updated, a new version of this-            -- record is created. The old one is destroyed by the "vacuum"-            -- command when no transaction needs it anymore. So there's an-            -- autovacuum daemon whose purpose is to do this cleanup, and that-            -- is sufficient most of the time. We assume that it's tuned to try-            -- to keep the "bloat" (dead records) at around 10% of the table-            -- size in the environment, and it's also tuned to not saturate the-            -- server with IO operations while doing the vacuum - vacuuming is-            -- IO intensive as there are a lot of reads and rewrites, which-            -- makes it slow and costly. So, autovacuum wouldn't be able to keep-            -- up with the aggressive batch update. Therefore we need to run-            -- vacuum ourselves, to keep things in check. The 5% limit is-            -- arbitrary, but a reasonable ballpark estimate: it more or less-            -- makes sure we keep dead records in the 10% envelope and the table-            -- doesn't grow too much during the operation.-            vacuumThreshold <- max 1000 . fromIntegral . (`div` 20) <$> getRowEstimate tableName-            let cursorLoop processed = do-                  cursorFetch_ cursor (CD_Forward batchSize)-                  primaryKeys <- fetchMany id-                  unless (null primaryKeys) $ do-                    updateSql primaryKeys-                    if processed + batchSize >= vacuumThreshold-                    then do-                      bracket_ (runSQL_ "COMMIT")-                               (runSQL_ "BEGIN")-                               (runQuery_ $ "VACUUM" <+> tableName)-                      cursorLoop 0-                    else do-                      commit-                      cursorLoop (processed + batchSize)-            cursorLoop 0-          updateTableVersion--      where-        logMigration = do-          logInfo_ $ arrListTable mgrTableName-            <> showt mgrFrom <+> "->" <+> showt (succ mgrFrom)--        updateTableVersion = do-          runQuery_ $ sqlUpdate "table_versions" $ do-            sqlSet "version"  (succ mgrFrom)-            sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName)--        -- Get the estimated number of rows of the given table. It might not-        -- work properly if the table is present in multiple database schemas.-        -- See https://wiki.postgresql.org/wiki/Count_estimate.-        getRowEstimate :: MonadDB m => RawSQL () -> m Int32-        getRowEstimate tableName = do-          runQuery_ . sqlSelect "pg_class" $ do-            sqlResult "reltuples::integer"-            sqlWhereEq "relname" $ unRawSQL tableName-          fetchOne runIdentity--    runMigrations :: [(Text, Int32)] -> m ()-    runMigrations dbTablesWithVersions = do-      let migrationsToRun = findMigrationsToRun dbTablesWithVersions-      validateMigrationsToRun migrationsToRun dbTablesWithVersions-      when (not . null $ migrationsToRun) $ do-        logInfo_ "Running migrations..."-        forM_ migrationsToRun $ \mgr -> fix $ \loop -> do-          let restartMigration query = do-                logAttention "Failed to acquire a lock" $ object ["query" .= query]-                logInfo_ "Restarting the migration shortly..."-                liftIO $ threadDelay 1000000-                loop-          handleJust lockNotAvailable restartMigration $ do-            forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do-              runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL lockTimeout-            runMigration mgr `onException` rollback-            logInfo_ $ "Committing migration changes..."-            commit-        logInfo_ "Running migrations... done."-      where-        intToSQL :: Int -> SQL-        intToSQL = unsafeSQL . show--        lockNotAvailable :: DBException -> Maybe String-        lockNotAvailable DBException{..}-          | Just DetailedQueryError{..} <- cast dbeError-          , qeErrorCode == LockNotAvailable = Just $ show dbeQueryContext-          | otherwise                       = Nothing--    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()-    validateMigrationsToRun migrationsToRun dbTablesWithVersions = do--      let migrationsToRunGrouped :: [[Migration m]]-          migrationsToRunGrouped =-            L.groupBy ((==) `on` mgrTableName) .-            L.sortBy (comparing mgrTableName) $ -- NB: stable sort-            migrationsToRun--          loc_common = "Database.PostgreSQL.PQTypes.Checks."-            ++ "checkDBConsistency.validateMigrationsToRun"--          lookupDBTableVer :: [Migration m] -> Maybe Int32-          lookupDBTableVer mgrGroup =-            lookup (unRawSQL . mgrTableName . headExc head_err-                    $ mgrGroup) dbTablesWithVersions-            where-              head_err = loc_common ++ ".lookupDBTableVer: broken invariant"--          groupsWithWrongDBTableVersions :: [([Migration m], Int32)]-          groupsWithWrongDBTableVersions =-            [ (mgrGroup, dbTableVer)-            | mgrGroup <- migrationsToRunGrouped-            , let dbTableVer = fromMaybe 0 $ lookupDBTableVer mgrGroup-            , dbTableVer /= (mgrFrom . headExc head_err $ mgrGroup)-            ]-            where-              head_err = loc_common-                ++ ".groupsWithWrongDBTableVersions: broken invariant"--          mgrGroupsNotInDB :: [[Migration m]]-          mgrGroupsNotInDB =-            [ mgrGroup-            | mgrGroup <- migrationsToRunGrouped-            , isNothing $ lookupDBTableVer mgrGroup-            ]--          groupsStartingWithDropTable :: [[Migration m]]-          groupsStartingWithDropTable =-            [ mgrGroup-            | mgrGroup <- mgrGroupsNotInDB-            , isDropTableMigration . headExc head_err $ mgrGroup-            ]-            where-              head_err = loc_common-                ++ ".groupsStartingWithDropTable: broken invariant"--          groupsNotStartingWithCreateTable :: [[Migration m]]-          groupsNotStartingWithCreateTable =-            [ mgrGroup-            | mgrGroup <- mgrGroupsNotInDB-            , mgrFrom (headExc head_err mgrGroup) /= 0-            ]-            where-              head_err = loc_common-                ++ ".groupsNotStartingWithCreateTable: broken invariant"--          tblNames :: [[Migration m]] -> [RawSQL ()]-          tblNames grps =-            [ mgrTableName . headExc head_err $ grp | grp <- grps ]-            where-              head_err = loc_common ++ ".tblNames: broken invariant"--      when (not . null $ groupsWithWrongDBTableVersions) $ do-        let tnms = tblNames . map fst $ groupsWithWrongDBTableVersions-        logAttention-          ("There are migration chains selected for execution "-            <> "that expect a different starting table version number "-            <> "from the one in the database. "-            <> "This likely means that the order of migrations is wrong.")-          $ object [ "tables" .= map unRawSQL tnms ]-        errorInvalidMigrations tnms--      when (not . null $ groupsStartingWithDropTable) $ do-        let tnms = tblNames groupsStartingWithDropTable-        logAttention "There are drop table migrations for non-existing tables."-          $ object [ "tables" .= map unRawSQL tnms ]-        errorInvalidMigrations tnms--      -- NB: the following check can break if we allow renaming tables.-      when (not . null $ groupsNotStartingWithCreateTable) $ do-        let tnms = tblNames groupsNotStartingWithCreateTable-        logAttention-          ("Some tables haven't been created yet, but" <>-            "their migration lists don't start with a create table migration.")-          $ object [ "tables" .=  map unRawSQL tnms ]-        errorInvalidMigrations tnms---- | Type synonym for a list of tables along with their database versions.-type TablesWithVersions = [(Table, Int32)]---- | Associate each table in the list with its version as it exists in--- the DB, or 0 if it's missing from the DB.-getTableVersions :: (MonadDB m, MonadThrow m) => [Table] -> m TablesWithVersions-getTableVersions tbls =-  sequence-  [ (\mver -> (tbl, fromMaybe 0 mver)) <$> checkTableVersion (tblNameString tbl)-  | tbl <- tbls ]---- | Given a result of 'getTableVersions' check if no tables are present in the--- database.-noTablesPresent :: TablesWithVersions -> Bool-noTablesPresent = all ((==) 0 . snd)---- | Like 'getTableVersions', but for all user-defined tables that--- actually exist in the DB.-getDBTableVersions :: (MonadDB m, MonadThrow m) => m [(Text, Int32)]-getDBTableVersions = do-  dbTableNames <- getDBTableNames-  sequence-    [ (\mver -> (name, fromMaybe 0 mver)) <$> checkTableVersion (T.unpack name)-    | name <- dbTableNames ]---- | Check whether the table exists in the DB, and return 'Just' its--- version if it does, or 'Nothing' if it doesn't.-checkTableVersion :: (MonadDB m, MonadThrow m) => String -> m (Maybe Int32)-checkTableVersion tblName = do-  doesExist <- runQuery01 . sqlSelect "pg_catalog.pg_class c" $ do-    sqlResult "TRUE"-    sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace"-    sqlWhereEq "c.relname" $ tblName-    sqlWhere "pg_catalog.pg_table_is_visible(c.oid)"-  if doesExist-    then do-      runQuery_ $ "SELECT version FROM table_versions WHERE name ="-        <?> tblName-      mver <- fetchMaybe runIdentity-      case mver of-        Just ver -> return $ Just ver-        Nothing  -> error $ "checkTableVersion: table '"-          ++ tblName-          ++ "' is present in the database, "-          ++ "but there is no corresponding version info in 'table_versions'."-    else do-      return Nothing---- *** TABLE STRUCTURE ***--sqlGetTableID :: Table -> SQL-sqlGetTableID table = parenthesize . toSQLCommand $-  sqlSelect "pg_catalog.pg_class c" $ do-    sqlResult "c.oid"-    sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace"-    sqlWhereEq "c.relname" $ tblNameString table-    sqlWhere "pg_catalog.pg_table_is_visible(c.oid)"---- *** PRIMARY KEY ***--sqlGetPrimaryKey-  :: (MonadDB m, MonadThrow m)-  => Table -> m (Maybe (PrimaryKey, RawSQL ()))-sqlGetPrimaryKey table = do--  (mColumnNumbers :: Maybe [Int16]) <- do-    runQuery_ . sqlSelect "pg_catalog.pg_constraint" $ do-      sqlResult "conkey"-      sqlWhereEqSql "conrelid" (sqlGetTableID table)-      sqlWhereEq "contype" 'p'-    fetchMaybe $ unArray1 . runIdentity--  case mColumnNumbers of-    Nothing -> do return Nothing-    Just columnNumbers -> do-      columnNames <- do-        forM columnNumbers $ \k -> do-          runQuery_ . sqlSelect "pk_columns" $ do--            sqlWith "key_series" . sqlSelect "pg_constraint as c2" $ do-              sqlResult "unnest(c2.conkey) as k"-              sqlWhereEqSql "c2.conrelid" $ sqlGetTableID table-              sqlWhereEq "c2.contype" 'p'--            sqlWith "pk_columns" . sqlSelect "key_series" $ do-              sqlJoinOn  "pg_catalog.pg_attribute as a" "a.attnum = key_series.k"-              sqlResult "a.attname::text as column_name"-              sqlResult "key_series.k as column_order"-              sqlWhereEqSql "a.attrelid" $ sqlGetTableID table--            sqlResult "pk_columns.column_name"-            sqlWhereEq "pk_columns.column_order" k--          fetchOne (\(Identity t) -> t :: String)--      runQuery_ . sqlSelect "pg_catalog.pg_constraint as c" $ do-        sqlWhereEq "c.contype" 'p'-        sqlWhereEqSql "c.conrelid" $ sqlGetTableID table-        sqlResult "c.conname::text"-        sqlResult $ Data.String.fromString-          ("array['" <> (mintercalate "', '" columnNames) <> "']::text[]")--      join <$> fetchMaybe fetchPrimaryKey--fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())-fetchPrimaryKey (name, Array1 columns) = (, unsafeSQL name)-  <$> (pkOnColumns $ map unsafeSQL columns)---- *** CHECKS ***--sqlGetChecks :: Table -> SQL-sqlGetChecks table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do-  sqlResult "c.conname::text"-  sqlResult "regexp_replace(pg_get_constraintdef(c.oid, true), \-            \'CHECK \\((.*)\\)', '\\1') AS body" -- check body-  sqlResult "c.convalidated" -- validated?-  sqlWhereEq "c.contype" 'c'-  sqlWhereEqSql "c.conrelid" $ sqlGetTableID table--fetchTableCheck :: (String, String, Bool) -> Check-fetchTableCheck (name, condition, validated) = Check {-  chkName = unsafeSQL name-, chkCondition = unsafeSQL condition-, chkValidated = validated-}---- *** INDEXES ***--sqlGetIndexes :: Table -> SQL-sqlGetIndexes table = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do-  sqlResult "c.relname::text" -- index name-  sqlResult $ "ARRAY(" <> selectCoordinates "0" "i.indnkeyatts" <> ")" -- array of key columns in the index-  sqlResult $ "ARRAY(" <> selectCoordinates "i.indnkeyatts" "i.indnatts" <> ")" -- array of included columns in the index-  sqlResult "am.amname::text" -- the method used (btree, gin etc)-  sqlResult "i.indisunique" -- is it unique?-  sqlResult "i.indisvalid"  -- is it valid?-  -- if partial, get constraint def-  sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"-  sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid"-  sqlJoinOn "pg_catalog.pg_am am" "c.relam = am.oid"-  sqlLeftJoinOn "pg_catalog.pg_constraint r"-    "r.conrelid = i.indrelid AND r.conindid = i.indexrelid"-  sqlWhereEqSql "i.indrelid" $ sqlGetTableID table-  sqlWhereIsNULL "r.contype" -- fetch only "pure" indexes-  where-    -- Get all coordinates of the index.-    selectCoordinates start end = smconcat [-        "WITH RECURSIVE coordinates(k, name) AS ("-      , "  VALUES (" <> start <> "::integer, NULL)"-      , "  UNION ALL"-      , "    SELECT k+1, pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true)"-      , "      FROM coordinates"-      , "     WHERE k < " <> end-      , ")"-      , "SELECT name FROM coordinates WHERE name IS NOT NULL"-      ]--fetchTableIndex-  :: (String, Array1 String, Array1 String, String, Bool, Bool, Maybe String)-  -> (TableIndex, RawSQL ())-fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, valid, mconstraint) =-  (TableIndex-   { idxColumns = map (indexColumn . unsafeSQL) keyColumns-   , idxInclude = map unsafeSQL includeColumns-   , idxMethod = read method-   , idxUnique = unique-   , idxValid = valid-   , idxWhere = unsafeSQL `liftM` mconstraint-   }-  , unsafeSQL name)---- *** FOREIGN KEYS ***--sqlGetForeignKeys :: Table -> SQL-sqlGetForeignKeys table = toSQLCommand-                          . sqlSelect "pg_catalog.pg_constraint r" $ do-  sqlResult "r.conname::text" -- fk name-  sqlResult $-    "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("-    <> unnestWithOrdinality "r.conkey"-    <> ") conkeys ON (a.attnum = conkeys.item) \-       \WHERE a.attrelid = r.conrelid \-       \ORDER BY conkeys.n)" -- constrained columns-  sqlResult "c.relname::text" -- referenced table-  sqlResult $ "ARRAY(SELECT a.attname::text \-              \FROM pg_catalog.pg_attribute a JOIN ("-    <> unnestWithOrdinality "r.confkey"-    <> ") confkeys ON (a.attnum = confkeys.item) \-       \WHERE a.attrelid = r.confrelid \-       \ORDER BY confkeys.n)" -- referenced columns-  sqlResult "r.confupdtype" -- on update-  sqlResult "r.confdeltype" -- on delete-  sqlResult "r.condeferrable" -- deferrable?-  sqlResult "r.condeferred" -- initially deferred?-  sqlResult "r.convalidated" -- validated?-  sqlJoinOn "pg_catalog.pg_class c" "c.oid = r.confrelid"-  sqlWhereEqSql "r.conrelid" $ sqlGetTableID table-  sqlWhereEq "r.contype" 'f'-  where-    unnestWithOrdinality :: RawSQL () -> SQL-    unnestWithOrdinality arr =-      "SELECT n, " <> raw arr-      <> "[n] AS item FROM generate_subscripts(" <> raw arr <> ", 1) AS n"--fetchForeignKey ::-  (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool)-  -> (ForeignKey, RawSQL ())-fetchForeignKey-  ( name, Array1 columns, reftable, Array1 refcolumns-  , on_update, on_delete, deferrable, deferred, validated ) = (ForeignKey {-  fkColumns = map unsafeSQL columns-, fkRefTable = unsafeSQL reftable-, fkRefColumns = map unsafeSQL refcolumns-, fkOnUpdate = charToForeignKeyAction on_update-, fkOnDelete = charToForeignKeyAction on_delete-, fkDeferrable = deferrable-, fkDeferred = deferred-, fkValidated = validated-}, unsafeSQL name)-  where-    charToForeignKeyAction c = case c of-      'a' -> ForeignKeyNoAction-      'r' -> ForeignKeyRestrict-      'c' -> ForeignKeyCascade-      'n' -> ForeignKeySetNull-      'd' -> ForeignKeySetDefault-      _   -> error $ "fetchForeignKey: invalid foreign key action code: "-                     ++ show c+module Database.PostgreSQL.PQTypes.Checks+  ( -- * Definitions+    DatabaseDefinitions (..)+  , emptyDbDefinitions++    -- * Checks+  , checkDatabase+  , checkDatabaseWithReport+  , createTable+  , createDomain++    -- * Options+  , ExtrasOptions (..)+  , defaultExtrasOptions+  , ObjectsValidationMode (..)++    -- * Migrations+  , migrateDatabase++    -- * Internals for tests+  , ValidationResult+  , validationError+  , validationInfo+  ) where++import Control.Arrow ((&&&))+import Control.Concurrent (threadDelay)+import Control.Monad+import Control.Monad.Catch+import Control.Monad.Extra (mconcatMapM)+import Control.Monad.Writer as W+import Data.Foldable (foldMap')+import Data.Function+import Data.Int+import Data.List (partition)+import Data.List qualified as L+import Data.Map qualified as M+import Data.Maybe+import Data.Monoid.Utils+import Data.Set qualified as S+import Data.String qualified+import Data.Text (Text)+import Data.Text qualified as T+import Data.Typeable (cast)+import Database.PostgreSQL.PQTypes+import GHC.Stack (HasCallStack)+import Log+import TextShow++import Database.PostgreSQL.PQTypes.Checks.Util+import Database.PostgreSQL.PQTypes.ExtrasOptions+import Database.PostgreSQL.PQTypes.Migrate+import Database.PostgreSQL.PQTypes.Model+import Database.PostgreSQL.PQTypes.SQL.Builder+import Database.PostgreSQL.PQTypes.Versions++headExc :: String -> [a] -> a+headExc s [] = error s+headExc _ (x : _) = x++data DatabaseDefinitions = DatabaseDefinitions+  { dbExtensions :: [Extension]+  , dbComposites :: [CompositeType]+  , dbEnums :: [EnumType]+  , dbDomains :: [Domain]+  , dbTables :: [Table]+  }++emptyDbDefinitions :: DatabaseDefinitions+emptyDbDefinitions = DatabaseDefinitions [] [] [] [] []++----------------------------------------++-- | Run migrations and check the database structure.+migrateDatabase+  :: (MonadIO m, MonadDB m, MonadLog m, MonadMask m)+  => ExtrasOptions+  -> DatabaseDefinitions+  -> [Migration m]+  -> m ()+migrateDatabase+  options+  DatabaseDefinitions+    { dbExtensions = extensions+    , dbComposites = composites+    , dbEnums = enums+    , dbDomains = domains+    , dbTables = tables+    }+  migrations = do+    setDBTimeZoneToUTC+    mapM_ checkExtension extensions+    tablesWithVersions <- getTableVersions (tableVersions : tables)+    -- 'checkDBConsistency' also performs migrations.+    checkDBConsistency options domains enums tablesWithVersions migrations+    resultCheck+      =<< checkCompositesStructure+        tablesWithVersions+        CreateCompositesIfDatabaseEmpty+        (eoObjectsValidationMode options)+        composites+    resultCheck =<< checkEnumTypes enums+    resultCheck =<< checkDomainsStructure domains+    resultCheck =<< checkDBStructure options tablesWithVersions+    resultCheck =<< checkTablesWereDropped migrations++    when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do+      resultCheck =<< checkUnknownTables tables+      resultCheck =<< checkExistenceOfVersionsForTables (tableVersions : tables)++    -- After migrations are done make sure the table versions are correct.+    resultCheck . checkVersions options =<< getTableVersions (tableVersions : tables)++    -- everything is OK, commit changes+    commit++-- | Run checks on the database structure and whether the database needs to be+-- migrated. Will do a full check of DB structure.+checkDatabaseWithReport+  :: forall m+   . (MonadDB m, MonadLog m, MonadThrow m)+  => ExtrasOptions+  -> DatabaseDefinitions+  -> m ValidationResult+checkDatabaseWithReport+  options+  DatabaseDefinitions+    { dbExtensions = _+    , dbComposites = composites+    , dbEnums = enums+    , dbDomains = domains+    , dbTables = tables+    } = execWriterT $ do+    (_, report) <- W.listen $ do+      tablesWithVersions <- getTableVersions (tableVersions : tables)+      tell $ checkVersions options tablesWithVersions+      tell+        =<< checkCompositesStructure+          tablesWithVersions+          DontCreateComposites+          (eoObjectsValidationMode options)+          composites+      tell =<< checkEnumTypes enums+      tell =<< checkDomainsStructure domains+      tell =<< checkDBStructure options tablesWithVersions+      when (eoObjectsValidationMode options == DontAllowUnknownObjects) $ do+        tell =<< checkUnknownTables tables+        tell =<< checkExistenceOfVersionsForTables (tableVersions : tables)++    -- Check initial setups only after database structure is considered+    -- consistent as before that some of the checks may fail internally.+    unless (resultHasErrors report) $+      tell =<< lift (checkInitialSetups tables)+    where+      checkInitialSetups :: [Table] -> m ValidationResult+      checkInitialSetups = mconcatMapM checkInitialSetupForTable++      checkInitialSetupForTable table = case tblInitialSetup table of+        Nothing -> return mempty+        Just setup ->+          checkInitialSetup setup >>= \case+            True -> return mempty+            False ->+              return . validationError $+                "Initial setup for table '"+                  <> tblNameText table+                  <> "' is not valid"++-- | An equivalent to `checkDatabaseWithReport opts dbDefs >>= resultCheck`.+checkDatabase+  :: forall m+   . (MonadDB m, MonadLog m, MonadThrow m)+  => ExtrasOptions+  -> DatabaseDefinitions+  -> m ()+checkDatabase options dbDefinitions =+  checkDatabaseWithReport options dbDefinitions >>= resultCheck++-- | Return SQL fragment of current catalog within quotes+currentCatalog :: (MonadDB m, MonadThrow m) => m (RawSQL ())+currentCatalog = do+  runSQL_ "SELECT current_catalog::text"+  dbname <- fetchOne runIdentity+  return $ unsafeSQL $ "\"" ++ dbname ++ "\""++-- | Check for a given extension. We need to read from 'pg_extension'+-- table as Amazon RDS limits usage of 'CREATE EXTENSION IF NOT EXISTS'.+checkExtension :: (MonadDB m, MonadLog m, MonadThrow m) => Extension -> m ()+checkExtension (Extension extension) = do+  logInfo_ $ "Checking for extension '" <> txtExtension <> "'"+  extensionExists <- runQuery01 . sqlSelect "pg_extension" $ do+    sqlResult "TRUE"+    sqlWhereEq "extname" $ unRawSQL extension+  if not extensionExists+    then do+      logInfo_ $ "Creating extension '" <> txtExtension <> "'"+      runSQL_ $ "CREATE EXTENSION IF NOT EXISTS" <+> raw extension+    else logInfo_ $ "Extension '" <> txtExtension <> "' exists"+  where+    txtExtension = unRawSQL extension++-- | Check whether the database returns timestamps in UTC, and set the+-- timezone to UTC if it doesn't.+setDBTimeZoneToUTC :: (MonadDB m, MonadLog m, MonadThrow m) => m ()+setDBTimeZoneToUTC = do+  runSQL_ "SHOW timezone"+  timezone :: String <- fetchOne runIdentity+  when (timezone /= "UTC") $ do+    dbname <- currentCatalog+    logInfo_ $+      "Setting '"+        <> unRawSQL dbname+        <> "' database to return timestamps in UTC"+    runQuery_ $ "ALTER DATABASE" <+> dbname <+> "SET TIMEZONE = 'UTC'"+    -- Setting the database timezone doesn't change the session timezone.+    runSQL_ "SET timezone = 'UTC'"++-- | Get the names of all user-defined tables that actually exist in+-- the DB.+getDBTableNames :: MonadDB m => m [Text]+getDBTableNames = do+  runQuery_ $ sqlSelect "information_schema.tables" $ do+    sqlResult "table_name::text"+    sqlWhere "table_name <> 'table_versions'"+    sqlWhere "table_type = 'BASE TABLE'"+    sqlWhereExists $ sqlSelect "unnest(current_schemas(false)) as cs" $ do+      sqlResult "TRUE"+      sqlWhere "cs = table_schema"+  fetchMany runIdentity++checkVersions :: ExtrasOptions -> TablesWithVersions -> ValidationResult+checkVersions options = mconcat . map checkVersion+  where+    checkVersion :: (Table, Int32) -> ValidationResult+    checkVersion (t@Table {..}, v)+      | if eoAllowHigherTableVersions options+          then tblVersion <= v+          else tblVersion == v =+          mempty+      | v == 0 =+          validationError $+            "Table '" <> tblNameText t <> "' must be created"+      | otherwise =+          validationError $+            "Table '"+              <> tblNameText t+              <> "' must be migrated"+              <+> showt v+              <+> "->"+              <+> showt tblVersion++-- | Check that there's a 1-to-1 correspondence between the list of+-- 'Table's and what's actually in the database.+checkUnknownTables :: (MonadDB m, MonadLog m) => [Table] -> m ValidationResult+checkUnknownTables tables = do+  dbTableNames <- getDBTableNames+  let tableNames = map (unRawSQL . tblName) tables+      absent = dbTableNames L.\\ tableNames+      notPresent = tableNames L.\\ dbTableNames++  if (not . null $ absent) || (not . null $ notPresent)+    then do+      mapM_ (logInfo_ . (<+>) "Unknown table:") absent+      mapM_ (logInfo_ . (<+>) "Table not present in the database:") notPresent+      return $+        validateIsNull "Unknown tables:" absent+          <> validateIsNull "Tables not present in the database:" notPresent+    else return mempty++validateIsNull :: Text -> [Text] -> ValidationResult+validateIsNull _ [] = mempty+validateIsNull msg ts = validationError $ msg <+> T.intercalate ", " ts++-- | Check that there's a 1-to-1 correspondence between the list of+-- 'Table's and what's actually in the table 'table_versions'.+checkExistenceOfVersionsForTables+  :: (MonadDB m, MonadLog m)+  => [Table]+  -> m ValidationResult+checkExistenceOfVersionsForTables tables = do+  runQuery_ $ sqlSelect "table_versions" $ do+    sqlResult "name::text"+  (existingTableNames :: [Text]) <- fetchMany runIdentity++  let tableNames = map (unRawSQL . tblName) tables+      absent = existingTableNames L.\\ tableNames+      notPresent = tableNames L.\\ existingTableNames++  if (not . null $ absent) || (not . null $ notPresent)+    then do+      mapM_ (logInfo_ . (<+>) "Unknown entry in 'table_versions':") absent+      mapM_+        (logInfo_ . (<+>) "Table not present in the 'table_versions':")+        notPresent+      return $+        validateIsNull "Unknown entry in table_versions':" absent+          <> validateIsNull "Tables not present in the 'table_versions':" notPresent+    else return mempty++checkDomainsStructure+  :: (MonadDB m, MonadThrow m)+  => [Domain]+  -> m ValidationResult+checkDomainsStructure defs = fmap mconcat . forM defs $ \def -> do+  runQuery_ . sqlSelect "pg_catalog.pg_type t1" $ do+    sqlResult "t1.typname::text" -- name+    sqlResult+      "(SELECT pg_catalog.format_type(t2.oid, t2.typtypmod) \+      \FROM pg_catalog.pg_type t2 \+      \WHERE t2.oid = t1.typbasetype)" -- type+    sqlResult "NOT t1.typnotnull" -- nullable+    sqlResult "t1.typdefault" -- default value+    sqlResult+      "ARRAY(SELECT c.conname::text FROM pg_catalog.pg_constraint c \+      \WHERE c.contypid = t1.oid ORDER by c.oid)" -- constraint names+    sqlResult+      "ARRAY(SELECT regexp_replace(pg_get_constraintdef(c.oid, true), '\+      \CHECK \\((.*)\\)', '\\1') FROM pg_catalog.pg_constraint c \+      \WHERE c.contypid = t1.oid \+      \ORDER by c.oid)" -- constraint definitions+    sqlResult+      "ARRAY(SELECT c.convalidated FROM pg_catalog.pg_constraint c \+      \WHERE c.contypid = t1.oid \+      \ORDER by c.oid)" -- are constraints validated?+    sqlWhereEq "t1.typname" $ unRawSQL $ domName def+  mdom <- fetchMaybe $+    \(dname, dtype, nullable, defval, cnames, conds, valids) ->+      Domain+        { domName = unsafeSQL dname+        , domType = dtype+        , domNullable = nullable+        , domDefault = unsafeSQL <$> defval+        , domChecks =+            mkChecks $+              zipWith3+                ( \cname cond validated ->+                    Check+                      { chkName = unsafeSQL cname+                      , chkCondition = unsafeSQL cond+                      , chkValidated = validated+                      }+                )+                (unArray1 cnames)+                (unArray1 conds)+                (unArray1 valids)+        }+  return $ case mdom of+    Just dom+      | dom /= def ->+          topMessage "domain" (unRawSQL $ domName dom) $+            mconcat+              [ compareAttr dom def "name" domName+              , compareAttr dom def "type" domType+              , compareAttr dom def "nullable" domNullable+              , compareAttr dom def "default" domDefault+              , compareAttr dom def "checks" domChecks+              ]+      | otherwise -> mempty+    Nothing ->+      validationError $+        "Domain '"+          <> unRawSQL (domName def)+          <> "' doesn't exist in the database"+  where+    compareAttr+      :: (Eq a, Show a)+      => Domain+      -> Domain+      -> Text+      -> (Domain -> a)+      -> ValidationResult+    compareAttr dom def attrname attr+      | attr dom == attr def = mempty+      | otherwise =+          validationError $+            "Attribute '"+              <> attrname+              <> "' does not match (database:"+              <+> T.pack (show $ attr dom)+              <> ", definition:"+              <+> T.pack (show $ attr def)+              <> ")"++checkEnumTypes+  :: (MonadDB m, MonadThrow m)+  => [EnumType]+  -> m ValidationResult+checkEnumTypes defs = fmap mconcat . forM defs $ \defEnum -> do+  runQuery_ . sqlSelect "pg_catalog.pg_type t" $ do+    sqlResult "t.typname::text" -- name+    sqlResult+      "ARRAY(SELECT e.enumlabel::text FROM pg_catalog.pg_enum e WHERE e.enumtypid = t.oid ORDER BY e.enumsortorder)" -- values+    sqlWhereEq "t.typname" $ unRawSQL $ etName defEnum+  enum <- fetchMaybe $+    \(enumName, enumValues) ->+      EnumType+        { etName = unsafeSQL enumName+        , etValues = map unsafeSQL $ unArray1 enumValues+        }+  pure $ case enum of+    Just dbEnum -> do+      let enumName = unRawSQL $ etName defEnum+          dbValues = map unRawSQL $ etValues dbEnum+          defValues = map unRawSQL $ etValues defEnum+          dbSet = S.fromList dbValues+          defSet = S.fromList defValues+      if+        | dbValues == defValues -> mempty+        | L.sort dbValues == L.sort defValues ->+            validationInfo $+              "Enum '"+                <> enumName+                <> "' has same values, but differs in order (database: "+                <> T.pack (show dbValues)+                <> ", definition: "+                <> T.pack (show defValues)+                <> "). "+                <> "This isn't usually a problem, unless the enum is used for ordering."+        | S.isSubsetOf defSet dbSet ->+            validationInfo $+              "Enum '"+                <> enumName+                <> "' has all necessary values, but the database has additional ones "+                <> "(database: "+                <> T.pack (show dbValues)+                <> ", definition: "+                <> T.pack (show defValues)+                <> ")"+        | otherwise ->+            validationError $+              "Enum '"+                <> enumName+                <> "' does not match (database: "+                <> T.pack (show dbValues)+                <> ", definition: "+                <> T.pack (show defValues)+                <> ")"+    Nothing ->+      validationError $+        "Enum '"+          <> unRawSQL (etName defEnum)+          <> "' doesn't exist in the database"++-- | Check that the tables that must have been dropped are actually+-- missing from the DB.+checkTablesWereDropped+  :: (MonadDB m, MonadThrow m)+  => [Migration m]+  -> m ValidationResult+checkTablesWereDropped mgrs = do+  let droppedTableNames =+        [ mgrTableName mgr+        | mgr <- mgrs+        , isDropTableMigration mgr+        ]+  fmap mconcat . forM droppedTableNames $+    \tblName -> do+      mver <- checkTableVersion (T.unpack . unRawSQL $ tblName)+      return $+        if isNothing mver+          then mempty+          else+            validationError $+              "The table '"+                <> unRawSQL tblName+                <> "' that must have been dropped"+                <> " is still present in the database."++data CompositesCreationMode+  = CreateCompositesIfDatabaseEmpty+  | DontCreateComposites+  deriving (Eq)++-- | Check that there is 1 to 1 correspondence between composite types in the+-- database and the list of their code definitions.+checkCompositesStructure+  :: MonadDB m+  => TablesWithVersions+  -> CompositesCreationMode+  -> ObjectsValidationMode+  -> [CompositeType]+  -> m ValidationResult+checkCompositesStructure tablesWithVersions ccm ovm compositeList =+  getDBCompositeTypes >>= \case+    [] | noTablesPresent tablesWithVersions && ccm == CreateCompositesIfDatabaseEmpty -> do+      -- DB is not initialized, create composites if there are any defined.+      mapM_ (runQuery_ . sqlCreateComposite) compositeList+      return mempty+    dbCompositeTypes ->+      pure $+        mconcat+          [ checkNotPresentComposites+          , checkDatabaseComposites+          ]+      where+        compositeMap =+          M.fromList $+            map ((unRawSQL . ctName) &&& ctColumns) compositeList++        checkNotPresentComposites =+          let notPresent =+                S.toList $+                  M.keysSet compositeMap+                    S.\\ S.fromList (map (unRawSQL . ctName) dbCompositeTypes)+          in validateIsNull "Composite types not present in the database:" notPresent++        checkDatabaseComposites = mconcat . (`map` dbCompositeTypes) $ \dbComposite ->+          let cname = unRawSQL $ ctName dbComposite+          in case cname `M.lookup` compositeMap of+              Just columns ->+                topMessage "composite type" cname $+                  checkColumns 1 columns (ctColumns dbComposite)+              Nothing -> case ovm of+                AllowUnknownObjects -> mempty+                DontAllowUnknownObjects ->+                  validationError $+                    mconcat+                      [ "Composite type '"+                      , T.pack $ show dbComposite+                      , "' from the database doesn't have a corresponding code definition"+                      ]+          where+            checkColumns+              :: Int -> [CompositeColumn] -> [CompositeColumn] -> ValidationResult+            checkColumns _ [] [] = mempty+            checkColumns _ rest [] =+              validationError $+                objectHasLess "Composite type" "columns" rest+            checkColumns _ [] rest =+              validationError $+                objectHasMore "Composite type" "columns" rest+            checkColumns !n (d : defs) (c : cols) =+              mconcat+                [ validateNames $ ccName d == ccName c+                , validateTypes $ ccType d == ccType c+                , checkColumns (n + 1) defs cols+                ]+              where+                validateNames True = mempty+                validateNames False =+                  validationError $+                    errorMsg ("no. " <> showt n) "names" (unRawSQL . ccName)++                validateTypes True = mempty+                validateTypes False =+                  validationError $+                    errorMsg (unRawSQL $ ccName d) "types" (T.pack . show . ccType)++                errorMsg ident attr f =+                  "Column '"+                    <> ident+                    <> "' differs in"+                    <+> attr+                    <+> "(database:"+                    <+> f c+                    <> ", definition:"+                    <+> f d+                    <> ")."++-- | Checks whether the database is consistent.+checkDBStructure+  :: forall m+   . (MonadDB m, MonadThrow m)+  => ExtrasOptions+  -> TablesWithVersions+  -> m ValidationResult+checkDBStructure options tables = fmap mconcat . forM tables $ \(table, version) -> do+  result <- topMessage "table" (tblNameText table) <$> checkTableStructure table+  -- If we allow higher table versions in the database, show inconsistencies as+  -- info messages only.+  return $+    if eoAllowHigherTableVersions options && tblVersion table < version+      then validationErrorsToInfos result+      else result+  where+    checkTableStructure :: Table -> m ValidationResult+    checkTableStructure table@Table {..} = do+      -- get table description from pg_catalog as describeTable+      -- mechanism from HDBC doesn't give accurate results+      runQuery_ $ sqlSelect "pg_catalog.pg_attribute a" $ do+        sqlResult "a.attname::text"+        sqlResult "pg_catalog.format_type(a.atttypid, a.atttypmod)"+        sqlResult . parenthesize . toSQLCommand $+          sqlSelect "pg_catalog.pg_collation c, pg_catalog.pg_type t" $ do+            sqlResult "c.collname::text"+            -- `typcollation` specifies the default collation of the type (if+            -- any), and `attcollation` is the collation of the column.+            sqlWhere "c.oid = a.attcollation AND t.oid = a.atttypid AND a.attcollation <> t.typcollation"+        sqlResult "NOT a.attnotnull"+        sqlResult . parenthesize . toSQLCommand $+          sqlSelect "pg_catalog.pg_attrdef d" $ do+            sqlResult "pg_catalog.pg_get_expr(d.adbin, d.adrelid)"+            sqlWhere "d.adrelid = a.attrelid"+            sqlWhere "d.adnum = a.attnum"+            sqlWhere "a.atthasdef"+        sqlWhere "a.attnum > 0"+        sqlWhere "NOT a.attisdropped"+        sqlWhereEqSql "a.attrelid" $ sqlGetTableID table+        sqlOrderBy "a.attnum"+      desc <- fetchMany fetchTableColumn++      isAbove15 <- checkVersionIsAtLeast15+      -- get info about constraints from pg_catalog+      pk <- sqlGetPrimaryKey table+      runQuery_ $ sqlGetChecks table+      checks <- fetchMany fetchTableCheck+      runQuery_ $ sqlGetIndexes isAbove15 table+      indexes <- fetchMany fetchTableIndex+      runQuery_ $ sqlGetForeignKeys table+      fkeys <- fetchMany fetchForeignKey+      triggers <- getDBTriggers tblName+      checkedOverlaps <- checkOverlappingIndexes tblName+      return $+        mconcat+          [ checkColumns 1 tblColumns desc+          , checkPrimaryKey tblPrimaryKey pk+          , checkChecks tblChecks checks+          , checkIndexes tblIndexes indexes+          , checkForeignKeys tblForeignKeys fkeys+          , checkForeignKeyIndexes tblPrimaryKey tblForeignKeys tblIndexes+          , checkTriggers tblTriggers triggers+          , checkedOverlaps+          ]+      where+        fetchTableColumn+          :: (String, ColumnType, Maybe Text, Bool, Maybe String) -> TableColumn+        fetchTableColumn (name, ctype, collation, nullable, mdefault) =+          TableColumn+            { colName = unsafeSQL name+            , colType = ctype+            , colCollation = flip rawSQL () <$> collation+            , colNullable = nullable+            , colDefault = unsafeSQL <$> mdefault+            }++        checkColumns+          :: Int -> [TableColumn] -> [TableColumn] -> ValidationResult+        checkColumns _ [] [] = mempty+        checkColumns _ rest [] =+          validationError $+            objectHasLess "Table" "columns" rest+        checkColumns _ [] rest =+          validationError $+            objectHasMore "Table" "columns" rest+        checkColumns !n (d : defs) (c : cols) =+          mconcat+            [ validateNames $ colName d == colName c+            , -- bigserial == bigint + autoincrement and there is no+              -- distinction between them after table is created.+              validateTypes $+                colType d == colType c+                  || (colType d == BigSerialT && colType c == BigIntT)+            , -- There is a problem with default values determined by+              -- sequences as they're implicitly specified by db, so+              -- let's omit them in such case.+              validateDefaults $+                colDefault d == colDefault c+                  || ( isNothing (colDefault d)+                        && (T.isPrefixOf "nextval('" . unRawSQL <$> colDefault c)+                          == Just True+                     )+            , validateNullables $ colNullable d == colNullable c+            , checkColumns (n + 1) defs cols+            ]+          where+            validateNames True = mempty+            validateNames False =+              validationError $+                errorMsg ("no. " <> showt n) "names" (unRawSQL . colName)++            validateTypes True = mempty+            validateTypes False =+              validationError $+                errorMsg cname "types" (T.pack . show . colType)+                  <+> sqlHint ("TYPE" <+> columnTypeToSQL (colType d))++            validateNullables True = mempty+            validateNullables False =+              validationError $+                errorMsg cname "nullables" (showt . colNullable)+                  <+> sqlHint+                    ( (if colNullable d then "DROP" else "SET")+                        <+> "NOT NULL"+                    )++            validateDefaults True = mempty+            validateDefaults False =+              validationError $+                errorMsg cname "defaults" (showt . fmap unRawSQL . colDefault)+                  <+> sqlHint set_default+              where+                set_default = case colDefault d of+                  Just v -> "SET DEFAULT" <+> v+                  Nothing -> "DROP DEFAULT"++            cname = unRawSQL $ colName d+            errorMsg ident attr f =+              "Column '"+                <> ident+                <> "' differs in"+                <+> attr+                <+> "(table:"+                <+> f c+                <> ", definition:"+                <+> f d+                <> ")."+            sqlHint sql =+              "(HINT: SQL for making the change is: ALTER TABLE"+                <+> tblNameText table+                <+> "ALTER COLUMN"+                <+> unRawSQL (colName d)+                <+> unRawSQL sql+                <> ")"++        checkPrimaryKey+          :: Maybe PrimaryKey+          -> Maybe (PrimaryKey, RawSQL ())+          -> ValidationResult+        checkPrimaryKey mdef mpk =+          mconcat+            [ checkEquality "PRIMARY KEY" def (map fst pk)+            , checkNames (const (pkName tblName)) pk+            , if eoEnforcePKs options+                then checkPKPresence tblName mdef mpk+                else mempty+            ]+          where+            def = maybeToList mdef+            pk = maybeToList mpk++        checkChecks :: [Check] -> [Check] -> ValidationResult+        checkChecks defs checks =+          mapValidationResult id mapErrs (checkEquality "CHECKs" defs checks)+          where+            mapErrs [] = []+            mapErrs errmsgs =+              errmsgs+                <> [ " (HINT: If checks are equal modulo number of \+                     \ parentheses/whitespaces used in conditions, \+                     \ just copy and paste expected output into source code)"+                   ]++        checkIndexes+          :: [TableIndex]+          -> [(TableIndex, RawSQL ())]+          -> ValidationResult+        checkIndexes defs allIndexes =+          mconcat $+            checkEquality "INDEXes" defs (map fst indexes)+              : checkNames (indexName tblName) indexes+              : map localIndexInfo localIndexes+          where+            localIndexInfo (index, name) =+              validationInfo $+                T.concat+                  [ "Found a local index '"+                  , unRawSQL name+                  , "': "+                  , T.pack (show index)+                  ]++            (localIndexes, indexes) = (`partition` allIndexes) $ \(_, name) ->+              -- Manually created indexes for ad-hoc improvements.+              "local_" `T.isPrefixOf` unRawSQL name+                -- Indexes related to the REINDEX operation, see+                -- https://www.postgresql.org/docs/15/sql-reindex.html+                || "_ccnew" `T.isSuffixOf` unRawSQL name+                || "_ccold" `T.isSuffixOf` unRawSQL name++        checkForeignKeys+          :: [ForeignKey]+          -> [(ForeignKey, RawSQL ())]+          -> ValidationResult+        checkForeignKeys defs fkeys =+          mconcat+            [ checkEquality "FOREIGN KEYs" defs (map fst fkeys)+            , checkNames (fkName tblName) fkeys+            ]++        checkForeignKeyIndexes :: Maybe PrimaryKey -> [ForeignKey] -> [TableIndex] -> ValidationResult+        checkForeignKeyIndexes pkey foreignKeys indexes =+          if eoCheckForeignKeysIndexes options+            then foldMap' go foreignKeys+            else mempty+          where+            -- Map index on the given table name to a list of list of names+            -- so that index on a and index on (b, c) becomes [[a], [b, c,]].+            allIndexes :: [[RawSQL ()]]+            allIndexes = fmap (fmap indexColumnName . idxColumns) . filter (isNothing . idxWhere) $ indexes++            allCoverage :: [[RawSQL ()]]+            allCoverage = maybe [] pkColumns pkey : allIndexes+            -- A foreign key is covered if it is a prefix of a list of indices.+            -- So a FK on a is covered by an index on (a, b) but not an index on (b, a).+            coveredFK :: ForeignKey -> [[RawSQL ()]] -> Bool+            coveredFK fk = any (\idx -> fkColumns fk `L.isPrefixOf` idx)++            go :: ForeignKey -> ValidationResult+            go fk =+              let columns = map unRawSQL (fkColumns fk)+              in if coveredFK fk allCoverage+                  then mempty+                  else validationError $ mconcat ["\n  ● Foreign key '(", T.intercalate "," columns, ")' is missing an index"]++        checkTriggers :: [Trigger] -> [(Trigger, RawSQL ())] -> ValidationResult+        checkTriggers defs triggers =+          mapValidationResult id mapErrs $ checkEquality "TRIGGERs" defs' triggers+          where+            defs' = map (\t -> (t, triggerFunctionMakeName $ triggerName t)) defs+            mapErrs [] = []+            mapErrs errmsgs =+              errmsgs+                <> [ "(HINT: If WHEN clauses are equal modulo number of parentheses, whitespace, \+                     \case of variables or type casts used in conditions, just copy and paste \+                     \expected output into source code.)"+                   ]++        checkOverlappingIndexes :: MonadDB m => RawSQL () -> m ValidationResult+        checkOverlappingIndexes tableName =+          if eoCheckOverlappingIndexes options+            then go+            else pure mempty+          where+            go = do+              let handleOverlap (contained, contains) =+                    mconcat+                      [ "\n  ●  Index "+                      , contains+                      , " contains index "+                      , contained+                      ]+              runSQL_ $ checkOverlappingIndexesQuery tableName+              overlaps <- fetchMany handleOverlap+              pure $+                if null overlaps+                  then mempty+                  else validationError . T.unlines $ "Some indexes are overlapping" : overlaps++-- | Checks whether database is consistent, performing migrations if+-- necessary. Requires all table names to be in lower case.+--+-- The migrations list must have the following properties:+--   * consecutive 'mgrFrom' numbers+--   * no duplicates+--   * all 'mgrFrom' are less than table version number of the table in+--     the 'tables' list+checkDBConsistency+  :: forall m+   . (MonadIO m, MonadDB m, MonadLog m, MonadMask m)+  => ExtrasOptions+  -> [Domain]+  -> [EnumType]+  -> TablesWithVersions+  -> [Migration m]+  -> m ()+checkDBConsistency options domains enums tablesWithVersions migrations = do+  autoTransaction <- tsAutoTransaction <$> getTransactionSettings+  unless autoTransaction $ do+    error "checkDBConsistency: tsAutoTransaction setting needs to be True"+  -- Check the validity of the migrations list.+  validateMigrations+  validateDropTableMigrations++  -- Load version numbers of the tables that actually exist in the DB.+  dbTablesWithVersions <- getDBTableVersions++  if noTablesPresent tablesWithVersions+    -- No tables are present, create everything from scratch.+    then do+      createDBSchema+      initializeDB++    -- Migration mode.+    else do+      -- Additional validity checks for the migrations list.+      validateMigrationsAgainstDB+        [ (tblName table, tblVersion table, actualVer)+        | (table, actualVer) <- tablesWithVersions+        ]+      validateDropTableMigrationsAgainstDB dbTablesWithVersions+      -- Run migrations, if necessary.+      runMigrations dbTablesWithVersions+  where+    tables = map fst tablesWithVersions++    errorInvalidMigrations :: HasCallStack => [RawSQL ()] -> a+    errorInvalidMigrations tblNames =+      error $+        "checkDBConsistency: invalid migrations for tables"+          <+> L.intercalate ", " (map (T.unpack . unRawSQL) tblNames)++    checkMigrationsListValidity :: Table -> [Int32] -> [Int32] -> m ()+    checkMigrationsListValidity+      table+      presentMigrationVersions+      expectedMigrationVersions = do+        when (presentMigrationVersions /= expectedMigrationVersions) $ do+          logAttention "Migrations are invalid" $+            object+              [ "table" .= tblNameText table+              , "migration_versions" .= presentMigrationVersions+              , "expected_migration_versions" .= expectedMigrationVersions+              ]+          errorInvalidMigrations [tblName table]++    validateMigrations :: m ()+    validateMigrations = forM_ tables $ \table -> do+      -- FIXME: https://github.com/scrive/hpqtypes-extras/issues/73+      let presentMigrationVersions =+            [ mgrFrom | Migration {..} <- migrations, mgrTableName == tblName table+            ]+          expectedMigrationVersions =+            reverse $+              take (length presentMigrationVersions) $+                reverse [0 .. tblVersion table - 1]+      checkMigrationsListValidity+        table+        presentMigrationVersions+        expectedMigrationVersions++    validateDropTableMigrations :: m ()+    validateDropTableMigrations = do+      let droppedTableNames =+            [ mgrTableName mgr | mgr <- migrations, isDropTableMigration mgr+            ]+          tableNames =+            [tblName tbl | tbl <- tables]++      -- Check that the intersection between the 'tables' list and+      -- dropped tables is empty.+      let intersection = L.intersect droppedTableNames tableNames+      unless (null intersection) $ do+        logAttention+          ( "The intersection between tables "+              <> "and dropped tables is not empty"+          )+          $ object+            ["intersection" .= map unRawSQL intersection]+        errorInvalidMigrations+          [ tblName tbl+          | tbl <- tables+          , tblName tbl `elem` intersection+          ]++      -- Check that if a list of migrations for a given table has a+      -- drop table migration, it is unique and is the last migration+      -- in the list.+      let migrationsByTable =+            L.groupBy+              ((==) `on` mgrTableName)+              migrations+          dropMigrationLists =+            [ mgrs | mgrs <- migrationsByTable, any isDropTableMigration mgrs+            ]+          invalidMigrationLists =+            [ mgrs | mgrs <- dropMigrationLists, (not . isDropTableMigration . last $ mgrs)+                                                  || (length . filter isDropTableMigration $ mgrs) > 1+            ]++      unless (null invalidMigrationLists) $ do+        let tablesWithInvalidMigrationLists =+              [ mgrTableName mgr | mgrs <- invalidMigrationLists, let mgr = head mgrs+              ]+        logAttention+          ( "Migration lists for some tables contain "+              <> "either multiple drop table migrations or "+              <> "a drop table migration in non-tail position."+          )+          $ object+            [ "tables"+                .= [ unRawSQL tblName+                   | tblName <- tablesWithInvalidMigrationLists+                   ]+            ]+        errorInvalidMigrations tablesWithInvalidMigrationLists++    createDBSchema :: m ()+    createDBSchema = do+      logInfo_ "Creating domains..."+      mapM_ createDomain domains+      logInfo_ "Creating enums..."+      mapM_ (runQuery_ . sqlCreateEnum) enums+      -- Create all tables with no constraints first to allow cyclic references.+      logInfo_ "Creating tables..."+      mapM_ (createTable False) tables+      logInfo_ "Creating table constraints..."+      mapM_ createTableConstraints tables+      logInfo_ "Done."++    initializeDB :: m ()+    initializeDB = do+      logInfo_ "Running initial setup for tables..."+      forM_ tables $ \t -> case tblInitialSetup t of+        Nothing -> return ()+        Just tis -> do+          logInfo_ $ "Initializing" <+> tblNameText t <> "..."+          initialSetup tis+      logInfo_ "Done."++    -- \| Input is a list of (table name, expected version, actual+    -- version) triples.+    validateMigrationsAgainstDB :: [(RawSQL (), Int32, Int32)] -> m ()+    validateMigrationsAgainstDB tablesWithVersions_ =+      forM_ tablesWithVersions_ $ \(tableName, expectedVer, actualVer) ->+        when (expectedVer /= actualVer) $+          case [ m | m@Migration {..} <- migrations, mgrTableName == tableName+               ] of+            [] ->+              error $+                "checkDBConsistency: no migrations found for table '"+                  ++ (T.unpack . unRawSQL $ tableName)+                  ++ "', cannot migrate "+                  ++ show actualVer+                  ++ " -> "+                  ++ show expectedVer+            (m : _)+              | mgrFrom m > actualVer ->+                  error $+                    "checkDBConsistency: earliest migration for table '"+                      ++ (T.unpack . unRawSQL $ tableName)+                      ++ "' is from version "+                      ++ show (mgrFrom m)+                      ++ ", cannot migrate "+                      ++ show actualVer+                      ++ " -> "+                      ++ show expectedVer+              | otherwise -> return ()++    validateDropTableMigrationsAgainstDB :: [(Text, Int32)] -> m ()+    validateDropTableMigrationsAgainstDB dbTablesWithVersions = do+      let dbTablesToDropWithVersions =+            [ (tblName, mgrFrom mgr, fromJust mver)+            | mgr <- migrations+            , isDropTableMigration mgr+            , let tblName = mgrTableName mgr+            , let mver = lookup (unRawSQL tblName) dbTablesWithVersions+            , isJust mver+            ]+      forM_ dbTablesToDropWithVersions $ \(tblName, fromVer, ver) ->+        when (fromVer /= ver) $+          -- In case when the table we're going to drop is an old+          -- version, check that there are migrations that bring it to+          -- a new one.+          validateMigrationsAgainstDB [(tblName, fromVer, ver)]++    findMigrationsToRun :: [(Text, Int32)] -> [Migration m]+    findMigrationsToRun dbTablesWithVersions =+      let tableNamesToDrop =+            [ mgrTableName mgr | mgr <- migrations, isDropTableMigration mgr+            ]+          droppedEventually :: Migration m -> Bool+          droppedEventually mgr = mgrTableName mgr `elem` tableNamesToDrop++          lookupVer :: Migration m -> Maybe Int32+          lookupVer mgr =+            lookup+              (unRawSQL $ mgrTableName mgr)+              dbTablesWithVersions++          tableDoesNotExist = isNothing . lookupVer++          -- The idea here is that we find the first migration we need+          -- to run and then just run all migrations in order after+          -- that one.+          migrationsToRun' =+            dropWhile+              ( \mgr ->+                  case lookupVer mgr of+                    -- Table doesn't exist in the DB. If it's a create+                    -- table migration and we're not going to drop the+                    -- table afterwards, this is our starting point.+                    Nothing ->+                      not $+                        (mgrFrom mgr == 0)+                          && (not . droppedEventually $ mgr)+                    -- Table exists in the DB. Run only those migrations+                    -- that have mgrFrom >= table version in the DB.+                    Just ver -> mgrFrom mgr < ver+              )+              migrations++          -- Special case: also include migrations for tables that do+          -- not exist in the DB and ARE going to be dropped if they+          -- come as a consecutive list before the starting point that+          -- we've found.+          --+          -- Case in point: createTable t, doSomethingTo t,+          -- doSomethingTo t1, dropTable t. If our starting point is+          -- 'doSomethingTo t1', and that step depends on 't',+          -- 'doSomethingTo t1' will fail. So we include 'createTable+          -- t' and 'doSomethingTo t' as well.+          l = length migrationsToRun'+          initialMigrations = drop l $ reverse migrations+          additionalMigrations' =+            takeWhile+              (\mgr -> droppedEventually mgr && tableDoesNotExist mgr)+              initialMigrations+          -- Check that all extra migration chains we've chosen begin+          -- with 'createTable', otherwise skip adding them (to+          -- prevent raising an exception during the validation step).+          additionalMigrations =+            let ret = reverse additionalMigrations'+                grps = L.groupBy ((==) `on` mgrTableName) ret+            in if any ((/=) 0 . mgrFrom . head) grps+                then []+                else ret+          -- Also there's no point in adding these extra migrations if+          -- we're not running any migrations to begin with.+          migrationsToRun =+            if not . null $ migrationsToRun'+              then additionalMigrations ++ migrationsToRun'+              else []+      in migrationsToRun++    runMigration :: Migration m -> m ()+    runMigration Migration {..} = do+      case mgrAction of+        StandardMigration mgrDo -> do+          logMigration+          mgrDo+          updateTableVersion+        DropTableMigration mgrDropTableMode -> do+          logInfo_ $ arrListTable mgrTableName <> "drop table"+          runQuery_ $+            sqlDropTable+              mgrTableName+              mgrDropTableMode+          runQuery_ $ sqlDelete "table_versions" $ do+            sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName)+        CreateIndexConcurrentlyMigration tname idx -> do+          logMigration+          -- We're in auto transaction mode (as ensured at the beginning of+          -- 'checkDBConsistency'), so we need to issue explicit SQL commit,+          -- because using 'commit' function automatically starts another+          -- transaction. We don't want that as concurrent creation of index+          -- won't run inside a transaction.+          bracket_ (runSQL_ "COMMIT") (runSQL_ "BEGIN") $ do+            -- If migration was run before but creation of an index failed, index+            -- will be left in the database in an inactive state, so when we+            -- rerun, we need to remove it first (see+            -- https://www.postgresql.org/docs/9.6/sql-createindex.html for more+            -- information).+            runQuery_ $ "DROP INDEX CONCURRENTLY IF EXISTS" <+> indexName tname idx+            runQuery_ (sqlCreateIndexConcurrently tname idx)+          updateTableVersion+        DropIndexConcurrentlyMigration tname idx -> do+          logMigration+          -- We're in auto transaction mode (as ensured at the beginning of+          -- 'checkDBConsistency'), so we need to issue explicit SQL commit,+          -- because using 'commit' function automatically starts another+          -- transaction. We don't want that as concurrent dropping of index+          -- won't run inside a transaction.+          bracket_ (runSQL_ "COMMIT") (runSQL_ "BEGIN") $ do+            runQuery_ (sqlDropIndexConcurrently tname idx)+          updateTableVersion+        ModifyColumnMigration tableName cursorSql updateSql batchSize -> do+          logMigration+          when (batchSize < 1000) $ do+            error "Batch size cannot be less than 1000"+          withCursorSQL "migration_cursor" NoScroll Hold cursorSql $ \cursor -> do+            -- Vacuum should be done approximately once every 5% of the table+            -- has been updated, or every 1000 rows as a minimum.+            --+            -- In PostgreSQL, when a record is updated, a new version of this+            -- record is created. The old one is destroyed by the "vacuum"+            -- command when no transaction needs it anymore. So there's an+            -- autovacuum daemon whose purpose is to do this cleanup, and that+            -- is sufficient most of the time. We assume that it's tuned to try+            -- to keep the "bloat" (dead records) at around 10% of the table+            -- size in the environment, and it's also tuned to not saturate the+            -- server with IO operations while doing the vacuum - vacuuming is+            -- IO intensive as there are a lot of reads and rewrites, which+            -- makes it slow and costly. So, autovacuum wouldn't be able to keep+            -- up with the aggressive batch update. Therefore we need to run+            -- vacuum ourselves, to keep things in check. The 5% limit is+            -- arbitrary, but a reasonable ballpark estimate: it more or less+            -- makes sure we keep dead records in the 10% envelope and the table+            -- doesn't grow too much during the operation.+            vacuumThreshold <- max 1000 . fromIntegral . (`div` 20) <$> getRowEstimate tableName+            let cursorLoop processed = do+                  cursorFetch_ cursor (CD_Forward batchSize)+                  primaryKeys <- fetchMany id+                  unless (null primaryKeys) $ do+                    updateSql primaryKeys+                    if processed + batchSize >= vacuumThreshold+                      then do+                        bracket_+                          (runSQL_ "COMMIT")+                          (runSQL_ "BEGIN")+                          (runQuery_ $ "VACUUM" <+> tableName)+                        cursorLoop 0+                      else do+                        commit+                        cursorLoop (processed + batchSize)+            cursorLoop 0+          updateTableVersion+      where+        logMigration = do+          logInfo_ $+            arrListTable mgrTableName+              <> showt mgrFrom+              <+> "->"+              <+> showt (succ mgrFrom)++        updateTableVersion = do+          runQuery_ $ sqlUpdate "table_versions" $ do+            sqlSet "version" (succ mgrFrom)+            sqlWhereEq "name" (T.unpack . unRawSQL $ mgrTableName)++        -- Get the estimated number of rows of the given table. It might not+        -- work properly if the table is present in multiple database schemas.+        -- See https://wiki.postgresql.org/wiki/Count_estimate.+        getRowEstimate :: MonadDB m => RawSQL () -> m Int32+        getRowEstimate tableName = do+          runQuery_ . sqlSelect "pg_class" $ do+            sqlResult "reltuples::integer"+            sqlWhereEq "relname" $ unRawSQL tableName+          fetchOne runIdentity++    runMigrations :: [(Text, Int32)] -> m ()+    runMigrations dbTablesWithVersions = do+      let migrationsToRun = findMigrationsToRun dbTablesWithVersions+      validateMigrationsToRun migrationsToRun dbTablesWithVersions+      unless (null migrationsToRun) $ do+        logInfo_ "Running migrations..."+        forM_ migrationsToRun $ \mgr -> fix $ \loop -> do+          let restartMigration query = do+                logAttention "Failed to acquire a lock" $ object ["query" .= query]+                logInfo_ "Restarting the migration shortly..."+                liftIO $ threadDelay 1000000+                loop+          handleJust lockNotAvailable restartMigration $ do+            forM_ (eoLockTimeoutMs options) $ \lockTimeout -> do+              runSQL_ $ "SET LOCAL lock_timeout TO" <+> intToSQL lockTimeout+            runMigration mgr `onException` rollback+            logInfo_ "Committing migration changes..."+            commit+        logInfo_ "Running migrations... done."+      where+        intToSQL :: Int -> SQL+        intToSQL = unsafeSQL . show++        lockNotAvailable :: DBException -> Maybe String+        lockNotAvailable DBException {..}+          | Just DetailedQueryError {..} <- cast dbeError+          , qeErrorCode == LockNotAvailable =+              Just $ show dbeQueryContext+          | otherwise = Nothing++    validateMigrationsToRun :: [Migration m] -> [(Text, Int32)] -> m ()+    validateMigrationsToRun migrationsToRun dbTablesWithVersions = do+      let migrationsToRunGrouped :: [[Migration m]]+          migrationsToRunGrouped =+            L.groupBy ((==) `on` mgrTableName)+              . L.sortOn mgrTableName+              $ migrationsToRun -- NB: stable sort+          loc_common =+            "Database.PostgreSQL.PQTypes.Checks."+              ++ "checkDBConsistency.validateMigrationsToRun"++          lookupDBTableVer :: [Migration m] -> Maybe Int32+          lookupDBTableVer mgrGroup =+            lookup+              ( unRawSQL . mgrTableName . headExc head_err $+                  mgrGroup+              )+              dbTablesWithVersions+            where+              head_err = loc_common ++ ".lookupDBTableVer: broken invariant"++          groupsWithWrongDBTableVersions :: [([Migration m], Int32)]+          groupsWithWrongDBTableVersions =+            [ (mgrGroup, dbTableVer)+            | mgrGroup <- migrationsToRunGrouped+            , let dbTableVer = fromMaybe 0 $ lookupDBTableVer mgrGroup+            , dbTableVer /= (mgrFrom . headExc head_err $ mgrGroup)+            ]+            where+              head_err =+                loc_common+                  ++ ".groupsWithWrongDBTableVersions: broken invariant"++          mgrGroupsNotInDB :: [[Migration m]]+          mgrGroupsNotInDB =+            [ mgrGroup+            | mgrGroup <- migrationsToRunGrouped+            , isNothing $ lookupDBTableVer mgrGroup+            ]++          groupsStartingWithDropTable :: [[Migration m]]+          groupsStartingWithDropTable =+            [ mgrGroup+            | mgrGroup <- mgrGroupsNotInDB+            , isDropTableMigration . headExc head_err $ mgrGroup+            ]+            where+              head_err =+                loc_common+                  ++ ".groupsStartingWithDropTable: broken invariant"++          groupsNotStartingWithCreateTable :: [[Migration m]]+          groupsNotStartingWithCreateTable =+            [ mgrGroup+            | mgrGroup <- mgrGroupsNotInDB+            , mgrFrom (headExc head_err mgrGroup) /= 0+            ]+            where+              head_err =+                loc_common+                  ++ ".groupsNotStartingWithCreateTable: broken invariant"++          tblNames :: [[Migration m]] -> [RawSQL ()]+          tblNames grps =+            [mgrTableName . headExc head_err $ grp | grp <- grps]+            where+              head_err = loc_common ++ ".tblNames: broken invariant"++      unless (null groupsWithWrongDBTableVersions) $ do+        let tnms = tblNames . map fst $ groupsWithWrongDBTableVersions+        logAttention+          ( "There are migration chains selected for execution "+              <> "that expect a different starting table version number "+              <> "from the one in the database. "+              <> "This likely means that the order of migrations is wrong."+          )+          $ object ["tables" .= map unRawSQL tnms]+        errorInvalidMigrations tnms++      unless (null groupsStartingWithDropTable) $ do+        let tnms = tblNames groupsStartingWithDropTable+        logAttention "There are drop table migrations for non-existing tables." $+          object ["tables" .= map unRawSQL tnms]+        errorInvalidMigrations tnms++      -- NB: the following check can break if we allow renaming tables.+      unless (null groupsNotStartingWithCreateTable) $ do+        let tnms = tblNames groupsNotStartingWithCreateTable+        logAttention+          ( "Some tables haven't been created yet, but"+              <> "their migration lists don't start with a create table migration."+          )+          $ object ["tables" .= map unRawSQL tnms]+        errorInvalidMigrations tnms++-- | Type synonym for a list of tables along with their database versions.+type TablesWithVersions = [(Table, Int32)]++-- The server_version_num has been there since 8.2+checkVersionIsAtLeast15 :: (MonadDB m, MonadThrow m) => m Bool+checkVersionIsAtLeast15 = do+  runSQL01_ "select current_setting('server_version_num',true)::int >= 150000;"+  fetchOne runIdentity++-- | Associate each table in the list with its version as it exists in+-- the DB, or 0 if it's missing from the DB.+getTableVersions :: (MonadDB m, MonadThrow m) => [Table] -> m TablesWithVersions+getTableVersions tbls =+  sequence+    [ (\mver -> (tbl, fromMaybe 0 mver)) <$> checkTableVersion (tblNameString tbl)+    | tbl <- tbls+    ]++-- | Given a result of 'getTableVersions' check if no tables are present in the+-- database.+noTablesPresent :: TablesWithVersions -> Bool+noTablesPresent = all ((==) 0 . snd)++-- | Like 'getTableVersions', but for all user-defined tables that+-- actually exist in the DB.+getDBTableVersions :: (MonadDB m, MonadThrow m) => m [(Text, Int32)]+getDBTableVersions = do+  dbTableNames <- getDBTableNames+  sequence+    [ (\mver -> (name, fromMaybe 0 mver)) <$> checkTableVersion (T.unpack name)+    | name <- dbTableNames+    ]++-- | Check whether the table exists in the DB, and return 'Just' its+-- version if it does, or 'Nothing' if it doesn't.+checkTableVersion :: (MonadDB m, MonadThrow m) => String -> m (Maybe Int32)+checkTableVersion tblName = do+  doesExist <- runQuery01 . sqlSelect "pg_catalog.pg_class c" $ do+    sqlResult "TRUE"+    sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace"+    sqlWhereEq "c.relname" tblName+    sqlWhere "pg_catalog.pg_table_is_visible(c.oid)"+  if doesExist+    then do+      runQuery_ $+        "SELECT version FROM table_versions WHERE name ="+          <?> tblName+      mver <- fetchMaybe runIdentity+      case mver of+        Just ver -> return $ Just ver+        Nothing ->+          error $+            "checkTableVersion: table '"+              ++ tblName+              ++ "' is present in the database, "+              ++ "but there is no corresponding version info in 'table_versions'."+    else do+      return Nothing++-- *** TABLE STRUCTURE ***++sqlGetTableID :: Table -> SQL+sqlGetTableID table = parenthesize . toSQLCommand $+  sqlSelect "pg_catalog.pg_class c" $ do+    sqlResult "c.oid"+    sqlLeftJoinOn "pg_catalog.pg_namespace n" "n.oid = c.relnamespace"+    sqlWhereEq "c.relname" $ tblNameString table+    sqlWhere "pg_catalog.pg_table_is_visible(c.oid)"++-- *** PRIMARY KEY ***++sqlGetPrimaryKey+  :: (MonadDB m, MonadThrow m)+  => Table+  -> m (Maybe (PrimaryKey, RawSQL ()))+sqlGetPrimaryKey table = do+  (mColumnNumbers :: Maybe [Int16]) <- do+    runQuery_ . sqlSelect "pg_catalog.pg_constraint" $ do+      sqlResult "conkey"+      sqlWhereEqSql "conrelid" (sqlGetTableID table)+      sqlWhereEq "contype" 'p'+    fetchMaybe $ unArray1 . runIdentity++  case mColumnNumbers of+    Nothing -> do return Nothing+    Just columnNumbers -> do+      columnNames <- do+        forM columnNumbers $ \k -> do+          runQuery_ . sqlSelect "pk_columns" $ do+            sqlWith "key_series" . sqlSelect "pg_constraint as c2" $ do+              sqlResult "unnest(c2.conkey) as k"+              sqlWhereEqSql "c2.conrelid" $ sqlGetTableID table+              sqlWhereEq "c2.contype" 'p'++            sqlWith "pk_columns" . sqlSelect "key_series" $ do+              sqlJoinOn "pg_catalog.pg_attribute as a" "a.attnum = key_series.k"+              sqlResult "a.attname::text as column_name"+              sqlResult "key_series.k as column_order"+              sqlWhereEqSql "a.attrelid" $ sqlGetTableID table++            sqlResult "pk_columns.column_name"+            sqlWhereEq "pk_columns.column_order" k++          fetchOne (\(Identity t) -> t :: String)++      runQuery_ . sqlSelect "pg_catalog.pg_constraint as c" $ do+        sqlWhereEq "c.contype" 'p'+        sqlWhereEqSql "c.conrelid" $ sqlGetTableID table+        sqlResult "c.conname::text"+        sqlResult $+          Data.String.fromString+            ("array['" <> mintercalate "', '" columnNames <> "']::text[]")++      join <$> fetchMaybe fetchPrimaryKey++fetchPrimaryKey :: (String, Array1 String) -> Maybe (PrimaryKey, RawSQL ())+fetchPrimaryKey (name, Array1 columns) =+  (,unsafeSQL name)+    <$> pkOnColumns (map unsafeSQL columns)++-- *** CHECKS ***++sqlGetChecks :: Table -> SQL+sqlGetChecks table = toSQLCommand . sqlSelect "pg_catalog.pg_constraint c" $ do+  sqlResult "c.conname::text"+  sqlResult+    "regexp_replace(pg_get_constraintdef(c.oid, true), \+    \'CHECK \\((.*)\\)', '\\1') AS body" -- check body+  sqlResult "c.convalidated" -- validated?+  sqlWhereEq "c.contype" 'c'+  sqlWhereEqSql "c.conrelid" $ sqlGetTableID table++fetchTableCheck :: (String, String, Bool) -> Check+fetchTableCheck (name, condition, validated) =+  Check+    { chkName = unsafeSQL name+    , chkCondition = unsafeSQL condition+    , chkValidated = validated+    }++-- *** INDEXES ***+sqlGetIndexes :: Bool -> Table -> SQL+sqlGetIndexes nullsNotDistinctSupported table = toSQLCommand . sqlSelect "pg_catalog.pg_class c" $ do+  sqlResult "c.relname::text" -- index name+  sqlResult $ "ARRAY(" <> selectCoordinates "0" "i.indnkeyatts" <> ")" -- array of key columns in the index+  sqlResult $ "ARRAY(" <> selectCoordinates "i.indnkeyatts" "i.indnatts" <> ")" -- array of included columns in the index+  sqlResult "am.amname::text" -- the method used (btree, gin etc)+  sqlResult "i.indisunique" -- is it unique?+  sqlResult "i.indisvalid" -- is it valid?+  -- does it have NULLS NOT DISTINCT ?+  if nullsNotDistinctSupported+    then sqlResult "i.indnullsnotdistinct"+    else sqlResult "false"+  -- if partial, get constraint def+  sqlResult "pg_catalog.pg_get_expr(i.indpred, i.indrelid, true)"+  sqlJoinOn "pg_catalog.pg_index i" "c.oid = i.indexrelid"+  sqlJoinOn "pg_catalog.pg_am am" "c.relam = am.oid"+  sqlLeftJoinOn+    "pg_catalog.pg_constraint r"+    "r.conrelid = i.indrelid AND r.conindid = i.indexrelid"+  sqlWhereEqSql "i.indrelid" $ sqlGetTableID table+  sqlWhereIsNULL "r.contype" -- fetch only "pure" indexes+  where+    -- Get all coordinates of the index.+    selectCoordinates start end =+      smconcat+        [ "WITH RECURSIVE coordinates(k, name) AS ("+        , "  VALUES (" <> start <> "::integer, NULL)"+        , "  UNION ALL"+        , "    SELECT k+1, pg_catalog.pg_get_indexdef(i.indexrelid, k+1, true)"+        , "      FROM coordinates"+        , "     WHERE k < " <> end+        , ")"+        , "SELECT name FROM coordinates WHERE name IS NOT NULL"+        ]++fetchTableIndex+  :: (String, Array1 String, Array1 String, String, Bool, Bool, Bool, Maybe String)+  -> (TableIndex, RawSQL ())+fetchTableIndex (name, Array1 keyColumns, Array1 includeColumns, method, unique, valid, nullsNotDistinct, mconstraint) =+  ( TableIndex+      { idxColumns = map (indexColumn . unsafeSQL) keyColumns+      , idxInclude = map unsafeSQL includeColumns+      , idxMethod = read method+      , idxUnique = unique+      , idxValid = valid+      , idxWhere = unsafeSQL <$> mconstraint+      , idxNotDistinctNulls = nullsNotDistinct+      }+  , unsafeSQL name+  )++-- *** FOREIGN KEYS ***++sqlGetForeignKeys :: Table -> SQL+sqlGetForeignKeys table = toSQLCommand+  . sqlSelect "pg_catalog.pg_constraint r"+  $ do+    sqlResult "r.conname::text" -- fk name+    sqlResult $+      "ARRAY(SELECT a.attname::text FROM pg_catalog.pg_attribute a JOIN ("+        <> unnestWithOrdinality "r.conkey"+        <> ") conkeys ON (a.attnum = conkeys.item) \+           \WHERE a.attrelid = r.conrelid \+           \ORDER BY conkeys.n)" -- constrained columns+    sqlResult "c.relname::text" -- referenced table+    sqlResult $+      "ARRAY(SELECT a.attname::text \+      \FROM pg_catalog.pg_attribute a JOIN ("+        <> unnestWithOrdinality "r.confkey"+        <> ") confkeys ON (a.attnum = confkeys.item) \+           \WHERE a.attrelid = r.confrelid \+           \ORDER BY confkeys.n)" -- referenced columns+    sqlResult "r.confupdtype" -- on update+    sqlResult "r.confdeltype" -- on delete+    sqlResult "r.condeferrable" -- deferrable?+    sqlResult "r.condeferred" -- initially deferred?+    sqlResult "r.convalidated" -- validated?+    sqlJoinOn "pg_catalog.pg_class c" "c.oid = r.confrelid"+    sqlWhereEqSql "r.conrelid" $ sqlGetTableID table+    sqlWhereEq "r.contype" 'f'+  where+    unnestWithOrdinality :: RawSQL () -> SQL+    unnestWithOrdinality arr =+      "SELECT n, "+        <> raw arr+        <> "[n] AS item FROM generate_subscripts("+        <> raw arr+        <> ", 1) AS n"++fetchForeignKey+  :: (String, Array1 String, String, Array1 String, Char, Char, Bool, Bool, Bool)+  -> (ForeignKey, RawSQL ())+fetchForeignKey+  ( name+    , Array1 columns+    , reftable+    , Array1 refcolumns+    , on_update+    , on_delete+    , deferrable+    , deferred+    , validated+    ) =+    ( ForeignKey+        { fkColumns = map unsafeSQL columns+        , fkRefTable = unsafeSQL reftable+        , fkRefColumns = map unsafeSQL refcolumns+        , fkOnUpdate = charToForeignKeyAction on_update+        , fkOnDelete = charToForeignKeyAction on_delete+        , fkDeferrable = deferrable+        , fkDeferred = deferred+        , fkValidated = validated+        }+    , unsafeSQL name+    )+    where+      charToForeignKeyAction c = case c of+        'a' -> ForeignKeyNoAction+        'r' -> ForeignKeyRestrict+        'c' -> ForeignKeyCascade+        'n' -> ForeignKeySetNull+        'd' -> ForeignKeySetDefault+        _ ->+          error $+            "fetchForeignKey: invalid foreign key action code: "+              ++ show c

@@ -1,85 +1,99 @@ {-# LANGUAGE CPP #-}-module Database.PostgreSQL.PQTypes.Checks.Util (-  ValidationResult,-  validationError,-  validationInfo,-  mapValidationResult,-  validationErrorsToInfos,-  resultCheck,-  topMessage,-  tblNameText,-  tblNameString,-  checkEquality,-  checkNames,-  checkPKPresence,-  objectHasLess,-  objectHasMore,-  arrListTable++module Database.PostgreSQL.PQTypes.Checks.Util+  ( ValidationResult+  , validationError+  , validationInfo+  , mapValidationResult+  , validationErrorsToInfos+  , resultCheck+  , resultHasErrors+  , topMessage+  , tblNameText+  , tblNameString+  , checkEquality+  , checkNames+  , checkPKPresence+  , objectHasLess+  , objectHasMore+  , arrListTable+  , checkOverlappingIndexesQuery   ) where  import Control.Monad.Catch #if !MIN_VERSION_base(4,11,0) import Data.Monoid #endif+import Data.List qualified as L import Data.Monoid.Utils+import Data.Semigroup qualified as SG import Data.Text (Text)+import Data.Text qualified as T import Log import TextShow-import qualified Data.List as L-import qualified Data.Text as T-import qualified Data.Semigroup as SG -import Database.PostgreSQL.PQTypes.Model import Database.PostgreSQL.PQTypes+import Database.PostgreSQL.PQTypes.Model  -- | A (potentially empty) list of info/error messages. data ValidationResult = ValidationResult-  { vrInfos  :: [Text]+  { vrInfos :: [Text]   , vrErrors :: [Text]   }+  deriving (Show, Eq)  validationError :: Text -> ValidationResult-validationError err = mempty { vrErrors = [err] }+validationError err = mempty {vrErrors = [err]}  validationInfo :: Text -> ValidationResult-validationInfo msg  = mempty { vrInfos = [msg] }+validationInfo msg = mempty {vrInfos = [msg]}  -- | Downgrade all error messages in a ValidationResult to info messages. validationErrorsToInfos :: ValidationResult -> ValidationResult-validationErrorsToInfos ValidationResult{..} =-  mempty { vrInfos = vrInfos <> vrErrors }+validationErrorsToInfos ValidationResult {..} =+  mempty {vrInfos = vrInfos <> vrErrors} -mapValidationResult ::-  ([Text] -> [Text]) -> ([Text] -> [Text]) -> ValidationResult -> ValidationResult-mapValidationResult mapInfos mapErrs ValidationResult{..} =-  mempty { vrInfos = mapInfos vrInfos, vrErrors = mapErrs vrErrors }+mapValidationResult+  :: ([Text] -> [Text]) -> ([Text] -> [Text]) -> ValidationResult -> ValidationResult+mapValidationResult mapInfos mapErrs ValidationResult {..} =+  mempty {vrInfos = mapInfos vrInfos, vrErrors = mapErrs vrErrors}  instance SG.Semigroup ValidationResult where-  (ValidationResult infos0 errs0) <> (ValidationResult infos1 errs1)-    = ValidationResult (infos0 <> infos1) (errs0 <> errs1)+  (ValidationResult infos0 errs0) <> (ValidationResult infos1 errs1) =+    ValidationResult (infos0 <> infos1) (errs0 <> errs1)  instance Monoid ValidationResult where-  mempty  = ValidationResult [] []+  mempty = ValidationResult [] []   mappend = (SG.<>)  topMessage :: Text -> Text -> ValidationResult -> ValidationResult-topMessage objtype objname vr@ValidationResult{..} =+topMessage objtype objname vr@ValidationResult {..} =   case vrErrors of     [] -> vr-    es -> ValidationResult vrInfos-          ("There are problems with the" <+>-            objtype <+> "'" <> objname <> "'" : es)+    es ->+      ValidationResult+        vrInfos+        ( "There are problems with the"+            <+> objtype+            <+> "'"+            <> objname+            <> "'"+            : es+        ) +resultHasErrors :: ValidationResult -> Bool+resultHasErrors ValidationResult {..} = not $ null vrErrors+ -- | Log all messages in a 'ValidationResult', and fail if any of them -- were errors. resultCheck   :: (MonadLog m, MonadThrow m)   => ValidationResult   -> m ()-resultCheck ValidationResult{..} = do+resultCheck ValidationResult {..} = do   mapM_ logInfo_ vrInfos   case vrErrors of-    []   -> return ()+    [] -> return ()     msgs -> do       mapM_ logAttention_ msgs       error "resultCheck: validation failed"@@ -95,19 +109,21 @@ checkEquality :: (Eq t, Show t) => Text -> [t] -> [t] -> ValidationResult checkEquality pname defs props = case (defs L.\\ props, props L.\\ defs) of   ([], []) -> mempty-  (def_diff, db_diff) -> validationError $ mconcat [-      "Table and its definition have diverged and have "-    , showt $ length db_diff-    , " and "-    , showt $ length def_diff-    , " different "-    , pname-    , " each, respectively:\n"-    , "  ● table:"-    , showDiff db_diff-    , "\n  ● definition:"-    , showDiff def_diff-    ]+  (def_diff, db_diff) ->+    validationError $+      mconcat+        [ "Table and its definition have diverged and have "+        , showt $ length db_diff+        , " and "+        , showt $ length def_diff+        , " different "+        , pname+        , " each, respectively:\n"+        , "  ● table:"+        , showDiff db_diff+        , "\n  ● definition:"+        , showDiff def_diff+        ]   where     showDiff = mconcat . map (("\n    ○ " <>) . T.pack . show) @@ -117,52 +133,110 @@     check (prop, name) = case prop_name prop of       pname         | pname == name -> mempty-        | otherwise     -> validationError . mconcat $ [-            "Property "-          , T.pack $ show prop-          , " has invalid name (expected: "-          , unRawSQL pname-          , ", given: "-          , unRawSQL name-          , ")."-          ]+        | otherwise ->+            validationError . mconcat $+              [ "Property "+              , T.pack $ show prop+              , " has invalid name (expected: "+              , unRawSQL pname+              , ", given: "+              , unRawSQL name+              , ")."+              ]  -- | Check presence of primary key on the named table. We cover all the cases so -- this could be used standalone, but note that the those where the table source -- definition and the table in the database differ in this respect is also -- covered by @checkEquality@.-checkPKPresence :: RawSQL ()-                -- ^ The name of the table to check for presence of primary key-              -> Maybe PrimaryKey-                -- ^ A possible primary key gotten from the table data structure-              -> Maybe (PrimaryKey, RawSQL ())-                -- ^ A possible primary key as retrieved from database along-                -- with its name-              -> ValidationResult+checkPKPresence+  :: RawSQL ()+  -- ^ The name of the table to check for presence of primary key+  -> Maybe PrimaryKey+  -- ^ A possible primary key gotten from the table data structure+  -> Maybe (PrimaryKey, RawSQL ())+  -- ^ A possible primary key as retrieved from database along+  -- with its name+  -> ValidationResult checkPKPresence tableName mdef mpk =   case (mdef, mpk) of     (Nothing, Nothing) -> valRes [noSrc, noTbl]-    (Nothing, Just _)  -> valRes [noSrc]-    (Just _, Nothing)  -> valRes [noTbl]-    _                  -> mempty+    (Nothing, Just _) -> valRes [noSrc]+    (Just _, Nothing) -> valRes [noTbl]+    _ -> mempty   where     noSrc = "no source definition"     noTbl = "no table definition"     valRes msgs =-        validationError . mconcat $-        [ "Table ", unRawSQL tableName+      validationError . mconcat $+        [ "Table "+        , unRawSQL tableName         , " has no primary key defined "-        , " (" <> (mintercalate ", " msgs) <> ")"]+        , " (" <> mintercalate ", " msgs <> ")"+        ]  objectHasLess :: Show t => Text -> Text -> t -> Text objectHasLess otype ptype missing =-  otype <+> "in the database has *less*" <+> ptype <+>-  "than its definition (missing:" <+> T.pack (show missing) <> ")"+  otype+    <+> "in the database has *less*"+    <+> ptype+    <+> "than its definition (missing:"+    <+> T.pack (show missing)+    <> ")"  objectHasMore :: Show t => Text -> Text -> t -> Text objectHasMore otype ptype extra =-  otype <+> "in the database has *more*" <+> ptype <+>-  "than its definition (extra:" <+> T.pack (show extra) <> ")"+  otype+    <+> "in the database has *more*"+    <+> ptype+    <+> "than its definition (extra:"+    <+> T.pack (show extra)+    <> ")"  arrListTable :: RawSQL () -> Text arrListTable tableName = " ->" <+> unRawSQL tableName <> ": "++checkOverlappingIndexesQuery :: RawSQL () -> SQL+checkOverlappingIndexesQuery tableName =+  smconcat+    [ "WITH"+    , -- get predicates (WHERE clause) definition in text format (ugly but the parsed version+      -- can differ even if the predicate is the same), ignore functional indexes at the same time+      -- as that would make this query very ugly+      "     indexdata1 AS (SELECT *"+    , "                         , ((regexp_match(pg_get_indexdef(indexrelid)"+    , "                                        , 'WHERE (.*)$')))[1] AS preddef"+    , "                    FROM pg_index"+    , "                    WHERE indexprs IS NULL"+    , "                    AND indrelid = '" <> raw tableName <> "'::regclass)"+    , -- add the rest of metadata and do the join+      "   , indexdata2 AS (SELECT t1.*"+    , "                         , pg_get_indexdef(t1.indexrelid) AS contained"+    , "                         , pg_get_indexdef(t2.indexrelid) AS contains"+    , "                         , array_to_string(t1.indkey, '+') AS colindex"+    , "                         , array_to_string(t2.indkey, '+') AS colotherindex"+    , "                         , t2.indexrelid AS other_index"+    , "                         , t2.indisunique AS other_indisunique"+    , "                         , t2.preddef AS other_preddef"+    , -- cross join all indexes on the same table to try all combination (except oneself)+      "                    FROM indexdata1 AS t1"+    , "                         INNER JOIN indexdata1 AS t2 ON t1.indrelid = t2.indrelid"+    , "                                                    AND t1.indexrelid <> t2.indexrelid)"+    , "  SELECT contained"+    , "       , contains"+    , "  FROM indexdata2"+    , " JOIN pg_class c ON (c.oid = indexdata2.indexrelid)"+    , -- The indexes are the same or the "other" is larger than us+      "  WHERE (colotherindex = colindex"+    , "      OR colotherindex LIKE colindex || '+%')"+    , -- and this is not a local index+      "    AND NOT c.relname ILIKE 'local_%'"+    , -- and we have the same predicate+      "    AND other_preddef IS NOT DISTINCT FROM preddef"+    , -- and either the other is unique (so better than us) or none of us is unique+      "    AND (NOT indisunique)"+    , "    OR ("+    , "             indisunique"+    , "         AND other_indisunique"+    , "         AND colindex = colotherindex"+    , ");"+    ]

@@ -1,22 +1,24 @@ {-# LANGUAGE AllowAmbiguousTypes #-}-module Database.PostgreSQL.PQTypes.Deriving (-  -- * Helpers, to be used with @deriving via@ (@-XDerivingVia@).-    SQLEnum(..)-  , EnumEncoding(..)-  , SQLEnumAsText(..)-  , EnumAsTextEncoding(..)++module Database.PostgreSQL.PQTypes.Deriving+  ( -- * Helpers, to be used with @deriving via@ (@-XDerivingVia@).+    SQLEnum (..)+  , EnumEncoding (..)+  , SQLEnumAsText (..)+  , EnumAsTextEncoding (..)+     -- * For use in doctests.   , isInjective   ) where -import Control.Exception (SomeException(..), throwIO)+import Control.Exception (SomeException (..), throwIO) import Data.List.Extra (enumerate, nubSort) import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Typeable import Database.PostgreSQL.PQTypes import Foreign.Storable-import qualified Data.Map.Strict as Map  -- | Helper newtype to be used with @deriving via@ to derive @(PQFormat, ToSQL, -- FromSQL)@ instances for enums, given an instance of 'EnumEncoding'.@@ -59,11 +61,14 @@   ( -- The semantic type needs to be finitely enumerable.     Enum a   , Bounded a-    -- The base type needs to be enumerable and ordered.-  , Enum (EnumBase a)+  , -- The base type needs to be enumerable and ordered.+    Enum (EnumBase a)   , Ord (EnumBase a)-  ) => EnumEncoding a where+  ) =>+  EnumEncoding a+  where   type EnumBase a+   -- | Encode @a@ as a base type.   encodeEnum :: a -> EnumBase a @@ -73,13 +78,14 @@   -- /Note:/ The default implementation looks up values in 'decodeEnumMap' and   -- can be overwritten for performance if necessary.   decodeEnum :: EnumBase a -> Either [(EnumBase a, EnumBase a)] a-  decodeEnum b = maybe (Left . intervals $ Map.keys (decodeEnumMap @a)) Right-               $ Map.lookup b (decodeEnumMap @a)+  decodeEnum b =+    maybe (Left . intervals $ Map.keys (decodeEnumMap @a)) Right $+      Map.lookup b (decodeEnumMap @a)    -- | Include the inverse map as a top-level part of the 'EnumEncoding'   -- instance to ensure it is only computed once by GHC.   decodeEnumMap :: Map (EnumBase a) a-  decodeEnumMap = Map.fromList [ (encodeEnum a, a) | a <- enumerate ]+  decodeEnumMap = Map.fromList [(encodeEnum a, a) | a <- enumerate]  instance PQFormat (EnumBase a) => PQFormat (SQLEnum a) where   pqFormat = pqFormat @(EnumBase a)@@ -88,7 +94,9 @@   ( EnumEncoding a   , PQFormat (EnumBase a)   , ToSQL (EnumBase a)-  ) => ToSQL (SQLEnum a) where+  )+  => ToSQL (SQLEnum a)+  where   type PQDest (SQLEnum a) = PQDest (EnumBase a)   toSQL (SQLEnum a) = toSQL $ encodeEnum a @@ -99,15 +107,20 @@   , FromSQL (EnumBase a)   , Show (EnumBase a)   , Typeable (EnumBase a)-  ) => FromSQL (SQLEnum a) where+  )+  => FromSQL (SQLEnum a)+  where   type PQBase (SQLEnum a) = PQBase (EnumBase a)   fromSQL base = do     b <- fromSQL base     case decodeEnum b of-      Left validRange -> throwIO $ SomeException RangeError-        { reRange = validRange-        , reValue = b-        }+      Left validRange ->+        throwIO $+          SomeException+            RangeError+              { reRange = validRange+              , reValue = b+              }       Right a -> return $ SQLEnum a  -- | A special case of 'SQLEnum', where the enum is to be encoded as text@@ -152,13 +165,14 @@   -- /Note:/ The default implementation looks up values in 'decodeEnumAsTextMap'   -- and can be overwritten for performance if necessary.   decodeEnumAsText :: Text -> Either [Text] a-  decodeEnumAsText text = maybe (Left $ Map.keys (decodeEnumAsTextMap @a)) Right-                        $ Map.lookup text (decodeEnumAsTextMap @a)+  decodeEnumAsText text =+    maybe (Left $ Map.keys (decodeEnumAsTextMap @a)) Right $+      Map.lookup text (decodeEnumAsTextMap @a)    -- | Include the inverse map as a top-level part of the 'SQLEnumTextEncoding'   -- instance to ensure it is only computed once by GHC.   decodeEnumAsTextMap :: Map Text a-  decodeEnumAsTextMap = Map.fromList [ (encodeEnumAsText a, a) | a <- enumerate ]+  decodeEnumAsTextMap = Map.fromList [(encodeEnumAsText a, a) | a <- enumerate]  instance EnumAsTextEncoding a => PQFormat (SQLEnumAsText a) where   pqFormat = pqFormat @Text@@ -172,10 +186,13 @@   fromSQL base = do     text <- fromSQL base     case decodeEnumAsText text of-      Left validValues -> throwIO $ SomeException InvalidValue-        { ivValue       = text-        , ivValidValues = Just validValues-        }+      Left validValues ->+        throwIO $+          SomeException+            InvalidValue+              { ivValue = text+              , ivValidValues = Just validValues+              }       Right a -> return $ SQLEnumAsText a  -- | To be used in doctests to prove injectivity of encoding functions.@@ -186,7 +203,7 @@ -- >>> isInjective (\(_ :: Bool) -> False) -- False isInjective :: (Enum a, Bounded a, Eq a, Eq b) => (a -> b) -> Bool-isInjective f = null [ (a, b) | a <- enumerate, b <- enumerate, a /= b, f a == f b ]+isInjective f = null [(a, b) | a <- enumerate, b <- enumerate, a /= b, f a == f b]  -- | Internal helper: given a list of values, decompose it into a list of -- intervals.@@ -195,16 +212,17 @@ -- [(-1,3),(42,43),(88,88)] -- -- prop> nubSort xs == concatMap (\(l,r) -> [l .. r]) (intervals xs)-intervals :: forall  a . (Enum a, Ord a) => [a] -> [(a, a)]+intervals :: forall a. (Enum a, Ord a) => [a] -> [(a, a)] intervals as = case nubSort as of   [] -> []   (first : ascendingRest) -> accumIntervals (first, first) ascendingRest   where     accumIntervals :: (a, a) -> [a] -> [(a, a)]     accumIntervals (lower, upper) [] = [(lower, upper)]-    accumIntervals (lower, upper) (first' : ascendingRest') = if succ upper == first'-      then accumIntervals (lower, first') ascendingRest'-      else (lower, upper) : accumIntervals (first', first') ascendingRest'+    accumIntervals (lower, upper) (first' : ascendingRest') =+      if succ upper == first'+        then accumIntervals (lower, first') ascendingRest'+        else (lower, upper) : accumIntervals (first', first') ascendingRest'  -- $setup -- >>> import Data.Int

@@ -1,28 +1,36 @@ module Database.PostgreSQL.PQTypes.ExtrasOptions-  ( ExtrasOptions(..)+  ( ExtrasOptions (..)   , defaultExtrasOptions-  , ObjectsValidationMode(..)+  , ObjectsValidationMode (..)   ) where -data ExtrasOptions =-    ExtrasOptions-    { eoLockTimeoutMs            :: !(Maybe Int)-    , eoEnforcePKs               :: !Bool-      -- ^ Validate that every handled table has a primary key-    , eoObjectsValidationMode    :: !ObjectsValidationMode-      -- ^ Validation mode for unknown tables and composite types.-    , eoAllowHigherTableVersions :: !Bool-      -- ^ Whether to allow tables in the database to have higher versions than-      -- the one in the code definition.-    } deriving Eq+data ExtrasOptions+  = ExtrasOptions+  { eoLockTimeoutMs :: !(Maybe Int)+  , eoEnforcePKs :: !Bool+  -- ^ Validate that every handled table has a primary key+  , eoObjectsValidationMode :: !ObjectsValidationMode+  -- ^ Validation mode for unknown tables and composite types.+  , eoAllowHigherTableVersions :: !Bool+  -- ^ Whether to allow tables in the database to have higher versions than+  -- the one in the code definition.+  , eoCheckForeignKeysIndexes :: !Bool+  -- ^ Check if all foreign keys have indexes.+  , eoCheckOverlappingIndexes :: !Bool+  -- ^ Check if some indexes are redundant+  }+  deriving (Eq)  defaultExtrasOptions :: ExtrasOptions-defaultExtrasOptions = ExtrasOptions-  { eoLockTimeoutMs            = Nothing-  , eoEnforcePKs               = False-  , eoObjectsValidationMode    = DontAllowUnknownObjects-  , eoAllowHigherTableVersions = False-  }+defaultExtrasOptions =+  ExtrasOptions+    { eoLockTimeoutMs = Nothing+    , eoEnforcePKs = False+    , eoObjectsValidationMode = DontAllowUnknownObjects+    , eoAllowHigherTableVersions = False+    , eoCheckForeignKeysIndexes = False+    , eoCheckOverlappingIndexes = False+    }  data ObjectsValidationMode = AllowUnknownObjects | DontAllowUnknownObjects-  deriving Eq+  deriving (Eq)

@@ -1,12 +1,12 @@-module Database.PostgreSQL.PQTypes.Migrate (-  createDomain,-  createTable,-  createTableConstraints,-  createTableTriggers+module Database.PostgreSQL.PQTypes.Migrate+  ( createDomain+  , createTable+  , createTableConstraints+  , createTableTriggers   ) where  import Control.Monad-import qualified Data.Foldable as F+import Data.Foldable qualified as F  import Database.PostgreSQL.PQTypes import Database.PostgreSQL.PQTypes.Checks.Util@@ -14,14 +14,14 @@ import Database.PostgreSQL.PQTypes.SQL.Builder  createDomain :: MonadDB m => Domain -> m ()-createDomain dom@Domain{..} = do+createDomain dom@Domain {..} = do   -- create the domain   runQuery_ $ sqlCreateDomain dom   -- add constraint checks to the domain   F.forM_ domChecks $ runQuery_ . sqlAlterDomain domName . sqlAddValidCheckMaybeDowntime  createTable :: MonadDB m => Bool -> Table -> m ()-createTable withConstraints table@Table{..} = do+createTable withConstraints table@Table {..} = do   -- Create empty table and add the columns.   runQuery_ $ sqlCreateTable tblName   runQuery_ $ sqlAlterTable tblName $ map sqlAddColumn tblColumns@@ -39,13 +39,12 @@     sqlSet "version" tblVersion  createTableConstraints :: MonadDB m => Table -> m ()-createTableConstraints Table{..} = when (not $ null addConstraints) $ do+createTableConstraints Table {..} = unless (null addConstraints) $ do   runQuery_ $ sqlAlterTable tblName addConstraints   where-    addConstraints = concat-      [ map sqlAddValidCheckMaybeDowntime tblChecks-      , map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys-      ]+    addConstraints =+      map sqlAddValidCheckMaybeDowntime tblChecks+        ++ map (sqlAddValidFKMaybeDowntime tblName) tblForeignKeys  createTableTriggers :: MonadDB m => Table -> m () createTableTriggers = mapM_ createTrigger . tblTriggers

@@ -1,8 +1,9 @@-module Database.PostgreSQL.PQTypes.Model (-    module Database.PostgreSQL.PQTypes.Model.Check+module Database.PostgreSQL.PQTypes.Model+  ( module Database.PostgreSQL.PQTypes.Model.Check   , module Database.PostgreSQL.PQTypes.Model.ColumnType   , module Database.PostgreSQL.PQTypes.Model.CompositeType   , module Database.PostgreSQL.PQTypes.Model.Domain+  , module Database.PostgreSQL.PQTypes.Model.EnumType   , module Database.PostgreSQL.PQTypes.Model.Extension   , module Database.PostgreSQL.PQTypes.Model.ForeignKey   , module Database.PostgreSQL.PQTypes.Model.Index@@ -16,6 +17,7 @@ import Database.PostgreSQL.PQTypes.Model.ColumnType import Database.PostgreSQL.PQTypes.Model.CompositeType import Database.PostgreSQL.PQTypes.Model.Domain+import Database.PostgreSQL.PQTypes.Model.EnumType import Database.PostgreSQL.PQTypes.Model.Extension import Database.PostgreSQL.PQTypes.Model.ForeignKey import Database.PostgreSQL.PQTypes.Model.Index

@@ -1,5 +1,5 @@-module Database.PostgreSQL.PQTypes.Model.Check (-    Check(..)+module Database.PostgreSQL.PQTypes.Model.Check+  ( Check (..)   , tblCheck   , sqlAddValidCheckMaybeDowntime   , sqlAddNotValidCheck@@ -10,19 +10,22 @@ import Data.Monoid.Utils import Database.PostgreSQL.PQTypes -data Check = Check {-  chkName      :: RawSQL ()-, chkCondition :: RawSQL ()-, chkValidated :: Bool -- ^ Set to 'False' if check is created as NOT VALID and-                       -- left in such state (for whatever reason).-} deriving (Eq, Ord, Show)+data Check = Check+  { chkName :: RawSQL ()+  , chkCondition :: RawSQL ()+  , chkValidated :: Bool+  -- ^ Set to 'False' if check is created as NOT VALID and+  -- left in such state (for whatever reason).+  }+  deriving (Eq, Ord, Show)  tblCheck :: Check-tblCheck = Check-  { chkName      = ""-  , chkCondition = ""-  , chkValidated = True-  }+tblCheck =+  Check+    { chkName = ""+    , chkCondition = ""+    , chkValidated = True+    }  -- | Add valid check constraint. Warning: PostgreSQL acquires SHARE ROW -- EXCLUSIVE lock (that prevents updates) on modified table for the duration of@@ -42,14 +45,15 @@ sqlValidateCheck checkName = "VALIDATE CONSTRAINT" <+> checkName  sqlAddCheck_ :: Bool -> Check -> RawSQL ()-sqlAddCheck_ valid Check{..} = smconcat [-    "ADD CONSTRAINT"-  , chkName-  , "CHECK ("-  , chkCondition-  , ")"-  , if valid then "" else " NOT VALID"-  ]+sqlAddCheck_ valid Check {..} =+  smconcat+    [ "ADD CONSTRAINT"+    , chkName+    , "CHECK ("+    , chkCondition+    , ")"+    , if valid then "" else " NOT VALID"+    ]  sqlDropCheck :: RawSQL () -> RawSQL () sqlDropCheck name = "DROP CONSTRAINT" <+> name

@@ -1,10 +1,10 @@-module Database.PostgreSQL.PQTypes.Model.ColumnType (-    ColumnType(..)+module Database.PostgreSQL.PQTypes.Model.ColumnType+  ( ColumnType (..)   , columnTypeToSQL   ) where +import Data.Text qualified as T import Database.PostgreSQL.PQTypes-import qualified Data.Text as T  data ColumnType   = BigIntT@@ -25,7 +25,7 @@   | XmlT   | ArrayT !ColumnType   | CustomT !(RawSQL ())-    deriving (Eq, Ord, Show)+  deriving (Eq, Ord, Show)  instance PQFormat ColumnType where   pqFormat = pqFormat @T.Text@@ -55,21 +55,21 @@           | otherwise -> CustomT $ rawSQL tname ()  columnTypeToSQL :: ColumnType -> RawSQL ()-columnTypeToSQL BigIntT            = "BIGINT"-columnTypeToSQL BigSerialT         = "BIGSERIAL"-columnTypeToSQL BinaryT            = "BYTEA"-columnTypeToSQL BoolT              = "BOOLEAN"-columnTypeToSQL DateT              = "DATE"-columnTypeToSQL DoubleT            = "DOUBLE PRECISION"-columnTypeToSQL IntegerT           = "INTEGER"-columnTypeToSQL UuidT              = "UUID"-columnTypeToSQL IntervalT          = "INTERVAL"-columnTypeToSQL JsonT              = "JSON"-columnTypeToSQL JsonbT             = "JSONB"-columnTypeToSQL SmallIntT          = "SMALLINT"-columnTypeToSQL TextT              = "TEXT"-columnTypeToSQL TSVectorT          = "TSVECTOR"+columnTypeToSQL BigIntT = "BIGINT"+columnTypeToSQL BigSerialT = "BIGSERIAL"+columnTypeToSQL BinaryT = "BYTEA"+columnTypeToSQL BoolT = "BOOLEAN"+columnTypeToSQL DateT = "DATE"+columnTypeToSQL DoubleT = "DOUBLE PRECISION"+columnTypeToSQL IntegerT = "INTEGER"+columnTypeToSQL UuidT = "UUID"+columnTypeToSQL IntervalT = "INTERVAL"+columnTypeToSQL JsonT = "JSON"+columnTypeToSQL JsonbT = "JSONB"+columnTypeToSQL SmallIntT = "SMALLINT"+columnTypeToSQL TextT = "TEXT"+columnTypeToSQL TSVectorT = "TSVECTOR" columnTypeToSQL TimestampWithZoneT = "TIMESTAMPTZ"-columnTypeToSQL XmlT               = "XML"-columnTypeToSQL (ArrayT t)         = columnTypeToSQL t <> "[]"-columnTypeToSQL (CustomT tname)    = tname+columnTypeToSQL XmlT = "XML"+columnTypeToSQL (ArrayT t) = columnTypeToSQL t <> "[]"+columnTypeToSQL (CustomT tname) = tname

@@ -1,30 +1,32 @@-module Database.PostgreSQL.PQTypes.Model.CompositeType (-    CompositeType(..)-  , CompositeColumn(..)+module Database.PostgreSQL.PQTypes.Model.CompositeType+  ( CompositeType (..)+  , CompositeColumn (..)   , compositeTypePqFormat   , sqlCreateComposite   , sqlDropComposite   , getDBCompositeTypes   ) where +import Data.ByteString qualified as BS import Data.Int import Data.Monoid.Utils+import Data.Text.Encoding qualified as T import Database.PostgreSQL.PQTypes-import qualified Data.ByteString as BS-import qualified Data.Text.Encoding as T  import Database.PostgreSQL.PQTypes.Model.ColumnType import Database.PostgreSQL.PQTypes.SQL.Builder -data CompositeType = CompositeType {-  ctName    :: !(RawSQL ())-, ctColumns :: ![CompositeColumn]-} deriving (Eq, Ord, Show)+data CompositeType = CompositeType+  { ctName :: !(RawSQL ())+  , ctColumns :: ![CompositeColumn]+  }+  deriving (Eq, Ord, Show) -data CompositeColumn = CompositeColumn {-  ccName :: !(RawSQL ())-, ccType :: ColumnType-} deriving (Eq, Ord, Show)+data CompositeColumn = CompositeColumn+  { ccName :: !(RawSQL ())+  , ccType :: ColumnType+  }+  deriving (Eq, Ord, Show)  -- | Convenience function for converting CompositeType definition to -- corresponding 'pqFormat' definition.@@ -33,15 +35,16 @@  -- | Make SQL query that creates a composite type. sqlCreateComposite :: CompositeType -> RawSQL ()-sqlCreateComposite CompositeType{..} = smconcat [-    "CREATE TYPE"-  , ctName-  , "AS ("-  , mintercalate ", " $ map columnToSQL ctColumns-  , ")"-  ]+sqlCreateComposite CompositeType {..} =+  smconcat+    [ "CREATE TYPE"+    , ctName+    , "AS ("+    , mintercalate ", " $ map columnToSQL ctColumns+    , ")"+    ]   where-    columnToSQL CompositeColumn{..} = ccName <+> columnTypeToSQL ccType+    columnToSQL CompositeColumn {..} = ccName <+> columnTypeToSQL ccType  -- | Make SQL query that drops a composite type. sqlDropComposite :: RawSQL () -> RawSQL ()@@ -68,8 +71,8 @@         sqlWhereEq "a.attrelid" oid         sqlOrderBy "a.attnum"       columns <- fetchMany fetch-      return CompositeType { ctName = unsafeSQL name, ctColumns = columns }+      return CompositeType {ctName = unsafeSQL name, ctColumns = columns}       where         fetch :: (String, ColumnType) -> CompositeColumn         fetch (cname, ctype) =-          CompositeColumn { ccName = unsafeSQL cname, ccType = ctype }+          CompositeColumn {ccName = unsafeSQL cname, ccType = ctype}

@@ -1,5 +1,5 @@-module Database.PostgreSQL.PQTypes.Model.Domain (-    Domain(..)+module Database.PostgreSQL.PQTypes.Model.Domain+  ( Domain (..)   , mkChecks   , sqlCreateDomain   , sqlAlterDomain@@ -49,31 +49,33 @@ -- and edit old migrations), whereas the current solution makes the -- transition trivial. -data Domain = Domain {-  -- | Name of the domain.-  domName     :: RawSQL ()-  -- | Type of the domain.-, domType     :: ColumnType-  -- | Defines whether the domain value can be NULL.+data Domain = Domain+  { domName :: RawSQL ()+  -- ^ Name of the domain.+  , domType :: ColumnType+  -- ^ Type of the domain.+  , domNullable :: Bool+  -- ^ Defines whether the domain value can be NULL.   -- *Cannot* be superseded by a table column definition.-, domNullable :: Bool-  -- Default value for the domain. *Can* be-  -- superseded by a table column definition.-, domDefault  :: Maybe (RawSQL ())-  -- Set of constraint checks on the domain.-, domChecks   :: Set Check-} deriving (Eq, Ord, Show)+  , -- Default value for the domain. *Can* be+    -- superseded by a table column definition.+    domDefault :: Maybe (RawSQL ())+  , -- Set of constraint checks on the domain.+    domChecks :: Set Check+  }+  deriving (Eq, Ord, Show)  mkChecks :: [Check] -> Set Check mkChecks = fromList  sqlCreateDomain :: Domain -> RawSQL ()-sqlCreateDomain Domain{..} = smconcat [-    "CREATE DOMAIN" <+> domName <+> "AS"-  , columnTypeToSQL domType-  , if domNullable then "NULL" else "NOT NULL"-  , maybe "" ("DEFAULT" <+>) domDefault-  ]+sqlCreateDomain Domain {..} =+  smconcat+    [ "CREATE DOMAIN" <+> domName <+> "AS"+    , columnTypeToSQL domType+    , if domNullable then "NULL" else "NOT NULL"+    , maybe "" ("DEFAULT" <+>) domDefault+    ]  sqlAlterDomain :: RawSQL () -> RawSQL () -> RawSQL () sqlAlterDomain dname alter = "ALTER DOMAIN" <+> dname <+> alter

@@ -0,0 +1,32 @@+module Database.PostgreSQL.PQTypes.Model.EnumType+  ( EnumType (..)+  , sqlCreateEnum+  , sqlDropEnum+  ) where++import Data.Monoid.Utils+import Data.Text qualified as T+import Database.PostgreSQL.PQTypes++data EnumType = EnumType+  { etName :: !(RawSQL ())+  , etValues :: ![RawSQL ()]+  }+  deriving (Eq, Ord, Show)++-- | Make SQL query that creates an enum type.+sqlCreateEnum :: EnumType -> RawSQL ()+sqlCreateEnum EnumType {..} =+  smconcat+    [ "CREATE TYPE"+    , etName+    , "AS ENUM ("+    , mintercalate ", " $ map quotedValue etValues+    , ")"+    ]+  where+    quotedValue v = rawSQL ("'" <> T.replace "'" "''" (unRawSQL v) <> "'" :: T.Text) ()++-- | Make SQL query that drops a composite type.+sqlDropEnum :: RawSQL () -> RawSQL ()+sqlDropEnum = ("DROP TYPE" <+>)

@@ -1,5 +1,5 @@-module Database.PostgreSQL.PQTypes.Model.Extension (-    Extension(..)+module Database.PostgreSQL.PQTypes.Model.Extension+  ( Extension (..)   , ununExtension   ) where @@ -7,7 +7,7 @@ import Data.Text (Text) import Database.PostgreSQL.PQTypes -newtype Extension = Extension { unExtension :: RawSQL () }+newtype Extension = Extension {unExtension :: RawSQL ()}   deriving (Eq, Ord, Show, IsString)  ununExtension :: Extension -> Text

@@ -1,6 +1,6 @@-module Database.PostgreSQL.PQTypes.Model.ForeignKey (-    ForeignKey(..)-  , ForeignKeyAction(..)+module Database.PostgreSQL.PQTypes.Model.ForeignKey+  ( ForeignKey (..)+  , ForeignKeyAction (..)   , fkOnColumn   , fkOnColumns   , fkName@@ -11,20 +11,22 @@   ) where  import Data.Monoid.Utils+import Data.Text qualified as T import Database.PostgreSQL.PQTypes-import qualified Data.Text as T -data ForeignKey = ForeignKey {-  fkColumns    :: [RawSQL ()]-, fkRefTable   :: RawSQL ()-, fkRefColumns :: [RawSQL ()]-, fkOnUpdate   :: ForeignKeyAction-, fkOnDelete   :: ForeignKeyAction-, fkDeferrable :: Bool-, fkDeferred   :: Bool-, fkValidated  :: Bool -- ^ Set to 'False' if foreign key is created as NOT-                       -- VALID and left in such state (for whatever reason).-} deriving (Eq, Ord, Show)+data ForeignKey = ForeignKey+  { fkColumns :: [RawSQL ()]+  , fkRefTable :: RawSQL ()+  , fkRefColumns :: [RawSQL ()]+  , fkOnUpdate :: ForeignKeyAction+  , fkOnDelete :: ForeignKeyAction+  , fkDeferrable :: Bool+  , fkDeferred :: Bool+  , fkValidated :: Bool+  -- ^ Set to 'False' if foreign key is created as NOT+  -- VALID and left in such state (for whatever reason).+  }+  deriving (Eq, Ord, Show)  data ForeignKeyAction   = ForeignKeyNoAction@@ -39,26 +41,29 @@   fkOnColumns [column] reftable [refcolumn]  fkOnColumns :: [RawSQL ()] -> RawSQL () -> [RawSQL ()] -> ForeignKey-fkOnColumns columns reftable refcolumns = ForeignKey {-  fkColumns    = columns-, fkRefTable   = reftable-, fkRefColumns = refcolumns-, fkOnUpdate   = ForeignKeyCascade-, fkOnDelete   = ForeignKeyNoAction-, fkDeferrable = True-, fkDeferred   = False-, fkValidated  = True-}+fkOnColumns columns reftable refcolumns =+  ForeignKey+    { fkColumns = columns+    , fkRefTable = reftable+    , fkRefColumns = refcolumns+    , fkOnUpdate = ForeignKeyCascade+    , fkOnDelete = ForeignKeyNoAction+    , fkDeferrable = True+    , fkDeferred = False+    , fkValidated = True+    }  fkName :: RawSQL () -> ForeignKey -> RawSQL ()-fkName tname ForeignKey{..} = shorten $ mconcat [-    "fk__"-  , tname-  , "__"-  , mintercalate "__" fkColumns-  , "__"-  , fkRefTable-  ]+fkName tname ForeignKey {..} =+  shorten $+    mconcat+      [ "fk__"+      , tname+      , "__"+      , mintercalate "__" fkColumns+      , "__"+      , fkRefTable+      ]   where     -- PostgreSQL's limit for identifier is 63 characters     shorten = flip rawSQL () . T.take 63 . unRawSQL@@ -82,22 +87,23 @@ sqlValidateFK tname fk = "VALIDATE CONSTRAINT" <+> fkName tname fk  sqlAddFK_ :: Bool -> RawSQL () -> ForeignKey -> RawSQL ()-sqlAddFK_ valid tname fk@ForeignKey{..} = mconcat [-    "ADD CONSTRAINT" <+> fkName tname fk <+> "FOREIGN KEY ("-  , mintercalate ", " fkColumns-  , ") REFERENCES" <+> fkRefTable <+> "("-  , mintercalate ", " fkRefColumns-  , ") ON UPDATE" <+> foreignKeyActionToSQL fkOnUpdate-  , "  ON DELETE" <+> foreignKeyActionToSQL fkOnDelete-  , " " <> if fkDeferrable then "DEFERRABLE" else "NOT DEFERRABLE"-  , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE"-  , if valid then "" else " NOT VALID"-  ]+sqlAddFK_ valid tname fk@ForeignKey {..} =+  mconcat+    [ "ADD CONSTRAINT" <+> fkName tname fk <+> "FOREIGN KEY ("+    , mintercalate ", " fkColumns+    , ") REFERENCES" <+> fkRefTable <+> "("+    , mintercalate ", " fkRefColumns+    , ") ON UPDATE" <+> foreignKeyActionToSQL fkOnUpdate+    , "  ON DELETE" <+> foreignKeyActionToSQL fkOnDelete+    , " " <> if fkDeferrable then "DEFERRABLE" else "NOT DEFERRABLE"+    , " INITIALLY" <+> if fkDeferred then "DEFERRED" else "IMMEDIATE"+    , if valid then "" else " NOT VALID"+    ]   where-    foreignKeyActionToSQL ForeignKeyNoAction   = "NO ACTION"-    foreignKeyActionToSQL ForeignKeyRestrict   = "RESTRICT"-    foreignKeyActionToSQL ForeignKeyCascade    = "CASCADE"-    foreignKeyActionToSQL ForeignKeySetNull    = "SET NULL"+    foreignKeyActionToSQL ForeignKeyNoAction = "NO ACTION"+    foreignKeyActionToSQL ForeignKeyRestrict = "RESTRICT"+    foreignKeyActionToSQL ForeignKeyCascade = "CASCADE"+    foreignKeyActionToSQL ForeignKeySetNull = "SET NULL"     foreignKeyActionToSQL ForeignKeySetDefault = "SET DEFAULT"  sqlDropFK :: RawSQL () -> ForeignKey -> RawSQL ()

@@ -1,14 +1,15 @@-module Database.PostgreSQL.PQTypes.Model.Index (-    TableIndex(..)-  , IndexColumn(..)+module Database.PostgreSQL.PQTypes.Model.Index+  ( TableIndex (..)+  , IndexColumn (..)   , indexColumn   , indexColumnWithOperatorClass-  , IndexMethod(..)+  , IndexMethod (..)   , tblIndex   , indexOnColumn   , indexOnColumns   , indexOnColumnWithMethod   , indexOnColumnsWithMethod+  , indexColumnName   , uniqueIndexOnColumn   , uniqueIndexOnColumnWithCondition   , uniqueIndexOnColumns@@ -19,32 +20,39 @@   , sqlDropIndexConcurrently   ) where +import Crypto.Hash qualified as H+import Data.ByteArray qualified as BA+import Data.ByteString.Base16 qualified as B16+import Data.ByteString.Char8 qualified as BS import Data.Char import Data.Function-import Data.String import Data.Monoid.Utils+import Data.String+import Data.Text qualified as T+import Data.Text.Encoding qualified as T import Database.PostgreSQL.PQTypes-import qualified Crypto.Hash as H-import qualified Data.ByteArray as BA-import qualified Data.ByteString.Base16 as B16-import qualified Data.ByteString.Char8 as BS-import qualified Data.Text as T-import qualified Data.Text.Encoding as T -data TableIndex = TableIndex {-  idxColumns :: [IndexColumn]-, idxInclude :: [RawSQL ()]-, idxMethod  :: IndexMethod-, idxUnique  :: Bool-, idxValid   :: Bool -- ^ If creation of index with CONCURRENTLY fails, index-                     -- will be marked as invalid. Set it to 'False' if such-                     -- situation is expected.-, idxWhere   :: Maybe (RawSQL ())-} deriving (Eq, Ord, Show)+data TableIndex = TableIndex+  { idxColumns :: [IndexColumn]+  , idxInclude :: [RawSQL ()]+  , idxMethod :: IndexMethod+  , idxUnique :: Bool+  , idxValid :: Bool+  , -- \^ If creation of index with CONCURRENTLY fails, index+    -- will be marked as invalid. Set it to 'False' if such+    -- situation is expected.+    idxWhere :: Maybe (RawSQL ())+  , idxNotDistinctNulls :: Bool+  }+  -- \^ Adds NULL NOT DISTINCT on the index, meaning that+  -- \^ only one NULL value will be accepted; other NULLs+  -- \^ will be perceived as a violation of the constraint.+  -- \^ NB: will only be used if idxUnique is set to True+  deriving (Eq, Ord, Show)  data IndexColumn   = IndexColumn (RawSQL ()) (Maybe (RawSQL ()))-  deriving Show+  deriving (Show)  -- If one of the two columns doesn't specify the operator class, we just ignore -- it and still treat them as equivalent.@@ -68,107 +76,129 @@ indexColumnName :: IndexColumn -> RawSQL () indexColumnName (IndexColumn col _) = col -data IndexMethod =-    BTree+data IndexMethod+  = BTree   | GIN   deriving (Eq, Ord)  instance Show IndexMethod where-    show BTree = "btree"-    show GIN   = "gin"+  show BTree = "btree"+  show GIN = "gin"  instance Read IndexMethod where-    readsPrec _ (map toLower -> "btree") = [(BTree,"")]-    readsPrec _ (map toLower -> "gin")   = [(GIN,"")]-    readsPrec _ _       = []+  readsPrec _ (map toLower -> "btree") = [(BTree, "")]+  readsPrec _ (map toLower -> "gin") = [(GIN, "")]+  readsPrec _ _ = []  tblIndex :: TableIndex-tblIndex = TableIndex {-  idxColumns = []-, idxInclude = []-, idxMethod = BTree-, idxUnique = False-, idxValid = True-, idxWhere = Nothing-}+tblIndex =+  TableIndex+    { idxColumns = []+    , idxInclude = []+    , idxMethod = BTree+    , idxUnique = False+    , idxValid = True+    , idxWhere = Nothing+    , idxNotDistinctNulls = False+    }  indexOnColumn :: IndexColumn -> TableIndex-indexOnColumn column = tblIndex { idxColumns = [column] }+indexOnColumn column = tblIndex {idxColumns = [column]}  -- | Create an index on the given column with the specified method.  No checks -- are made that the method is appropriate for the type of the column. indexOnColumnWithMethod :: IndexColumn -> IndexMethod -> TableIndex indexOnColumnWithMethod column method =-    tblIndex { idxColumns = [column]-             , idxMethod = method }+  tblIndex+    { idxColumns = [column]+    , idxMethod = method+    }  indexOnColumns :: [IndexColumn] -> TableIndex-indexOnColumns columns = tblIndex { idxColumns = columns }+indexOnColumns columns = tblIndex {idxColumns = columns}  -- | Create an index on the given columns with the specified method.  No checks -- are made that the method is appropriate for the type of the column; -- cf. [the PostgreSQL manual](https://www.postgresql.org/docs/current/static/indexes-multicolumn.html). indexOnColumnsWithMethod :: [IndexColumn] -> IndexMethod -> TableIndex indexOnColumnsWithMethod columns method =-    tblIndex { idxColumns = columns-             , idxMethod = method }+  tblIndex+    { idxColumns = columns+    , idxMethod = method+    }  uniqueIndexOnColumn :: IndexColumn -> TableIndex-uniqueIndexOnColumn column = TableIndex {-  idxColumns = [column]-, idxInclude = []-, idxMethod = BTree-, idxUnique = True-, idxValid = True-, idxWhere = Nothing-}+uniqueIndexOnColumn column =+  TableIndex+    { idxColumns = [column]+    , idxInclude = []+    , idxMethod = BTree+    , idxUnique = True+    , idxValid = True+    , idxWhere = Nothing+    , idxNotDistinctNulls = False+    }  uniqueIndexOnColumns :: [IndexColumn] -> TableIndex-uniqueIndexOnColumns columns = TableIndex {-  idxColumns = columns-, idxInclude = []-, idxMethod = BTree-, idxUnique = True-, idxValid = True-, idxWhere = Nothing-}+uniqueIndexOnColumns columns =+  TableIndex+    { idxColumns = columns+    , idxInclude = []+    , idxMethod = BTree+    , idxUnique = True+    , idxValid = True+    , idxWhere = Nothing+    , idxNotDistinctNulls = False+    }  uniqueIndexOnColumnWithCondition :: IndexColumn -> RawSQL () -> TableIndex-uniqueIndexOnColumnWithCondition column whereC = TableIndex {-  idxColumns = [column]-, idxInclude = []-, idxMethod = BTree-, idxUnique = True-, idxValid = True-, idxWhere = Just whereC-}+uniqueIndexOnColumnWithCondition column whereC =+  TableIndex+    { idxColumns = [column]+    , idxInclude = []+    , idxMethod = BTree+    , idxUnique = True+    , idxValid = True+    , idxWhere = Just whereC+    , idxNotDistinctNulls = False+    }  indexName :: RawSQL () -> TableIndex -> RawSQL ()-indexName tname TableIndex{..} = flip rawSQL () $ T.take 63 . unRawSQL $ mconcat [-    if idxUnique then "unique_idx__" else "idx__"-  , tname-  , "__"-  , mintercalate "__" $ map (asText sanitize . indexColumnName) idxColumns-  , if null idxInclude-    then ""-    else "$$" <> mintercalate "__" (map (asText sanitize) idxInclude)-  , maybe "" (("__" <>) . hashWhere) idxWhere-  ]+indexName tname TableIndex {..} =+  flip rawSQL () $+    T.take 63 . unRawSQL $+      mconcat+        [ if idxUnique then "unique_idx__" else "idx__"+        , tname+        , "__"+        , mintercalate "__" $ map (asText sanitize . indexColumnName) idxColumns+        , if null idxInclude+            then ""+            else "$$" <> mintercalate "__" (map (asText sanitize) idxInclude)+        , maybe "" (("__" <>) . hashWhere) idxWhere+        ]   where     asText f = flip rawSQL () . f . unRawSQL     -- See http://www.postgresql.org/docs/9.4/static/sql-syntax-lexical.html#SQL-SYNTAX-IDENTIFIERS.     -- Remove all unallowed characters and replace them by at most one adjacent dollar sign.     sanitize = T.pack . foldr go [] . T.unpack       where-        go c acc = if isAlphaNum c || c == '_'-          then c : acc-          else case acc of-            ('$':_) ->       acc-            _       -> '$' : acc+        go c acc =+          if isAlphaNum c || c == '_'+            then c : acc+            else case acc of+              ('$' : _) -> acc+              _ -> '$' : acc     -- hash WHERE clause and add it to index name so that indexes     -- with the same columns, but different constraints can coexist-    hashWhere = asText $ T.decodeUtf8 . B16.encode . BS.take 10-      . BA.convert . H.hash @_ @H.RIPEMD160 . T.encodeUtf8+    hashWhere =+      asText $+        T.decodeUtf8+          . B16.encode+          . BS.take 10+          . BA.convert+          . H.hash @_ @H.RIPEMD160+          . T.encodeUtf8  -- | Create an index. Warning: if the affected table is large, this will prevent -- the table from being modified during the creation. If this is not acceptable,@@ -183,27 +213,33 @@ sqlCreateIndexConcurrently = sqlCreateIndex_ True  sqlCreateIndex_ :: Bool -> RawSQL () -> TableIndex -> RawSQL ()-sqlCreateIndex_ concurrently tname idx@TableIndex{..} = mconcat [-    "CREATE"-  , if idxUnique then " UNIQUE" else ""-  , " INDEX "-  , if concurrently then "CONCURRENTLY " else ""-  , indexName tname idx-  , " ON" <+> tname-  , " USING" <+> (rawSQL (T.pack . show $ idxMethod) ()) <+> "("-  , mintercalate ", "-      (map-        (\case-          IndexColumn col Nothing -> col-          IndexColumn col (Just opclass) -> col <+> opclass+sqlCreateIndex_ concurrently tname idx@TableIndex {..} =+  mconcat+    [ "CREATE"+    , if idxUnique then " UNIQUE" else ""+    , " INDEX "+    , if concurrently then "CONCURRENTLY " else ""+    , indexName tname idx+    , " ON" <+> tname+    , " USING" <+> rawSQL (T.pack . show $ idxMethod) () <+> "("+    , mintercalate+        ", "+        ( map+            ( \case+                IndexColumn col Nothing -> col+                IndexColumn col (Just opclass) -> col <+> opclass+            )+            idxColumns         )-        idxColumns)-  , ")"-  , if null idxInclude-    then ""-    else " INCLUDE (" <> mintercalate ", " idxInclude <> ")"-  , maybe "" (" WHERE" <+>) idxWhere-  ]+    , ")"+    , if null idxInclude+        then ""+        else " INCLUDE (" <> mintercalate ", " idxInclude <> ")"+    , if idxUnique && idxNotDistinctNulls+        then " NULLS NOT DISTINCT"+        else ""+    , maybe "" (" WHERE" <+>) idxWhere+    ]  -- | Drop an index. Warning: if you don't want to lock out concurrent operations -- on the index's table, use 'DropIndexConcurrentlyMigration'. See

@@ -1,33 +1,31 @@ {-# LANGUAGE CPP #-}-{- | -Using migrations is fairly easy. After you've defined the lists of-migrations and tables, just run-'Database.PostgreSQL.PQTypes.Checks.migrateDatabase':--@-tables :: [Table]-tables = ...--migrations :: [Migration]-migrations = ...--migrateDatabase options extensions domains tables migrations-@--Migrations are run strictly in the order specified in the migrations-list, starting with the first migration for which the corresponding-table in the DB has the version number equal to the 'mgrFrom' field of-the migration.---}--module Database.PostgreSQL.PQTypes.Model.Migration (-    DropTableMode(..),-    MigrationAction(..),-    Migration(..),-    isStandardMigration, isDropTableMigration-  )  where+-- |+--+-- Using migrations is fairly easy. After you've defined the lists of+-- migrations and tables, just run+-- 'Database.PostgreSQL.PQTypes.Checks.migrateDatabase':+--+-- @+-- definitions = emptyDbDefinitions { ... }+--+-- migrations :: [Migration]+-- migrations = ...+--+-- migrateDatabase options definitions migrations+-- @+--+-- Migrations are run strictly in the order specified in the migrations+-- list, starting with the first migration for which the corresponding+-- table in the DB has the version number equal to the 'mgrFrom' field of+-- the migration.+module Database.PostgreSQL.PQTypes.Model.Migration+  ( DropTableMode (..)+  , MigrationAction (..)+  , Migration (..)+  , isStandardMigration+  , isDropTableMigration+  ) where  import Data.Int @@ -39,74 +37,73 @@  -- | Migration action to run, either an arbitrary 'MonadDB' action, or -- something more fine-grained.-data MigrationAction m =--  -- | Standard migration, i.e. an arbitrary 'MonadDB' action.-  StandardMigration (m ())--  -- | Drop table migration. Parameter is the drop table mode-  -- (@RESTRICT@/@CASCADE@). The 'Migration' record holds the name of-  -- the table to drop.-  | DropTableMigration DropTableMode--  -- | Migration for creating an index concurrently.-  | CreateIndexConcurrentlyMigration-      (RawSQL ()) -- ^ Table name-      TableIndex  -- ^ Index--  -- | Migration for dropping an index concurrently.-  | DropIndexConcurrentlyMigration-      (RawSQL ()) -- ^ Table name-      TableIndex  -- ^ Index--  -- | Migration for modifying columns. Parameters are:-  ---  -- Name of the table that the cursor is associated with. It has to be the same as in the-  -- cursor SQL, see the second parameter.-  ---  -- SQL providing a list of primary keys from the associated table that will be used for the cursor.-  ---  -- Function that takes a batch of primary keys provided by the cursor SQL and runs an arbitrary computation-  -- within MonadDB. The function might be called repeatedly depending on the batch size and total number of-  -- selected primary keys. See the last argument.-  ---  -- Batch size of primary keys to be fetched at once by the cursor SQL and be given to the modification function.-  -- To handle multi-column primary keys, the following needs to be done:-  ---  --   1. Get the list of tuples from PostgreSQL.-  --   2. Unzip them into a tuple of lists in Haskell.-  --   3. Pass the lists to PostgreSQL as separate parameters and zip them back in the SQL,-  --      see https://stackoverflow.com/questions/12414750/is-there-something-like-a-zip-function-in-postgresql-that-combines-two-arrays for more details.-  | forall t . FromRow t => ModifyColumnMigration (RawSQL ()) SQL ([t] -> m ()) Int+data MigrationAction m+  = -- | Standard migration, i.e. an arbitrary 'MonadDB' action.+    StandardMigration (m ())+  | -- | Drop table migration. Parameter is the drop table mode+    -- (@RESTRICT@/@CASCADE@). The 'Migration' record holds the name of+    -- the table to drop.+    DropTableMigration DropTableMode+  | -- | Migration for creating an index concurrently.+    CreateIndexConcurrentlyMigration+      (RawSQL ())+      -- ^ Table name+      TableIndex+      -- ^ Index+  | -- | Migration for dropping an index concurrently.+    DropIndexConcurrentlyMigration+      (RawSQL ())+      -- ^ Table name+      TableIndex+      -- ^ Index+  | -- | Migration for modifying columns. Parameters are:+    --+    -- Name of the table that the cursor is associated with. It has to be the same as in the+    -- cursor SQL, see the second parameter.+    --+    -- SQL providing a list of primary keys from the associated table that will be used for the cursor.+    --+    -- Function that takes a batch of primary keys provided by the cursor SQL and runs an arbitrary computation+    -- within MonadDB. The function might be called repeatedly depending on the batch size and total number of+    -- selected primary keys. See the last argument.+    --+    -- Batch size of primary keys to be fetched at once by the cursor SQL and be given to the modification function.+    -- To handle multi-column primary keys, the following needs to be done:+    --+    --   1. Get the list of tuples from PostgreSQL.+    --   2. Unzip them into a tuple of lists in Haskell.+    --   3. Pass the lists to PostgreSQL as separate parameters and zip them back in the SQL,+    --      see https://stackoverflow.com/questions/12414750/is-there-something-like-a-zip-function-in-postgresql-that-combines-two-arrays for more details.+    forall t. FromRow t => ModifyColumnMigration (RawSQL ()) SQL ([t] -> m ()) Int  -- | Migration object.-data Migration m =-  Migration {-  -- | The name of the table you're migrating.-  mgrTableName :: RawSQL ()-  -- | The version you're migrating *from* (you don't specify what+data Migration m+  = Migration+  { mgrTableName :: RawSQL ()+  -- ^ The name of the table you're migrating.+  , mgrFrom :: Int32+  -- ^ The version you're migrating *from* (you don't specify what   -- version you migrate TO, because version is always increased by 1,   -- so if 'mgrFrom' is 2, that means that after that migration is run,   -- table version will equal 3-, mgrFrom   :: Int32-  -- | Migration action.-, mgrAction :: MigrationAction m+  , mgrAction :: MigrationAction m+  -- ^ Migration action.   }  isStandardMigration :: Migration m -> Bool-isStandardMigration Migration{..} =+isStandardMigration Migration {..} =   case mgrAction of-    StandardMigration{}                -> True-    DropTableMigration{}               -> False-    CreateIndexConcurrentlyMigration{} -> False-    DropIndexConcurrentlyMigration{}   -> False-    ModifyColumnMigration{}            -> False+    StandardMigration {} -> True+    DropTableMigration {} -> False+    CreateIndexConcurrentlyMigration {} -> False+    DropIndexConcurrentlyMigration {} -> False+    ModifyColumnMigration {} -> False  isDropTableMigration :: Migration m -> Bool-isDropTableMigration Migration{..} =+isDropTableMigration Migration {..} =   case mgrAction of-    StandardMigration{}                -> False-    DropTableMigration{}               -> True-    CreateIndexConcurrentlyMigration{} -> False-    DropIndexConcurrentlyMigration{}   -> False-    ModifyColumnMigration{}            -> False+    StandardMigration {} -> False+    DropTableMigration {} -> True+    CreateIndexConcurrentlyMigration {} -> False+    DropIndexConcurrentlyMigration {} -> False+    ModifyColumnMigration {} -> False

@@ -1,8 +1,9 @@-module Database.PostgreSQL.PQTypes.Model.PrimaryKey (-    PrimaryKey+module Database.PostgreSQL.PQTypes.Model.PrimaryKey+  ( PrimaryKey   , pkOnColumn   , pkOnColumns   , pkName+  , pkColumns   , sqlAddPK   , sqlAddPKUsing   , sqlDropPK@@ -20,32 +21,37 @@ pkOnColumn column = Just . PrimaryKey . toNubList $ [column]  pkOnColumns :: [RawSQL ()] -> Maybe PrimaryKey-pkOnColumns []      = Nothing+pkOnColumns [] = Nothing pkOnColumns columns = Just . PrimaryKey . toNubList $ columns  pkName :: RawSQL () -> RawSQL () pkName tname = mconcat ["pk__", tname] +pkColumns :: PrimaryKey -> [RawSQL ()]+pkColumns (PrimaryKey columns) = fromNubList columns+ sqlAddPK :: RawSQL () -> PrimaryKey -> RawSQL ()-sqlAddPK tname (PrimaryKey columns) = smconcat [-    "ADD CONSTRAINT"-  , pkName tname-  , "PRIMARY KEY ("-  , mintercalate ", " $ fromNubList columns-  , ")"-  ]+sqlAddPK tname (PrimaryKey columns) =+  smconcat+    [ "ADD CONSTRAINT"+    , pkName tname+    , "PRIMARY KEY ("+    , mintercalate ", " $ fromNubList columns+    , ")"+    ]  -- | Convert a unique index into a primary key. Main usage is to build a unique -- index concurrently first (so that its creation doesn't conflict with table -- updates on the modified table) and then convert it into a primary key using -- this function. sqlAddPKUsing :: RawSQL () -> TableIndex -> RawSQL ()-sqlAddPKUsing tname idx = smconcat-  [ "ADD CONSTRAINT"-  , pkName tname-  , "PRIMARY KEY USING INDEX"-  , indexName tname idx-  ]+sqlAddPKUsing tname idx =+  smconcat+    [ "ADD CONSTRAINT"+    , pkName tname+    , "PRIMARY KEY USING INDEX"+    , indexName tname idx+    ]  sqlDropPK :: RawSQL () -> RawSQL () sqlDropPK tname = "DROP CONSTRAINT" <+> pkName tname

@@ -1,17 +1,17 @@-module Database.PostgreSQL.PQTypes.Model.Table (-    TableColumn(..)+module Database.PostgreSQL.PQTypes.Model.Table+  ( TableColumn (..)   , tblColumn   , sqlAddColumn   , sqlAlterColumn   , sqlDropColumn-  , Rows(..)-  , Table(..)+  , Rows (..)+  , Table (..)   , tblTable   , sqlCreateTable   , sqlAlterTable-  , DropTableMode(..)+  , DropTableMode (..)   , sqlDropTable-  , TableInitialSetup(..)+  , TableInitialSetup (..)   ) where  import Control.Monad.Catch@@ -27,32 +27,35 @@ import Database.PostgreSQL.PQTypes.Model.PrimaryKey import Database.PostgreSQL.PQTypes.Model.Trigger -data TableColumn = TableColumn {-  colName      :: RawSQL ()-, colType      :: ColumnType-, colCollation :: Maybe (RawSQL ())-, colNullable  :: Bool-, colDefault   :: Maybe (RawSQL ())-} deriving Show+data TableColumn = TableColumn+  { colName :: RawSQL ()+  , colType :: ColumnType+  , colCollation :: Maybe (RawSQL ())+  , colNullable :: Bool+  , colDefault :: Maybe (RawSQL ())+  }+  deriving (Show)  tblColumn :: TableColumn-tblColumn = TableColumn {-  colName = error "tblColumn: column name must be specified"-, colType = error "tblColumn: column type must be specified"-, colCollation = Nothing-, colNullable = True-, colDefault = Nothing-}+tblColumn =+  TableColumn+    { colName = error "tblColumn: column name must be specified"+    , colType = error "tblColumn: column type must be specified"+    , colCollation = Nothing+    , colNullable = True+    , colDefault = Nothing+    }  sqlAddColumn :: TableColumn -> RawSQL ()-sqlAddColumn TableColumn{..} = smconcat [-    "ADD COLUMN"-  , colName-  , columnTypeToSQL colType-  , maybe "" (\c -> "COLLATE \"" <> c <> "\"") colCollation-  , if colNullable then "NULL" else "NOT NULL"-  , maybe "" ("DEFAULT" <+>) colDefault-  ]+sqlAddColumn TableColumn {..} =+  smconcat+    [ "ADD COLUMN"+    , colName+    , columnTypeToSQL colType+    , maybe "" (\c -> "COLLATE \"" <> c <> "\"") colCollation+    , if colNullable then "NULL" else "NOT NULL"+    , maybe "" ("DEFAULT" <+>) colDefault+    ]  sqlAlterColumn :: RawSQL () -> RawSQL () -> RawSQL () sqlAlterColumn cname alter = "ALTER COLUMN" <+> cname <+> alter@@ -64,56 +67,61 @@  data Rows = forall row. (Show row, ToRow row) => Rows [ByteString] [row] -data Table =-  Table {-  tblName               :: RawSQL () -- ^ Must be in lower case.-, tblVersion            :: Int32-, tblColumns            :: [TableColumn]-, tblPrimaryKey         :: Maybe PrimaryKey-, tblChecks             :: [Check]-, tblForeignKeys        :: [ForeignKey]-, tblIndexes            :: [TableIndex]-, tblTriggers           :: [Trigger]-, tblInitialSetup       :: Maybe TableInitialSetup-}+data Table+  = Table+  { tblName :: RawSQL ()+  -- ^ Must be in lower case.+  , tblVersion :: Int32+  , tblColumns :: [TableColumn]+  , tblPrimaryKey :: Maybe PrimaryKey+  , tblChecks :: [Check]+  , tblForeignKeys :: [ForeignKey]+  , tblIndexes :: [TableIndex]+  , tblTriggers :: [Trigger]+  , tblInitialSetup :: Maybe TableInitialSetup+  } -data TableInitialSetup = TableInitialSetup {-  checkInitialSetup :: forall m. (MonadDB m, MonadThrow m) => m Bool-, initialSetup      :: forall m. (MonadDB m, MonadThrow m) => m ()-}+data TableInitialSetup = TableInitialSetup+  { checkInitialSetup :: forall m. (MonadDB m, MonadThrow m) => m Bool+  , initialSetup :: forall m. (MonadDB m, MonadThrow m) => m ()+  }  tblTable :: Table-tblTable = Table {-  tblName = error "tblTable: table name must be specified"-, tblVersion = error "tblTable: table version must be specified"-, tblColumns = error "tblTable: table columns must be specified"-, tblPrimaryKey = Nothing-, tblChecks = []-, tblForeignKeys = []-, tblIndexes = []-, tblTriggers = []-, tblInitialSetup = Nothing-}+tblTable =+  Table+    { tblName = error "tblTable: table name must be specified"+    , tblVersion = error "tblTable: table version must be specified"+    , tblColumns = error "tblTable: table columns must be specified"+    , tblPrimaryKey = Nothing+    , tblChecks = []+    , tblForeignKeys = []+    , tblIndexes = []+    , tblTriggers = []+    , tblInitialSetup = Nothing+    }  sqlCreateTable :: RawSQL () -> RawSQL () sqlCreateTable tname = "CREATE TABLE" <+> tname <+> "()"  -- | Whether to also drop objects that depend on the table.-data DropTableMode =-  -- | Automatically drop objects that depend on the table (such as views).-  DropTableCascade |-  -- | Refuse to drop the table if any objects depend on it. This is the default.-  DropTableRestrict+data DropTableMode+  = -- | Automatically drop objects that depend on the table (such as views).+    DropTableCascade+  | -- | Refuse to drop the table if any objects depend on it. This is the default.+    DropTableRestrict  sqlDropTable :: RawSQL () -> DropTableMode -> RawSQL ()-sqlDropTable tname mode = "DROP TABLE" <+> tname-  <+> case mode of-        DropTableCascade  -> "CASCADE"-        DropTableRestrict -> "RESTRICT"+sqlDropTable tname mode =+  "DROP TABLE"+    <+> tname+    <+> case mode of+      DropTableCascade -> "CASCADE"+      DropTableRestrict -> "RESTRICT"  sqlAlterTable :: RawSQL () -> [RawSQL ()] -> RawSQL ()-sqlAlterTable tname alter_statements = smconcat [-    "ALTER TABLE"-  , tname-  , mintercalate ", " alter_statements-  ]+sqlAlterTable tname alter_statements =+  smconcat+    [ "ALTER TABLE"+    , tname+    , mintercalate ", " alter_statements+    ]

@@ -1,16 +1,15 @@ -- | -- Module: Database.PostgreSQL.PQTypes.Model.Trigger ----- Trigger name must be unique among triggers of same table. Only @CONSTRAINT@ triggers are--- supported. They can only be run @AFTER@ an event. The associated functions are always--- created with no arguments and always @RETURN TRIGGER@.+-- Trigger name must be unique among triggers of the same table. ----- For details, see <https://www.postgresql.org/docs/11/sql-createtrigger.html>.--module Database.PostgreSQL.PQTypes.Model.Trigger (-  -- * Triggers-    TriggerEvent(..)-  , Trigger(..)+-- For details, see <https://www.postgresql.org/docs/current/sql-createtrigger.html>.+module Database.PostgreSQL.PQTypes.Model.Trigger+  ( -- * Triggers+    TriggerKind (..)+  , TriggerActionTime (..)+  , TriggerEvent (..)+  , Trigger (..)   , triggerMakeName   , triggerBaseName   , sqlCreateTrigger@@ -18,10 +17,14 @@   , createTrigger   , dropTrigger   , getDBTriggers-  -- * Trigger functions++    -- * Trigger functions   , sqlCreateTriggerFunction   , sqlDropTriggerFunction   , triggerFunctionMakeName++    -- * Constraints+  , ConstraintAttributes (..)   ) where  import Data.Bits (testBit)@@ -29,60 +32,95 @@ import Data.Int import Data.Monoid.Utils import Data.Set (Set)+import Data.Set qualified as Set import Data.Text (Text)+import Data.Text qualified as Text import Database.PostgreSQL.PQTypes import Database.PostgreSQL.PQTypes.SQL.Builder-import qualified Data.Set as Set-import qualified Data.Text as Text +-- | Timing for a regular trigger.+--+-- @since 1.17.0.0+data TriggerActionTime+  = -- | An @AFTER@ trigger.+    After+  | -- | A @BEFORE@ trigger.+    Before+  deriving (Eq, Show)++-- | Possible combinations of constraint attributes.+--+-- @since 1.17.0.0+data ConstraintAttributes+  = -- | The @NOT DEFERRABLE [INITIALLY IMMEDIATE]@ constraint.+    -- A @NOT DEFERRABLE@ constraint is @INITIALLY IMMEDIATE@ by default.+    NotDeferrable+  | -- | The @DEFERRABLE [INITIALLY IMMEDIATE]@ constraint.+    -- A @DEFERRABLE@ constraint is @INITIALLY IMMEDIATE@ by default.+    Deferrable+  | -- | The @DEFERRABLE INITIALLY DEFERRED@ constraint.+    DeferrableInitiallyDeferred+  deriving (Eq, Show)++-- | Trigger kind.+--+-- @since 1.17.0.0+data TriggerKind+  = -- | Create a regular trigger: @CREATE TRIGGER@+    TriggerRegular TriggerActionTime+  | -- | Create a constraint trigger: @CREATE CONSTRAINT TRIGGER@+    TriggerConstraint ConstraintAttributes+  deriving (Eq, Show)+ -- | Trigger event name. -- -- @since 1.15.0.0 data TriggerEvent-  = TriggerInsert-  -- ^ The @INSERT@ event.-  | TriggerUpdate-  -- ^ The @UPDATE@ event.-  | TriggerUpdateOf [RawSQL ()]-  -- ^ The @UPDATE OF column1 [, column2 ...]@ event.-  | TriggerDelete-  -- ^ The @DELETE@ event.+  = -- | The @INSERT@ event.+    TriggerInsert+  | -- | The @UPDATE@ event.+    TriggerUpdate+  | -- | The @UPDATE OF column1 [, column2 ...]@ event.+    TriggerUpdateOf [RawSQL ()]+  | -- | The @DELETE@ event.+    TriggerDelete   deriving (Eq, Ord, Show)  -- | Trigger. -- -- @since 1.15.0.0-data Trigger = Trigger {-    triggerTable             :: RawSQL ()-    -- ^ The table that the trigger is associated with.-  , triggerName              :: RawSQL ()-    -- ^ The internal name without any prefixes. Trigger name must be unique among-    -- triggers of same table. See 'triggerMakeName'.-  , triggerEvents            :: Set TriggerEvent-    -- ^ The set of events. Corresponds to the @{ __event__ [ OR ... ] }@ in the trigger-    -- definition. The order in which they are defined doesn't matter and there can-    -- only be one of each.-  , triggerDeferrable        :: Bool-    -- ^ Is the trigger @DEFERRABLE@ or @NOT DEFERRABLE@ ?-  , triggerInitiallyDeferred :: Bool-    -- ^ Is the trigger @INITIALLY DEFERRED@ or @INITIALLY IMMEDIATE@ ?-  , triggerWhen              :: Maybe (RawSQL ())-    -- ^ The condition that specifies whether the trigger should fire. Corresponds to the-    -- @WHEN ( __condition__ )@ in the trigger definition.-  , triggerFunction          :: RawSQL ()-    -- ^ The function to execute when the trigger fires.-} deriving (Show)+data Trigger = Trigger+  { triggerTable :: RawSQL ()+  -- ^ The table that the trigger is associated with.+  , triggerName :: RawSQL ()+  -- ^ The internal name without any prefixes. Trigger name must be unique among+  -- triggers of same table. See 'triggerMakeName'.+  , triggerKind :: TriggerKind+  -- ^ The kind of trigger we want to create.+  -- @since 1.17.0.0+  , triggerEvents :: Set TriggerEvent+  -- ^ The set of events. Corresponds to the @{ __event__ [ OR ... ] }@ in the trigger+  -- definition. The order in which they are defined doesn't matter and there can+  -- only be one of each.+  , triggerWhen :: Maybe (RawSQL ())+  -- ^ The condition that specifies whether the trigger should fire. Corresponds to the+  -- @WHEN ( __condition__ )@ in the trigger definition.+  , triggerFunction :: RawSQL ()+  -- ^ The function to execute when the trigger fires.+  -- The function is declared as taking no arguments and returning type @trigger@.+  }+  deriving (Show)  instance Eq Trigger where   t1 == t2 =     triggerTable t1 == triggerTable t2-    && triggerName t1 == triggerName t2-    && triggerEvents t1 == triggerEvents t2-    && triggerDeferrable t1 == triggerDeferrable t2-    && triggerInitiallyDeferred t1 == triggerInitiallyDeferred t2-    && triggerWhen t1 == triggerWhen t2-    -- Function source code is not guaranteed to be equal, so we ignore it.+      && triggerName t1 == triggerName t2+      && triggerKind t1 == triggerKind t2+      && triggerEvents t1 == triggerEvents t2+      && triggerWhen t1 == triggerWhen t2 +-- Function source code is not guaranteed to be equal, so we ignore it.+ -- | Make a trigger name that can be used in SQL. -- -- Given a base @name@ and @tableName@, return a new name that will be used as the@@ -107,47 +145,57 @@ triggerEventName = \case   TriggerInsert -> "INSERT"   TriggerUpdate -> "UPDATE"-  TriggerUpdateOf columns -> if null columns-                             then error "UPDATE OF must have columns."-                             else "UPDATE OF" <+> mintercalate ", " columns+  TriggerUpdateOf columns ->+    if null columns+      then error "UPDATE OF must have columns."+      else "UPDATE OF" <+> mintercalate ", " columns   TriggerDelete -> "DELETE"  -- | Build an SQL statement that creates a trigger. ----- Only supports @CONSTRAINT@ triggers which can only run @AFTER@.--- -- @since 1.15.0 sqlCreateTrigger :: Trigger -> RawSQL ()-sqlCreateTrigger Trigger{..} =-  "CREATE CONSTRAINT TRIGGER" <+> trgName-    <+> "AFTER" <+> trgEvents-    <+> "ON" <+> triggerTable-    <+> trgTiming+sqlCreateTrigger Trigger {..} =+  "CREATE"+    <+> trgKind+    <+> trgName+    <+> tgrActionTime+    <+> trgEvents+    <+> "ON"+    <+> triggerTable+    <+> trgConstraintAttributes     <+> "FOR EACH ROW"     <+> trgWhen-    <+> "EXECUTE FUNCTION" <+> trgFunction+    <+> "EXECUTE FUNCTION"+    <+> trgFunction     <+> "()"   where+    trgKind = case triggerKind of+      TriggerRegular _ -> "TRIGGER"+      TriggerConstraint _ -> "CONSTRAINT TRIGGER"     trgName       | triggerName == "" = error "Trigger must have a name."       | otherwise = triggerMakeName triggerName triggerTable+    tgrActionTime = case triggerKind of+      TriggerRegular After -> "AFTER"+      TriggerRegular Before -> "BEFORE"+      TriggerConstraint _ -> "AFTER"     trgEvents       | triggerEvents == Set.empty = error "Trigger must have at least one event."       | otherwise = mintercalate " OR " . map triggerEventName $ Set.toList triggerEvents-    trgTiming = let deferrable = (if triggerDeferrable then "" else "NOT") <+> "DEFERRABLE"-                    deferred   = if triggerInitiallyDeferred-                                 then "INITIALLY DEFERRED"-                                 else "INITIALLY IMMEDIATE"-                in deferrable <+> deferred+    trgConstraintAttributes = case triggerKind of+      TriggerRegular _ -> ""+      TriggerConstraint NotDeferrable -> "NOT DEFERRABLE"+      TriggerConstraint Deferrable -> "DEFERRABLE"+      TriggerConstraint DeferrableInitiallyDeferred -> "DEFERRABLE INITIALLY DEFERRED"     trgWhen = maybe "" (\w -> "WHEN (" <+> w <+> ")") triggerWhen     trgFunction = triggerFunctionMakeName triggerName - -- | Build an SQL statement that drops a trigger. -- -- @since 1.15.0 sqlDropTrigger :: Trigger -> RawSQL ()-sqlDropTrigger Trigger{..} =+sqlDropTrigger Trigger {..} =   -- In theory, because the trigger is dependent on its function, it should be enough to   -- 'DROP FUNCTION triggerFunction CASCADE'. However, let's make this safe and go with   -- the default RESTRICT here.@@ -197,8 +245,9 @@   runQuery_ . sqlSelect "pg_trigger t" $ do     sqlResult "t.tgname::text" -- name     sqlResult "t.tgtype" -- smallint == int2 => (2 bytes)+    sqlResult "t.tgconstraint > 0" -- we only check if CONSTRAINT has been specified     sqlResult "t.tgdeferrable" -- boolean-    sqlResult "t.tginitdeferred"-- boolean+    sqlResult "t.tginitdeferred" -- boolean     -- This gets the entire query that created this trigger. Note that it's decompiled and     -- normalized, which means that it's likely not what the user actually typed. For     -- example, if the original query had excessive whitespace in it, it won't be in this@@ -213,16 +262,16 @@     sqlWhereEq "c.relname" $ unRawSQL tableName   fetchMany getTrigger   where-    getTrigger :: (String, Int16, Bool, Bool, String, String, String, String) -> (Trigger, RawSQL ())-    getTrigger (tgname, tgtype, tgdeferrable, tginitdeferrable, triggerdef, proname, prosrc, tblName) =-      ( Trigger { triggerTable = tableName'-                , triggerName = triggerBaseName (unsafeSQL tgname) tableName'-                , triggerEvents = trgEvents-                , triggerDeferrable = tgdeferrable-                , triggerInitiallyDeferred = tginitdeferrable-                , triggerWhen = tgrWhen-                , triggerFunction = unsafeSQL prosrc-                }+    getTrigger :: (String, Int16, Bool, Bool, Bool, String, String, String, String) -> (Trigger, RawSQL ())+    getTrigger (tgname, tgtype, tgconstraint, tgdeferrable, tginitdeferrable, triggerdef, proname, prosrc, tblName) =+      ( Trigger+          { triggerTable = tableName'+          , triggerName = triggerBaseName (unsafeSQL tgname) tableName'+          , triggerKind = tgrKind+          , triggerEvents = trgEvents+          , triggerWhen = tgrWhen+          , triggerFunction = unsafeSQL prosrc+          }       , unsafeSQL proname       )       where@@ -233,8 +282,8 @@         parseBetween left right =           let (prefix, match) = Text.breakOnEnd left $ Text.pack triggerdef           in if Text.null prefix-             then Nothing-             else Just $ (rawSQL . fst $ Text.breakOn right match) ()+              then Nothing+              else Just $ (rawSQL . fst $ Text.breakOn right match) ()          -- Get the WHEN part of the query. Anything between WHEN and EXECUTE is what we         -- want. The Postgres' grammar guarantees that WHEN and EXECUTE are always next to@@ -242,28 +291,53 @@         tgrWhen :: Maybe (RawSQL ())         tgrWhen = parseBetween "WHEN (" ") EXECUTE" +        tgrKind :: TriggerKind+        tgrKind =+          if tgconstraint+            then TriggerConstraint trgConstraintAttrs+            else TriggerRegular tgrActionTime++        trgConstraintAttrs :: ConstraintAttributes+        trgConstraintAttrs = case (tgdeferrable, tginitdeferrable) of+          (False, False) -> NotDeferrable+          (True, False) -> Deferrable+          (True, True) -> DeferrableInitiallyDeferred+          (False, True) -> error "A constraint declared INITIALLY DEFERRED must be DEFERRABLE."++        tgrActionTime :: TriggerActionTime+        tgrActionTime = case (tgtypeInsteadBit, tgtypeBeforeBit) of+          (False, False) -> After+          (False, True) -> Before+          (True, False) -> error "INSTEAD OF triggers are not available on tables."+          (True, True) -> error "The tgtype can't match more than one timing."+          where+            -- Taken from PostgreSQL sources: src/include/catalog/pg_trigger.h:+            tgtypeBeforeBit = testBit tgtype 1 -- #define TRIGGER_TYPE_BEFORE (1 << 1)+            tgtypeInsteadBit = testBit tgtype 6 -- #define TRIGGER_TYPE_INSTEAD (1 << 6)+         -- Similarly, in case of UPDATE OF, the columns can be simply parsed from the         -- original query. Note that UPDATE and UPDATE OF are mutually exclusive and have         -- the same bit set in the underlying tgtype bit field.         trgEvents :: Set TriggerEvent         trgEvents =-          foldl' (\set (mask, event) ->-                    if testBit tgtype mask-                    then-                      Set.insert-                        (if event == TriggerUpdate-                         then maybe event trgUpdateOf $ parseBetween "UPDATE OF " " ON"-                         else event-                        )-                        set-                    else set-                 )-          Set.empty-          -- Taken from PostgreSQL sources: src/include/catalog/pg_trigger.h:-          [ (2, TriggerInsert) -- #define TRIGGER_TYPE_INSERT (1 << 2)-          , (3, TriggerDelete) -- #define TRIGGER_TYPE_DELETE (1 << 3)-          , (4, TriggerUpdate) -- #define TRIGGER_TYPE_UPDATE (1 << 4)-          ]+          foldl'+            ( \set (mask, event) ->+                if testBit tgtype mask+                  then+                    Set.insert+                      ( if event == TriggerUpdate+                          then maybe event trgUpdateOf $ parseBetween "UPDATE OF " " ON"+                          else event+                      )+                      set+                  else set+            )+            Set.empty+            -- Taken from PostgreSQL sources: src/include/catalog/pg_trigger.h:+            [ (2, TriggerInsert) -- #define TRIGGER_TYPE_INSERT (1 << 2)+            , (3, TriggerDelete) -- #define TRIGGER_TYPE_DELETE (1 << 3)+            , (4, TriggerUpdate) -- #define TRIGGER_TYPE_UPDATE (1 << 4)+            ]          trgUpdateOf :: RawSQL () -> TriggerEvent         trgUpdateOf columnsSQL =@@ -277,10 +351,10 @@ -- -- @since 1.15.0.0 sqlCreateTriggerFunction :: Trigger -> RawSQL ()-sqlCreateTriggerFunction Trigger{..} =+sqlCreateTriggerFunction Trigger {..} =   "CREATE FUNCTION"     <+> triggerFunctionMakeName triggerName-    <>  "()"+    <> "()"     <+> "RETURNS TRIGGER"     <+> "AS $$"     <+> triggerFunction@@ -293,7 +367,7 @@ -- -- @since 1.15.0.0 sqlDropTriggerFunction :: Trigger -> RawSQL ()-sqlDropTriggerFunction Trigger{..} =+sqlDropTriggerFunction Trigger {..} =   "DROP FUNCTION" <+> triggerFunctionMakeName triggerName <+> "RESTRICT"  -- | Make a trigger function name that can be used in SQL.@@ -305,4 +379,3 @@ -- @since 1.16.0.0 triggerFunctionMakeName :: RawSQL () -> RawSQL () triggerFunctionMakeName name = "trgfun__" <> name-

@@ -1,91 +1,88 @@-{- |--Module "Database.PostgreSQL.PQTypes.SQL.Builder" offers a nice-monadic DSL for building SQL statements on the fly. Some examples:-->>> :{-sqlSelect "documents" $ do-  sqlResult "id"-  sqlResult "title"-  sqlResult "mtime"-  sqlOrderBy "documents.mtime DESC"-  sqlWhereILike "documents.title" "%pattern%"-:}-SQL " SELECT  id, title, mtime FROM documents WHERE (documents.title ILIKE <\"%pattern%\">)    ORDER BY documents.mtime DESC  "--@SQL.Builder@ supports SELECT as 'sqlSelect' and data manipulation using-'sqlInsert', 'sqlInsertSelect', 'sqlDelete' and 'sqlUpdate'.-->>> import Data.Time->>> let title = "title" :: String->>> let ctime  = read "2020-01-01 00:00:00 UTC" :: UTCTime->>> :{-sqlInsert "documents" $ do-  sqlSet "title" title-  sqlSet "ctime" ctime-  sqlResult "id"-:}-SQL " INSERT INTO documents (title, ctime) VALUES (<\"title\">, <2020-01-01 00:00:00 UTC>)  RETURNING id"--The 'sqlInsertSelect' is particulary interesting as it supports INSERT-of values taken from a SELECT clause from same or even different-tables.--There is a possibility to do multiple inserts at once. Data given by-'sqlSetList' will be inserted multiple times, data given by 'sqlSet'-will be multiplied as many times as needed to cover all inserted rows-(it is common to all rows). If you use multiple 'sqlSetList' then-lists will be made equal in length by appending @DEFAULT@ as fill-element.-->>> :{-sqlInsert "documents" $ do-  sqlSet "ctime" ctime-  sqlSetList "title" ["title1", "title2", "title3"]-  sqlResult "id"-:}-SQL " INSERT INTO documents (ctime, title) VALUES (<2020-01-01 00:00:00 UTC>, <\"title1\">) , (<2020-01-01 00:00:00 UTC>, <\"title2\">) , (<2020-01-01 00:00:00 UTC>, <\"title3\">)  RETURNING id"--The above will insert 3 new documents.--@SQL.Builder@ provides quite a lot of SQL magic, including @ORDER BY@ as-'sqlOrderBy', @GROUP BY@ as 'sqlGroupBy'.-->>> :{-sqlSelect "documents" $ do-  sqlResult "id"-  sqlResult "title"-  sqlResult "mtime"-  sqlOrderBy "documents.mtime DESC"-  sqlOrderBy "documents.title"-  sqlGroupBy "documents.status"-  sqlJoinOn "users" "documents.user_id = users.id"-  sqlWhere $ mkSQL "documents.title ILIKE" <?> "%pattern%"-:}-SQL " SELECT  id, title, mtime FROM documents  JOIN  users  ON  documents.user_id = users.id WHERE (documents.title ILIKE <\"%pattern%\">)  GROUP BY documents.status  ORDER BY documents.mtime DESC, documents.title  "--Joins are done by 'sqlJoinOn', 'sqlLeftJoinOn', 'sqlRightJoinOn',-'sqlJoinOn', 'sqlFullJoinOn'. If everything fails use 'sqlJoin' and-'sqlFrom' to set join clause as string. Support for a join grammars as-some kind of abstract syntax data type is lacking.-->>> :{-sqlDelete "mails" $ do-  sqlWhere "id > 67"-:}-SQL " DELETE FROM mails  WHERE (id > 67) "-->>> :{-sqlUpdate "document_tags" $ do-  sqlSet "value" (123 :: Int)-  sqlWhere "name = 'abc'"-:}-SQL " UPDATE document_tags SET value=<123>  WHERE (name = 'abc') "---}- -- TODO: clean this up, add more documentation. +-- |+--+-- Module "Database.PostgreSQL.PQTypes.SQL.Builder" offers a nice+-- monadic DSL for building SQL statements on the fly. Some examples:+--+-- >>> :{+-- sqlSelect "documents" $ do+--   sqlResult "id"+--   sqlResult "title"+--   sqlResult "mtime"+--   sqlOrderBy "documents.mtime DESC"+--   sqlWhereILike "documents.title" "%pattern%"+-- :}+-- SQL " SELECT  id, title, mtime FROM documents WHERE (documents.title ILIKE <\"%pattern%\">)    ORDER BY documents.mtime DESC  "+--+-- @SQL.Builder@ supports SELECT as 'sqlSelect' and data manipulation using+-- 'sqlInsert', 'sqlInsertSelect', 'sqlDelete' and 'sqlUpdate'.+--+-- >>> import Data.Time+-- >>> let title = "title" :: String+-- >>> let ctime  = read "2020-01-01 00:00:00 UTC" :: UTCTime+-- >>> :{+-- sqlInsert "documents" $ do+--   sqlSet "title" title+--   sqlSet "ctime" ctime+--   sqlResult "id"+-- :}+-- SQL " INSERT INTO documents (title, ctime) VALUES (<\"title\">, <2020-01-01 00:00:00 UTC>)  RETURNING id"+--+-- The 'sqlInsertSelect' is particulary interesting as it supports INSERT+-- of values taken from a SELECT clause from same or even different+-- tables.+--+-- There is a possibility to do multiple inserts at once. Data given by+-- 'sqlSetList' will be inserted multiple times, data given by 'sqlSet'+-- will be multiplied as many times as needed to cover all inserted rows+-- (it is common to all rows). If you use multiple 'sqlSetList' then+-- lists will be made equal in length by appending @DEFAULT@ as fill+-- element.+--+-- >>> :{+-- sqlInsert "documents" $ do+--   sqlSet "ctime" ctime+--   sqlSetList "title" ["title1", "title2", "title3"]+--   sqlResult "id"+-- :}+-- SQL " INSERT INTO documents (ctime, title) VALUES (<2020-01-01 00:00:00 UTC>, <\"title1\">) , (<2020-01-01 00:00:00 UTC>, <\"title2\">) , (<2020-01-01 00:00:00 UTC>, <\"title3\">)  RETURNING id"+--+-- The above will insert 3 new documents.+--+-- @SQL.Builder@ provides quite a lot of SQL magic, including @ORDER BY@ as+-- 'sqlOrderBy', @GROUP BY@ as 'sqlGroupBy'.+--+-- >>> :{+-- sqlSelect "documents" $ do+--   sqlResult "id"+--   sqlResult "title"+--   sqlResult "mtime"+--   sqlOrderBy "documents.mtime DESC"+--   sqlOrderBy "documents.title"+--   sqlGroupBy "documents.status"+--   sqlJoinOn "users" "documents.user_id = users.id"+--   sqlWhere $ mkSQL "documents.title ILIKE" <?> "%pattern%"+-- :}+-- SQL " SELECT  id, title, mtime FROM documents  JOIN  users  ON  documents.user_id = users.id WHERE (documents.title ILIKE <\"%pattern%\">)  GROUP BY documents.status  ORDER BY documents.mtime DESC, documents.title  "+--+-- Joins are done by 'sqlJoinOn', 'sqlLeftJoinOn', 'sqlRightJoinOn',+-- 'sqlJoinOn', 'sqlFullJoinOn'. If everything fails use 'sqlJoin' and+-- 'sqlFrom' to set join clause as string. Support for a join grammars as+-- some kind of abstract syntax data type is lacking.+--+-- >>> :{+-- sqlDelete "mails" $ do+--   sqlWhere "id > 67"+-- :}+-- SQL " DELETE FROM mails  WHERE (id > 67) "+--+-- >>> :{+-- sqlUpdate "document_tags" $ do+--   sqlSet "value" (123 :: Int)+--   sqlWhere "name = 'abc'"+-- :}+-- SQL " UPDATE document_tags SET value=<123>  WHERE (name = 'abc') " module Database.PostgreSQL.PQTypes.SQL.Builder   ( sqlWhere   , sqlWhereEq@@ -102,7 +99,6 @@   , sqlWhereILike   , sqlWhereIsNULL   , sqlWhereIsNotNULL-   , sqlFrom   , sqlJoin   , sqlJoinOn@@ -127,25 +123,27 @@   , sqlLimit   , sqlDistinct   , sqlWith+  , sqlWithRecursive   , sqlWithMaterialized   , sqlUnion   , sqlUnionAll   , checkAndRememberMaterializationSupport-   , sqlSelect   , sqlSelect2-  , SqlSelect(..)+  , SqlSelect (..)   , sqlInsert-  , SqlInsert(..)+  , SqlInsert (..)   , sqlInsertSelect-  , SqlInsertSelect(..)+  , SqlInsertSelect (..)   , sqlUpdate-  , SqlUpdate(..)+  , SqlUpdate (..)   , sqlDelete-  , SqlDelete(..)-+  , SqlDelete (..)+  , SqlWhereAll (..)+  , sqlAll+  , SqlWhereAny (..)+  , sqlAny   , sqlWhereAny-   , SqlResult   , SqlSet   , SqlFrom@@ -155,25 +153,23 @@   , SqlGroupByHaving   , SqlOffsetLimit   , SqlDistinct--  , SqlCondition(..)+  , SqlCondition (..)   , sqlGetWhereConditions--  , Sqlable(..)+  , Sqlable (..)   , sqlOR   , sqlConcatComma   , sqlConcatAND   , sqlConcatOR   , parenthesize-  , AscDesc(..)+  , AscDesc (..)   )-  where+where -import Control.Monad.State import Control.Monad.Catch-import Data.Int-import Data.IORef+import Control.Monad.State import Data.Either+import Data.IORef+import Data.Int import Data.List import Data.Maybe import Data.Monoid.Utils@@ -221,76 +217,90 @@ -- structure of a condition. For now it seems that the only -- interesting case is EXISTS (SELECT ...), because that internal -- SELECT can have explainable clauses.-data SqlCondition = SqlPlainCondition SQL-                  | SqlExistsCondition SqlSelect-                    deriving (Typeable, Show)+data SqlCondition+  = SqlPlainCondition SQL+  | SqlExistsCondition SqlSelect+  deriving (Typeable, Show)  instance Sqlable SqlCondition where   toSQLCommand (SqlPlainCondition a) = a-  toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a { sqlSelectResult = ["TRUE"] }) <> ")"+  toSQLCommand (SqlExistsCondition a) = "EXISTS (" <> toSQLCommand (a {sqlSelectResult = ["TRUE"]}) <> ")"  data SqlSelect = SqlSelect-  { sqlSelectFrom     :: SQL-  , sqlSelectUnion    :: [SQL]+  { sqlSelectFrom :: SQL+  , sqlSelectUnion :: [SQL]   , sqlSelectUnionAll :: [SQL]   , sqlSelectDistinct :: Bool-  , sqlSelectResult   :: [SQL]-  , sqlSelectWhere    :: [SqlCondition]-  , sqlSelectOrderBy  :: [SQL]-  , sqlSelectGroupBy  :: [SQL]-  , sqlSelectHaving   :: [SQL]-  , sqlSelectOffset   :: Integer-  , sqlSelectLimit    :: Integer-  , sqlSelectWith     :: [(SQL, SQL, Materialized)]+  , sqlSelectResult :: [SQL]+  , sqlSelectWhere :: [SqlCondition]+  , sqlSelectOrderBy :: [SQL]+  , sqlSelectGroupBy :: [SQL]+  , sqlSelectHaving :: [SQL]+  , sqlSelectOffset :: Integer+  , sqlSelectLimit :: Integer+  , sqlSelectWith :: [(SQL, SQL, Materialized)]+  , sqlSelectRecursiveWith :: Recursive   }  data SqlUpdate = SqlUpdate-  { sqlUpdateWhat   :: SQL-  , sqlUpdateFrom   :: SQL-  , sqlUpdateWhere  :: [SqlCondition]-  , sqlUpdateSet    :: [(SQL,SQL)]+  { sqlUpdateWhat :: SQL+  , sqlUpdateFrom :: SQL+  , sqlUpdateWhere :: [SqlCondition]+  , sqlUpdateSet :: [(SQL, SQL)]   , sqlUpdateResult :: [SQL]-  , sqlUpdateWith   :: [(SQL, SQL, Materialized)]+  , sqlUpdateWith :: [(SQL, SQL, Materialized)]+  , sqlUpdateRecursiveWith :: Recursive   }  data SqlInsert = SqlInsert-  { sqlInsertWhat       :: SQL+  { sqlInsertWhat :: SQL   , sqlInsertOnConflict :: Maybe (SQL, Maybe SQL)-  , sqlInsertSet        :: [(SQL, Multiplicity SQL)]-  , sqlInsertResult     :: [SQL]-  , sqlInsertWith       :: [(SQL, SQL, Materialized)]+  , sqlInsertSet :: [(SQL, Multiplicity SQL)]+  , sqlInsertResult :: [SQL]+  , sqlInsertWith :: [(SQL, SQL, Materialized)]+  , sqlInsertRecursiveWith :: Recursive   }  data SqlInsertSelect = SqlInsertSelect-  { sqlInsertSelectWhat       :: SQL+  { sqlInsertSelectWhat :: SQL   , sqlInsertSelectOnConflict :: Maybe (SQL, Maybe SQL)-  , sqlInsertSelectDistinct   :: Bool-  , sqlInsertSelectSet        :: [(SQL, SQL)]-  , sqlInsertSelectResult     :: [SQL]-  , sqlInsertSelectFrom       :: SQL-  , sqlInsertSelectWhere      :: [SqlCondition]-  , sqlInsertSelectOrderBy    :: [SQL]-  , sqlInsertSelectGroupBy    :: [SQL]-  , sqlInsertSelectHaving     :: [SQL]-  , sqlInsertSelectOffset     :: Integer-  , sqlInsertSelectLimit      :: Integer-  , sqlInsertSelectWith       :: [(SQL, SQL, Materialized)]+  , sqlInsertSelectDistinct :: Bool+  , sqlInsertSelectSet :: [(SQL, SQL)]+  , sqlInsertSelectResult :: [SQL]+  , sqlInsertSelectFrom :: SQL+  , sqlInsertSelectWhere :: [SqlCondition]+  , sqlInsertSelectOrderBy :: [SQL]+  , sqlInsertSelectGroupBy :: [SQL]+  , sqlInsertSelectHaving :: [SQL]+  , sqlInsertSelectOffset :: Integer+  , sqlInsertSelectLimit :: Integer+  , sqlInsertSelectWith :: [(SQL, SQL, Materialized)]+  , sqlInsertSelectRecursiveWith :: Recursive   }  data SqlDelete = SqlDelete-  { sqlDeleteFrom   :: SQL-  , sqlDeleteUsing  :: SQL-  , sqlDeleteWhere  :: [SqlCondition]+  { sqlDeleteFrom :: SQL+  , sqlDeleteUsing :: SQL+  , sqlDeleteWhere :: [SqlCondition]   , sqlDeleteResult :: [SQL]-  , sqlDeleteWith   :: [(SQL, SQL, Materialized)]+  , sqlDeleteWith :: [(SQL, SQL, Materialized)]+  , sqlDeleteRecursiveWith :: Recursive   } --- | This is not exported and is used as an implementation detail in--- 'sqlWhereAll'.-data SqlAll = SqlAll-  { sqlAllWhere :: [SqlCondition]+-- | Type representing a set of conditions that are joined by 'AND'.+--+-- When no conditions are given, the result is 'TRUE'.+newtype SqlWhereAll = SqlWhereAll+  { sqlWhereAllWhere :: [SqlCondition]   } +-- | Type representing a set of conditions that are joined by 'OR'.+--+-- When no conditions are given, the result is 'FALSE'.+newtype SqlWhereAny = SqlWhereAny+  { sqlWhereAnyWhere :: [SqlCondition]+  }+ instance Show SqlSelect where   show = show . toSQLCommand @@ -306,14 +316,17 @@ instance Show SqlDelete where   show = show . toSQLCommand -instance Show SqlAll where+instance Show SqlWhereAll where   show = show . toSQLCommand +instance Show SqlWhereAny where+  show = show . toSQLCommand+ emitClause :: Sqlable sql => SQL -> sql -> SQL emitClause name s = case toSQLCommand s of   sql     | isSqlEmpty sql -> ""-    | otherwise   -> name <+> sql+    | otherwise -> name <+> sql  emitClausesSep :: SQL -> SQL -> [SQL] -> SQL emitClausesSep _name _sep [] = mempty@@ -339,99 +352,109 @@   withSQL = withSQL . toSQLCommand  instance Sqlable SqlSelect where-  toSQLCommand cmd = smconcat-    [ emitClausesSepComma "WITH" $-      map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlSelectWith cmd)-    , if hasUnion || hasUnionAll-      then emitClausesSep "" unionKeyword (mainSelectClause : unionCmd)-      else mainSelectClause-    , emitClausesSepComma "GROUP BY" (sqlSelectGroupBy cmd)-    , emitClausesSep "HAVING" "AND" (sqlSelectHaving cmd)-    , orderByClause-    , if sqlSelectOffset cmd > 0-      then unsafeSQL ("OFFSET " ++ show (sqlSelectOffset cmd))-      else ""-    , if sqlSelectLimit cmd >= 0-      then limitClause-      else ""-    ]-    where-      mainSelectClause = smconcat-        [ "SELECT" <+> (if sqlSelectDistinct cmd then "DISTINCT" else mempty)-        , sqlConcatComma (sqlSelectResult cmd)-        , emitClause "FROM" (sqlSelectFrom cmd)-        , emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlSelectWhere cmd)-        -- If there's a union, the result is sorted and has a limit, applying-        -- the order and limit to the main subquery won't reduce the overall-        -- query result, but might reduce its processing time.-        , if hasUnion && not (null $ sqlSelectOrderBy cmd) && sqlSelectLimit cmd >= 0-          then smconcat [orderByClause, limitClause]+  toSQLCommand cmd =+    smconcat+      [ emitClausesSepComma (recursiveClause $ sqlSelectRecursiveWith cmd) $+          map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlSelectWith cmd)+      , if hasUnion || hasUnionAll+          then emitClausesSep "" unionKeyword (mainSelectClause : unionCmd)+          else mainSelectClause+      , emitClausesSepComma "GROUP BY" (sqlSelectGroupBy cmd)+      , emitClausesSep "HAVING" "AND" (sqlSelectHaving cmd)+      , orderByClause+      , if sqlSelectOffset cmd > 0+          then unsafeSQL ("OFFSET " ++ show (sqlSelectOffset cmd))           else ""-        ]+      , if sqlSelectLimit cmd >= 0+          then limitClause+          else ""+      ]+    where+      mainSelectClause =+        smconcat+          [ "SELECT" <+> (if sqlSelectDistinct cmd then "DISTINCT" else mempty)+          , sqlConcatComma (sqlSelectResult cmd)+          , emitClause "FROM" (sqlSelectFrom cmd)+          , emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlSelectWhere cmd)+          , -- If there's a union, the result is sorted and has a limit, applying+            -- the order and limit to the main subquery won't reduce the overall+            -- query result, but might reduce its processing time.+            if hasUnion && not (null $ sqlSelectOrderBy cmd) && sqlSelectLimit cmd >= 0+              then smconcat [orderByClause, limitClause]+              else ""+          ] -      hasUnion      = not . null $ sqlSelectUnion cmd-      hasUnionAll   = not . null $ sqlSelectUnionAll cmd+      hasUnion = not . null $ sqlSelectUnion cmd+      hasUnionAll = not . null $ sqlSelectUnionAll cmd       unionKeyword = case (hasUnion, hasUnionAll) of-                        (False, True) -> "UNION ALL"-                        (True, False) -> "UNION"-                        -- False, False is caught by the (hasUnion || hasUnionAll) above.-                        -- Hence, the catch-all is implicitly for (True, True).-                        _ -> error "Having both `sqlSelectUnion` and `sqlSelectUnionAll` is not supported at the moment."+        (False, True) -> "UNION ALL"+        (True, False) -> "UNION"+        -- False, False is caught by the (hasUnion || hasUnionAll) above.+        -- Hence, the catch-all is implicitly for (True, True).+        _ -> error "Having both `sqlSelectUnion` and `sqlSelectUnionAll` is not supported at the moment."       unionCmd = case (hasUnion, hasUnionAll) of-                        (False, True) -> sqlSelectUnionAll cmd-                        (True, False) -> sqlSelectUnion cmd-                        -- False, False is caught by the (hasUnion || hasUnionAll) above.-                        -- Hence, the catch-all is implicitly for (True, True).-                        _ -> error "Having both `sqlSelectUnion` and `sqlSelectUnionAll` is not supported at the moment."+        (False, True) -> sqlSelectUnionAll cmd+        (True, False) -> sqlSelectUnion cmd+        -- False, False is caught by the (hasUnion || hasUnionAll) above.+        -- Hence, the catch-all is implicitly for (True, True).+        _ -> error "Having both `sqlSelectUnion` and `sqlSelectUnionAll` is not supported at the moment."       orderByClause = emitClausesSepComma "ORDER BY" $ sqlSelectOrderBy cmd-      limitClause   = unsafeSQL $ "LIMIT" <+> show (sqlSelectLimit cmd)+      limitClause = unsafeSQL $ "LIMIT" <+> show (sqlSelectLimit cmd)  emitClauseOnConflictForInsert :: Maybe (SQL, Maybe SQL) -> SQL emitClauseOnConflictForInsert = \case-       Nothing                   -> ""-       Just (condition, maction) -> emitClause "ON CONFLICT" $-         condition <+> "DO" <+> fromMaybe "NOTHING" maction+  Nothing -> ""+  Just (condition, maction) ->+    emitClause "ON CONFLICT" $+      condition <+> "DO" <+> fromMaybe "NOTHING" maction  instance Sqlable SqlInsert where   toSQLCommand cmd =-    emitClausesSepComma "WITH" (map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertWith cmd)) <+>-    "INSERT INTO" <+> sqlInsertWhat cmd <+>-    parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd))) <+>-    emitClausesSep "VALUES" "," (map sqlConcatComma (transpose (map (makeLongEnough . snd) (sqlInsertSet cmd)))) <+>-    emitClauseOnConflictForInsert (sqlInsertOnConflict cmd) <+>-    emitClausesSepComma "RETURNING" (sqlInsertResult cmd)-   where-     -- this is the longest list of values-     longest = maximum (1 : (map (lengthOfEither . snd) (sqlInsertSet cmd)))-     lengthOfEither (Single _) = 1-     lengthOfEither (Many x)   = length x-     makeLongEnough (Single x) = take longest (repeat x)-     makeLongEnough (Many x)   = take longest (x ++ repeat "DEFAULT")+    emitClausesSepComma+      (recursiveClause $ sqlInsertRecursiveWith cmd)+      (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertWith cmd))+      <+> "INSERT INTO"+      <+> sqlInsertWhat cmd+      <+> parenthesize (sqlConcatComma (map fst (sqlInsertSet cmd)))+      <+> emitClausesSep "VALUES" "," (map sqlConcatComma (transpose (map (makeLongEnough . snd) (sqlInsertSet cmd))))+      <+> emitClauseOnConflictForInsert (sqlInsertOnConflict cmd)+      <+> emitClausesSepComma "RETURNING" (sqlInsertResult cmd)+    where+      -- this is the longest list of values+      longest = maximum (1 : map (lengthOfEither . snd) (sqlInsertSet cmd))+      lengthOfEither (Single _) = 1+      lengthOfEither (Many x) = length x+      makeLongEnough (Single x) = replicate longest x+      makeLongEnough (Many x) = take longest (x ++ repeat "DEFAULT")  instance Sqlable SqlInsertSelect where-  toSQLCommand cmd = smconcat-    -- WITH clause needs to be at the top level, so we emit it here and not-    -- include it in the SqlSelect below.-    [ emitClausesSepComma "WITH" $-      map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertSelectWith cmd)-    , "INSERT INTO" <+> sqlInsertSelectWhat cmd-    , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd-    , parenthesize . toSQLCommand $ SqlSelect { sqlSelectFrom    = sqlInsertSelectFrom cmd-                                              , sqlSelectUnion   = []-                                              , sqlSelectUnionAll = []-                                              , sqlSelectDistinct = sqlInsertSelectDistinct cmd-                                              , sqlSelectResult  = fmap snd $ sqlInsertSelectSet cmd-                                              , sqlSelectWhere   = sqlInsertSelectWhere cmd-                                              , sqlSelectOrderBy = sqlInsertSelectOrderBy cmd-                                              , sqlSelectGroupBy = sqlInsertSelectGroupBy cmd-                                              , sqlSelectHaving  = sqlInsertSelectHaving cmd-                                              , sqlSelectOffset  = sqlInsertSelectOffset cmd-                                              , sqlSelectLimit   = sqlInsertSelectLimit cmd-                                              , sqlSelectWith    = []-                                              }-    , emitClauseOnConflictForInsert (sqlInsertSelectOnConflict cmd)-    , emitClausesSepComma "RETURNING" $ sqlInsertSelectResult cmd-    ]+  toSQLCommand cmd =+    smconcat+      -- WITH clause needs to be at the top level, so we emit it here and not+      -- include it in the SqlSelect below.+      [ emitClausesSepComma (recursiveClause $ sqlInsertSelectRecursiveWith cmd) $+          map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlInsertSelectWith cmd)+      , "INSERT INTO" <+> sqlInsertSelectWhat cmd+      , parenthesize . sqlConcatComma . map fst $ sqlInsertSelectSet cmd+      , parenthesize . toSQLCommand $+          SqlSelect+            { sqlSelectFrom = sqlInsertSelectFrom cmd+            , sqlSelectUnion = []+            , sqlSelectUnionAll = []+            , sqlSelectDistinct = sqlInsertSelectDistinct cmd+            , sqlSelectResult = snd <$> sqlInsertSelectSet cmd+            , sqlSelectWhere = sqlInsertSelectWhere cmd+            , sqlSelectOrderBy = sqlInsertSelectOrderBy cmd+            , sqlSelectGroupBy = sqlInsertSelectGroupBy cmd+            , sqlSelectHaving = sqlInsertSelectHaving cmd+            , sqlSelectOffset = sqlInsertSelectOffset cmd+            , sqlSelectLimit = sqlInsertSelectLimit cmd+            , sqlSelectWith = []+            , sqlSelectRecursiveWith = NonRecursive+            }+      , emitClauseOnConflictForInsert (sqlInsertSelectOnConflict cmd)+      , emitClausesSepComma "RETURNING" $ sqlInsertSelectResult cmd+      ]  -- This function has to be called as one of first things in your program -- for the library to make sure that it is aware if the "WITH MATERIALIZED"@@ -439,7 +462,7 @@ checkAndRememberMaterializationSupport :: (MonadDB m, MonadIO m, MonadMask m) => m () checkAndRememberMaterializationSupport = do   res :: Either DBException Int64 <- try . withNewConnection $ do-    runSQL01_ $ "WITH t(n) AS MATERIALIZED (SELECT (1 :: bigint)) SELECT n FROM t LIMIT 1"+    runSQL01_ "WITH t(n) AS MATERIALIZED (SELECT (1 :: bigint)) SELECT n FROM t LIMIT 1"     fetchOne runIdentity   liftIO $ writeIORef withMaterializedSupported (isRight res) @@ -448,138 +471,181 @@ withMaterializedSupported = unsafePerformIO $ newIORef False  isWithMaterializedSupported :: Bool+{-# NOINLINE isWithMaterializedSupported #-} isWithMaterializedSupported = unsafePerformIO $ readIORef withMaterializedSupported  materializedClause :: Materialized -> SQL materializedClause Materialized = if isWithMaterializedSupported then "MATERIALIZED" else "" materializedClause NonMaterialized = if isWithMaterializedSupported then "NOT MATERIALIZED" else "" +recursiveClause :: Recursive -> SQL+recursiveClause Recursive = "WITH RECURSIVE"+recursiveClause NonRecursive = "WITH"+ instance Sqlable SqlUpdate where   toSQLCommand cmd =-    emitClausesSepComma "WITH" (map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlUpdateWith cmd)) <+>-    "UPDATE" <+> sqlUpdateWhat cmd <+> "SET" <+>-    sqlConcatComma (map (\(name, command) -> name <> "=" <> command) (sqlUpdateSet cmd)) <+>-    emitClause "FROM" (sqlUpdateFrom cmd) <+>-    emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlUpdateWhere cmd) <+>-    emitClausesSepComma "RETURNING" (sqlUpdateResult cmd)+    emitClausesSepComma+      (recursiveClause $ sqlUpdateRecursiveWith cmd)+      (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlUpdateWith cmd))+      <+> "UPDATE"+      <+> sqlUpdateWhat cmd+      <+> "SET"+      <+> sqlConcatComma (map (\(name, command) -> name <> "=" <> command) (sqlUpdateSet cmd))+      <+> emitClause "FROM" (sqlUpdateFrom cmd)+      <+> emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlUpdateWhere cmd)+      <+> emitClausesSepComma "RETURNING" (sqlUpdateResult cmd)  instance Sqlable SqlDelete where   toSQLCommand cmd =-    emitClausesSepComma "WITH" (map (\(name,command,mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlDeleteWith cmd)) <+>-    "DELETE FROM" <+> sqlDeleteFrom cmd <+>-    emitClause "USING" (sqlDeleteUsing cmd) <+>-        emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlDeleteWhere cmd) <+>-    emitClausesSepComma "RETURNING" (sqlDeleteResult cmd)+    emitClausesSepComma+      (recursiveClause $ sqlDeleteRecursiveWith cmd)+      (map (\(name, command, mat) -> name <+> "AS" <+> materializedClause mat <+> parenthesize command) (sqlDeleteWith cmd))+      <+> "DELETE FROM"+      <+> sqlDeleteFrom cmd+      <+> emitClause "USING" (sqlDeleteUsing cmd)+      <+> emitClausesSep "WHERE" "AND" (map toSQLCommand $ sqlDeleteWhere cmd)+      <+> emitClausesSepComma "RETURNING" (sqlDeleteResult cmd) -instance Sqlable SqlAll where-  toSQLCommand cmd | null (sqlAllWhere cmd) = "TRUE"-  toSQLCommand cmd =-    "(" <+> smintercalate "AND" (map (parenthesize . toSQLCommand) (sqlAllWhere cmd)) <+> ")"+instance Sqlable SqlWhereAll where+  toSQLCommand cmd = case sqlWhereAllWhere cmd of+    [] -> "TRUE"+    [cond] -> toSQLCommand cond+    conds -> parenthesize $ smintercalate "AND" (map (parenthesize . toSQLCommand) conds) +instance Sqlable SqlWhereAny where+  toSQLCommand cmd = case sqlWhereAnyWhere cmd of+    [] -> "FALSE"+    [cond] -> toSQLCommand cond+    conds -> parenthesize $ smintercalate "OR" (map (parenthesize . toSQLCommand) conds)+ sqlSelect :: SQL -> State SqlSelect () -> SqlSelect sqlSelect table refine =-  execState refine (SqlSelect table [] [] False [] [] [] [] [] 0 (-1) [])+  execState refine (SqlSelect table [] [] False [] [] [] [] [] 0 (-1) [] NonRecursive)  sqlSelect2 :: SQL -> State SqlSelect () -> SqlSelect sqlSelect2 from refine =-  execState refine (SqlSelect from [] [] False [] [] [] [] [] 0 (-1) [])+  execState refine (SqlSelect from [] [] False [] [] [] [] [] 0 (-1) [] NonRecursive)  sqlInsert :: SQL -> State SqlInsert () -> SqlInsert sqlInsert table refine =-  execState refine (SqlInsert table Nothing mempty [] [])+  execState refine (SqlInsert table Nothing mempty [] [] NonRecursive)  sqlInsertSelect :: SQL -> SQL -> State SqlInsertSelect () -> SqlInsertSelect sqlInsertSelect table from refine =-  execState refine (SqlInsertSelect-                    { sqlInsertSelectWhat       = table-                    , sqlInsertSelectOnConflict = Nothing-                    , sqlInsertSelectDistinct   = False-                    , sqlInsertSelectSet        = []-                    , sqlInsertSelectResult     = []-                    , sqlInsertSelectFrom       = from-                    , sqlInsertSelectWhere      = []-                    , sqlInsertSelectOrderBy    = []-                    , sqlInsertSelectGroupBy    = []-                    , sqlInsertSelectHaving     = []-                    , sqlInsertSelectOffset     = 0-                    , sqlInsertSelectLimit      = -1-                    , sqlInsertSelectWith       = []-                    })+  execState+    refine+    ( SqlInsertSelect+        { sqlInsertSelectWhat = table+        , sqlInsertSelectOnConflict = Nothing+        , sqlInsertSelectDistinct = False+        , sqlInsertSelectSet = []+        , sqlInsertSelectResult = []+        , sqlInsertSelectFrom = from+        , sqlInsertSelectWhere = []+        , sqlInsertSelectOrderBy = []+        , sqlInsertSelectGroupBy = []+        , sqlInsertSelectHaving = []+        , sqlInsertSelectOffset = 0+        , sqlInsertSelectLimit = -1+        , sqlInsertSelectWith = []+        , sqlInsertSelectRecursiveWith = NonRecursive+        }+    )  sqlUpdate :: SQL -> State SqlUpdate () -> SqlUpdate sqlUpdate table refine =-  execState refine (SqlUpdate table mempty [] [] [] [])+  execState refine (SqlUpdate table mempty [] [] [] [] NonRecursive)  sqlDelete :: SQL -> State SqlDelete () -> SqlDelete sqlDelete table refine =-  execState refine (SqlDelete  { sqlDeleteFrom   = table-                               , sqlDeleteUsing  = mempty-                               , sqlDeleteWhere  = []-                               , sqlDeleteResult = []-                               , sqlDeleteWith   = []-                               })-+  execState+    refine+    ( SqlDelete+        { sqlDeleteFrom = table+        , sqlDeleteUsing = mempty+        , sqlDeleteWhere = []+        , sqlDeleteResult = []+        , sqlDeleteWith = []+        , sqlDeleteRecursiveWith = NonRecursive+        }+    )  data Materialized = Materialized | NonMaterialized+data Recursive = Recursive | NonRecursive -class SqlWith a where-  sqlWith1 :: a -> SQL -> SQL -> Materialized -> a+-- This instance guarantees that once a single CTE has+-- been marked as recursive, the whole "WITH" block will+-- get the RECURSIVE keyword associated to it.+instance Semigroup Recursive where+  _ <> Recursive = Recursive+  Recursive <> _ = Recursive+  _ <> _ = NonRecursive +class SqlWith a where+  sqlWith1 :: a -> SQL -> SQL -> Materialized -> Recursive -> a  instance SqlWith SqlSelect where-  sqlWith1 cmd name sql mat = cmd { sqlSelectWith = sqlSelectWith cmd ++ [(name,sql, mat)] }+  sqlWith1 cmd name sql mat recurse = cmd {sqlSelectWith = sqlSelectWith cmd ++ [(name, sql, mat)], sqlSelectRecursiveWith = recurse <> sqlSelectRecursiveWith cmd}  instance SqlWith SqlInsertSelect where-  sqlWith1 cmd name sql mat = cmd { sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name,sql,mat)] }+  sqlWith1 cmd name sql mat recurse = cmd {sqlInsertSelectWith = sqlInsertSelectWith cmd ++ [(name, sql, mat)], sqlInsertSelectRecursiveWith = recurse <> sqlInsertSelectRecursiveWith cmd}  instance SqlWith SqlUpdate where-  sqlWith1 cmd name sql mat = cmd { sqlUpdateWith = sqlUpdateWith cmd ++ [(name,sql,mat)] }+  sqlWith1 cmd name sql mat recurse = cmd {sqlUpdateWith = sqlUpdateWith cmd ++ [(name, sql, mat)], sqlUpdateRecursiveWith = recurse <> sqlUpdateRecursiveWith cmd}  instance SqlWith SqlDelete where-  sqlWith1 cmd name sql mat = cmd { sqlDeleteWith = sqlDeleteWith cmd ++ [(name,sql,mat)] }+  sqlWith1 cmd name sql mat recurse = cmd {sqlDeleteWith = sqlDeleteWith cmd ++ [(name, sql, mat)], sqlDeleteRecursiveWith = recurse <> sqlDeleteRecursiveWith cmd}  sqlWith :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()-sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized)+sqlWith name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized NonRecursive)  sqlWithMaterialized :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()-sqlWithMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) Materialized)+sqlWithMaterialized name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) Materialized NonRecursive) +-- | Note: RECURSIVE only powers SELECTs (but the SELECT can feed an UPDATE outside of the recursive query).+sqlWithRecursive :: (MonadState v m, SqlWith v, Sqlable s) => SQL -> s -> m ()+sqlWithRecursive name sql = modify (\cmd -> sqlWith1 cmd name (toSQLCommand sql) NonMaterialized Recursive)+ -- | Note: WHERE clause of the main SELECT is treated specially, i.e. it only -- applies to the main SELECT, not the whole union. sqlUnion :: (MonadState SqlSelect m, Sqlable sql) => [sql] -> m ()-sqlUnion sqls = modify (\cmd -> cmd { sqlSelectUnion = map toSQLCommand sqls })+sqlUnion sqls = modify (\cmd -> cmd {sqlSelectUnion = map toSQLCommand sqls})  -- | Note: WHERE clause of the main SELECT is treated specially, i.e. it only -- applies to the main SELECT, not the whole union. -- -- @since 1.16.4.0 sqlUnionAll :: (MonadState SqlSelect m, Sqlable sql) => [sql] -> m ()-sqlUnionAll sqls = modify (\cmd -> cmd { sqlSelectUnionAll = map toSQLCommand sqls })+sqlUnionAll sqls = modify (\cmd -> cmd {sqlSelectUnionAll = map toSQLCommand sqls})  class SqlWhere a where   sqlWhere1 :: a -> SqlCondition -> a   sqlGetWhereConditions :: a -> [SqlCondition]  instance SqlWhere SqlSelect where-  sqlWhere1 cmd cond = cmd { sqlSelectWhere = sqlSelectWhere cmd ++ [cond] }+  sqlWhere1 cmd cond = cmd {sqlSelectWhere = sqlSelectWhere cmd ++ [cond]}   sqlGetWhereConditions = sqlSelectWhere  instance SqlWhere SqlInsertSelect where-  sqlWhere1 cmd cond = cmd { sqlInsertSelectWhere = sqlInsertSelectWhere cmd ++ [cond] }+  sqlWhere1 cmd cond = cmd {sqlInsertSelectWhere = sqlInsertSelectWhere cmd ++ [cond]}   sqlGetWhereConditions = sqlInsertSelectWhere  instance SqlWhere SqlUpdate where-  sqlWhere1 cmd cond = cmd { sqlUpdateWhere = sqlUpdateWhere cmd ++ [cond] }+  sqlWhere1 cmd cond = cmd {sqlUpdateWhere = sqlUpdateWhere cmd ++ [cond]}   sqlGetWhereConditions = sqlUpdateWhere  instance SqlWhere SqlDelete where-  sqlWhere1 cmd cond = cmd { sqlDeleteWhere = sqlDeleteWhere cmd ++ [cond] }+  sqlWhere1 cmd cond = cmd {sqlDeleteWhere = sqlDeleteWhere cmd ++ [cond]}   sqlGetWhereConditions = sqlDeleteWhere -instance SqlWhere SqlAll where-  sqlWhere1 cmd cond = cmd { sqlAllWhere = sqlAllWhere cmd ++ [cond] }-  sqlGetWhereConditions = sqlAllWhere+instance SqlWhere SqlWhereAll where+  sqlWhere1 cmd cond = cmd {sqlWhereAllWhere = sqlWhereAllWhere cmd ++ [cond]}+  sqlGetWhereConditions = sqlWhereAllWhere +instance SqlWhere SqlWhereAny where+  sqlWhere1 cmd cond = cmd {sqlWhereAnyWhere = sqlWhereAnyWhere cmd ++ [cond]}+  sqlGetWhereConditions = sqlWhereAnyWhere+ -- | The @WHERE@ part of an SQL query. See above for a usage -- example. See also 'SqlCondition'. sqlWhere :: (MonadState v m, SqlWhere v) => SQL -> m ()@@ -598,12 +664,15 @@ sqlWhereLike name value = sqlWhere $ name <+> "LIKE" <?> value  sqlWhereILike :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> a -> m ()-sqlWhereILike name value = sqlWhere  $ name <+> "ILIKE" <?> value+sqlWhereILike name value = sqlWhere $ name <+> "ILIKE" <?> value  -- | Similar to 'sqlWhereIn', but uses @ANY@ instead of @SELECT UNNEST@. sqlWhereEqualsAny :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m () sqlWhereEqualsAny name values = sqlWhere $ name <+> "= ANY(" <?> Array1 values <+> ")" +-- | Note: `sqlWhereIn` will unpack the array using `UNNEST`. Using a postgresql function in this way+-- will interfere with the planner. Use `sqlWhereEqualsAny` instead, except if you know that+-- `UNNEST` will optimize better. sqlWhereIn :: (MonadState v m, SqlWhere v, Show a, ToSQL a) => SQL -> [a] -> m () sqlWhereIn name values = do   -- Unpack the array to give query optimizer more options.@@ -624,7 +693,7 @@  sqlWhereNotExists :: (MonadState v m, SqlWhere v) => SqlSelect -> m () sqlWhereNotExists sqlSelectD = do-  sqlWhere ("NOT EXISTS (" <+> toSQLCommand (sqlSelectD { sqlSelectResult = ["TRUE"] }) <+> ")")+  sqlWhere ("NOT EXISTS (" <+> toSQLCommand (sqlSelectD {sqlSelectResult = ["TRUE"]}) <+> ")")  sqlWhereIsNULL :: (MonadState v m, SqlWhere v) => SQL -> m () sqlWhereIsNULL col = sqlWhere $ col <+> "IS NULL"@@ -632,31 +701,44 @@ sqlWhereIsNotNULL :: (MonadState v m, SqlWhere v) => SQL -> m () sqlWhereIsNotNULL col = sqlWhere $ col <+> "IS NOT NULL" +-- | Run monad that joins all conditions using 'AND' operator.+--+-- When no conditions are given, the result is 'TRUE'.+--+-- Note: This is usally not needed as `SqlSelect`, `SqlUpdate` and `SqlDelete`+-- already join conditions using 'AND' by default, but it can be useful when+-- nested in `sqlAny`.+sqlAll :: State SqlWhereAll () -> SQL+sqlAll = toSQLCommand . (`execState` SqlWhereAll [])++-- | Run monad that joins all conditions using 'OR' operator.+--+-- When no conditions are given, the result is 'FALSE'.+sqlAny :: State SqlWhereAny () -> SQL+sqlAny = toSQLCommand . (`execState` SqlWhereAny [])+ -- | Add a condition in the WHERE statement that holds if any of the given -- condition holds.-sqlWhereAny :: (MonadState v m, SqlWhere v) => [State SqlAll ()] -> m ()-sqlWhereAny = sqlWhere . sqlWhereAnyImpl--sqlWhereAnyImpl :: [State SqlAll ()] -> SQL-sqlWhereAnyImpl [] = "FALSE"-sqlWhereAnyImpl l =-  "(" <+> smintercalate "OR" (map (parenthesize . toSQLCommand-                                   . flip execState (SqlAll [])) l) <+> ")"+--+-- These conditions are joined with 'OR' operator.+-- When no conditions are given, the result is 'FALSE'.+sqlWhereAny :: (MonadState v m, SqlWhere v) => [State SqlWhereAll ()] -> m ()+sqlWhereAny = sqlWhere . sqlAny . mapM_ (sqlWhere . sqlAll)  class SqlFrom a where   sqlFrom1 :: a -> SQL -> a  instance SqlFrom SqlSelect where-  sqlFrom1 cmd sql = cmd { sqlSelectFrom = sqlSelectFrom cmd <+> sql }+  sqlFrom1 cmd sql = cmd {sqlSelectFrom = sqlSelectFrom cmd <+> sql}  instance SqlFrom SqlInsertSelect where-  sqlFrom1 cmd sql = cmd { sqlInsertSelectFrom = sqlInsertSelectFrom cmd <+> sql }+  sqlFrom1 cmd sql = cmd {sqlInsertSelectFrom = sqlInsertSelectFrom cmd <+> sql}  instance SqlFrom SqlUpdate where-  sqlFrom1 cmd sql = cmd { sqlUpdateFrom = sqlUpdateFrom cmd <+> sql }+  sqlFrom1 cmd sql = cmd {sqlUpdateFrom = sqlUpdateFrom cmd <+> sql}  instance SqlFrom SqlDelete where-  sqlFrom1 cmd sql = cmd { sqlDeleteUsing = sqlDeleteUsing cmd <+> sql }+  sqlFrom1 cmd sql = cmd {sqlDeleteUsing = sqlDeleteUsing cmd <+> sql}  sqlFrom :: (MonadState v m, SqlFrom v) => SQL -> m () sqlFrom sql = modify (\cmd -> sqlFrom1 cmd sql)@@ -665,46 +747,58 @@ sqlJoin table = sqlFrom (", " <+> table)  sqlJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()-sqlJoinOn table condition = sqlFrom (" JOIN " <+>-                                     table <+>-                                     " ON " <+>-                                     condition)+sqlJoinOn table condition =+  sqlFrom+    ( " JOIN "+        <+> table+        <+> " ON "+        <+> condition+    )  sqlLeftJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()-sqlLeftJoinOn table condition = sqlFrom (" LEFT JOIN " <+>-                                         table <+>-                                         " ON " <+>-                                         condition)+sqlLeftJoinOn table condition =+  sqlFrom+    ( " LEFT JOIN "+        <+> table+        <+> " ON "+        <+> condition+    )  sqlRightJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()-sqlRightJoinOn table condition = sqlFrom (" RIGHT JOIN " <+>-                                          table <+>-                                          " ON " <+>-                                          condition)+sqlRightJoinOn table condition =+  sqlFrom+    ( " RIGHT JOIN "+        <+> table+        <+> " ON "+        <+> condition+    )  sqlFullJoinOn :: (MonadState v m, SqlFrom v) => SQL -> SQL -> m ()-sqlFullJoinOn table condition = sqlFrom (" FULL JOIN " <+>-                                         table <+>-                                         " ON " <+>-                                         condition)+sqlFullJoinOn table condition =+  sqlFrom+    ( " FULL JOIN "+        <+> table+        <+> " ON "+        <+> condition+    )  class SqlSet a where   sqlSet1 :: a -> SQL -> SQL -> a  instance SqlSet SqlUpdate where-  sqlSet1 cmd name v = cmd { sqlUpdateSet = sqlUpdateSet cmd ++ [(name, v)] }+  sqlSet1 cmd name v = cmd {sqlUpdateSet = sqlUpdateSet cmd ++ [(name, v)]}  instance SqlSet SqlInsert where-  sqlSet1 cmd name v = cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Single v)] }+  sqlSet1 cmd name v = cmd {sqlInsertSet = sqlInsertSet cmd ++ [(name, Single v)]}  instance SqlSet SqlInsertSelect where-  sqlSet1 cmd name v = cmd { sqlInsertSelectSet = sqlInsertSelectSet cmd ++ [(name, v)] }+  sqlSet1 cmd name v = cmd {sqlInsertSelectSet = sqlInsertSelectSet cmd ++ [(name, v)]}  sqlSetCmd :: (MonadState v m, SqlSet v) => SQL -> SQL -> m () sqlSetCmd name sql = modify (\cmd -> sqlSet1 cmd name sql) -sqlSetCmdList :: (MonadState SqlInsert m) => SQL -> [SQL] -> m ()-sqlSetCmdList name as = modify (\cmd -> cmd { sqlInsertSet = sqlInsertSet cmd ++ [(name, Many as)] })+sqlSetCmdList :: MonadState SqlInsert m => SQL -> [SQL] -> m ()+sqlSetCmdList name as = modify (\cmd -> cmd {sqlInsertSet = sqlInsertSet cmd ++ [(name, Many as)]})  sqlSet :: (MonadState v m, SqlSet v, Show a, ToSQL a) => SQL -> a -> m () sqlSet name a = sqlSetCmd name (sqlParam a)@@ -727,20 +821,20 @@   sqlOnConflictOnColumns1 :: Sqlable sql => a -> [SQL] -> sql -> a  instance SqlOnConflict SqlInsert where-  sqlOnConflictDoNothing1 cmd = -    cmd { sqlInsertOnConflict = Just ("", Nothing) }-  sqlOnConflictOnColumns1 cmd columns sql = -    cmd { sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql) }-  sqlOnConflictOnColumnsDoNothing1 cmd columns = -    cmd { sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing) }+  sqlOnConflictDoNothing1 cmd =+    cmd {sqlInsertOnConflict = Just ("", Nothing)}+  sqlOnConflictOnColumns1 cmd columns sql =+    cmd {sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql)}+  sqlOnConflictOnColumnsDoNothing1 cmd columns =+    cmd {sqlInsertOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing)}  instance SqlOnConflict SqlInsertSelect where-  sqlOnConflictDoNothing1 cmd = -    cmd { sqlInsertSelectOnConflict = Just ("", Nothing) }-  sqlOnConflictOnColumns1 cmd columns sql = -    cmd { sqlInsertSelectOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql) }-  sqlOnConflictOnColumnsDoNothing1 cmd columns = -    cmd { sqlInsertSelectOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing) }+  sqlOnConflictDoNothing1 cmd =+    cmd {sqlInsertSelectOnConflict = Just ("", Nothing)}+  sqlOnConflictOnColumns1 cmd columns sql =+    cmd {sqlInsertSelectOnConflict = Just (parenthesize $ sqlConcatComma columns, Just $ toSQLCommand sql)}+  sqlOnConflictOnColumnsDoNothing1 cmd columns =+    cmd {sqlInsertSelectOnConflict = Just (parenthesize $ sqlConcatComma columns, Nothing)}  sqlOnConflictDoNothing :: (MonadState v m, SqlOnConflict v) => m () sqlOnConflictDoNothing = modify sqlOnConflictDoNothing1@@ -755,19 +849,19 @@   sqlResult1 :: a -> SQL -> a  instance SqlResult SqlSelect where-  sqlResult1 cmd sql = cmd { sqlSelectResult = sqlSelectResult cmd ++ [sql] }+  sqlResult1 cmd sql = cmd {sqlSelectResult = sqlSelectResult cmd ++ [sql]}  instance SqlResult SqlInsert where-  sqlResult1 cmd sql = cmd { sqlInsertResult = sqlInsertResult cmd ++ [sql] }+  sqlResult1 cmd sql = cmd {sqlInsertResult = sqlInsertResult cmd ++ [sql]}  instance SqlResult SqlInsertSelect where-  sqlResult1 cmd sql = cmd { sqlInsertSelectResult = sqlInsertSelectResult cmd ++ [sql] }+  sqlResult1 cmd sql = cmd {sqlInsertSelectResult = sqlInsertSelectResult cmd ++ [sql]}  instance SqlResult SqlUpdate where-  sqlResult1 cmd sql = cmd { sqlUpdateResult = sqlUpdateResult cmd ++ [sql] }+  sqlResult1 cmd sql = cmd {sqlUpdateResult = sqlUpdateResult cmd ++ [sql]}  instance SqlResult SqlDelete where-  sqlResult1 cmd sql = cmd { sqlDeleteResult = sqlDeleteResult cmd ++ [sql] }+  sqlResult1 cmd sql = cmd {sqlDeleteResult = sqlDeleteResult cmd ++ [sql]}  sqlResult :: (MonadState v m, SqlResult v) => SQL -> m () sqlResult sql = modify (\cmd -> sqlResult1 cmd sql)@@ -776,11 +870,10 @@   sqlOrderBy1 :: a -> SQL -> a  instance SqlOrderBy SqlSelect where-  sqlOrderBy1 cmd sql = cmd { sqlSelectOrderBy = sqlSelectOrderBy cmd ++ [sql] }+  sqlOrderBy1 cmd sql = cmd {sqlSelectOrderBy = sqlSelectOrderBy cmd ++ [sql]}  instance SqlOrderBy SqlInsertSelect where-  sqlOrderBy1 cmd sql = cmd { sqlInsertSelectOrderBy = sqlInsertSelectOrderBy cmd ++ [sql] }-+  sqlOrderBy1 cmd sql = cmd {sqlInsertSelectOrderBy = sqlInsertSelectOrderBy cmd ++ [sql]}  sqlOrderBy :: (MonadState v m, SqlOrderBy v) => SQL -> m () sqlOrderBy sql = modify (\cmd -> sqlOrderBy1 cmd sql)@@ -790,12 +883,12 @@   sqlHaving1 :: a -> SQL -> a  instance SqlGroupByHaving SqlSelect where-  sqlGroupBy1 cmd sql = cmd { sqlSelectGroupBy = sqlSelectGroupBy cmd ++ [sql] }-  sqlHaving1 cmd sql = cmd { sqlSelectHaving = sqlSelectHaving cmd ++ [sql] }+  sqlGroupBy1 cmd sql = cmd {sqlSelectGroupBy = sqlSelectGroupBy cmd ++ [sql]}+  sqlHaving1 cmd sql = cmd {sqlSelectHaving = sqlSelectHaving cmd ++ [sql]}  instance SqlGroupByHaving SqlInsertSelect where-  sqlGroupBy1 cmd sql = cmd { sqlInsertSelectGroupBy = sqlInsertSelectGroupBy cmd ++ [sql] }-  sqlHaving1 cmd sql = cmd { sqlInsertSelectHaving = sqlInsertSelectHaving cmd ++ [sql] }+  sqlGroupBy1 cmd sql = cmd {sqlInsertSelectGroupBy = sqlInsertSelectGroupBy cmd ++ [sql]}+  sqlHaving1 cmd sql = cmd {sqlInsertSelectHaving = sqlInsertSelectHaving cmd ++ [sql]}  sqlGroupBy :: (MonadState v m, SqlGroupByHaving v) => SQL -> m () sqlGroupBy sql = modify (\cmd -> sqlGroupBy1 cmd sql)@@ -803,18 +896,17 @@ sqlHaving :: (MonadState v m, SqlGroupByHaving v) => SQL -> m () sqlHaving sql = modify (\cmd -> sqlHaving1 cmd sql) - class SqlOffsetLimit a where   sqlOffset1 :: a -> Integer -> a   sqlLimit1 :: a -> Integer -> a  instance SqlOffsetLimit SqlSelect where-  sqlOffset1 cmd num = cmd { sqlSelectOffset = num }-  sqlLimit1 cmd num = cmd { sqlSelectLimit = num }+  sqlOffset1 cmd num = cmd {sqlSelectOffset = num}+  sqlLimit1 cmd num = cmd {sqlSelectLimit = num}  instance SqlOffsetLimit SqlInsertSelect where-  sqlOffset1 cmd num = cmd { sqlInsertSelectOffset = num }-  sqlLimit1 cmd num = cmd { sqlInsertSelectLimit = num }+  sqlOffset1 cmd num = cmd {sqlInsertSelectOffset = num}+  sqlLimit1 cmd num = cmd {sqlInsertSelectLimit = num}  sqlOffset :: (MonadState v m, SqlOffsetLimit v, Integral int) => int -> m () sqlOffset val = modify (\cmd -> sqlOffset1 cmd $ toInteger val)@@ -826,10 +918,10 @@   sqlDistinct1 :: a -> a  instance SqlDistinct SqlSelect where-  sqlDistinct1 cmd = cmd { sqlSelectDistinct = True }+  sqlDistinct1 cmd = cmd {sqlSelectDistinct = True}  instance SqlDistinct SqlInsertSelect where-  sqlDistinct1 cmd = cmd { sqlInsertSelectDistinct = True }+  sqlDistinct1 cmd = cmd {sqlInsertSelectDistinct = True}  sqlDistinct :: (MonadState v m, SqlDistinct v) => m ()-sqlDistinct = modify (\cmd -> sqlDistinct1 cmd)+sqlDistinct = modify sqlDistinct1

@@ -1,15 +1,15 @@ module Database.PostgreSQL.PQTypes.Utils.NubList-    ( NubList    -- opaque-    , toNubList  -- smart construtor-    , fromNubList-    , overNubList-    ) where+  ( NubList -- opaque+  , toNubList -- smart construtor+  , fromNubList+  , overNubList+  ) where  import Data.Typeable -import qualified Text.Read as R-import qualified Data.Set as Set-import qualified Data.Semigroup as SG+import Data.Semigroup qualified as SG+import Data.Set qualified as Set+import Text.Read qualified as R  {-   This module is a copy-paste fork of Distribution.Utils.NubList in Cabal@@ -19,9 +19,9 @@ -}  -- | NubList : A de-duplicated list that maintains the original order.-newtype NubList a =-    NubList { fromNubList :: [a] }-    deriving (Eq, Typeable)+newtype NubList a+  = NubList {fromNubList :: [a]}+  deriving (Eq, Typeable)  -- NubList assumes that nub retains the list order while removing duplicate -- elements (keeping the first occurence). Documentation for "Data.List.nub"@@ -30,41 +30,42 @@  -- | Smart constructor for the NubList type. toNubList :: Ord a => [a] -> NubList a-toNubList list = NubList $ (ordNubBy id) list+toNubList = NubList . ordNubBy id  -- | Lift a function over lists to a function over NubLists. overNubList :: Ord a => ([a] -> [a]) -> NubList a -> NubList a overNubList f (NubList list) = toNubList . f $ list  instance Ord a => SG.Semigroup (NubList a) where-    (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys-      where-        listUnion :: (Ord a) => [a] -> [a] -> [a]-        listUnion a b = a-          ++ ordNubBy id (filter (`Set.notMember` (Set.fromList a)) b)-+  (NubList xs) <> (NubList ys) = NubList $ xs `listUnion` ys+    where+      listUnion :: Ord a => [a] -> [a] -> [a]+      listUnion a b =+        a+          ++ ordNubBy id (filter (`Set.notMember` Set.fromList a) b)  instance Ord a => Monoid (NubList a) where-    mempty  = NubList []-    mappend = (SG.<>)+  mempty = NubList []+  mappend = (SG.<>)  instance Show a => Show (NubList a) where-    show (NubList list) = show list+  show (NubList list) = show list  instance (Ord a, Read a) => Read (NubList a) where-    readPrec = readNubList toNubList+  readPrec = readNubList toNubList  -- | Helper used by NubList/NubListR's Read instances.-readNubList :: (Read a) => ([a] -> l a) -> R.ReadPrec (l a)+readNubList :: Read a => ([a] -> l a) -> R.ReadPrec (l a) readNubList toList = R.parens . R.prec 10 $ fmap toList R.readPrec  ordNubBy :: Ord b => (a -> b) -> [a] -> [a]-ordNubBy f l = go Set.empty l+ordNubBy f = go Set.empty   where     go !_ [] = []-    go !s (x:xs)+    go !s (x : xs)       | y `Set.member` s = go s xs-      | otherwise        = let !s' = Set.insert y s-                            in x : go s' xs+      | otherwise =+          let !s' = Set.insert y s+          in x : go s' xs       where         y = f x

@@ -3,12 +3,13 @@ import Database.PostgreSQL.PQTypes.Model  tableVersions :: Table-tableVersions = tblTable {-    tblName = "table_versions"-  , tblVersion = 1-  , tblColumns = [-      tblColumn { colName = "name", colType = TextT, colNullable = False }-    , tblColumn { colName = "version", colType = IntegerT, colNullable = False }-    ]-  , tblPrimaryKey = pkOnColumn "name"-  }+tableVersions =+  tblTable+    { tblName = "table_versions"+    , tblVersion = 1+    , tblColumns =+        [ tblColumn {colName = "name", colType = TextT, colNullable = False}+        , tblColumn {colName = "version", colType = IntegerT, colNullable = False}+        ]+    , tblPrimaryKey = pkOnColumn "name"+    }

@@ -1,1641 +1,2441 @@-module Main where--import Control.Monad.Catch-import Control.Monad (forM_)-import Control.Monad.IO.Class-import Data.Either-import Data.List (zip4)-import Data.Monoid-import Prelude-import Data.Typeable-import Data.UUID.Types-import qualified Data.Set as Set-import qualified Data.Text as T--import Data.Monoid.Utils-import Database.PostgreSQL.PQTypes-import Database.PostgreSQL.PQTypes.Checks-import Database.PostgreSQL.PQTypes.Model.ColumnType-import Database.PostgreSQL.PQTypes.Model.CompositeType-import Database.PostgreSQL.PQTypes.Model.ForeignKey-import Database.PostgreSQL.PQTypes.Model.Index-import Database.PostgreSQL.PQTypes.Model.Migration-import Database.PostgreSQL.PQTypes.Model.PrimaryKey-import Database.PostgreSQL.PQTypes.Model.Table-import Database.PostgreSQL.PQTypes.Model.Trigger-import Database.PostgreSQL.PQTypes.SQL.Builder-import Log-import Log.Backend.StandardOutput--import Test.Tasty-import Test.Tasty.HUnit-import Test.Tasty.Options--data ConnectionString = ConnectionString String-  deriving Typeable--instance IsOption ConnectionString where-  defaultValue = ConnectionString-    -- For GitHub Actions CI-    "host=postgres user=postgres password=postgres"-  parseValue   = Just . ConnectionString-  optionName   = return "connection-string"-  optionHelp   = return "Postgres connection string"---- Simple example schemata inspired by the one in--- <  http://www.databaseanswers.org/data_models/bank_robberies/index.htm>------ Schema 1: Bank robberies, tables:---           bank, bad_guy, robbery, participated_in_robbery, witness,---           witnessed_robbery--- Schema 2: Witnesses go into witness protection program,---           (some) bad guys get arrested:---           drop tables witness and witnessed_robbery,---           add table under_arrest--- Schema 3: Bad guys get their prison sentences:---           drop table under_arrest---           add table prison_sentence--- Schema 4: New 'cash' column for the 'bank' table.--- Schema 5: Create a new table 'flash',---           drop the 'cash' column from the 'bank' table,---           drop table 'flash'.--- Cleanup:  drop everything--tableBankSchema1 :: Table-tableBankSchema1 =-  tblTable-  { tblName = "bank"-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "id",       colType = UuidT-                , colNullable = False-                , colDefault = Just "gen_random_uuid()" }-    , tblColumn { colName = "name",     colType = TextT-                , colCollation = Just "en_US"-                , colNullable = False }-    , tblColumn { colName = "location", colType = TextT-                , colCollation = Just "C"-                , colNullable = False }-    ]-  , tblPrimaryKey = pkOnColumn "id"-  , tblTriggers = []-  }--tableBankSchema2 :: Table-tableBankSchema2 = tableBankSchema1--tableBankSchema3 :: Table-tableBankSchema3 = tableBankSchema2--tableBankMigration4 :: (MonadDB m) => Migration m-tableBankMigration4 = Migration-  { mgrTableName = tblName tableBankSchema3-  , mgrFrom      = 1-  , mgrAction    = StandardMigration $ do-      runQuery_ $ sqlAlterTable (tblName tableBankSchema3) [-        sqlAddColumn $ tblColumn-          { colName = "cash"-          , colType = IntegerT-          , colNullable = False-          , colDefault = Just "0"-          }-        ]-  }--tableBankSchema4 :: Table-tableBankSchema4 = tableBankSchema3 {-    tblVersion = (tblVersion tableBankSchema3)  + 1-  , tblColumns = (tblColumns tableBankSchema3) ++ [-      tblColumn-      { colName = "cash", colType = IntegerT-      , colNullable = False-      , colDefault = Just "0"-      }-    ]-  }---tableBankMigration5fst :: (MonadDB m) => Migration m-tableBankMigration5fst = Migration-  { mgrTableName = tblName tableBankSchema3-  , mgrFrom      = 2-  , mgrAction    = StandardMigration $ do-      runQuery_ $ sqlAlterTable (tblName tableBankSchema4) [-        sqlDropColumn $ "cash"-        ]-  }--tableBankMigration5snd :: (MonadDB m) => Migration m-tableBankMigration5snd = Migration-  { mgrTableName = tblName tableBankSchema3-  , mgrFrom      = 3-  , mgrAction    = CreateIndexConcurrentlyMigration-                     (tblName tableBankSchema3)-                     ((indexOnColumn "name") { idxInclude = ["id", "location"] })-  }--tableBankSchema5 :: Table-tableBankSchema5 = tableBankSchema4 {-    tblVersion = (tblVersion tableBankSchema4) + 2-  , tblColumns = filter (\c -> colName c /= "cash")-      (tblColumns tableBankSchema4)-  , tblIndexes = [(indexOnColumn "name") { idxInclude = ["id", "location"] }]-  }--tableBadGuySchema1 :: Table-tableBadGuySchema1 =-  tblTable-  { tblName = "bad_guy"-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "id",        colType = UuidT-                , colNullable = False-                , colDefault = Just "gen_random_uuid()" }-    , tblColumn { colName = "firstname", colType = TextT-                , colNullable = False }-    , tblColumn { colName = "lastname",  colType = TextT-                , colNullable = False }-    ]-  , tblPrimaryKey = pkOnColumn "id" }--tableBadGuySchema2 :: Table-tableBadGuySchema2 = tableBadGuySchema1--tableBadGuySchema3 :: Table-tableBadGuySchema3 = tableBadGuySchema2--tableBadGuySchema4 :: Table-tableBadGuySchema4 = tableBadGuySchema3--tableBadGuySchema5 :: Table-tableBadGuySchema5 = tableBadGuySchema4--tableRobberySchema1 :: Table-tableRobberySchema1 =-  tblTable-  { tblName = "robbery"-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "id",      colType = UuidT-                , colNullable = False-                , colDefault = Just "gen_random_uuid()" }-    , tblColumn { colName = "bank_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "date",    colType = DateT-                , colNullable = False, colDefault = Just "now()" }-    ]-  , tblPrimaryKey  = pkOnColumn "id"-  , tblForeignKeys = [fkOnColumn "bank_id" "bank" "id"] }--tableRobberySchema2 :: Table-tableRobberySchema2 = tableRobberySchema1--tableRobberySchema3 :: Table-tableRobberySchema3 = tableRobberySchema2--tableRobberySchema4 :: Table-tableRobberySchema4 = tableRobberySchema3--tableRobberySchema5 :: Table-tableRobberySchema5 = tableRobberySchema4--tableParticipatedInRobberySchema1 :: Table-tableParticipatedInRobberySchema1 =-  tblTable-  { tblName = "participated_in_robbery"-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "bad_guy_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "robbery_id", colType = UuidT-                , colNullable = False }-    ]-  , tblPrimaryKey  = pkOnColumns ["bad_guy_id", "robbery_id"]-  , tblForeignKeys = [fkOnColumn  "bad_guy_id" "bad_guy" "id"-                     ,fkOnColumn  "robbery_id" "robbery" "id"] }--tableParticipatedInRobberySchema2 :: Table-tableParticipatedInRobberySchema2 = tableParticipatedInRobberySchema1--tableParticipatedInRobberySchema3 :: Table-tableParticipatedInRobberySchema3 = tableParticipatedInRobberySchema2--tableParticipatedInRobberySchema4 :: Table-tableParticipatedInRobberySchema4 = tableParticipatedInRobberySchema3--tableParticipatedInRobberySchema5 :: Table-tableParticipatedInRobberySchema5 = tableParticipatedInRobberySchema4--tableWitnessName :: RawSQL ()-tableWitnessName = "witness"--tableWitnessSchema1 :: Table-tableWitnessSchema1 =-  tblTable-  { tblName = tableWitnessName-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "id",        colType = UuidT-                , colNullable = False-                , colDefault = Just "gen_random_uuid()" }-    , tblColumn { colName = "firstname", colType = TextT-                , colNullable = False }-    , tblColumn { colName = "lastname",  colType = TextT-                , colNullable = False }-    ]-  , tblPrimaryKey = pkOnColumn "id" }--tableWitnessedRobberyName :: RawSQL ()-tableWitnessedRobberyName = "witnessed_robbery"--tableWitnessedRobberySchema1 :: Table-tableWitnessedRobberySchema1 =-  tblTable-  { tblName = tableWitnessedRobberyName-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "witness_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "robbery_id", colType = UuidT-                , colNullable = False }-    ]-  , tblPrimaryKey  = pkOnColumns ["witness_id", "robbery_id"]-  , tblForeignKeys = [fkOnColumn  "witness_id" "witness" "id"-                     ,fkOnColumn  "robbery_id" "robbery" "id"] }--tableUnderArrestName :: RawSQL ()-tableUnderArrestName = "under_arrest"--tableUnderArrestSchema2 :: Table-tableUnderArrestSchema2 =-  tblTable-  { tblName = tableUnderArrestName-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "bad_guy_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "robbery_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "court_date", colType = DateT-                , colNullable = False-                , colDefault  = Just "now()" }-    ]-  , tblPrimaryKey  = pkOnColumns ["bad_guy_id", "robbery_id"]-  , tblForeignKeys = [fkOnColumn  "bad_guy_id" "bad_guy" "id"-                     ,fkOnColumn  "robbery_id" "robbery" "id"] }--tablePrisonSentenceName :: RawSQL ()-tablePrisonSentenceName = "prison_sentence"--tablePrisonSentenceSchema3 :: Table-tablePrisonSentenceSchema3 =-  tblTable-  { tblName = tablePrisonSentenceName-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "bad_guy_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "robbery_id", colType = UuidT-                , colNullable = False }-    , tblColumn { colName = "sentence_start"-                , colType = DateT-                , colNullable = False-                , colDefault  = Just "now()" }-    , tblColumn { colName = "sentence_length"-                , colType = IntegerT-                , colNullable = False-                , colDefault  = Just "6" }-    , tblColumn { colName = "prison_name"-                , colType = TextT-                , colNullable = False }-    ]-  , tblPrimaryKey  = pkOnColumns ["bad_guy_id", "robbery_id"]-  , tblForeignKeys = [fkOnColumn  "bad_guy_id" "bad_guy" "id"-                     ,fkOnColumn  "robbery_id" "robbery" "id"] }--tablePrisonSentenceSchema4 :: Table-tablePrisonSentenceSchema4 = tablePrisonSentenceSchema3--tablePrisonSentenceSchema5 :: Table-tablePrisonSentenceSchema5 = tablePrisonSentenceSchema4--tableFlashName :: RawSQL ()-tableFlashName = "flash"--tableFlash :: Table-tableFlash =-  tblTable-  { tblName = tableFlashName-  , tblVersion = 1-  , tblColumns =-    [ tblColumn { colName = "flash_id", colType = UuidT, colNullable = False }-    ]-  }--createTableMigration :: (MonadDB m) => Table -> Migration m-createTableMigration tbl = Migration-  { mgrTableName = tblName tbl-  , mgrFrom      = 0-  , mgrAction    = StandardMigration $ do-      createTable True tbl-  }--dropTableMigration :: (MonadDB m) => Table -> Migration m-dropTableMigration tbl = Migration-  { mgrTableName = tblName tbl-  , mgrFrom      = tblVersion tbl-  , mgrAction    = DropTableMigration DropTableCascade-  }--schema1Tables :: [Table]-schema1Tables = [ tableBankSchema1-                , tableBadGuySchema1-                , tableRobberySchema1-                , tableParticipatedInRobberySchema1-                , tableWitnessSchema1-                , tableWitnessedRobberySchema1-                ]--schema1Migrations :: (MonadDB m) => [Migration m]-schema1Migrations =-  [ createTableMigration tableBankSchema1-  , createTableMigration tableBadGuySchema1-  , createTableMigration tableRobberySchema1-  , createTableMigration tableParticipatedInRobberySchema1-  , createTableMigration tableWitnessSchema1-  , createTableMigration tableWitnessedRobberySchema1-  ]--schema2Tables :: [Table]-schema2Tables = [ tableBankSchema2-                , tableBadGuySchema2-                , tableRobberySchema2-                , tableParticipatedInRobberySchema2-                , tableUnderArrestSchema2-                ]--schema2Migrations :: (MonadDB m) => [Migration m]-schema2Migrations = schema1Migrations-                 ++ [ dropTableMigration   tableWitnessedRobberySchema1-                    , dropTableMigration   tableWitnessSchema1-                    , createTableMigration tableUnderArrestSchema2-                    ]--schema3Tables :: [Table]-schema3Tables = [ tableBankSchema3-                , tableBadGuySchema3-                , tableRobberySchema3-                , tableParticipatedInRobberySchema3-                , tablePrisonSentenceSchema3-                ]--schema3Migrations :: (MonadDB m) => [Migration m]-schema3Migrations = schema2Migrations-                 ++ [ dropTableMigration   tableUnderArrestSchema2-                    , createTableMigration tablePrisonSentenceSchema3 ]--schema4Tables :: [Table]-schema4Tables = [ tableBankSchema4-                , tableBadGuySchema4-                , tableRobberySchema4-                , tableParticipatedInRobberySchema4-                , tablePrisonSentenceSchema4-                ]--schema4Migrations :: (MonadDB m) => [Migration m]-schema4Migrations = schema3Migrations-                 ++ [ tableBankMigration4 ]--schema5Tables :: [Table]-schema5Tables = [ tableBankSchema5-                , tableBadGuySchema5-                , tableRobberySchema5-                , tableParticipatedInRobberySchema5-                , tablePrisonSentenceSchema5-                ]--schema5Migrations :: (MonadDB m) => [Migration m]-schema5Migrations = schema4Migrations-                 ++ [ createTableMigration tableFlash-                    , tableBankMigration5fst-                    , tableBankMigration5snd-                    , dropTableMigration tableFlash-                    ]--schema6Tables :: [Table]-schema6Tables =-          [ tableBankSchema1-          , tableBadGuySchema1-          , tableRobberySchema1-          , tableParticipatedInRobberySchema1-              { tblVersion = (tblVersion tableParticipatedInRobberySchema1) + 1,-                tblPrimaryKey = Nothing }-          , tableWitnessSchema1-          , tableWitnessedRobberySchema1-          ]--schema6Migrations :: (MonadDB m) => Migration m-schema6Migrations =-    Migration-    { mgrTableName = tblName tableParticipatedInRobberySchema1-    , mgrFrom = tblVersion tableParticipatedInRobberySchema1-    , mgrAction =-      StandardMigration $ do-        runQuery_ $ ("ALTER TABLE participated_in_robbery DROP CONSTRAINT \-                     \pk__participated_in_robbery" :: RawSQL ())-    }---type TestM a = DBT (LogT IO) a--createTablesSchema1 :: (String -> TestM ()) -> TestM ()-createTablesSchema1 step = do-  let extensions    = ["pgcrypto"]-      composites    = []-      domains       = []-  step "Creating the database (schema version 1)..."-  migrateDatabase defaultExtrasOptions extensions domains-    composites schema1Tables schema1Migrations--  -- Add a local index that shouldn't trigger validation errors.-  runSQL_ "CREATE INDEX local_idx_bank_name ON bank(name)"--  checkDatabase defaultExtrasOptions composites domains schema1Tables--testDBSchema1 :: (String -> TestM ()) -> TestM ([UUID], [UUID])-testDBSchema1 step = do-  step "Running test queries (schema version 1)..."--  -- Populate the 'bank' table.-  runQuery_ . sqlInsert "bank" $ do-    sqlSetList "name" ["HSBC" :: T.Text, "Swedbank", "Nordea", "Citi"-                      ,"Wells Fargo"]-    sqlSetList "location" ["13 Foo St., Tucson, AZ, USa" :: T.Text-                          , "18 Bargatan, Stockholm, Sweden"-                          , "23 Baz Lane, Liverpool, UK"-                          , "2/3 Quux Ave., Milton Keynes, UK"-                          , "6600 Sunset Blvd., Los Angeles, CA, USA"]-    sqlResult "id"-  (bankIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'bank' table" 5 (length bankIds)--  -- Try to insert with existing ID to check that ON CONFLICT works properly-  let bankId = head bankIds-      name = "Santander" :: T.Text-      location = "Spain" :: T.Text--  runQuery_ . sqlInsert "bank" $ do-    sqlSet "id" bankId-    sqlSet "name" name-    sqlSet "location" location-    sqlOnConflictOnColumns ["id"] . sqlUpdate "" $ do-      sqlSet "name" name-      sqlSet "location" location-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlResult "location"-    sqlWhereEq "id" bankId-  details1 <- fetchOne id-  liftIO $ assertEqual "INSERT ON CONFLICT updates" (name, location) details1--  runQuery_ . sqlInsert "bank" $ do-    sqlSet "id" bankId-    sqlSet "name" ("" :: T.Text)-    sqlSet "location" ("" :: T.Text)-    sqlOnConflictDoNothing-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlResult "location"-    sqlWhereEq "id" bankId-  details3 <- fetchOne id-  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (1)" (name, location) details3--  runQuery_ . sqlInsert "bank" $ do-    sqlSet "id" bankId-    sqlSet "name" ("" :: T.Text)-    sqlSet "location" ("" :: T.Text)-    sqlOnConflictOnColumnsDoNothing ["id"]-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlResult "location"-    sqlWhereEq "id" bankId-  details4 <- fetchOne id-  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details4--  -- If NO CONFLICT is not specified, make sure we throw an exception.-  eres :: Either DBException () <- try . withSavepoint "testDBSchema" $ do-    runQuery_ . sqlInsert "bank" $ do-      sqlSet "id" bankId-      sqlSet "name" name-      sqlSet "location" location-  liftIO $ assertBool "If ON CONFLICT is not specified an exception is thrown" (isLeft eres)--  runQuery_ . sqlInsertSelect "bank" "bank" $ do-    sqlSetCmd "id" "id"-    sqlSetCmd "name" "name"-    sqlSetCmd "location" "location"-    sqlWhereEq "id" bankId-    sqlOnConflictOnColumns ["id"] . sqlUpdate "" $ do-      sqlSet "name" name-      sqlSet "location" location-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlResult "location"-    sqlWhereEq "id" bankId-  details5 <- fetchOne id-  liftIO $ assertEqual "INSERT ON CONFLICT updates" (name, location) details5--  runQuery_ . sqlInsertSelect "bank" "bank" $ do-    sqlSetCmd "id" "id"-    sqlSetCmd "name" "name"-    sqlSetCmd "location" "location"-    sqlWhereEq "id" bankId-    sqlOnConflictDoNothing-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlResult "location"-    sqlWhereEq "id" bankId-  details6 <- fetchOne id-  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (1)" (name, location) details6--  runQuery_ . sqlInsertSelect "bank" "bank" $ do-    sqlSetCmd "id" "id"-    sqlSetCmd "name" "name"-    sqlSetCmd "location" "location"-    sqlWhereEq "id" bankId-    sqlOnConflictOnColumnsDoNothing ["id"]-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlResult "location"-    sqlWhereEq "id" bankId-  details7 <- fetchOne id-  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details7--  -- If NO CONFLICT is not specified, make sure we throw an exception.-  eres1 :: Either DBException () <- try . withSavepoint "testDBSchema" $ do-    runQuery_ . sqlInsertSelect "bank" "bank" $ do-      sqlSetCmd "id" "id"-      sqlSetCmd "name" "name"-      sqlSetCmd "location" "location"-      sqlWhereEq "id" bankId-  liftIO $ assertBool "If ON CONFLICT is not specified an exception is thrown" (isLeft eres1)--  -- Populate the 'bad_guy' table.-  runQuery_ . sqlInsert "bad_guy" $ do-    sqlSetList "firstname" ["Neil" :: T.Text, "Lee", "Freddie", "Frankie"-                           ,"James", "Roy"]-    sqlSetList "lastname" ["Hetzel"::T.Text, "Murray", "Foreman", "Fraser"-                          ,"Crosbie", "Shaw"]-    sqlResult "id"-  (badGuyIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'bad_guy' table" 6 (length badGuyIds)--  -- Populate the 'robbery' table.-  runQuery_ . sqlInsert "robbery" $ do-    sqlSetList "bank_id" [bankIds !! idx | idx <- [0,3]]-    sqlResult "id"-  (robberyIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'robbery' table" 2 (length robberyIds)--  -- Populate the 'participated_in_robbery' table.-  runQuery_ . sqlInsert "participated_in_robbery" $ do-    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [0,2]]-    sqlSet "robbery_id" (robberyIds !! 0)-    sqlResult "bad_guy_id"-  (participatorIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'participated_in_robbery' table" 2-    (length participatorIds)--  runQuery_ . sqlInsert "participated_in_robbery" $ do-    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [3,4]]-    sqlSet "robbery_id" (robberyIds !! 1)-    sqlResult "bad_guy_id"-  (participatorIds' :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'participated_in_robbery' table" 2-    (length participatorIds')--  -- Populate the 'witness' table.-  runQuery_ . sqlInsert "witness" $ do-    sqlSetList "firstname" ["Meredith" :: T.Text, "Charlie", "Peter", "Emun"-                           ,"Benedict", "Erica"]-    sqlSetList "lastname" ["Vickers"::T.Text, "Holloway", "Weyland", "Eliott"-                          ,"Wong", "Hackett"]-    sqlResult "id"-  (witnessIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'witness' table" 6 (length witnessIds)--  -- Populate the 'witnessed_robbery' table.-  runQuery_ . sqlInsert "witnessed_robbery" $ do-    sqlSetList "witness_id" [witnessIds  !! idx | idx <- [0,1]]-    sqlSet "robbery_id" (robberyIds !! 0)-    sqlResult "witness_id"-  (robberyWitnessIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'witnessed_robbery' table" 2-    (length robberyWitnessIds)--  runQuery_ . sqlInsert "witnessed_robbery" $ do-    sqlSetList "witness_id" [witnessIds  !! idx | idx <- [2,3,4]]-    sqlSet "robbery_id" (robberyIds !! 1)-    sqlResult "witness_id"-  (robberyWitnessIds' :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'witnessed_robbery' table" 3-    (length robberyWitnessIds')--  -- Create a new record to test order-by case sensitivity.-  runQuery_ . sqlInsert "bank" $ do-    sqlSet "name" ("byblos bank" :: T.Text)-    sqlSet "location" ("SYRIA" :: T.Text)--  -- Check that ordering results by the "location" column uses case-sensitive-  -- sorting (since the collation method for that column is "C").-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "location"-    sqlOrderBy "location"--  details8 <- fetchMany runIdentity-  liftIO $ assertEqual "Using collation method \"C\" leads to case-sensitive ordering of results"-    [ "18 Bargatan, Stockholm, Sweden" :: String-    , "2/3 Quux Ave., Milton Keynes, UK"-    , "23 Baz Lane, Liverpool, UK"-    , "6600 Sunset Blvd., Los Angeles, CA, USA"-    , "SYRIA"-    , "Spain"-    ]-    details8--  -- Check that ordering results by the "name" column uses case-insensitive-  -- sorting (since the collation method for that column is "en_US").-  runQuery_ . sqlSelect "bank" $ do-    sqlResult "name"-    sqlOrderBy "name"--  details9 <- fetchMany runIdentity-  liftIO $ assertEqual "Using collation method \"en_US\" leads to case-insensitive ordering of results"-    [ "byblos bank" :: String-    , "Citi"-    , "Nordea"-    , "Santander"-    , "Swedbank"-    , "Wells Fargo"-    ]-    details9--  do-    deletedRows <- runQuery . sqlDelete "witness" $ do-      sqlWhereEq "id" $ witnessIds !! 5-      sqlResult "firstname"-      sqlResult "lastname"-    liftIO $ assertEqual "DELETE FROM 'witness' table" 1 deletedRows--    deletedName <- fetchOne id-    liftIO $ assertEqual "DELETE FROM 'witness' table RETURNING firstname, lastname"-      ("Erica" :: String, "Hackett" :: String)-      deletedName--  return (badGuyIds, robberyIds)--migrateDBToSchema2 :: (String -> TestM ()) -> TestM ()-migrateDBToSchema2 step = do-  let extensions    = ["pgcrypto"]-      composites    = []-      domains       = []-  step "Migrating the database (schema version 1 -> schema version 2)..."-  migrateDatabase defaultExtrasOptions { eoLockTimeoutMs = Just 1000 } extensions composites domains-    schema2Tables schema2Migrations-  checkDatabase defaultExtrasOptions composites domains schema2Tables---- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'.-migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM ()-migrateDBToSchema2Hacky step = do-  let extensions    = ["pgcrypto"]-      composites    = []-      domains       = []-  step "Hackily migrating the database (schema version 1 \-       \-> schema version 2)..."-  migrateDatabase defaultExtrasOptions extensions composites domains-    schema2Tables schema2Migrations'-  checkDatabase defaultExtrasOptions composites domains schema2Tables-    where-      schema2Migrations' = createTableMigration tableFlash : schema2Migrations--testDBSchema2 :: (String -> TestM ()) -> [UUID] -> [UUID] -> TestM ()-testDBSchema2 step badGuyIds robberyIds = do-  step "Running test queries (schema version 2)..."--  -- Check that table 'witness' doesn't exist.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"-    <> " AND tablename = 'witness')";-  (witnessExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Table 'witness' doesn't exist" False witnessExists--  -- Check that table 'witnessed_robbery' doesn't exist.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"-    <> " AND tablename = 'witnessed_robbery')";-  (witnessedRobberyExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Table 'witnessed_robbery' doesn't exist" False-    witnessedRobberyExists--  -- Populate table 'under_arrest'.-  runQuery_ . sqlInsert "under_arrest" $ do-    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [0,2]]-    sqlSet "robbery_id" (robberyIds !! 0)-    sqlResult "bad_guy_id"-  (arrestedIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'under_arrest' table" 2-    (length arrestedIds)--  runQuery_ . sqlInsert "under_arrest" $ do-    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [3,4]]-    sqlSet "robbery_id" (robberyIds !! 1)-    sqlResult "bad_guy_id"-  (arrestedIds' :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'under_arrest' table" 2-    (length arrestedIds')--  return ()--migrateDBToSchema3 :: (String -> TestM ()) -> TestM ()-migrateDBToSchema3 step = do-  let extensions    = ["pgcrypto"]-      composites    = []-      domains       = []-  step "Migrating the database (schema version 2 -> schema version 3)..."-  migrateDatabase defaultExtrasOptions extensions composites domains-    schema3Tables schema3Migrations-  checkDatabase defaultExtrasOptions composites domains schema3Tables--testDBSchema3 :: (String -> TestM ()) -> [UUID] -> [UUID] -> TestM ()-testDBSchema3 step badGuyIds robberyIds = do-  step "Running test queries (schema version 3)..."--  -- Check that table 'under_arrest' doesn't exist.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"-    <> " AND tablename = 'under_arrest')";-  (underArrestExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Table 'under_arrest' doesn't exist" False-    underArrestExists--  -- Check that the table 'prison_sentence' exists.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"-    <> " AND tablename = 'prison_sentence')";-  (prisonSentenceExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Table 'prison_sentence' does exist" True-    prisonSentenceExists--  -- Populate table 'prison_sentence'.-  runQuery_ . sqlInsert "prison_sentence" $ do-    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [0,2]]-    sqlSet "robbery_id" (robberyIds !! 0)-    sqlSet "sentence_length" (12::Int)-    sqlSet "prison_name" ("Long Kesh"::T.Text)-    sqlResult "bad_guy_id"-  (sentencedIds :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'prison_sentence' table" 2-    (length sentencedIds)--  runQuery_ . sqlInsert "prison_sentence" $ do-    sqlSetList "bad_guy_id" [badGuyIds  !! idx | idx <- [3,4]]-    sqlSet "robbery_id" (robberyIds !! 1)-    sqlSet "sentence_length" (9::Int)-    sqlSet "prison_name" ("Wormwood Scrubs"::T.Text)-    sqlResult "bad_guy_id"-  (sentencedIds' :: [UUID]) <- fetchMany runIdentity-  liftIO $ assertEqual "INSERT into 'prison_sentence' table" 2-    (length sentencedIds')--  return ()--migrateDBToSchema4 :: (String -> TestM ()) -> TestM ()-migrateDBToSchema4 step = do-  let extensions    = ["pgcrypto"]-      composites    = []-      domains       = []-  step "Migrating the database (schema version 3 -> schema version 4)..."-  migrateDatabase defaultExtrasOptions extensions composites domains-    schema4Tables schema4Migrations-  checkDatabase defaultExtrasOptions composites domains schema4Tables--testDBSchema4 :: (String -> TestM ()) -> TestM ()-testDBSchema4 step = do-  step "Running test queries (schema version 4)..."--  -- Check that the 'bank' table has a 'cash' column.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM information_schema.columns"-    <> " WHERE table_schema = 'public'"-    <> " AND table_name = 'bank'"-    <> " AND column_name = 'cash')";-  (colCashExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Column 'cash' in the table 'bank' does exist" True-    colCashExists--  return ()--migrateDBToSchema5 :: (String -> TestM ()) -> TestM ()-migrateDBToSchema5 step = do-  let extensions    = ["pgcrypto"]-      composites    = []-      domains       = []-  step "Migrating the database (schema version 4 -> schema version 5)..."-  migrateDatabase defaultExtrasOptions extensions composites domains-    schema5Tables schema5Migrations-  checkDatabase defaultExtrasOptions composites domains schema5Tables--testDBSchema5 :: (String -> TestM ()) -> TestM ()-testDBSchema5 step = do-  step "Running test queries (schema version 5)..."--  -- Check that the 'bank' table doesn't have a 'cash' column.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM information_schema.columns"-    <> " WHERE table_schema = 'public'"-    <> " AND table_name = 'bank'"-    <> " AND column_name = 'cash')";-  (colCashExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Column 'cash' in the table 'bank' doesn't exist" False-    colCashExists--  -- Check that the 'flash' table doesn't exist.-  runSQL_ $ "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"-    <> " AND tablename = 'flash')";-  (flashExists :: Bool) <- fetchOne runIdentity-  liftIO $ assertEqual "Table 'flash' doesn't exist" False flashExists--  return ()---- | May require 'ALTER SCHEMA public OWNER TO $user' the first time--- you run this.-freshTestDB ::  (String -> TestM ()) -> TestM ()-freshTestDB step = do-  step "Dropping the test DB schema..."-  runSQL_ "DROP SCHEMA public CASCADE"-  runSQL_ "CREATE SCHEMA public"---- | Re-used by 'migrationTest5'.-migrationTest1Body :: (String -> TestM ()) -> TestM ()-migrationTest1Body step = do-  createTablesSchema1 step-  (badGuyIds, robberyIds) <--    testDBSchema1     step--  migrateDBToSchema2  step-  testDBSchema2       step badGuyIds robberyIds--  migrateDBToSchema3  step-  testDBSchema3       step badGuyIds robberyIds--  migrateDBToSchema4  step-  testDBSchema4       step--  migrateDBToSchema5  step-  testDBSchema5       step--bankTrigger1 :: Trigger-bankTrigger1 =-  Trigger { triggerTable = "bank"-          , triggerName = "trigger_1"-          , triggerEvents = Set.fromList [TriggerInsert]-          , triggerDeferrable = False-          , triggerInitiallyDeferred = False-          , triggerWhen = Nothing-          , triggerFunction =-                "begin"-            <+> "  perform true;"-            <+> "  return null;"-            <+> "end;"-          }--bankTrigger2 :: Trigger-bankTrigger2 =-  bankTrigger1-  { triggerFunction =-          "begin"-      <+> "  return null;"-      <+> "end;"-  }--bankTrigger3 :: Trigger-bankTrigger3 =-  Trigger { triggerTable = "bank"-          , triggerName = "trigger_3"-          , triggerEvents = Set.fromList [TriggerInsert, TriggerUpdateOf [unsafeSQL "location"]]-          , triggerDeferrable = True-          , triggerInitiallyDeferred = True-          , triggerWhen = Nothing-          , triggerFunction =-                "begin"-            <+> "  perform true;"-            <+> "  return null;"-            <+> "end;"-          }--bankTrigger2Proper :: Trigger-bankTrigger2Proper =-  bankTrigger2 { triggerName = "trigger_2" }--testTriggers :: HasCallStack => (String -> TestM ()) -> TestM ()-testTriggers step = do-  step "Running trigger tests..."--  step "create the initial database"-  migrate [tableBankSchema1] [createTableMigration tableBankSchema1]--  do-    let msg = "checkDatabase fails if there are triggers in the database but not in the schema"-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = []-                                }-             ]-        ms = [ createTriggerMigration 1 bankTrigger1 ]-    step msg-    assertException msg $ migrate ts ms--  do-    let msg = "checkDatabase fails if there are triggers in the schema but not in the database"-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [bankTrigger1]-                                }-             ]-        ms = []-    triggerStep msg $ do-      assertException msg $ migrate ts ms--  do-    let msg = "test succeeds when creating a single trigger"-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [bankTrigger1]-                                }-             ]-        ms = [ createTriggerMigration 1 bankTrigger1 ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [bankTrigger1] True--  do-    -- Attempt to create the same triggers twice. Should fail with a DBException saying-    -- that function already exists.-    let msg = "database exception is raised if trigger is created twice"-        ts = [ tableBankSchema1 { tblVersion = 3-                                , tblTriggers = [bankTrigger1]-                                }-             ]-        ms = [ createTriggerMigration 1 bankTrigger1-             , createTriggerMigration 2 bankTrigger1-             ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "database exception is raised if triggers only differ in function name"-        ts = [ tableBankSchema1 { tblVersion = 3-                                , tblTriggers = [bankTrigger1, bankTrigger2]-                                }-             ]-        ms = [ createTriggerMigration 1 bankTrigger1-             , createTriggerMigration 2 bankTrigger2-             ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "successfully migrate two triggers"-        ts = [ tableBankSchema1 { tblVersion = 3-                                , tblTriggers = [bankTrigger1, bankTrigger2Proper]-                                }-             ]-        ms = [ createTriggerMigration 1 bankTrigger1-             , createTriggerMigration 2 bankTrigger2Proper-             ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [bankTrigger1, bankTrigger2Proper] True--  do-    let msg = "database exception is raised if trigger's WHEN is syntactically incorrect"-        trg = bankTrigger1 { triggerWhen = Just "WILL FAIL" }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "database exception is raised if trigger's WHEN uses undefined column"-        trg = bankTrigger1 { triggerWhen = Just "NEW.foobar = 1" }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    -- This trigger is valid. However, the WHEN clause specified in triggerWhen is not-    -- what gets returned from the database. The decompiled and normalized WHEN clause-    -- from the database looks like this:-    --   new.name <> 'foobar'::text-    -- We simply assert an exception, which presumably comes from the migration framework,-    -- while it should actually be a deeper check for just the differing WHEN-    -- clauses. On the other hand, it's probably good enough as it is.-    -- See the comment for 'getDBTriggers' in src/Database/PostgreSQL/PQTypes/Model/Trigger.hs.-    let msg = "checkDatabase fails if WHEN clauses from database and code differ"-        trg = bankTrigger1 { triggerWhen = Just "NEW.name != 'foobar'" }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertException msg $ migrate ts ms--  do-    let msg = "successfully migrate trigger with valid WHEN"-        trg = bankTrigger1 { triggerWhen = Just "new.name <> 'foobar'::text" }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [trg] True--  do-    let msg = "successfully migrate trigger that is deferrable"-        trg = bankTrigger1 { triggerDeferrable = True }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [trg] True--  do-    let msg = "successfully migrate trigger that is deferrable and initially deferred"-        trg = bankTrigger1 { triggerDeferrable = True-                           , triggerInitiallyDeferred = True-                           }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [trg] True--  do-    let msg = "database exception is raised if trigger is initially deferred but not deferrable"-        trg = bankTrigger1 { triggerDeferrable = False-                           , triggerInitiallyDeferred = True-                           }-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "database exception is raised if dropping trigger that does not exist"-        trg = bankTrigger1-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ dropTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "database exception is raised if dropping trigger function of which does not exist"-        trg = bankTrigger2-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ dropTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "successfully drop trigger"-        trg = bankTrigger1-        ts = [ tableBankSchema1 { tblVersion = 3-                                , tblTriggers = []-                                }-             ]-        ms = [ createTriggerMigration 1 trg, dropTriggerMigration 2 trg ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [trg] False--  do-    let msg = "database exception is raised if dropping trigger twice"-        trg = bankTrigger2-        ts = [ tableBankSchema1 { tblVersion = 3-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ dropTriggerMigration 1 trg, dropTriggerMigration 2 trg ]-    triggerStep msg $ do-      assertDBException msg $ migrate ts ms--  do-    let msg = "successfully create trigger with multiple events"-        trg = bankTrigger3-        ts = [ tableBankSchema1 { tblVersion = 2-                                , tblTriggers = [trg]-                                }-             ]-        ms = [ createTriggerMigration 1 trg ]-    triggerStep msg $ do-      assertNoException msg $ migrate ts ms-      verify [trg] True--  where-    triggerStep msg rest = do-      recreateTriggerDB-      step msg-      rest--    migrate tables migrations = do-      migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations-      checkDatabase defaultExtrasOptions [] [] tables--    -- Verify that the given triggers are (not) present in the database.-    verify :: (MonadIO m, MonadDB m, HasCallStack) => [Trigger] -> Bool -> m ()-    verify triggers present = do-      dbTriggers <- getDBTriggers "bank"-      let trgs = map fst dbTriggers-          ok = and $ map (`elem` trgs) triggers-          err = "Triggers " <> (if present then "" else "not ") <> "present in the database."-          trans = if present then id else not-      liftIO . assertBool err $ trans ok--    triggerMigration :: MonadDB m => (Trigger -> m ()) -> Int -> Trigger -> Migration m-    triggerMigration fn from trg = Migration-      { mgrTableName = tblName tableBankSchema1-      , mgrFrom = fromIntegral from-      , mgrAction = StandardMigration $ fn trg-      }--    createTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m-    createTriggerMigration = triggerMigration createTrigger--    dropTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m-    dropTriggerMigration = triggerMigration dropTrigger--    recreateTriggerDB = do-      runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_1 ON bank;"-      runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_2 ON bank;"-      runSQL_ "DROP FUNCTION IF EXISTS trgfun__trigger_1;"-      runSQL_ "DROP FUNCTION IF EXISTS trgfun__trigger_2;"-      runSQL_ "DROP TABLE IF EXISTS bank;"-      runSQL_ "DELETE FROM table_versions WHERE name = 'bank'";-      migrate [tableBankSchema1] [createTableMigration tableBankSchema1]--testSqlWith :: HasCallStack => (String -> TestM ()) -> TestM ()-testSqlWith step = do-  step "Running sql WITH tests"-  testPass-  runSQL_ "DELETE FROM bank"-  step "Checking for WITH MATERIALIZED support"-  checkAndRememberMaterializationSupport-  step "Running sql WITH tests again with WITH MATERIALIZED support flag set"-  testPass-  where-    migrate tables migrations = do-      migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] tables migrations-      checkDatabase defaultExtrasOptions [] [] tables-    testPass = do-      step "create the initial database"-      migrate [tableBankSchema1] [createTableMigration tableBankSchema1]-      step "inserting initial data"-      runQuery_ . sqlInsert "bank" $ do-        sqlSetList "name" (["HSBC" :: T.Text, "other"])-        sqlSetList "location" (["13 Foo St., Tucson" :: T.Text, "no address"])-        sqlResult "id"-      step "testing WITH .. INSERT SELECT"-      runQuery_ . sqlInsertSelect "bank" "bank_name" $ do-        sqlWith "bank_name" $ do-          sqlSelect "bank" $ do-            sqlResult "'another'"-            sqlLimit (1 :: Int)-        sqlFrom "bank_name"-        sqlSetCmd "name" "bank_name"-        sqlSet "location" ("Other side" :: T.Text)-      step "testing WITH .. UPDATE"-      runQuery_ . sqlUpdate "bank" $ do-        sqlWith "other_bank" $ do-          sqlSelect "bank" $ do-            sqlWhereEq "name" ("other" :: T.Text)-            sqlResult "id"-        sqlFrom "other_bank"-        sqlSet "location" ("abcd" :: T.Text)-        sqlWhereInSql "bank.id" $ mkSQL "other_bank.id"-        sqlResult "bank.id"-      step "testing WITH .. DELETE"-      runQuery_ . sqlDelete "bank" $ do-        sqlWith "other_bank" $ do-          sqlSelect "bank" $ do-            sqlWhereEq "name" ("other" :: T.Text)-            sqlResult "id"-        sqlFrom "other_bank"-        sqlWhereInSql "bank.id" $ mkSQL "other_bank.id"-      step "testing WITH .. SELECT"-      runQuery_ . sqlSelect "bank" $ do-        sqlWith "other_bank" $ do-          sqlSelect "bank" $ do-            sqlResult "name"-        sqlFrom "other_bank"-        sqlResult "other_bank.name"-      (results :: [T.Text]) <- fetchMany runIdentity-      liftIO $ assertEqual "Wrong number of banks left" 2 (length results)--testUnion :: HasCallStack => (String -> TestM ()) -> TestM ()-testUnion step = do-  step "Running SQL UNION tests"-  testPass-  where-    testPass = do-      runQuery_ . sqlSelect "" $ do-        sqlResult "true"-        sqlUnion-          [ sqlSelect "" $ do-              sqlResult "false"-          , sqlSelect "" $ do-              sqlResult "true"-          ]-      result <- fetchMany runIdentity-      liftIO $ assertEqual "UNION of booleans"-        [False, True]-        result---testUnionAll :: HasCallStack => (String -> TestM ()) -> TestM ()-testUnionAll step = do-  step "Running SQL UNION ALL tests"-  testPass-  where-    testPass = do-      runQuery_ . sqlSelect "" $ do-        sqlResult "true"-        sqlUnionAll-          [ sqlSelect "" $ do-              sqlResult "false"-          , sqlSelect "" $ do-              sqlResult "true"-          ]-      result <- fetchMany runIdentity-      liftIO $ assertEqual "UNION ALL of booleans"-        [True, False, True]-        result--migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest1 connSource =-  testCaseSteps' "Migration test 1" connSource $ \step -> do-  freshTestDB         step--  migrationTest1Body  step---- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownObjects'-migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest2 connSource =-  testCaseSteps' "Migration test 2" connSource $ \step -> do-  freshTestDB    step--  createTablesSchema1 step--  let composite = CompositeType-        { ctName = "composite"-        , ctColumns =-          [ CompositeColumn { ccName = "cint",  ccType = UuidT }-          , CompositeColumn { ccName = "ctext", ccType = TextT }-          ]-        }-      currentSchema   = schema1Tables-      differentSchema = schema5Tables-      extrasOptions   = defaultExtrasOptions { eoEnforcePKs = True }-      extrasOptionsWithUnknownObjects = extrasOptions { eoObjectsValidationMode = AllowUnknownObjects }--  runQuery_ $ sqlCreateComposite composite--  assertNoException "checkDatabase should run fine for consistent DB" $-    checkDatabase extrasOptions [composite] [] currentSchema-  assertException "checkDatabase fails if composite type definition is not provided" $-    checkDatabase extrasOptions [] [] currentSchema-  assertNoException "checkDatabaseAllowUnknownTables runs fine \-                    \for consistent DB" $-    checkDatabase extrasOptionsWithUnknownObjects [composite] [] currentSchema-  assertNoException "checkDatabaseAllowUnknownTables runs fine \-                    \for consistent DB with unknown composite type in the database" $-    checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema-  assertException "checkDatabase should throw exception for wrong schema" $-    checkDatabase extrasOptions [] [] differentSchema-  assertException ("checkDatabaseAllowUnknownObjects \-                   \should throw exception for wrong scheme") $-    checkDatabase extrasOptionsWithUnknownObjects [] [] differentSchema--  runSQL_ "INSERT INTO table_versions (name, version) \-          \VALUES ('unknown_table', 0)"-  assertException "checkDatabase throw when extra entry in 'table_versions'" $-    checkDatabase extrasOptions [] [] currentSchema-  assertNoException ("checkDatabaseAllowUnknownObjects \-                     \accepts extra entry in 'table_versions'") $-    checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema-  runSQL_ "DELETE FROM table_versions where name='unknown_table'"--  runSQL_ "CREATE TABLE unknown_table (title text)"-  assertException "checkDatabase should throw with unknown table" $-    checkDatabase extrasOptions [] [] currentSchema-  assertNoException "checkDatabaseAllowUnknownObjects accepts unknown table" $-    checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema--  runSQL_ "INSERT INTO table_versions (name, version) \-          \VALUES ('unknown_table', 0)"-  assertException "checkDatabase should throw with unknown table" $-    checkDatabase extrasOptions [] [] currentSchema-  assertNoException ("checkDatabaseAllowUnknownObjects \-                     \accepts unknown tables with version") $-    checkDatabase extrasOptionsWithUnknownObjects [] [] currentSchema--  freshTestDB    step--  let schema1TablesWithMissingPK     = schema6Tables-      schema1MigrationsWithMissingPK = schema6Migrations-      withMissingPKSchema            = schema1TablesWithMissingPK-      optionsNoPKCheck               = defaultExtrasOptions-                                       { eoEnforcePKs = False }-      optionsWithPKCheck             = defaultExtrasOptions-                                       { eoEnforcePKs = True }--  step "Recreating the database (schema version 1, one table is missing PK)..."--  migrateDatabase optionsNoPKCheck ["pgcrypto"] [] []-    schema1TablesWithMissingPK [schema1MigrationsWithMissingPK]-  checkDatabase optionsNoPKCheck [] [] withMissingPKSchema--  assertException-    "checkDatabase should throw when PK missing from table \-    \'participated_in_robbery' and check is enabled" $-    checkDatabase optionsWithPKCheck [] [] withMissingPKSchema-  assertNoException-    "checkDatabase should not throw when PK missing from table \-    \'participated_in_robbery' and check is disabled" $-    checkDatabase optionsNoPKCheck [] [] withMissingPKSchema--  freshTestDB step--migrationTest3 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest3 connSource =-  testCaseSteps' "Migration test 3" connSource $ \step -> do-  freshTestDB         step--  createTablesSchema1 step-  (badGuyIds, robberyIds) <--    testDBSchema1     step--  migrateDBToSchema2  step-  testDBSchema2       step badGuyIds robberyIds--  assertException ( "Trying to run the same migration twice should fail, \-                     \when starting with a createTable migration" ) $-    migrateDBToSchema2Hacky  step--  freshTestDB         step---- | Test that running the same migrations twice doesn't result in--- unexpected errors.-migrationTest4 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest4 connSource =-  testCaseSteps' "Migration test 4" connSource $ \step -> do-  freshTestDB         step--  migrationTest1Body  step--  -- Here we run step 5 for the second time. This should be a no-op.-  migrateDBToSchema5  step-  testDBSchema5       step--  freshTestDB         step---- | Test triggers.-triggerTests :: ConnectionSourceM (LogT IO) -> TestTree-triggerTests connSource =-  testCaseSteps' "Trigger tests" connSource $ \step -> do-    freshTestDB  step-    testTriggers step--sqlWithTests :: ConnectionSourceM (LogT IO) -> TestTree-sqlWithTests connSource =-  testCaseSteps' "sql WITH tests" connSource $ \step -> do-    freshTestDB step-    testSqlWith step--unionTests :: ConnectionSourceM (LogT IO) -> TestTree-unionTests connSource =-  testCaseSteps' "SQL UNION Tests" connSource $ \step -> do-    freshTestDB step-    testUnion step--unionAllTests :: ConnectionSourceM (LogT IO) -> TestTree-unionAllTests connSource =-  testCaseSteps' "SQL UNION ALL Tests" connSource $ \step -> do-    freshTestDB step-    testUnionAll step--eitherExc :: MonadCatch m => (SomeException -> m ()) -> (a -> m ()) -> m a -> m ()-eitherExc left right c = try c >>= either left right--migrationTest5 :: ConnectionSourceM (LogT IO) -> TestTree-migrationTest5 connSource =-  testCaseSteps' "Migration test 5" connSource $ \step -> do-    freshTestDB step--    step "Creating the database (schema version 1)..."-    migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] [table1] [createTableMigration table1]-    checkDatabase defaultExtrasOptions [] [] [table1]--    step "Populating the 'bank' table..."-    runQuery_ . sqlInsert "bank" $ do-      sqlSetList "name" $ (\i -> "bank" <> show i) <$> numbers-      sqlSetList "location" $ (\i -> "location" <> show i) <$> numbers--    -- Explicitly vacuum to update the catalog so that getting the row number estimates-    -- works. The bracket_ trick is here because vacuum can't run inside a transaction-    -- block, which every test runs in.-    bracket_ (runSQL_ "COMMIT")-             (runSQL_ "BEGIN")-             (runSQL_ "VACUUM bank")--    forM_ (zip4 tables migrations steps assertions) $-      \(table, migration, step', assertion) -> do-        step step'-        migrateDatabase defaultExtrasOptions ["pgcrypto"] [] [] [table] [migration]-        checkDatabase defaultExtrasOptions [] [] [table]-        uncurry assertNoException assertion--    freshTestDB step--  where-    -- Chosen by a fair dice roll.-    numbers = [1..101] :: [Int]-    table1 = tableBankSchema1-    tables = [ table1 { tblVersion = 2-                      , tblColumns = tblColumns table1 ++ [stringColumn]-                      }-             , table1 { tblVersion = 3-                      , tblColumns = tblColumns table1 ++ [stringColumn]-                      }-             , table1 { tblVersion = 4-                      , tblColumns = tblColumns table1 ++ [stringColumn, boolColumn]-                      }-             , table1 { tblVersion = 5-                      , tblColumns = tblColumns table1 ++ [stringColumn, boolColumn]-                      }-             ]--    migrations = [ addStringColumnMigration-                 , copyStringColumnMigration-                 , addBoolColumnMigration-                 , modifyBoolColumnMigration-                 ]--    steps = [ "Adding string column (version 1 -> version 2)..."-            , "Copying string column (version 2 -> version 3)..."-            , "Adding bool column (version 3 -> version 4)..."-            , "Modifying bool column (version 4 -> version 5)..."-            ]--    assertions =-      [ ("Check that the string column has been added" :: String, checkAddStringColumn)-      , ("Check that the string data has been copied", checkCopyStringColumn)-      , ("Check that the bool column has been added", checkAddBoolColumn)-      , ("Check that the bool column has been modified", checkModifyBoolColumn)-      ]--    stringColumn = tblColumn { colName = "name_new"-                             , colType = TextT-                             }--    boolColumn = tblColumn { colName = "name_is_true"-                            , colType = BoolT-                            , colNullable = False-                            , colDefault = Just "false"-                            }--    cursorSql = "SELECT id FROM bank" :: SQL--    addStringColumnMigration = Migration-      { mgrTableName = "bank"-      , mgrFrom = 1-      , mgrAction = StandardMigration $-        runQuery_ $ sqlAlterTable "bank" [ sqlAddColumn stringColumn ]-      }--    copyStringColumnMigration = Migration-      { mgrTableName = "bank"-      , mgrFrom = 2-      , mgrAction = ModifyColumnMigration "bank" cursorSql copyColumnSql 1000-      }-    copyColumnSql :: MonadDB m => [Identity UUID] -> m ()-    copyColumnSql primaryKeys =-      runQuery_ . sqlUpdate "bank" $ do-        sqlSetCmd "name_new" "bank.name"-        sqlWhereEqualsAny "bank.id" $ runIdentity <$> primaryKeys--    addBoolColumnMigration = Migration-      { mgrTableName = "bank"-      , mgrFrom = 3-      , mgrAction = StandardMigration $-        runQuery_ $ sqlAlterTable "bank" [ sqlAddColumn boolColumn ]-      }--    modifyBoolColumnMigration = Migration-      { mgrTableName = "bank"-      , mgrFrom = 4-      , mgrAction = ModifyColumnMigration "bank" cursorSql modifyColumnSql 1000-      }-    modifyColumnSql :: MonadDB m => [Identity UUID] -> m ()-    modifyColumnSql primaryKeys =-      runQuery_ . sqlUpdate "bank" $ do-        sqlSet "name_is_true" True-        sqlWhereIn "bank.id" $ runIdentity <$> primaryKeys--    checkAddStringColumn = do-      runQuery_ . sqlSelect "bank" $ sqlResult "name_new"-      rows :: [Maybe T.Text] <- fetchMany runIdentity-      liftIO . assertEqual "No name_new in empty column" True $ all (== Nothing) rows--    checkCopyStringColumn = do-      runQuery_ . sqlSelect "bank" $ sqlResult "name_new"-      rows_new :: [Maybe T.Text] <- fetchMany runIdentity-      runQuery_ . sqlSelect "bank" $ sqlResult "name"-      rows_old :: [Maybe T.Text] <- fetchMany runIdentity-      liftIO . assertEqual "All name_new are equal name" True $-        all (uncurry (==)) $ zip rows_new rows_old--    checkAddBoolColumn = do-      runQuery_ . sqlSelect "bank" $ sqlResult "name_is_true"-      rows :: [Maybe Bool] <- fetchMany runIdentity-      liftIO . assertEqual "All name_is_true default to false" True $ all (== Just False) rows--    checkModifyBoolColumn = do-      runQuery_ . sqlSelect "bank" $ sqlResult "name_is_true"-      rows :: [Maybe Bool] <- fetchMany runIdentity-      liftIO . assertEqual "All name_is_true are true" True $ all (== Just True) rows--assertNoException :: String -> TestM () -> TestM ()-assertNoException t c = eitherExc-  (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t))-  (const $ return ()) c--assertException :: String -> TestM () -> TestM ()-assertException t c = eitherExc-  (const $ return ())-  (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t)) c--assertDBException :: String -> TestM () -> TestM ()-assertDBException t c =-  try c >>= either (\DBException{} -> pure ())-                   (const . liftIO . assertFailure $ "No DBException thrown for: " ++ t)---- | A variant of testCaseSteps that works in TestM monad.-testCaseSteps' :: TestName -> ConnectionSourceM (LogT IO)-               -> ((String -> TestM ()) -> TestM ())-               -> TestTree-testCaseSteps' testName connSource f =-  testCaseSteps testName $ \step' -> do-  let step s = liftIO $ step' s-  withStdOutLogger $ \logger ->-    runLogT "hpqtypes-extras-test" logger defaultLogLevel $-    runDBT connSource defaultTransactionSettings $-    f step--main :: IO ()-main = do-  defaultMainWithIngredients ings $-    askOption $ \(ConnectionString connectionString) ->-    let connSettings = defaultConnectionSettings-                       { csConnInfo = T.pack connectionString }-        ConnectionSource connSource = simpleSource connSettings-    in-    testGroup "DB tests" [ migrationTest1 connSource-                         , migrationTest2 connSource-                         , migrationTest3 connSource-                         , migrationTest4 connSource-                         , migrationTest5 connSource-                         , triggerTests connSource-                         , sqlWithTests connSource-                         , unionTests connSource-                         , unionAllTests connSource-                         ]-  where-    ings =-      includingOptions [Option (Proxy :: Proxy ConnectionString)]-      : defaultIngredients+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use head" #-}+module Main where++import Control.Monad (forM_)+import Control.Monad.Catch+import Control.Monad.IO.Class+import Data.Either+import Data.List (zip4)+import Data.Set qualified as Set+import Data.Text qualified as T+import Data.Typeable+import Data.UUID.Types++import Data.Monoid.Utils+import Database.PostgreSQL.PQTypes+import Database.PostgreSQL.PQTypes.Checks+import Database.PostgreSQL.PQTypes.Model.ColumnType+import Database.PostgreSQL.PQTypes.Model.CompositeType+import Database.PostgreSQL.PQTypes.Model.EnumType+import Database.PostgreSQL.PQTypes.Model.ForeignKey+import Database.PostgreSQL.PQTypes.Model.Index+import Database.PostgreSQL.PQTypes.Model.Migration+import Database.PostgreSQL.PQTypes.Model.PrimaryKey+import Database.PostgreSQL.PQTypes.Model.Table+import Database.PostgreSQL.PQTypes.Model.Trigger+import Database.PostgreSQL.PQTypes.SQL.Builder+import Log+import Log.Backend.StandardOutput++import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.Options++newtype ConnectionString = ConnectionString String+  deriving (Typeable)++instance IsOption ConnectionString where+  defaultValue =+    ConnectionString+      -- For GitHub Actions CI+      "host=postgres user=postgres password=postgres"+  parseValue = Just . ConnectionString+  optionName = return "connection-string"+  optionHelp = return "Postgres connection string"++-- Simple example schemata inspired by the one in+-- <  http://www.databaseanswers.org/data_models/bank_robberies/index.htm>+--+-- Schema 1: Bank robberies, tables:+--           bank, bad_guy, robbery, participated_in_robbery, witness,+--           witnessed_robbery+-- Schema 2: Witnesses go into witness protection program,+--           (some) bad guys get arrested:+--           drop tables witness and witnessed_robbery,+--           add table under_arrest+-- Schema 3: Bad guys get their prison sentences:+--           drop table under_arrest+--           add table prison_sentence+-- Schema 4: New 'cash' column for the 'bank' table.+-- Schema 5: Create a new table 'flash',+--           drop the 'cash' column from the 'bank' table,+--           drop table 'flash'.+-- Cleanup:  drop everything++tableBankSchema1 :: Table+tableBankSchema1 =+  tblTable+    { tblName = "bank"+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "id"+            , colType = UuidT+            , colNullable = False+            , colDefault = Just "gen_random_uuid()"+            }+        , tblColumn+            { colName = "name"+            , colType = TextT+            , colCollation = Just "en_US"+            , colNullable = False+            }+        , tblColumn+            { colName = "location"+            , colType = TextT+            , colCollation = Just "C"+            , colNullable = False+            }+        ]+    , tblPrimaryKey = pkOnColumn "id"+    , tblTriggers = []+    }++tableBankSchema2 :: Table+tableBankSchema2 = tableBankSchema1++tableBankSchema3 :: Table+tableBankSchema3 = tableBankSchema2++tableBankMigration4 :: MonadDB m => Migration m+tableBankMigration4 =+  Migration+    { mgrTableName = tblName tableBankSchema3+    , mgrFrom = 1+    , mgrAction = StandardMigration $ do+        runQuery_ $+          sqlAlterTable+            (tblName tableBankSchema3)+            [ sqlAddColumn $+                tblColumn+                  { colName = "cash"+                  , colType = IntegerT+                  , colNullable = False+                  , colDefault = Just "0"+                  }+            ]+    }++tableBankSchema4 :: Table+tableBankSchema4 =+  tableBankSchema3+    { tblVersion = tblVersion tableBankSchema3 + 1+    , tblColumns =+        tblColumns tableBankSchema3+          ++ [ tblColumn+                { colName = "cash"+                , colType = IntegerT+                , colNullable = False+                , colDefault = Just "0"+                }+             ]+    }++tableBankMigration5fst :: MonadDB m => Migration m+tableBankMigration5fst =+  Migration+    { mgrTableName = tblName tableBankSchema3+    , mgrFrom = 2+    , mgrAction = StandardMigration $ do+        runQuery_ $+          sqlAlterTable+            (tblName tableBankSchema4)+            [ sqlDropColumn "cash"+            ]+    }++tableBankMigration5snd :: MonadDB m => Migration m+tableBankMigration5snd =+  Migration+    { mgrTableName = tblName tableBankSchema3+    , mgrFrom = 3+    , mgrAction =+        CreateIndexConcurrentlyMigration+          (tblName tableBankSchema3)+          ((indexOnColumn "name") {idxInclude = ["id", "location"]})+    }++tableBankSchema5 :: Table+tableBankSchema5 =+  tableBankSchema4+    { tblVersion = tblVersion tableBankSchema4 + 2+    , tblColumns =+        filter+          (\c -> colName c /= "cash")+          (tblColumns tableBankSchema4)+    , tblIndexes = [(indexOnColumn "name") {idxInclude = ["id", "location"]}]+    }++tableBadGuySchema1 :: Table+tableBadGuySchema1 =+  tblTable+    { tblName = "bad_guy"+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "id"+            , colType = UuidT+            , colNullable = False+            , colDefault = Just "gen_random_uuid()"+            }+        , tblColumn+            { colName = "firstname"+            , colType = TextT+            , colNullable = False+            }+        , tblColumn+            { colName = "lastname"+            , colType = TextT+            , colNullable = False+            }+        ]+    , tblPrimaryKey = pkOnColumn "id"+    }++tableBadGuySchema2 :: Table+tableBadGuySchema2 = tableBadGuySchema1++tableBadGuySchema3 :: Table+tableBadGuySchema3 = tableBadGuySchema2++tableBadGuySchema4 :: Table+tableBadGuySchema4 = tableBadGuySchema3++tableBadGuySchema5 :: Table+tableBadGuySchema5 = tableBadGuySchema4++tableRobberySchema1 :: Table+tableRobberySchema1 =+  tblTable+    { tblName = "robbery"+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "id"+            , colType = UuidT+            , colNullable = False+            , colDefault = Just "gen_random_uuid()"+            }+        , tblColumn+            { colName = "bank_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "date"+            , colType = DateT+            , colNullable = False+            , colDefault = Just "now()"+            }+        ]+    , tblPrimaryKey = pkOnColumn "id"+    , tblForeignKeys = [fkOnColumn "bank_id" "bank" "id"]+    }++tableRobberySchema2 :: Table+tableRobberySchema2 = tableRobberySchema1++tableRobberySchema3 :: Table+tableRobberySchema3 = tableRobberySchema2++tableRobberySchema4 :: Table+tableRobberySchema4 = tableRobberySchema3++tableRobberySchema5 :: Table+tableRobberySchema5 = tableRobberySchema4++tableParticipatedInRobberySchema1 :: Table+tableParticipatedInRobberySchema1 =+  tblTable+    { tblName = "participated_in_robbery"+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "bad_guy_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "robbery_id"+            , colType = UuidT+            , colNullable = False+            }+        ]+    , tblPrimaryKey = pkOnColumns ["bad_guy_id", "robbery_id"]+    , tblForeignKeys =+        [ fkOnColumn "bad_guy_id" "bad_guy" "id"+        , fkOnColumn "robbery_id" "robbery" "id"+        ]+    }++tableParticipatedInRobberySchema2 :: Table+tableParticipatedInRobberySchema2 = tableParticipatedInRobberySchema1++tableParticipatedInRobberySchema3 :: Table+tableParticipatedInRobberySchema3 = tableParticipatedInRobberySchema2++tableParticipatedInRobberySchema4 :: Table+tableParticipatedInRobberySchema4 = tableParticipatedInRobberySchema3++tableParticipatedInRobberySchema5 :: Table+tableParticipatedInRobberySchema5 = tableParticipatedInRobberySchema4++tableWitnessName :: RawSQL ()+tableWitnessName = "witness"++tableWitnessSchema1 :: Table+tableWitnessSchema1 =+  tblTable+    { tblName = tableWitnessName+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "id"+            , colType = UuidT+            , colNullable = False+            , colDefault = Just "gen_random_uuid()"+            }+        , tblColumn+            { colName = "firstname"+            , colType = TextT+            , colNullable = False+            }+        , tblColumn+            { colName = "lastname"+            , colType = TextT+            , colNullable = False+            }+        ]+    , tblPrimaryKey = pkOnColumn "id"+    }++tableWitnessedRobberyName :: RawSQL ()+tableWitnessedRobberyName = "witnessed_robbery"++tableWitnessedRobberySchema1 :: Table+tableWitnessedRobberySchema1 =+  tblTable+    { tblName = tableWitnessedRobberyName+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "witness_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "robbery_id"+            , colType = UuidT+            , colNullable = False+            }+        ]+    , tblPrimaryKey = pkOnColumns ["witness_id", "robbery_id"]+    , tblForeignKeys =+        [ fkOnColumn "witness_id" "witness" "id"+        , fkOnColumn "robbery_id" "robbery" "id"+        ]+    }++tableUnderArrestName :: RawSQL ()+tableUnderArrestName = "under_arrest"++tableUnderArrestSchema2 :: Table+tableUnderArrestSchema2 =+  tblTable+    { tblName = tableUnderArrestName+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "bad_guy_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "robbery_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "court_date"+            , colType = DateT+            , colNullable = False+            , colDefault = Just "now()"+            }+        ]+    , tblPrimaryKey = pkOnColumns ["bad_guy_id", "robbery_id"]+    , tblForeignKeys =+        [ fkOnColumn "bad_guy_id" "bad_guy" "id"+        , fkOnColumn "robbery_id" "robbery" "id"+        ]+    }++tablePrisonSentenceName :: RawSQL ()+tablePrisonSentenceName = "prison_sentence"++tablePrisonSentenceSchema3 :: Table+tablePrisonSentenceSchema3 =+  tblTable+    { tblName = tablePrisonSentenceName+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "bad_guy_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "robbery_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "sentence_start"+            , colType = DateT+            , colNullable = False+            , colDefault = Just "now()"+            }+        , tblColumn+            { colName = "sentence_length"+            , colType = IntegerT+            , colNullable = False+            , colDefault = Just "6"+            }+        , tblColumn+            { colName = "prison_name"+            , colType = TextT+            , colNullable = False+            }+        ]+    , tblPrimaryKey = pkOnColumns ["bad_guy_id", "robbery_id"]+    , tblForeignKeys =+        [ fkOnColumn "bad_guy_id" "bad_guy" "id"+        , fkOnColumn "robbery_id" "robbery" "id"+        ]+    }++tablePrisonSentenceSchema4 :: Table+tablePrisonSentenceSchema4 = tablePrisonSentenceSchema3++tablePrisonSentenceSchema5 :: Table+tablePrisonSentenceSchema5 = tablePrisonSentenceSchema4++tableFlashName :: RawSQL ()+tableFlashName = "flash"++tableFlash :: Table+tableFlash =+  tblTable+    { tblName = tableFlashName+    , tblVersion = 1+    , tblColumns =+        [ tblColumn {colName = "flash_id", colType = UuidT, colNullable = False}+        ]+    }++tableCartelName :: RawSQL ()+tableCartelName = "cartel"++tableCartel :: Table+tableCartel =+  tblTable+    { tblName = tableCartelName+    , tblVersion = 1+    , tblColumns =+        [ tblColumn+            { colName = "cartel_member_id"+            , colType = UuidT+            , colNullable = False+            }+        , tblColumn+            { colName = "cartel_boss_id"+            , colType = UuidT+            , colNullable = True+            }+        ]+    , tblPrimaryKey = pkOnColumns ["cartel_member_id"]+    , tblForeignKeys =+        [ fkOnColumn "cartel_member_id" "bad_guy" "id"+        , fkOnColumn "cartel_boss_id" "bad_guy" "id"+        ]+    }++tableCartelSchema1 :: Table+tableCartelSchema1 = tableCartel++createTableMigration :: MonadDB m => Table -> Migration m+createTableMigration tbl =+  Migration+    { mgrTableName = tblName tbl+    , mgrFrom = 0+    , mgrAction = StandardMigration $ do+        createTable True tbl+    }++dropTableMigration :: MonadDB m => Table -> Migration m+dropTableMigration tbl =+  Migration+    { mgrTableName = tblName tbl+    , mgrFrom = tblVersion tbl+    , mgrAction = DropTableMigration DropTableCascade+    }++schema1Tables :: [Table]+schema1Tables =+  [ tableBankSchema1+  , tableBadGuySchema1+  , tableRobberySchema1+  , tableParticipatedInRobberySchema1+  , tableWitnessSchema1+  , tableWitnessedRobberySchema1+  ]++schema1Migrations :: MonadDB m => [Migration m]+schema1Migrations =+  [ createTableMigration tableBankSchema1+  , createTableMigration tableBadGuySchema1+  , createTableMigration tableRobberySchema1+  , createTableMigration tableParticipatedInRobberySchema1+  , createTableMigration tableWitnessSchema1+  , createTableMigration tableWitnessedRobberySchema1+  ]++schema2Tables :: [Table]+schema2Tables =+  [ tableBankSchema2+  , tableBadGuySchema2+  , tableRobberySchema2+  , tableParticipatedInRobberySchema2+  , tableUnderArrestSchema2+  ]++schema2Migrations :: MonadDB m => [Migration m]+schema2Migrations =+  schema1Migrations+    ++ [ dropTableMigration tableWitnessedRobberySchema1+       , dropTableMigration tableWitnessSchema1+       , createTableMigration tableUnderArrestSchema2+       ]++schema3Tables :: [Table]+schema3Tables =+  [ tableBankSchema3+  , tableBadGuySchema3+  , tableRobberySchema3+  , tableParticipatedInRobberySchema3+  , tablePrisonSentenceSchema3+  ]++schema3Migrations :: MonadDB m => [Migration m]+schema3Migrations =+  schema2Migrations+    ++ [ dropTableMigration tableUnderArrestSchema2+       , createTableMigration tablePrisonSentenceSchema3+       ]++schema4Tables :: [Table]+schema4Tables =+  [ tableBankSchema4+  , tableBadGuySchema4+  , tableRobberySchema4+  , tableParticipatedInRobberySchema4+  , tablePrisonSentenceSchema4+  ]++schema4Migrations :: MonadDB m => [Migration m]+schema4Migrations =+  schema3Migrations+    ++ [tableBankMigration4]++schema5Tables :: [Table]+schema5Tables =+  [ tableBankSchema5+  , tableBadGuySchema5+  , tableRobberySchema5+  , tableParticipatedInRobberySchema5+  , tablePrisonSentenceSchema5+  ]++schema5Migrations :: MonadDB m => [Migration m]+schema5Migrations =+  schema4Migrations+    ++ [ createTableMigration tableFlash+       , tableBankMigration5fst+       , tableBankMigration5snd+       , dropTableMigration tableFlash+       ]++schema6Tables :: [Table]+schema6Tables =+  [ tableBankSchema1+  , tableBadGuySchema1+  , tableRobberySchema1+  , tableParticipatedInRobberySchema1+      { tblVersion = tblVersion tableParticipatedInRobberySchema1 + 1+      , tblPrimaryKey = Nothing+      }+  , tableWitnessSchema1+  , tableWitnessedRobberySchema1+  ]++schema6Migrations :: MonadDB m => Migration m+schema6Migrations =+  Migration+    { mgrTableName = tblName tableParticipatedInRobberySchema1+    , mgrFrom = tblVersion tableParticipatedInRobberySchema1+    , mgrAction =+        StandardMigration $ do+          runQuery_+            ( "ALTER TABLE participated_in_robbery DROP CONSTRAINT \+              \pk__participated_in_robbery"+                :: RawSQL ()+            )+    }++type TestM a = DBT (LogT IO) a++createTablesSchema1 :: (String -> TestM ()) -> TestM ()+createTablesSchema1 step = do+  let definitions = tableDefsWithPgCrypto schema1Tables+  step "Creating the database (schema version 1)..."+  migrateDatabase defaultExtrasOptions definitions schema1Migrations++  -- Add a local index that shouldn't trigger validation errors.+  runSQL_ "CREATE INDEX local_idx_bank_name ON bank(name)"++  checkDatabase defaultExtrasOptions definitions++testDBSchema1 :: (String -> TestM ()) -> TestM ([UUID], [UUID])+testDBSchema1 step = do+  step "Running test queries (schema version 1)..."++  -- Populate the 'bank' table.+  runQuery_ . sqlInsert "bank" $ do+    sqlSetList+      "name"+      [ "HSBC" :: T.Text+      , "Swedbank"+      , "Nordea"+      , "Citi"+      , "Wells Fargo"+      ]+    sqlSetList+      "location"+      [ "13 Foo St., Tucson, AZ, USa" :: T.Text+      , "18 Bargatan, Stockholm, Sweden"+      , "23 Baz Lane, Liverpool, UK"+      , "2/3 Quux Ave., Milton Keynes, UK"+      , "6600 Sunset Blvd., Los Angeles, CA, USA"+      ]+    sqlResult "id"+  (bankIds :: [UUID]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'bank' table" 5 (length bankIds)++  -- Try to insert with existing ID to check that ON CONFLICT works properly+  let bankId = head bankIds+      name = "Santander" :: T.Text+      location = "Spain" :: T.Text++  runQuery_ . sqlInsert "bank" $ do+    sqlSet "id" bankId+    sqlSet "name" name+    sqlSet "location" location+    sqlOnConflictOnColumns ["id"] . sqlUpdate "" $ do+      sqlSet "name" name+      sqlSet "location" location+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlResult "location"+    sqlWhereEq "id" bankId+  details1 <- fetchOne id+  liftIO $ assertEqual "INSERT ON CONFLICT updates" (name, location) details1++  runQuery_ . sqlInsert "bank" $ do+    sqlSet "id" bankId+    sqlSet "name" ("" :: T.Text)+    sqlSet "location" ("" :: T.Text)+    sqlOnConflictDoNothing+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlResult "location"+    sqlWhereEq "id" bankId+  details3 <- fetchOne id+  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (1)" (name, location) details3++  runQuery_ . sqlInsert "bank" $ do+    sqlSet "id" bankId+    sqlSet "name" ("" :: T.Text)+    sqlSet "location" ("" :: T.Text)+    sqlOnConflictOnColumnsDoNothing ["id"]+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlResult "location"+    sqlWhereEq "id" bankId+  details4 <- fetchOne id+  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details4++  -- If NO CONFLICT is not specified, make sure we throw an exception.+  eres :: Either DBException () <- try . withSavepoint "testDBSchema" $ do+    runQuery_ . sqlInsert "bank" $ do+      sqlSet "id" bankId+      sqlSet "name" name+      sqlSet "location" location+  liftIO $ assertBool "If ON CONFLICT is not specified an exception is thrown" (isLeft eres)++  runQuery_ . sqlInsertSelect "bank" "bank" $ do+    sqlSetCmd "id" "id"+    sqlSetCmd "name" "name"+    sqlSetCmd "location" "location"+    sqlWhereEq "id" bankId+    sqlOnConflictOnColumns ["id"] . sqlUpdate "" $ do+      sqlSet "name" name+      sqlSet "location" location+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlResult "location"+    sqlWhereEq "id" bankId+  details5 <- fetchOne id+  liftIO $ assertEqual "INSERT ON CONFLICT updates" (name, location) details5++  runQuery_ . sqlInsertSelect "bank" "bank" $ do+    sqlSetCmd "id" "id"+    sqlSetCmd "name" "name"+    sqlSetCmd "location" "location"+    sqlWhereEq "id" bankId+    sqlOnConflictDoNothing+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlResult "location"+    sqlWhereEq "id" bankId+  details6 <- fetchOne id+  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (1)" (name, location) details6++  runQuery_ . sqlInsertSelect "bank" "bank" $ do+    sqlSetCmd "id" "id"+    sqlSetCmd "name" "name"+    sqlSetCmd "location" "location"+    sqlWhereEq "id" bankId+    sqlOnConflictOnColumnsDoNothing ["id"]+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlResult "location"+    sqlWhereEq "id" bankId+  details7 <- fetchOne id+  liftIO $ assertEqual "INSERT ON CONFLICT does nothing (2)" (name, location) details7++  -- If NO CONFLICT is not specified, make sure we throw an exception.+  eres1 :: Either DBException () <- try . withSavepoint "testDBSchema" $ do+    runQuery_ . sqlInsertSelect "bank" "bank" $ do+      sqlSetCmd "id" "id"+      sqlSetCmd "name" "name"+      sqlSetCmd "location" "location"+      sqlWhereEq "id" bankId+  liftIO $ assertBool "If ON CONFLICT is not specified an exception is thrown" (isLeft eres1)++  -- Populate the 'bad_guy' table.+  runQuery_ . sqlInsert "bad_guy" $ do+    sqlSetList+      "firstname"+      [ "Neil" :: T.Text+      , "Lee"+      , "Freddie"+      , "Frankie"+      , "James"+      , "Roy"+      ]+    sqlSetList+      "lastname"+      [ "Hetzel" :: T.Text+      , "Murray"+      , "Foreman"+      , "Fraser"+      , "Crosbie"+      , "Shaw"+      ]+    sqlResult "id"+  (badGuyIds :: [UUID]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'bad_guy' table" 6 (length badGuyIds)++  -- Populate the 'robbery' table.+  runQuery_ . sqlInsert "robbery" $ do+    sqlSetList "bank_id" [bankIds !! idx | idx <- [0, 3]]+    sqlResult "id"+  (robberyIds :: [UUID]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'robbery' table" 2 (length robberyIds)++  -- Populate the 'participated_in_robbery' table.+  runQuery_ . sqlInsert "participated_in_robbery" $ do+    sqlSetList "bad_guy_id" [badGuyIds !! idx | idx <- [0, 2]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlResult "bad_guy_id"+  (participatorIds :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'participated_in_robbery' table"+      2+      (length participatorIds)++  runQuery_ . sqlInsert "participated_in_robbery" $ do+    sqlSetList "bad_guy_id" [badGuyIds !! idx | idx <- [3, 4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlResult "bad_guy_id"+  (participatorIds' :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'participated_in_robbery' table"+      2+      (length participatorIds')++  -- Populate the 'witness' table.+  runQuery_ . sqlInsert "witness" $ do+    sqlSetList+      "firstname"+      [ "Meredith" :: T.Text+      , "Charlie"+      , "Peter"+      , "Emun"+      , "Benedict"+      , "Erica"+      ]+    sqlSetList+      "lastname"+      [ "Vickers" :: T.Text+      , "Holloway"+      , "Weyland"+      , "Eliott"+      , "Wong"+      , "Hackett"+      ]+    sqlResult "id"+  (witnessIds :: [UUID]) <- fetchMany runIdentity+  liftIO $ assertEqual "INSERT into 'witness' table" 6 (length witnessIds)++  -- Populate the 'witnessed_robbery' table.+  runQuery_ . sqlInsert "witnessed_robbery" $ do+    sqlSetList "witness_id" [witnessIds !! idx | idx <- [0, 1]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlResult "witness_id"+  (robberyWitnessIds :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'witnessed_robbery' table"+      2+      (length robberyWitnessIds)++  runQuery_ . sqlInsert "witnessed_robbery" $ do+    sqlSetList "witness_id" [witnessIds !! idx | idx <- [2, 3, 4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlResult "witness_id"+  (robberyWitnessIds' :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'witnessed_robbery' table"+      3+      (length robberyWitnessIds')++  -- Create a new record to test order-by case sensitivity.+  runQuery_ . sqlInsert "bank" $ do+    sqlSet "name" ("byblos bank" :: T.Text)+    sqlSet "location" ("SYRIA" :: T.Text)++  -- Check that ordering results by the "location" column uses case-sensitive+  -- sorting (since the collation method for that column is "C").+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "location"+    sqlOrderBy "location"++  details8 <- fetchMany runIdentity+  liftIO $+    assertEqual+      "Using collation method \"C\" leads to case-sensitive ordering of results"+      [ "18 Bargatan, Stockholm, Sweden" :: String+      , "2/3 Quux Ave., Milton Keynes, UK"+      , "23 Baz Lane, Liverpool, UK"+      , "6600 Sunset Blvd., Los Angeles, CA, USA"+      , "SYRIA"+      , "Spain"+      ]+      details8++  -- Check that ordering results by the "name" column uses case-insensitive+  -- sorting (since the collation method for that column is "en_US").+  runQuery_ . sqlSelect "bank" $ do+    sqlResult "name"+    sqlOrderBy "name"++  details9 <- fetchMany runIdentity+  liftIO $+    assertEqual+      "Using collation method \"en_US\" leads to case-insensitive ordering of results"+      [ "byblos bank" :: String+      , "Citi"+      , "Nordea"+      , "Santander"+      , "Swedbank"+      , "Wells Fargo"+      ]+      details9++  do+    deletedRows <- runQuery . sqlDelete "witness" $ do+      sqlWhereEq "id" $ witnessIds !! 5+      sqlResult "firstname"+      sqlResult "lastname"+    liftIO $ assertEqual "DELETE FROM 'witness' table" 1 deletedRows++    deletedName <- fetchOne id+    liftIO $+      assertEqual+        "DELETE FROM 'witness' table RETURNING firstname, lastname"+        ("Erica" :: String, "Hackett" :: String)+        deletedName++  return (badGuyIds, robberyIds)++migrateDBToSchema2 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema2 step = do+  let definitions = tableDefsWithPgCrypto schema2Tables+  step "Migrating the database (schema version 1 -> schema version 2)..."+  migrateDatabase+    defaultExtrasOptions {eoLockTimeoutMs = Just 1000}+    definitions+    schema2Migrations+  checkDatabase defaultExtrasOptions definitions++-- | Hacky version of 'migrateDBToSchema2' used by 'migrationTest3'.+migrateDBToSchema2Hacky :: (String -> TestM ()) -> TestM ()+migrateDBToSchema2Hacky step = do+  let definitions = tableDefsWithPgCrypto schema2Tables+  step+    "Hackily migrating the database (schema version 1 \+    \-> schema version 2)..."+  migrateDatabase+    defaultExtrasOptions+    definitions+    schema2Migrations'+  checkDatabase defaultExtrasOptions definitions+  where+    schema2Migrations' = createTableMigration tableFlash : schema2Migrations++testDBSchema2 :: (String -> TestM ()) -> [UUID] -> [UUID] -> TestM ()+testDBSchema2 step badGuyIds robberyIds = do+  step "Running test queries (schema version 2)..."++  -- Check that table 'witness' doesn't exist.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+      <> " AND tablename = 'witness')"+  (witnessExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'witness' doesn't exist" False witnessExists++  -- Check that table 'witnessed_robbery' doesn't exist.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+      <> " AND tablename = 'witnessed_robbery')"+  (witnessedRobberyExists :: Bool) <- fetchOne runIdentity+  liftIO $+    assertEqual+      "Table 'witnessed_robbery' doesn't exist"+      False+      witnessedRobberyExists++  -- Populate table 'under_arrest'.+  runQuery_ . sqlInsert "under_arrest" $ do+    sqlSetList "bad_guy_id" [badGuyIds !! idx | idx <- [0, 2]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlResult "bad_guy_id"+  (arrestedIds :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'under_arrest' table"+      2+      (length arrestedIds)++  runQuery_ . sqlInsert "under_arrest" $ do+    sqlSetList "bad_guy_id" [badGuyIds !! idx | idx <- [3, 4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlResult "bad_guy_id"+  (arrestedIds' :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'under_arrest' table"+      2+      (length arrestedIds')++  return ()++migrateDBToSchema3 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema3 step = do+  let definitions = tableDefsWithPgCrypto schema3Tables+  step "Migrating the database (schema version 2 -> schema version 3)..."+  migrateDatabase+    defaultExtrasOptions+    definitions+    schema3Migrations+  checkDatabase defaultExtrasOptions definitions++testDBSchema3 :: (String -> TestM ()) -> [UUID] -> [UUID] -> TestM ()+testDBSchema3 step badGuyIds robberyIds = do+  step "Running test queries (schema version 3)..."++  -- Check that table 'under_arrest' doesn't exist.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+      <> " AND tablename = 'under_arrest')"+  (underArrestExists :: Bool) <- fetchOne runIdentity+  liftIO $+    assertEqual+      "Table 'under_arrest' doesn't exist"+      False+      underArrestExists++  -- Check that the table 'prison_sentence' exists.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+      <> " AND tablename = 'prison_sentence')"+  (prisonSentenceExists :: Bool) <- fetchOne runIdentity+  liftIO $+    assertEqual+      "Table 'prison_sentence' does exist"+      True+      prisonSentenceExists++  -- Populate table 'prison_sentence'.+  runQuery_ . sqlInsert "prison_sentence" $ do+    sqlSetList "bad_guy_id" [badGuyIds !! idx | idx <- [0, 2]]+    sqlSet "robbery_id" (robberyIds !! 0)+    sqlSet "sentence_length" (12 :: Int)+    sqlSet "prison_name" ("Long Kesh" :: T.Text)+    sqlResult "bad_guy_id"+  (sentencedIds :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'prison_sentence' table"+      2+      (length sentencedIds)++  runQuery_ . sqlInsert "prison_sentence" $ do+    sqlSetList "bad_guy_id" [badGuyIds !! idx | idx <- [3, 4]]+    sqlSet "robbery_id" (robberyIds !! 1)+    sqlSet "sentence_length" (9 :: Int)+    sqlSet "prison_name" ("Wormwood Scrubs" :: T.Text)+    sqlResult "bad_guy_id"+  (sentencedIds' :: [UUID]) <- fetchMany runIdentity+  liftIO $+    assertEqual+      "INSERT into 'prison_sentence' table"+      2+      (length sentencedIds')++  return ()++migrateDBToSchema4 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema4 step = do+  let definitions = tableDefsWithPgCrypto schema4Tables+  step "Migrating the database (schema version 3 -> schema version 4)..."+  migrateDatabase+    defaultExtrasOptions+    definitions+    schema4Migrations+  checkDatabase defaultExtrasOptions definitions++testDBSchema4 :: (String -> TestM ()) -> TestM ()+testDBSchema4 step = do+  step "Running test queries (schema version 4)..."++  -- Check that the 'bank' table has a 'cash' column.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM information_schema.columns"+      <> " WHERE table_schema = 'public'"+      <> " AND table_name = 'bank'"+      <> " AND column_name = 'cash')"+  (colCashExists :: Bool) <- fetchOne runIdentity+  liftIO $+    assertEqual+      "Column 'cash' in the table 'bank' does exist"+      True+      colCashExists++  return ()++migrateDBToSchema5 :: (String -> TestM ()) -> TestM ()+migrateDBToSchema5 step = do+  let definitions = tableDefsWithPgCrypto schema5Tables+  step "Migrating the database (schema version 4 -> schema version 5)..."+  migrateDatabase defaultExtrasOptions definitions schema5Migrations+  checkDatabase defaultExtrasOptions definitions++testDBSchema5 :: (String -> TestM ()) -> TestM ()+testDBSchema5 step = do+  step "Running test queries (schema version 5)..."++  -- Check that the 'bank' table doesn't have a 'cash' column.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM information_schema.columns"+      <> " WHERE table_schema = 'public'"+      <> " AND table_name = 'bank'"+      <> " AND column_name = 'cash')"+  (colCashExists :: Bool) <- fetchOne runIdentity+  liftIO $+    assertEqual+      "Column 'cash' in the table 'bank' doesn't exist"+      False+      colCashExists++  -- Check that the 'flash' table doesn't exist.+  runSQL_ $+    "SELECT EXISTS (SELECT 1 FROM pg_tables WHERE schemaname = 'public'"+      <> " AND tablename = 'flash')"+  (flashExists :: Bool) <- fetchOne runIdentity+  liftIO $ assertEqual "Table 'flash' doesn't exist" False flashExists++  return ()++-- | May require 'ALTER SCHEMA public OWNER TO $user' the first time+-- you run this.+freshTestDB :: (String -> TestM ()) -> TestM ()+freshTestDB step = do+  step "Dropping the test DB schema..."+  runSQL_ "DROP SCHEMA public CASCADE"+  runSQL_ "CREATE SCHEMA public"++-- | Re-used by 'migrationTest5'.+migrationTest1Body :: (String -> TestM ()) -> TestM ()+migrationTest1Body step = do+  createTablesSchema1 step+  (badGuyIds, robberyIds) <-+    testDBSchema1 step++  migrateDBToSchema2 step+  testDBSchema2 step badGuyIds robberyIds++  migrateDBToSchema3 step+  testDBSchema3 step badGuyIds robberyIds++  migrateDBToSchema4 step+  testDBSchema4 step++  migrateDBToSchema5 step+  testDBSchema5 step++bankTrigger1 :: Trigger+bankTrigger1 =+  Trigger+    { triggerTable = "bank"+    , triggerName = "trigger_1"+    , triggerKind = TriggerConstraint NotDeferrable+    , triggerEvents = Set.fromList [TriggerInsert]+    , triggerWhen = Nothing+    , triggerFunction =+        "begin"+          <+> "  perform true;"+          <+> "  return null;"+          <+> "end;"+    }++bankTrigger2 :: Trigger+bankTrigger2 =+  bankTrigger1+    { triggerFunction =+        "begin"+          <+> "  return null;"+          <+> "end;"+    }++bankTrigger3 :: Trigger+bankTrigger3 =+  Trigger+    { triggerTable = "bank"+    , triggerName = "trigger_3"+    , triggerKind = TriggerConstraint DeferrableInitiallyDeferred+    , triggerEvents = Set.fromList [TriggerInsert, TriggerUpdateOf [unsafeSQL "location"]]+    , triggerWhen = Nothing+    , triggerFunction =+        "begin"+          <+> "  perform true;"+          <+> "  return null;"+          <+> "end;"+    }++bankTrigger2Proper :: Trigger+bankTrigger2Proper =+  bankTrigger2 {triggerName = "trigger_2"}++testTriggers :: HasCallStack => (String -> TestM ()) -> TestM ()+testTriggers step = do+  step "Running trigger tests..."++  step "create the initial database"+  migrate [tableBankSchema1] [createTableMigration tableBankSchema1]++  do+    let msg = "checkDatabase fails if there are triggers in the database but not in the schema"+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = []+              }+          ]+        ms = [createTriggerMigration 1 bankTrigger1]+    step msg+    assertException msg $ migrate ts ms++  do+    let msg = "checkDatabase fails if there are triggers in the schema but not in the database"+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [bankTrigger1]+              }+          ]+        ms = []+    triggerStep msg $ do+      assertException msg $ migrate ts ms++  do+    let msg = "test succeeds when creating a single trigger"+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [bankTrigger1]+              }+          ]+        ms = [createTriggerMigration 1 bankTrigger1]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [bankTrigger1] True++  do+    -- Attempt to create the same triggers twice. Should fail with a DBException saying+    -- that function already exists.+    let msg = "database exception is raised if trigger is created twice"+        ts =+          [ tableBankSchema1+              { tblVersion = 3+              , tblTriggers = [bankTrigger1]+              }+          ]+        ms =+          [ createTriggerMigration 1 bankTrigger1+          , createTriggerMigration 2 bankTrigger1+          ]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "database exception is raised if triggers only differ in function name"+        ts =+          [ tableBankSchema1+              { tblVersion = 3+              , tblTriggers = [bankTrigger1, bankTrigger2]+              }+          ]+        ms =+          [ createTriggerMigration 1 bankTrigger1+          , createTriggerMigration 2 bankTrigger2+          ]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "successfully migrate two triggers"+        ts =+          [ tableBankSchema1+              { tblVersion = 3+              , tblTriggers = [bankTrigger1, bankTrigger2Proper]+              }+          ]+        ms =+          [ createTriggerMigration 1 bankTrigger1+          , createTriggerMigration 2 bankTrigger2Proper+          ]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [bankTrigger1, bankTrigger2Proper] True++  do+    let msg = "database exception is raised if trigger's WHEN is syntactically incorrect"+        trg = bankTrigger1 {triggerWhen = Just "WILL FAIL"}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "database exception is raised if trigger's WHEN uses undefined column"+        trg = bankTrigger1 {triggerWhen = Just "NEW.foobar = 1"}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    -- This trigger is valid. However, the WHEN clause specified in triggerWhen is not+    -- what gets returned from the database. The decompiled and normalized WHEN clause+    -- from the database looks like this:+    --   new.name <> 'foobar'::text+    -- We simply assert an exception, which presumably comes from the migration framework,+    -- while it should actually be a deeper check for just the differing WHEN+    -- clauses. On the other hand, it's probably good enough as it is.+    -- See the comment for 'getDBTriggers' in src/Database/PostgreSQL/PQTypes/Model/Trigger.hs.+    let msg = "checkDatabase fails if WHEN clauses from database and code differ"+        trg = bankTrigger1 {triggerWhen = Just "NEW.name != 'foobar'"}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertException msg $ migrate ts ms++  do+    let msg = "successfully migrate trigger with valid WHEN"+        trg = bankTrigger1 {triggerWhen = Just "new.name <> 'foobar'::text"}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "successfully migrate a constraint trigger that is deferrable"+        trg = bankTrigger1 {triggerKind = TriggerConstraint Deferrable}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "successfully migrate a constraint trigger that is deferrable and initially deferred"+        trg = bankTrigger1 {triggerKind = TriggerConstraint DeferrableInitiallyDeferred}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "successfully migrate a regular AFTER trigger"+        trg = bankTrigger1 {triggerKind = TriggerRegular After}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "successfully migrate a regular BEFORE trigger"+        trg = bankTrigger1 {triggerKind = TriggerRegular Before}+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True++  do+    let msg = "database exception is raised if dropping trigger that does not exist"+        trg = bankTrigger1+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [dropTriggerMigration 1 trg]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "database exception is raised if dropping trigger function of which does not exist"+        trg = bankTrigger2+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [dropTriggerMigration 1 trg]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "successfully drop trigger"+        trg = bankTrigger1+        ts =+          [ tableBankSchema1+              { tblVersion = 3+              , tblTriggers = []+              }+          ]+        ms = [createTriggerMigration 1 trg, dropTriggerMigration 2 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] False++  do+    let msg = "database exception is raised if dropping trigger twice"+        trg = bankTrigger2+        ts =+          [ tableBankSchema1+              { tblVersion = 3+              , tblTriggers = [trg]+              }+          ]+        ms = [dropTriggerMigration 1 trg, dropTriggerMigration 2 trg]+    triggerStep msg $ do+      assertDBException msg $ migrate ts ms++  do+    let msg = "successfully create trigger with multiple events"+        trg = bankTrigger3+        ts =+          [ tableBankSchema1+              { tblVersion = 2+              , tblTriggers = [trg]+              }+          ]+        ms = [createTriggerMigration 1 trg]+    triggerStep msg $ do+      assertNoException msg $ migrate ts ms+      verify [trg] True+  where+    triggerStep msg rest = do+      recreateTriggerDB+      step msg+      rest++    migrate tables migrations = do+      let definitions = tableDefsWithPgCrypto tables+      migrateDatabase defaultExtrasOptions definitions migrations+      checkDatabase defaultExtrasOptions definitions++    -- Verify that the given triggers are (not) present in the database.+    verify :: (MonadIO m, MonadDB m, HasCallStack) => [Trigger] -> Bool -> m ()+    verify triggers present = do+      dbTriggers <- getDBTriggers "bank"+      let trgs = map fst dbTriggers+          ok = all (`elem` trgs) triggers+          err = "Triggers " <> (if present then "" else "not ") <> "present in the database."+          trans = if present then id else not+      liftIO . assertBool err $ trans ok++    triggerMigration :: MonadDB m => (Trigger -> m ()) -> Int -> Trigger -> Migration m+    triggerMigration fn from trg =+      Migration+        { mgrTableName = tblName tableBankSchema1+        , mgrFrom = fromIntegral from+        , mgrAction = StandardMigration $ fn trg+        }++    createTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m+    createTriggerMigration = triggerMigration createTrigger++    dropTriggerMigration :: MonadDB m => Int -> Trigger -> Migration m+    dropTriggerMigration = triggerMigration dropTrigger++    recreateTriggerDB = do+      runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_1 ON bank;"+      runSQL_ "DROP TRIGGER IF EXISTS trg__bank__trigger_2 ON bank;"+      runSQL_ "DROP FUNCTION IF EXISTS trgfun__trigger_1;"+      runSQL_ "DROP FUNCTION IF EXISTS trgfun__trigger_2;"+      runSQL_ "DROP TABLE IF EXISTS bank;"+      runSQL_ "DELETE FROM table_versions WHERE name = 'bank'"+      migrate [tableBankSchema1] [createTableMigration tableBankSchema1]++testSqlWith :: HasCallStack => (String -> TestM ()) -> TestM ()+testSqlWith step = do+  step "Running sql WITH tests"+  testPass+  runSQL_ "DELETE FROM bank"+  step "Checking for WITH MATERIALIZED support"+  checkAndRememberMaterializationSupport+  step "Running sql WITH tests again with WITH MATERIALIZED support flag set"+  testPass+  where+    migrate tables migrations = do+      let definitions = tableDefsWithPgCrypto tables+      migrateDatabase defaultExtrasOptions definitions migrations+      checkDatabase defaultExtrasOptions definitions+    testPass = do+      step "create the initial database"+      migrate [tableBankSchema1] [createTableMigration tableBankSchema1]+      step "inserting initial data"+      runQuery_ . sqlInsert "bank" $ do+        sqlSetList "name" ["HSBC" :: T.Text, "other"]+        sqlSetList "location" ["13 Foo St., Tucson" :: T.Text, "no address"]+        sqlResult "id"+      step "testing WITH .. INSERT SELECT"+      runQuery_ . sqlInsertSelect "bank" "bank_name" $ do+        sqlWith "bank_name" $ do+          sqlSelect "bank" $ do+            sqlResult "'another'"+            sqlLimit (1 :: Int)+        sqlFrom "bank_name"+        sqlSetCmd "name" "bank_name"+        sqlSet "location" ("Other side" :: T.Text)+      step "testing WITH .. UPDATE"+      runQuery_ . sqlUpdate "bank" $ do+        sqlWith "other_bank" $ do+          sqlSelect "bank" $ do+            sqlWhereEq "name" ("other" :: T.Text)+            sqlResult "id"+        sqlFrom "other_bank"+        sqlSet "location" ("abcd" :: T.Text)+        sqlWhereInSql "bank.id" $ mkSQL "other_bank.id"+        sqlResult "bank.id"+      step "testing WITH .. DELETE"+      runQuery_ . sqlDelete "bank" $ do+        sqlWith "other_bank" $ do+          sqlSelect "bank" $ do+            sqlWhereEq "name" ("other" :: T.Text)+            sqlResult "id"+        sqlFrom "other_bank"+        sqlWhereInSql "bank.id" $ mkSQL "other_bank.id"+      step "testing WITH .. SELECT"+      runQuery_ . sqlSelect "bank" $ do+        sqlWith "other_bank" $ do+          sqlSelect "bank" $ do+            sqlResult "name"+        sqlFrom "other_bank"+        sqlResult "other_bank.name"+      (results :: [T.Text]) <- fetchMany runIdentity+      liftIO $ assertEqual "Wrong number of banks left" 2 (length results)++testSqlWithRecursive :: HasCallStack => (String -> TestM ()) -> TestM ()+testSqlWithRecursive step = do+  step "Running WITH RECURSIVE tests"+  testPass+  where+    migrate tables migrations = do+      let definitions = tableDefsWithPgCrypto tables+      migrateDatabase defaultExtrasOptions definitions migrations+      checkDatabase defaultExtrasOptions definitions+    testPass = do+      step "create the initial database"+      migrate [tableBadGuySchema1, tableCartelSchema1] [createTableMigration tableBadGuySchema1, createTableMigration tableCartelSchema1]+      step "inserting initial data"+      runQuery_ . sqlInsert "bad_guy" $ do+        sqlSetList "firstname" ["Pablo" :: T.Text, "Gustavo", "Mario"]+        sqlSetList "lastname" ["Escobar" :: T.Text, "Rivero", "Vallejo"]+        sqlResult "id"+      (badGuyIds :: [UUID]) <- fetchMany runIdentity+      -- Populate the 'cartel' table+      -- We will have a simple direct hierarchy just to test the recursion:+      -- Pablo is the boss of Gustavo, who is the boss of Mario+      runQuery_ . sqlInsert "cartel" $ do+        sqlSetList "cartel_member_id" badGuyIds+        sqlSetList "cartel_boss_id" $ Nothing : (Just <$> take 2 badGuyIds)+      step "Checking a recursive query on the cartel table"+      runQuery_ . sqlSelect "rcartel" $ do+        sqlWithRecursive "rcartel" $ do+          sqlSelect "cartel root" $ do+            sqlResult "root.cartel_member_id"+            sqlResult "root.cartel_boss_id"+            sqlWhere "root.cartel_boss_id IS NULL"+            sqlUnionAll+              [ sqlSelect "cartel child" $ do+                  sqlResult "child.cartel_member_id"+                  sqlResult "child.cartel_boss_id"+                  sqlJoinOn "rcartel rcartel1" "child.cartel_boss_id = rcartel1.cartel_member_id"+              ]+        -- This dummy with is not actually used+        -- It's just here to test that further "sqlWith" do not remove the RECURSIVE+        -- keyword when actually producing the SQL+        sqlWith "lcartel" $ do+          sqlSelect "rcartel c" $ do+            sqlResult "c.cartel_member_id"+            sqlResult "c.cartel_boss_id"+        sqlResult "member.firstname"+        sqlResult "member.lastname"+        sqlResult "boss.firstname"+        sqlResult "boss.lastname"+        sqlJoinOn "bad_guy member" "rcartel.cartel_member_id = member.id"+        sqlLeftJoinOn "bad_guy boss" "rcartel.cartel_boss_id = boss.id"+      let toCartel :: (T.Text, T.Text, Maybe T.Text, Maybe T.Text) -> (T.Text, Maybe T.Text)+          toCartel (memberFn, memberLn, bossFn, bossLn) =+            (T.intercalate " " [memberFn, memberLn], T.intercalate " " <$> sequence [bossFn, bossLn])+      results <- fetchMany toCartel+      liftIO $+        assertEqual+          "Wrong cartel hierarchy retrieved"+          results+          [ ("Pablo Escobar", Nothing)+          , ("Gustavo Rivero", Just "Pablo Escobar")+          , ("Mario Vallejo", Just "Gustavo Rivero")+          ]++testUnion :: HasCallStack => (String -> TestM ()) -> TestM ()+testUnion step = do+  step "Running SQL UNION tests"+  testPass+  where+    testPass = do+      runQuery_ . sqlSelect "" $ do+        sqlResult "true"+        sqlUnion+          [ sqlSelect "" $ do+              sqlResult "false"+          , sqlSelect "" $ do+              sqlResult "true"+          ]+      result <- fetchMany runIdentity+      liftIO $+        assertEqual+          "UNION of booleans"+          [False, True]+          result++testUnionAll :: HasCallStack => (String -> TestM ()) -> TestM ()+testUnionAll step = do+  step "Running SQL UNION ALL tests"+  testPass+  where+    testPass = do+      runQuery_ . sqlSelect "" $ do+        sqlResult "true"+        sqlUnionAll+          [ sqlSelect "" $ do+              sqlResult "false"+          , sqlSelect "" $ do+              sqlResult "true"+          ]+      result <- fetchMany runIdentity+      liftIO $+        assertEqual+          "UNION ALL of booleans"+          [True, False, True]+          result++migrationTest1 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest1 connSource =+  testCaseSteps' "Migration test 1" connSource $ \step -> do+    freshTestDB step++    migrationTest1Body step++-- | Test for behaviour of 'checkDatabase' and 'checkDatabaseAllowUnknownObjects'+migrationTest2 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest2 connSource =+  testCaseSteps' "Migration test 2" connSource $ \step -> do+    freshTestDB step++    createTablesSchema1 step++    let composite =+          CompositeType+            { ctName = "composite"+            , ctColumns =+                [ CompositeColumn {ccName = "cint", ccType = UuidT}+                , CompositeColumn {ccName = "ctext", ccType = TextT}+                ]+            }+        currentSchema = schema1Tables+        differentSchema = schema5Tables+        extrasOptions = defaultExtrasOptions {eoEnforcePKs = True}+        extrasOptionsWithUnknownObjects = extrasOptions {eoObjectsValidationMode = AllowUnknownObjects}++    runQuery_ $ sqlCreateComposite composite++    assertNoException "checkDatabase should run fine for consistent DB" $+      checkDatabase extrasOptions $+        emptyDbDefinitions {dbComposites = [composite], dbTables = currentSchema}+    assertException "checkDatabase fails if composite type definition is not provided" $+      checkDatabase extrasOptions $+        emptyDbDefinitions {dbTables = currentSchema}+    assertNoException+      "checkDatabaseAllowUnknownTables runs fine \+      \for consistent DB"+      $ checkDatabase extrasOptionsWithUnknownObjects+      $ emptyDbDefinitions {dbComposites = [composite], dbTables = currentSchema}+    assertNoException+      "checkDatabaseAllowUnknownTables runs fine \+      \for consistent DB with unknown composite type in the database"+      $ checkDatabase extrasOptionsWithUnknownObjects+      $ emptyDbDefinitions {dbTables = currentSchema}+    assertException "checkDatabase should throw exception for wrong schema" $+      checkDatabase extrasOptions emptyDbDefinitions {dbTables = differentSchema}+    assertException+      "checkDatabaseAllowUnknownObjects \+      \should throw exception for wrong scheme"+      $ checkDatabase extrasOptionsWithUnknownObjects emptyDbDefinitions {dbTables = differentSchema}++    runSQL_+      "INSERT INTO table_versions (name, version) \+      \VALUES ('unknown_table', 0)"+    assertException "checkDatabase throw when extra entry in 'table_versions'" $+      checkDatabase extrasOptions $+        emptyDbDefinitions {dbTables = currentSchema}+    assertNoException+      "checkDatabaseAllowUnknownObjects \+      \accepts extra entry in 'table_versions'"+      $ checkDatabase extrasOptionsWithUnknownObjects+      $ emptyDbDefinitions {dbTables = currentSchema}+    runSQL_ "DELETE FROM table_versions where name='unknown_table'"++    runSQL_ "CREATE TABLE unknown_table (title text)"+    assertException "checkDatabase should throw with unknown table" $+      checkDatabase extrasOptions $+        emptyDbDefinitions {dbTables = currentSchema}+    assertNoException "checkDatabaseAllowUnknownObjects accepts unknown table" $+      checkDatabase extrasOptionsWithUnknownObjects $+        emptyDbDefinitions {dbTables = currentSchema}++    runSQL_+      "INSERT INTO table_versions (name, version) \+      \VALUES ('unknown_table', 0)"+    assertException "checkDatabase should throw with unknown table" $+      checkDatabase extrasOptions $+        emptyDbDefinitions {dbTables = currentSchema}+    assertNoException+      "checkDatabaseAllowUnknownObjects \+      \accepts unknown tables with version"+      $ checkDatabase extrasOptionsWithUnknownObjects+      $ emptyDbDefinitions {dbTables = currentSchema}++    freshTestDB step++    let withMissingPKSchema = schema6Tables+        schema1MigrationsWithMissingPK = schema6Migrations+        optionsNoPKCheck =+          defaultExtrasOptions+            { eoEnforcePKs = False+            }+        optionsWithPKCheck =+          defaultExtrasOptions+            { eoEnforcePKs = True+            }++    step "Recreating the database (schema version 1, one table is missing PK)..."++    migrateDatabase+      optionsNoPKCheck+      (tableDefsWithPgCrypto withMissingPKSchema)+      [schema1MigrationsWithMissingPK]+    checkDatabase optionsNoPKCheck (tableDefsWithPgCrypto withMissingPKSchema)++    assertException+      "checkDatabase should throw when PK missing from table \+      \'participated_in_robbery' and check is enabled"+      $ checkDatabase optionsWithPKCheck+      $ emptyDbDefinitions {dbTables = withMissingPKSchema}+    assertNoException+      "checkDatabase should not throw when PK missing from table \+      \'participated_in_robbery' and check is disabled"+      $ checkDatabase optionsNoPKCheck+      $ emptyDbDefinitions {dbTables = withMissingPKSchema}++    freshTestDB step++migrationTest3 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest3 connSource =+  testCaseSteps' "Migration test 3" connSource $ \step -> do+    freshTestDB step++    createTablesSchema1 step+    (badGuyIds, robberyIds) <-+      testDBSchema1 step++    migrateDBToSchema2 step+    testDBSchema2 step badGuyIds robberyIds++    assertException+      "Trying to run the same migration twice should fail, \+      \when starting with a createTable migration"+      $ migrateDBToSchema2Hacky step++    freshTestDB step++-- | Test that running the same migrations twice doesn't result in+-- unexpected errors.+migrationTest4 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest4 connSource =+  testCaseSteps' "Migration test 4" connSource $ \step -> do+    freshTestDB step++    migrationTest1Body step++    -- Here we run step 5 for the second time. This should be a no-op.+    migrateDBToSchema5 step+    testDBSchema5 step++    freshTestDB step++-- | Test triggers.+triggerTests :: ConnectionSourceM (LogT IO) -> TestTree+triggerTests connSource =+  testCaseSteps' "Trigger tests" connSource $ \step -> do+    freshTestDB step+    testTriggers step++sqlWithTests :: ConnectionSourceM (LogT IO) -> TestTree+sqlWithTests connSource =+  testCaseSteps' "sql WITH tests" connSource $ \step -> do+    freshTestDB step+    testSqlWith step++unionTests :: ConnectionSourceM (LogT IO) -> TestTree+unionTests connSource =+  testCaseSteps' "SQL UNION Tests" connSource $ \step -> do+    freshTestDB step+    testUnion step++sqlWithRecursiveTests :: ConnectionSourceM (LogT IO) -> TestTree+sqlWithRecursiveTests connSource =+  testCaseSteps' "SQL WITH RECURSIVE Tests" connSource $ \step -> do+    freshTestDB step+    testSqlWithRecursive step++unionAllTests :: ConnectionSourceM (LogT IO) -> TestTree+unionAllTests connSource =+  testCaseSteps' "SQL UNION ALL Tests" connSource $ \step -> do+    freshTestDB step+    testUnionAll step++eitherExc :: MonadCatch m => (SomeException -> m ()) -> (a -> m ()) -> m a -> m ()+eitherExc left right c = try c >>= either left right++migrationTest5 :: ConnectionSourceM (LogT IO) -> TestTree+migrationTest5 connSource =+  testCaseSteps' "Migration test 5" connSource $ \step -> do+    freshTestDB step++    step "Creating the database (schema version 1)..."+    migrateDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1]) [createTableMigration table1]+    checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1])++    step "Populating the 'bank' table..."+    runQuery_ . sqlInsert "bank" $ do+      sqlSetList "name" $ (\i -> "bank" <> show i) <$> numbers+      sqlSetList "location" $ (\i -> "location" <> show i) <$> numbers++    -- Explicitly vacuum to update the catalog so that getting the row number estimates+    -- works. The bracket_ trick is here because vacuum can't run inside a transaction+    -- block, which every test runs in.+    bracket_+      (runSQL_ "COMMIT")+      (runSQL_ "BEGIN")+      (runSQL_ "VACUUM bank")++    forM_ (zip4 tables migrations steps assertions) $+      \(table, migration, step', assertion) -> do+        step step'+        migrateDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table]) [migration]+        checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table])+        uncurry assertNoException assertion++    freshTestDB step+  where+    -- Chosen by a fair dice roll.+    numbers = [1 .. 101] :: [Int]+    table1 = tableBankSchema1+    tables =+      [ table1+          { tblVersion = 2+          , tblColumns = tblColumns table1 ++ [stringColumn]+          }+      , table1+          { tblVersion = 3+          , tblColumns = tblColumns table1 ++ [stringColumn]+          }+      , table1+          { tblVersion = 4+          , tblColumns = tblColumns table1 ++ [stringColumn, boolColumn]+          }+      , table1+          { tblVersion = 5+          , tblColumns = tblColumns table1 ++ [stringColumn, boolColumn]+          }+      ]++    migrations =+      [ addStringColumnMigration+      , copyStringColumnMigration+      , addBoolColumnMigration+      , modifyBoolColumnMigration+      ]++    steps =+      [ "Adding string column (version 1 -> version 2)..."+      , "Copying string column (version 2 -> version 3)..."+      , "Adding bool column (version 3 -> version 4)..."+      , "Modifying bool column (version 4 -> version 5)..."+      ]++    assertions =+      [ ("Check that the string column has been added" :: String, checkAddStringColumn)+      , ("Check that the string data has been copied", checkCopyStringColumn)+      , ("Check that the bool column has been added", checkAddBoolColumn)+      , ("Check that the bool column has been modified", checkModifyBoolColumn)+      ]++    stringColumn =+      tblColumn+        { colName = "name_new"+        , colType = TextT+        }++    boolColumn =+      tblColumn+        { colName = "name_is_true"+        , colType = BoolT+        , colNullable = False+        , colDefault = Just "false"+        }++    cursorSql = "SELECT id FROM bank" :: SQL++    addStringColumnMigration =+      Migration+        { mgrTableName = "bank"+        , mgrFrom = 1+        , mgrAction =+            StandardMigration $+              runQuery_ $+                sqlAlterTable "bank" [sqlAddColumn stringColumn]+        }++    copyStringColumnMigration =+      Migration+        { mgrTableName = "bank"+        , mgrFrom = 2+        , mgrAction = ModifyColumnMigration "bank" cursorSql copyColumnSql 1000+        }+    copyColumnSql :: MonadDB m => [Identity UUID] -> m ()+    copyColumnSql primaryKeys =+      runQuery_ . sqlUpdate "bank" $ do+        sqlSetCmd "name_new" "bank.name"+        sqlWhereEqualsAny "bank.id" $ runIdentity <$> primaryKeys++    addBoolColumnMigration =+      Migration+        { mgrTableName = "bank"+        , mgrFrom = 3+        , mgrAction =+            StandardMigration $+              runQuery_ $+                sqlAlterTable "bank" [sqlAddColumn boolColumn]+        }++    modifyBoolColumnMigration =+      Migration+        { mgrTableName = "bank"+        , mgrFrom = 4+        , mgrAction = ModifyColumnMigration "bank" cursorSql modifyColumnSql 1000+        }+    modifyColumnSql :: MonadDB m => [Identity UUID] -> m ()+    modifyColumnSql primaryKeys =+      runQuery_ . sqlUpdate "bank" $ do+        sqlSet "name_is_true" True+        sqlWhereIn "bank.id" $ runIdentity <$> primaryKeys++    checkAddStringColumn = do+      runQuery_ . sqlSelect "bank" $ sqlResult "name_new"+      rows :: [Maybe T.Text] <- fetchMany runIdentity+      liftIO . assertEqual "No name_new in empty column" True $ all (== Nothing) rows++    checkCopyStringColumn = do+      runQuery_ . sqlSelect "bank" $ sqlResult "name_new"+      rows_new :: [Maybe T.Text] <- fetchMany runIdentity+      runQuery_ . sqlSelect "bank" $ sqlResult "name"+      rows_old :: [Maybe T.Text] <- fetchMany runIdentity+      liftIO . assertEqual "All name_new are equal name" True $+        all (uncurry (==)) $+          zip rows_new rows_old++    checkAddBoolColumn = do+      runQuery_ . sqlSelect "bank" $ sqlResult "name_is_true"+      rows :: [Maybe Bool] <- fetchMany runIdentity+      liftIO . assertEqual "All name_is_true default to false" True $ all (== Just False) rows++    checkModifyBoolColumn = do+      runQuery_ . sqlSelect "bank" $ sqlResult "name_is_true"+      rows :: [Maybe Bool] <- fetchMany runIdentity+      liftIO . assertEqual "All name_is_true are true" True $ all (== Just True) rows++foreignKeyIndexesTests :: ConnectionSourceM (LogT IO) -> TestTree+foreignKeyIndexesTests connSource =+  testCaseSteps' "Foreign key indexes tests" connSource $ \step -> do+    freshTestDB step++    step "Create database with two tables, no foreign key checking"+    do+      let options = defaultExtrasOptions+      migrateDatabase+        options+        (tableDefsWithPgCrypto [table1, table2])+        [createTableMigration table1, createTableMigration table2]+      checkDatabase defaultExtrasOptions (tableDefsWithPgCrypto [table1, table2])++    step "Create database with two tables, with foreign key checking"+    do+      let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True}+      assertException "Foreign keys are missing" $+        migrateDatabase+          options+          (tableDefsWithPgCrypto [table1, table2])+          [createTableMigration table1, createTableMigration table2]++    step "Table is missing several foreign key indexes"+    do+      let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True}+      assertException "Foreign keys are missing" $+        migrateDatabase+          options+          (tableDefsWithPgCrypto [table1, table2, table3])+          [createTableMigration table1, createTableMigration table2, createTableMigration table3]++    step "Multi column indexes covering a FK pass the checks"+    do+      let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True}+      migrateDatabase+        options+        (tableDefsWithPgCrypto [table4])+        [ dropTableMigration table1+        , dropTableMigration table2+        , dropTableMigration table3+        , createTableMigration table4+        ]+      checkDatabase options (tableDefsWithPgCrypto [table4])+    step "Multi column indexes not covering a FK fail the checks"+    do+      let options = defaultExtrasOptions {eoCheckForeignKeysIndexes = True}+      assertException "Foreign keys are missing" $+        migrateDatabase+          options+          (tableDefsWithPgCrypto [table5])+          [ dropTableMigration table4+          , createTableMigration table5+          ]+  where+    table1 :: Table+    table1 =+      tblTable+        { tblName = "fktest1"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False}+            , tblColumn {colName = "name", colType = TextT}+            , tblColumn {colName = "location", colType = TextT}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        }+    table2 :: Table+    table2 =+      tblTable+        { tblName = "fktest2"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False}+            , tblColumn {colName = "fkid", colType = UuidT}+            , tblColumn {colName = "fkname", colType = TextT}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblForeignKeys =+            [ fkOnColumn "fkid" "fktest1" "id"+            ]+        }+    table3 :: Table+    table3 =+      tblTable+        { tblName = "fktest3"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False}+            , tblColumn {colName = "fk1id", colType = UuidT}+            , tblColumn {colName = "fk2id", colType = UuidT}+            , tblColumn {colName = "fkname", colType = TextT}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblForeignKeys =+            [ fkOnColumn "fk1id" "fktest1" "id"+            , fkOnColumn "fk2id" "fktest2" "id"+            ]+        }+    table4 :: Table+    table4 =+      tblTable+        { tblName = "fktest4"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False}+            , tblColumn {colName = "fk4id", colType = UuidT}+            , tblColumn {colName = "fk4name", colType = TextT}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblForeignKeys =+            [ fkOnColumn "fk4id" "fktest4" "id"+            ]+        , tblIndexes =+            [ indexOnColumns [indexColumn "fk4id", indexColumn "fk4name"]+            ]+        }+    table5 :: Table+    table5 =+      tblTable+        { tblName = "fktest5"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False}+            , tblColumn {colName = "fk5id", colType = UuidT}+            , tblColumn {colName = "fk5name", colType = TextT}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblForeignKeys =+            [ fkOnColumn "fk5id" "fktest5" "id"+            ]+        , tblIndexes =+            [ indexOnColumns [indexColumn "fk5thing", indexColumn "fk5id"]+            ]+        }++overlapingIndexesTests :: ConnectionSourceM (LogT IO) -> TestTree+overlapingIndexesTests connSource = do+  testCaseSteps' "Overlapping indexes tests" connSource $ \step -> do+    freshTestDB step++    let definitions = tableDefsWithPgCrypto [table1]++    step "Migration is correct if not checking for overlapping indexes"+    do+      let options = defaultExtrasOptions {eoCheckOverlappingIndexes = False}+      migrateDatabase+        options+        definitions+        [createTableMigration table1]++    step "Migration invalid when flagging overlapping indexes"+    do+      let options = defaultExtrasOptions {eoCheckOverlappingIndexes = True}+      assertException "Some indexes are overlapping" $+        migrateDatabase+          options+          definitions+          [createTableMigration table1]+  where+    table1 :: Table+    table1 =+      tblTable+        { tblName = "idx_test"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False}+            , tblColumn {colName = "idx1", colType = UuidT}+            , tblColumn {colName = "idx2", colType = UuidT}+            , tblColumn {colName = "idx3", colType = UuidT}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblIndexes =+            [ indexOnColumns [indexColumn "idx1", indexColumn "idx2"]+            , indexOnColumns [indexColumn "idx1"]+            ]+        }++nullsNotDistinctTests :: ConnectionSourceM (LogT IO) -> TestTree+nullsNotDistinctTests connSource = do+  testCaseSteps' "NULLS NOT DISTINCT tests" connSource $ \step -> do+    freshTestDB step++    step "Create a database with indexes"+    do+      let definitions = tableDefsWithPgCrypto [nullTableTest1, nullTableTest2]+      migrateDatabase+        defaultExtrasOptions+        definitions+        [createTableMigration nullTableTest1, createTableMigration nullTableTest2]+      checkDatabase defaultExtrasOptions definitions++    step "Insert two NULLs on a column with a default UNIQUE index"+    do+      runQuery_ . sqlInsert "nulltests1" $ do+        sqlSet "content" (Nothing @T.Text)+      runQuery_ . sqlInsert "nulltests1" $ do+        sqlSet "content" (Nothing @T.Text)++    step "Insert NULLs on a column with a NULLS NOT DISTINCT index"+    do+      runQuery_ . sqlInsert "nulltests2" $ do+        sqlSet "content" (Nothing @T.Text)+      assertDBException "Cannot insert twice a null value with NULLS NOT DISTINCT" $ runQuery_ . sqlInsert "nulltests2" $ do+        sqlSet "content" (Nothing @T.Text)+  where+    nullTableTest1 =+      tblTable+        { tblName = "nulltests1"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False, colDefault = Just "gen_random_uuid()"}+            , tblColumn {colName = "content", colType = TextT, colNullable = True}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblIndexes =+            [ uniqueIndexOnColumn "content"+            ]+        }++    nullTableTest2 =+      tblTable+        { tblName = "nulltests2"+        , tblVersion = 1+        , tblColumns =+            [ tblColumn {colName = "id", colType = UuidT, colNullable = False, colDefault = Just "gen_random_uuid()"}+            , tblColumn {colName = "content", colType = TextT, colNullable = True}+            ]+        , tblPrimaryKey = pkOnColumn "id"+        , tblIndexes =+            [ (uniqueIndexOnColumn "content") {idxNotDistinctNulls = True}+            ]+        }++sqlAnyAllTests :: TestTree+sqlAnyAllTests =+  testGroup+    "SQL ANY/ALL tests"+    [ testCase "sqlAll produces correct queries" $ do+        assertSqlEqual "empty sqlAll is TRUE" "TRUE" . sqlAll $ pure ()+        assertSqlEqual "sigle condition is emmited as is" "cond" $ sqlAll $ sqlWhere "cond"+        assertSqlEqual+          "each condition as well as entire condition is parenthesized"+          "((cond1) AND (cond2))"+          $ sqlAll+          $ do+            sqlWhere "cond1"+            sqlWhere "cond2"++        assertSqlEqual+          "sqlAll can be nested"+          "((cond1) AND (cond2) AND (((cond3) AND (cond4))))"+          $ sqlAll+          $ do+            sqlWhere "cond1"+            sqlWhere "cond2"+            sqlWhere . sqlAll $ do+              sqlWhere "cond3"+              sqlWhere "cond4"+    , testCase "sqlAny produces correct queries" $ do+        assertSqlEqual "empty sqlAny is FALSE" "FALSE" . sqlAny $ pure ()+        assertSqlEqual "sigle condition is emmited as is" "cond" $ sqlAny $ sqlWhere "cond"+        assertSqlEqual+          "each condition as well as entire condition is parenthesized"+          "((cond1) OR (cond2))"+          $ sqlAny+          $ do+            sqlWhere "cond1"+            sqlWhere "cond2"++        assertSqlEqual+          "sqlAny can be nested"+          "((cond1) OR (cond2) OR (((cond3) OR (cond4))))"+          $ sqlAny+          $ do+            sqlWhere "cond1"+            sqlWhere "cond2"+            sqlWhere . sqlAny $ do+              sqlWhere "cond3"+              sqlWhere "cond4"+    , testCase "mixing sqlAny and all produces correct queries" $ do+        assertSqlEqual+          "sqlAny and sqlAll can be mixed"+          "((((cond1) OR (cond2))) AND (((cond3) OR (cond4))))"+          $ sqlAll+          $ do+            sqlWhere . sqlAny $ do+              sqlWhere "cond1"+              sqlWhere "cond2"+            sqlWhere . sqlAny $ do+              sqlWhere "cond3"+              sqlWhere "cond4"+    , testCase "sqlWhereAny produces correct queries" $ do+        -- `sqlWhereAny` has to be wrapped in `sqlAll` to disambiguate the `SqlWhere` monad.+        assertSqlEqual "empty sqlWhereAny is FALSE" "FALSE" . sqlAll $ sqlWhereAny []+        assertSqlEqual+          "each condition as well as entire condition is parenthesized and joined with OR"+          "((cond1) OR (cond2))"+          . sqlAll+          $ sqlWhereAny [sqlWhere "cond1", sqlWhere "cond2"]+        assertSqlEqual+          "nested multi-conditions are parenthesized and joined with AND"+          "((cond1) OR (((cond2) AND (cond3))) OR (cond4))"+          . sqlAll+          $ sqlWhereAny+            [ sqlWhere "cond1"+            , do+                sqlWhere "cond2"+                sqlWhere "cond3"+            , sqlWhere "cond4"+            ]+    ]+  where+    assertSqlEqual :: Sqlable a => String -> a -> a -> Assertion+    assertSqlEqual msg a b =+      assertEqual+        msg+        (show $ toSQLCommand a)+        (show $ toSQLCommand b)++enumTest :: ConnectionSourceM (LogT IO) -> TestTree+enumTest connSource =+  testCaseSteps' "Enum tests" connSource $ \step -> do+    freshTestDB step++    step "Create a database with an enum"+    migrateDatabase+      defaultExtrasOptions+      (emptyDbDefinitions {dbEnums = [enum1]})+      []++    step "Check the database"+    checkDatabase defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1]})++    step "Check the database with missing enum"+    do+      report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1, enum2]})+      liftIO $+        assertEqual+          "Missing enum2 should be reported"+          (validationError "Enum 'enum2' doesn't exist in the database")+          report++    step "Check the database with reordered enum"+    do+      report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1misorder]})+      liftIO $+        assertEqual+          "Order mismatch should be reported"+          ( validationInfo+              "Enum 'enum1' has same values, but differs in order \+              \(database: [\"enum-100\",\"enum-101\"], definition: [\"enum-101\",\"enum-100\"]). \+              \This isn't usually a problem, unless the enum is used for ordering."+          )+          report++    step "Check the database with mismatching enum"+    do+      report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1mismatch]})+      liftIO $+        assertEqual+          "DB mismatch should be reported"+          (validationError "Enum 'enum1' does not match (database: [\"enum-100\",\"enum-101\"], definition: [\"enum-100\",\"enum-102\"])")+          report++    step "Check the database with extra enum values"+    do+      report <- checkDatabaseWithReport defaultExtrasOptions (emptyDbDefinitions {dbEnums = [enum1missing]})+      liftIO $+        assertEqual+          "Extra values in the DB enum should be reported"+          (validationInfo "Enum 'enum1' has all necessary values, but the database has additional ones (database: [\"enum-100\",\"enum-101\"], definition: [\"enum-100\"])")+          report+  where+    enum1 = EnumType {etName = "enum1", etValues = ["enum-100", "enum-101"]}+    enum2 = EnumType {etName = "enum2", etValues = ["enum-200", "enum-201", "enum-202"]}+    enum1misorder = EnumType {etName = "enum1", etValues = ["enum-101", "enum-100"]}+    enum1mismatch = EnumType {etName = "enum1", etValues = ["enum-100", "enum-102"]}+    enum1missing = EnumType {etName = "enum1", etValues = ["enum-100"]}++assertNoException :: String -> TestM () -> TestM ()+assertNoException t =+  eitherExc+    (const $ liftIO $ assertFailure ("Exception thrown for: " ++ t))+    (const $ return ())++assertException :: String -> TestM () -> TestM ()+assertException t =+  eitherExc+    (const $ return ())+    (const $ liftIO $ assertFailure ("No exception thrown for: " ++ t))++assertDBException :: String -> TestM () -> TestM ()+assertDBException t c =+  try c+    >>= either+      (\DBException {} -> pure ())+      (const . liftIO . assertFailure $ "No DBException thrown for: " ++ t)++-- | A variant of testCaseSteps that works in TestM monad.+testCaseSteps'+  :: TestName+  -> ConnectionSourceM (LogT IO)+  -> ((String -> TestM ()) -> TestM ())+  -> TestTree+testCaseSteps' testName connSource f =+  testCaseSteps testName $ \step' -> do+    let step s = liftIO $ step' s+    withStdOutLogger $ \logger ->+      runLogT "hpqtypes-extras-test" logger defaultLogLevel $+        runDBT connSource defaultTransactionSettings $+          f step++tableDefsWithPgCrypto :: [Table] -> DatabaseDefinitions+tableDefsWithPgCrypto tables =+  emptyDbDefinitions {dbTables = tables, dbExtensions = ["pgcrypto"]}++main :: IO ()+main = do+  defaultMainWithIngredients ings $+    askOption $ \(ConnectionString connectionString) ->+      let connSettings =+            defaultConnectionSettings+              { csConnInfo = T.pack connectionString+              }+          ConnectionSource connSource = simpleSource connSettings+      in testGroup+          "DB tests"+          [ migrationTest1 connSource+          , migrationTest2 connSource+          , migrationTest3 connSource+          , migrationTest4 connSource+          , migrationTest5 connSource+          , triggerTests connSource+          , sqlWithTests connSource+          , unionTests connSource+          , unionAllTests connSource+          , sqlWithRecursiveTests connSource+          , foreignKeyIndexesTests connSource+          , overlapingIndexesTests connSource+          , nullsNotDistinctTests connSource+          , sqlAnyAllTests+          , enumTest connSource+          ]+  where+    ings =+      includingOptions [Option (Proxy :: Proxy ConnectionString)]+        : defaultIngredients