diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/benchmark/Main.hs b/benchmark/Main.hs --- a/benchmark/Main.hs +++ b/benchmark/Main.hs @@ -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" diff --git a/hpqtypes-extras.cabal b/hpqtypes-extras.cabal --- a/hpqtypes-extras.cabal +++ b/hpqtypes-extras.cabal @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Checks.hs b/src/Database/PostgreSQL/PQTypes/Checks.hs --- a/src/Database/PostgreSQL/PQTypes/Checks.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs --- a/src/Database/PostgreSQL/PQTypes/Checks/Util.hs +++ b/src/Database/PostgreSQL/PQTypes/Checks/Util.hs @@ -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" + , ");" + ] diff --git a/src/Database/PostgreSQL/PQTypes/Deriving.hs b/src/Database/PostgreSQL/PQTypes/Deriving.hs --- a/src/Database/PostgreSQL/PQTypes/Deriving.hs +++ b/src/Database/PostgreSQL/PQTypes/Deriving.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs --- a/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs +++ b/src/Database/PostgreSQL/PQTypes/ExtrasOptions.hs @@ -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) diff --git a/src/Database/PostgreSQL/PQTypes/Migrate.hs b/src/Database/PostgreSQL/PQTypes/Migrate.hs --- a/src/Database/PostgreSQL/PQTypes/Migrate.hs +++ b/src/Database/PostgreSQL/PQTypes/Migrate.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model.hs b/src/Database/PostgreSQL/PQTypes/Model.hs --- a/src/Database/PostgreSQL/PQTypes/Model.hs +++ b/src/Database/PostgreSQL/PQTypes/Model.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/Check.hs b/src/Database/PostgreSQL/PQTypes/Model/Check.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Check.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Check.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs --- a/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ColumnType.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs b/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs --- a/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/CompositeType.hs @@ -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} diff --git a/src/Database/PostgreSQL/PQTypes/Model/Domain.hs b/src/Database/PostgreSQL/PQTypes/Model/Domain.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Domain.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Domain.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs b/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs new file mode 100644 --- /dev/null +++ b/src/Database/PostgreSQL/PQTypes/Model/EnumType.hs @@ -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" <+>) diff --git a/src/Database/PostgreSQL/PQTypes/Model/Extension.hs b/src/Database/PostgreSQL/PQTypes/Model/Extension.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Extension.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Extension.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs --- a/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/ForeignKey.hs @@ -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 () diff --git a/src/Database/PostgreSQL/PQTypes/Model/Index.hs b/src/Database/PostgreSQL/PQTypes/Model/Index.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Index.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Index.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Migration.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Migration.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs --- a/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/PrimaryKey.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Model/Table.hs b/src/Database/PostgreSQL/PQTypes/Model/Table.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Table.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Table.hs @@ -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 + ] diff --git a/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs b/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs --- a/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs +++ b/src/Database/PostgreSQL/PQTypes/Model/Trigger.hs @@ -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 . - -module Database.PostgreSQL.PQTypes.Model.Trigger ( - -- * Triggers - TriggerEvent(..) - , Trigger(..) +-- For details, see . +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 - diff --git a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs --- a/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs +++ b/src/Database/PostgreSQL/PQTypes/SQL/Builder.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs b/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs --- a/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs +++ b/src/Database/PostgreSQL/PQTypes/Utils/NubList.hs @@ -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 diff --git a/src/Database/PostgreSQL/PQTypes/Versions.hs b/src/Database/PostgreSQL/PQTypes/Versions.hs --- a/src/Database/PostgreSQL/PQTypes/Versions.hs +++ b/src/Database/PostgreSQL/PQTypes/Versions.hs @@ -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" + } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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