From 6712d0ad657fb17c8c6aeddf3e65e7046bc4cff1 Mon Sep 17 00:00:00 2001 From: Ajeet D'Souza <98ajeet@gmail.com> Date: Fri, 14 Jun 2019 12:36:27 +0530 Subject: [PATCH 01/10] Separate DB and metadata migrations Add SystemDefined newtype, switch to one-step metadata migrations Add Haddock documentation Fix errors in code review create helper function to run sql transactions --- server/src-exec/Main.hs | 9 +- server/src-exec/Migrate.hs | 461 +++++------------- server/src-exec/Ops.hs | 6 +- server/src-lib/Hasura/GraphQL/Schema.hs | 3 +- server/src-lib/Hasura/RQL/DDL/Metadata.hs | 12 +- .../Hasura/RQL/DDL/Relationship/Rename.hs | 2 + server/src-lib/Hasura/RQL/DDL/Schema.hs | 7 +- server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs | 3 +- .../Hasura/RQL/DDL/Schema/Cache.hs-boot | 3 +- .../src-lib/Hasura/RQL/DDL/Schema/Catalog.hs | 12 +- .../src-lib/Hasura/RQL/DDL/Schema/Function.hs | 22 +- server/src-lib/Hasura/RQL/DDL/Schema/Table.hs | 32 +- server/src-lib/Hasura/RQL/Types.hs | 8 +- server/src-lib/Hasura/RQL/Types/Catalog.hs | 2 +- server/src-lib/Hasura/RQL/Types/Common.hs | 8 + server/src-lib/Hasura/RQL/Types/Error.hs | 2 - .../src-lib/Hasura/RQL/Types/SchemaCache.hs | 4 +- server/src-lib/Hasura/Server/App.hs | 10 +- server/src-lib/Hasura/Server/Query.hs | 41 +- server/src-lib/Hasura/Server/SchemaUpdate.hs | 11 +- server/src-lib/Hasura/Server/Telemetry.hs | 4 +- server/src-rsr/clear_system_metadata.sql | 9 + server/src-rsr/migrate_from_08_to_1.sql | 11 + server/src-rsr/migrate_from_16_to_17.sql | 4 + ...ate_from_1.sql => migrate_from_1_to_2.sql} | 0 server/src-rsr/migrate_from_2_to_3.sql | 9 + server/src-rsr/migrate_metadata_from_1.yaml | 66 --- .../migrate_metadata_from_15_to_16.yaml | 10 - .../src-rsr/migrate_metadata_from_4_to_5.yaml | 4 - .../src-rsr/migrate_metadata_from_7_to_8.yaml | 24 - .../src-rsr/migrate_metadata_from_8_to_9.yaml | 4 - 31 files changed, 271 insertions(+), 532 deletions(-) create mode 100644 server/src-rsr/clear_system_metadata.sql create mode 100644 server/src-rsr/migrate_from_08_to_1.sql create mode 100644 server/src-rsr/migrate_from_16_to_17.sql rename server/src-rsr/{migrate_from_1.sql => migrate_from_1_to_2.sql} (100%) create mode 100644 server/src-rsr/migrate_from_2_to_3.sql delete mode 100644 server/src-rsr/migrate_metadata_from_1.yaml delete mode 100644 server/src-rsr/migrate_metadata_from_15_to_16.yaml delete mode 100644 server/src-rsr/migrate_metadata_from_4_to_5.yaml delete mode 100644 server/src-rsr/migrate_metadata_from_7_to_8.yaml delete mode 100644 server/src-rsr/migrate_metadata_from_8_to_9.yaml diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index fb07c03b84f70..55cdfe321f3ac 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -29,7 +29,7 @@ import Hasura.Logging import Hasura.Prelude import Hasura.RQL.DDL.Metadata (fetchMetadata) import Hasura.RQL.Types (SQLGenCtx (..), SchemaCache (..), - adminUserInfo, emptySchemaCache) + adminUserInfo, emptySchemaCache, SystemDefined(..)) import Hasura.Server.App (HasuraApp (..), SchemaCacheRef (..), getSCFromRef, logInconsObjs, mkWaiApp) @@ -37,7 +37,7 @@ import Hasura.Server.Auth import Hasura.Server.CheckUpdates (checkForUpdates) import Hasura.Server.Init import Hasura.Server.Logging -import Hasura.Server.Query (peelRun) +import Hasura.Server.Query (RunCtx (..), peelRun) import Hasura.Server.SchemaUpdate import Hasura.Server.Telemetry import Hasura.Server.Version (currentVersion) @@ -234,8 +234,9 @@ main = do runExceptT $ Q.runTx pool (Q.Serializable, Nothing) tx runAsAdmin pool sqlGenCtx httpManager m = do - res <- runExceptT $ peelRun emptySchemaCache adminUserInfo - httpManager sqlGenCtx (PGExecCtx pool Q.Serializable) m + res <- runExceptT $ peelRun emptySchemaCache + (RunCtx adminUserInfo httpManager sqlGenCtx $ SystemDefined True) + (PGExecCtx pool Q.Serializable) m return $ fmap fst res procConnInfo rci = diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 4032c123d4af9..26af9bf5b288a 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -1,3 +1,7 @@ +{- | +Description: Migrations for Hasura catalog. +-} + module Migrate ( curCatalogVer , migrateCatalog @@ -18,174 +22,119 @@ import qualified Data.Yaml.TH as Y import qualified Database.PG.Query as Q + +type Migration m = + ( MonadTx m + , HasHttpManager m + , HasSystemDefined m + , CacheRWM m + , UserInfoM m + , MonadIO m + , HasSQLGenCtx m + ) + curCatalogVer :: T.Text curCatalogVer = "24" -migrateMetadata - :: ( MonadTx m - , HasHttpManager m - , CacheRWM m - , UserInfoM m - , MonadIO m - , HasSQLGenCtx m - ) - => Bool -> RQLQuery -> m () -migrateMetadata buildSC rqlQuery = do - -- Build schema cache from 'hdb_catalog' only if current - -- metadata migration depends on metadata added in previous versions - when buildSC $ buildSchemaCacheStrict - -- run the RQL query to Migrate metadata - void $ runQueryM rqlQuery - -setAsSystemDefinedFor2 :: (MonadTx m) => m () -setAsSystemDefinedFor2 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - UPDATE hdb_catalog.hdb_table - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND ( table_name = 'event_triggers' - OR table_name = 'event_log' - OR table_name = 'event_invocation_logs' - ); - UPDATE hdb_catalog.hdb_relationship - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND ( table_name = 'event_triggers' - OR table_name = 'event_log' - OR table_name = 'event_invocation_logs' - ); - |] +getCatalogVersion :: MonadTx m => m T.Text +getCatalogVersion = do + res <- liftTx $ Q.withQE defaultTxErrorHandler [Q.sql| + SELECT version FROM hdb_catalog.hdb_version |] () False + return $ runIdentity $ Q.getRow res -setAsSystemDefinedFor5 :: (MonadTx m) => m () -setAsSystemDefinedFor5 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - UPDATE hdb_catalog.hdb_table - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND table_name = 'remote_schemas'; - |] +migrateCatalog :: Migration m => UTCTime -> m String +migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion + where + migrateFrom previousVersion + | previousVersion == curCatalogVer = + return $ "already at the latest version. current version: " <> show curCatalogVer + | [] <- neededMigrations = + throw400 NotSupported $ "unsupported version : " <> previousVersion + | otherwise = + traverse_ snd neededMigrations *> postMigrate + where + neededMigrations = dropWhile ((/= previousVersion) . fst) migrations + migrations = + [ ("0.8", from08To1) + , ("1", from1To2) + , ("2", from2To3) + , ("3", from3To4) + , ("4", from4To5) + , ("5", from5To6) + , ("6", from6To7) + , ("7", from7To8) + , ("8", from8To9) + , ("9", from9To10) + , ("10", from10To11) + , ("11", from11To12) + , ("12", from12To13) + , ("13", from13To14) + , ("14", from14To15) + , ("15", from15To16) + , ("16", from16To17) + , ("17", from17To18) + , ("18", from18To19) + , ("19", from19To20) + , ("20", from20To21) + , ("21", from21To22) + , ("22", from22To23) + , ("23", from23To24) + ] -setAsSystemDefinedFor8 :: (MonadTx m) => m () -setAsSystemDefinedFor8 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - UPDATE hdb_catalog.hdb_table - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND ( table_name = 'hdb_function_agg' - OR table_name = 'hdb_function' - ); - UPDATE hdb_catalog.hdb_relationship - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND table_name = 'hdb_function_agg'; - |] + postMigrate = do + -- update the catalog version + updateVersion + -- replace system metadata + clearSystemMetadata + createSystemMetadata + -- try building the schema cache + buildSchemaCacheStrict + return $ "successfully migrated to " ++ show curCatalogVer -setAsSystemDefinedFor9 :: (MonadTx m) => m () -setAsSystemDefinedFor9 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - UPDATE hdb_catalog.hdb_table - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND table_name = 'hdb_version'; - |] + updateVersion = + liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| + UPDATE "hdb_catalog"."hdb_version" + SET "version" = $1, + "upgraded_on" = $2 + |] (curCatalogVer, migrationTime) False -setAsSystemDefinedFor16 :: MonadTx m => m () -setAsSystemDefinedFor16 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - UPDATE hdb_catalog.hdb_table - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND table_name = 'hdb_query_collection'; - |] +runTx :: MonadTx m => Q.Query -> m () +runTx = liftTx . Q.multiQE defaultTxErrorHandler -getCatalogVersion - :: (MonadTx m) - => m T.Text -getCatalogVersion = do - res <- liftTx $ Q.withQE defaultTxErrorHandler [Q.sql| - SELECT version FROM hdb_catalog.hdb_version - |] () False - return $ runIdentity $ Q.getRow res +clearSystemMetadata :: MonadTx m => m () +clearSystemMetadata = runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") -from08To1 :: (MonadTx m) => m () -from08To1 = liftTx $ Q.catchE defaultTxErrorHandler $ do - Q.unitQ "ALTER TABLE hdb_catalog.hdb_relationship ADD COLUMN comment TEXT NULL" () False - Q.unitQ "ALTER TABLE hdb_catalog.hdb_permission ADD COLUMN comment TEXT NULL" () False - Q.unitQ "ALTER TABLE hdb_catalog.hdb_query_template ADD COLUMN comment TEXT NULL" () False - Q.unitQ [Q.sql| - UPDATE hdb_catalog.hdb_query_template - SET template_defn = - json_build_object('type', 'select', 'args', template_defn->'select'); - |] () False - -from1To2 - :: ( MonadTx m - , HasHttpManager m - , HasSQLGenCtx m - , CacheRWM m - , UserInfoM m - , MonadIO m - ) - => m () -from1To2 = do - -- Migrate database - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_1.sql") - migrateMetadata False migrateMetadataFrom1 - -- Set as system defined - setAsSystemDefinedFor2 - where - migrateMetadataFrom1 = - $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_1.yaml" :: Q (TExp RQLQuery))) - -from2To3 :: (MonadTx m) => m () -from2To3 = liftTx $ Q.catchE defaultTxErrorHandler $ do - Q.unitQ "ALTER TABLE hdb_catalog.event_triggers ADD COLUMN headers JSON" () False - Q.unitQ "ALTER TABLE hdb_catalog.event_log ADD COLUMN next_retry_at TIMESTAMP" () False - Q.unitQ "CREATE INDEX ON hdb_catalog.event_log (trigger_id)" () False - Q.unitQ "CREATE INDEX ON hdb_catalog.event_invocation_logs (event_id)" () False - --- custom resolver -from4To5 - :: ( MonadTx m - , HasHttpManager m - , HasSQLGenCtx m - , CacheRWM m - , UserInfoM m - , MonadIO m - ) - => m () -from4To5 = do - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_4_to_5.sql") - migrateMetadata False migrateMetadataFrom4 - -- Set as system defined - setAsSystemDefinedFor5 +createSystemMetadata :: Migration m => m () +createSystemMetadata = void $ runQueryM rqlQuery where - migrateMetadataFrom4 = - $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_4_to_5.yaml" :: Q (TExp RQLQuery))) + rqlQuery = $(unTypeQ (Y.decodeFile "src-rsr/hdb_metadata.yaml" :: Q (TExp RQLQuery))) +from08To1 :: MonadTx m => m () +from08To1 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_08_to_1.sql") -from3To4 :: (MonadTx m) => m () +from1To2 :: MonadTx m => m () +from1To2 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_1_to_2.sql") + +from2To3 :: MonadTx m => m () +from2To3 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_2_to_3.sql") + +from3To4 :: MonadTx m => m () from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do - Q.unitQ "ALTER TABLE hdb_catalog.event_triggers ADD COLUMN configuration JSON" () False + Q.unitQ [Q.sql| + ALTER TABLE hdb_catalog.event_triggers + ADD COLUMN configuration JSON |] () False eventTriggers <- map uncurryEventTrigger <$> Q.listQ [Q.sql| - SELECT e.name, e.definition::json, e.webhook, e.num_retries, e.retry_interval, e.headers::json - FROM hdb_catalog.event_triggers e - |] () False + SELECT e.name, e.definition::json, e.webhook, e.num_retries, e.retry_interval, e.headers::json + FROM hdb_catalog.event_triggers e |] () False forM_ eventTriggers updateEventTrigger3To4 - Q.unitQ "ALTER TABLE hdb_catalog.event_triggers\ - \ DROP COLUMN definition\ - \, DROP COLUMN query\ - \, DROP COLUMN webhook\ - \, DROP COLUMN num_retries\ - \, DROP COLUMN retry_interval\ - \, DROP COLUMN headers" () False + Q.unitQ [Q.sql| + ALTER TABLE hdb_catalog.event_triggers + DROP COLUMN definition, + DROP COLUMN query, + DROP COLUMN webhook, + DROP COLUMN num_retries, + DROP COLUMN retry_interval, + DROP COLUMN headers |] () False where uncurryEventTrigger (trn, Q.AltJ tDef, w, nr, rint, Q.AltJ headers) = EventTriggerConf trn tDef (Just w) Nothing (RetryConf nr rint Nothing) headers @@ -196,136 +145,44 @@ from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do WHERE name = $2 |] (Q.AltJ $ A.toJSON etc, name) True -from5To6 :: (MonadTx m) => m () -from5To6 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_5_to_6.sql") - return () +from4To5 :: MonadTx m => m () +from4To5 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_4_to_5.sql") -from6To7 :: (MonadTx m) => m () -from6To7 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_6_to_7.sql") - return () +from5To6 :: MonadTx m => m () +from5To6 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_5_to_6.sql") -from7To8 - :: ( MonadTx m - , HasHttpManager m - , HasSQLGenCtx m - , CacheRWM m - , UserInfoM m - , MonadIO m - ) - => m () -from7To8 = do - -- Migrate database - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_7_to_8.sql") - -- Migrate metadata - -- Building schema cache is required since this metadata migration - -- involves in creating object relationship to hdb_catalog.hdb_table - migrateMetadata True migrateMetadataFrom7 - setAsSystemDefinedFor8 - where - migrateMetadataFrom7 = - $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_7_to_8.yaml" :: Q (TExp RQLQuery))) - --- alter hdb_version table and track it (telemetry changes) -from8To9 - :: ( MonadTx m - , HasHttpManager m - , HasSQLGenCtx m - , CacheRWM m - , UserInfoM m - , MonadIO m - ) - => m () -from8To9 = do - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_8_to_9.sql") - -- Migrate metadata - migrateMetadata False migrateMetadataFrom8 - -- Set as system defined - setAsSystemDefinedFor9 - where - migrateMetadataFrom8 = - $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_8_to_9.yaml" :: Q (TExp RQLQuery))) +from6To7 :: MonadTx m => m () +from6To7 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_6_to_7.sql") --- alter foreign keys on hdb_relationship and hdb_permission table to have ON UPDATE CASCADE -from9To10 :: (MonadTx m) => m () -from9To10 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_9_to_10.sql") - return () +from7To8 :: MonadTx m => m () +from7To8 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_7_to_8.sql") -from10To11 :: (MonadTx m) => m () -from10To11 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_10_to_11.sql") - return () +from8To9 :: MonadTx m => m () +from8To9 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_8_to_9.sql") -from11To12 :: (MonadTx m) => m () -from11To12 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_11_to_12.sql") - return () +from9To10 :: MonadTx m => m () +from9To10 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_9_to_10.sql") -from12To13 :: (MonadTx m) => m () -from12To13 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_12_to_13.sql") - return () +from10To11 :: MonadTx m => m () +from10To11 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_10_to_11.sql") -from13To14 :: (MonadTx m) => m () -from13To14 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_13_to_14.sql") - return () +from11To12 :: MonadTx m => m () +from11To12 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_11_to_12.sql") -from14To15 :: (MonadTx m) => m () -from14To15 = liftTx $ do - -- Migrate database - Q.Discard () <- Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_14_to_15.sql") - return () +from12To13 :: MonadTx m => m () +from12To13 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_12_to_13.sql") -from15To16 - :: ( MonadTx m - , HasHttpManager m - , HasSQLGenCtx m - , CacheRWM m - , UserInfoM m - , MonadIO m - ) - => m () -from15To16 = do - -- Migrate database - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_15_to_16.sql") - -- Migrate metadata - migrateMetadata False migrateMetadataFrom13 - -- Set as system defined - setAsSystemDefinedFor16 - where - migrateMetadataFrom13 = - $(unTypeQ (Y.decodeFile "src-rsr/migrate_metadata_from_15_to_16.yaml" :: Q (TExp RQLQuery))) +from13To14 :: MonadTx m => m () +from13To14 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_13_to_14.sql") + +from14To15 :: MonadTx m => m () +from14To15 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_14_to_15.sql") + +from15To16 :: MonadTx m => m () +from15To16 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_15_to_16.sql") from16To17 :: MonadTx m => m () -from16To17 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - UPDATE hdb_catalog.hdb_table - SET is_system_defined = 'true' - WHERE table_schema = 'hdb_catalog' - AND table_name = 'hdb_allowlist'; - |] +from16To17 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_16_to_17.sql") from17To18 :: MonadTx m => m () from17To18 = @@ -373,63 +230,3 @@ from23To24 = ALTER TABLE hdb_catalog.hdb_table ADD COLUMN configuration JSONB NOT NULL DEFAULT '{}'::jsonb; |] -migrateCatalog - :: ( MonadTx m - , CacheRWM m - , MonadIO m - , UserInfoM m - , HasHttpManager m - , HasSQLGenCtx m - ) - => UTCTime -> m String -migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion - where - migrateFrom previousVersion - | previousVersion == curCatalogVer = - return $ "already at the latest version. current version: " <> show curCatalogVer - | [] <- neededMigrations = - throw400 NotSupported $ "unsupported version : " <> previousVersion - | otherwise = - traverse_ snd neededMigrations >> postMigrate - where - neededMigrations = dropWhile ((/= previousVersion) . fst) migrations - migrations = - [ ("0.8", from08To1) - , ("1", from1To2) - , ("2", from2To3) - , ("3", from3To4) - , ("4", from4To5) - , ("5", from5To6) - , ("6", from6To7) - , ("7", from7To8) - , ("8", from8To9) - , ("9", from9To10) - , ("10", from10To11) - , ("11", from11To12) - , ("12", from12To13) - , ("13", from13To14) - , ("14", from14To15) - , ("15", from15To16) - , ("16", from16To17) - , ("17", from17To18) - , ("18", from18To19) - , ("19", from19To20) - , ("20", from20To21) - , ("21", from21To22) - , ("22", from22To23) - , ("23", from23To24) - ] - - postMigrate = do - -- update the catalog version - updateVersion - -- try building the schema cache - buildSchemaCacheStrict - return $ "successfully migrated to " ++ show curCatalogVer - - updateVersion = - liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| - UPDATE "hdb_catalog"."hdb_version" - SET "version" = $1, - "upgraded_on" = $2 - |] (curCatalogVer, migrationTime) False diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index 747ff094fc03f..2e4321356dd90 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -26,6 +26,7 @@ import qualified Database.PG.Query.Connection as Q initCatalogSafe :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m + , HasSystemDefined m ) => UTCTime -> m String initCatalogSafe initTime = do @@ -61,6 +62,7 @@ initCatalogSafe initTime = do initCatalogStrict :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m + , HasSystemDefined m ) => Bool -> UTCTime -> m String initCatalogStrict createSchema initTime = do @@ -131,8 +133,8 @@ cleanCatalog = liftTx $ Q.catchE defaultTxErrorHandler $ do Q.unitQ "DROP SCHEMA hdb_catalog CASCADE" () False execQuery - :: ( MonadTx m, CacheRWM m, MonadIO m - , UserInfoM m, HasHttpManager m, HasSQLGenCtx m + :: ( MonadTx m, CacheRWM m, MonadIO m, UserInfoM m + , HasHttpManager m, HasSQLGenCtx m, HasSystemDefined m ) => BL.ByteString -> m BL.ByteString execQuery queryBs = do diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index 37d3940bbcb09..7d54e8445e0f5 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -639,8 +639,7 @@ mkGCtxMap tableCache functionCache = do return $ flip Map.map typesMap $ \(ty, flds, insCtxMap) -> mkGCtx ty flds insCtxMap where - tableFltr ti = not (_tiSystemDefined ti) - && isValidObjectName (_tiName ti) + tableFltr ti = not (isSystemDefined $ _tiSystemDefined ti) && isValidObjectName (_tiName ti) getRootFlds roleMap = do (_, RootFields query mutation, _) <- onNothing diff --git a/server/src-lib/Hasura/RQL/DDL/Metadata.hs b/server/src-lib/Hasura/RQL/DDL/Metadata.hs index 84c788564c90c..7365cfaee5eba 100644 --- a/server/src-lib/Hasura/RQL/DDL/Metadata.hs +++ b/server/src-lib/Hasura/RQL/DDL/Metadata.hs @@ -51,6 +51,7 @@ import qualified Hasura.RQL.DDL.Schema as DS import qualified Hasura.RQL.Types.EventTrigger as DTS import qualified Hasura.RQL.Types.RemoteSchema as TRS + data TableMeta = TableMeta { _tmTable :: !QualifiedTable @@ -134,8 +135,8 @@ clearMetadata = Q.catchE defaultTxErrorHandler $ do Q.unitQ "DELETE FROM hdb_catalog.hdb_query_collection WHERE is_system_defined <> 'true'" () False runClearMetadata - :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m - , MonadIO m, HasHttpManager m, HasSQLGenCtx m + :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m + , HasHttpManager m, HasSystemDefined m, HasSQLGenCtx m ) => ClearMetadata -> m EncJSON runClearMetadata _ = do @@ -219,6 +220,7 @@ applyQP2 , MonadIO m , HasHttpManager m , HasSQLGenCtx m + , HasSystemDefined m ) => ReplaceMetadata -> m EncJSON @@ -228,7 +230,6 @@ applyQP2 (ReplaceMetadata tables mFunctions mSchemas mCollections mAllowlist) = DS.buildSchemaCacheStrict withPathK "tables" $ do - -- tables and views indexedForM_ tables $ \tableMeta -> do let tableName = tableMeta ^. tmTable @@ -301,6 +302,7 @@ applyQP2 (ReplaceMetadata tables mFunctions mSchemas mCollections mAllowlist) = runReplaceMetadata :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m + , HasSystemDefined m ) => ReplaceMetadata -> m EncJSON runReplaceMetadata q = do @@ -443,8 +445,8 @@ instance FromJSON ReloadMetadata where $(deriveToJSON defaultOptions ''ReloadMetadata) runReloadMetadata - :: ( QErrM m, UserInfoM m, CacheRWM m - , MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m + :: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m + , HasHttpManager m, HasSystemDefined m, HasSQLGenCtx m ) => ReloadMetadata -> m EncJSON runReloadMetadata _ = do diff --git a/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs b/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs index e11dcf5cbe105..8d46d17e06072 100644 --- a/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs +++ b/server/src-lib/Hasura/RQL/DDL/Relationship/Rename.hs @@ -20,6 +20,7 @@ renameRelP2 , CacheRWM m , MonadIO m , HasHttpManager m + , HasSystemDefined m , HasSQLGenCtx m ) => QualifiedTable -> RelName -> RelInfo -> m () @@ -46,6 +47,7 @@ runRenameRel , UserInfoM m , MonadIO m , HasHttpManager m + , HasSystemDefined m , HasSQLGenCtx m ) => RenameRel -> m EncJSON diff --git a/server/src-lib/Hasura/RQL/DDL/Schema.hs b/server/src-lib/Hasura/RQL/DDL/Schema.hs index 980392a2fe0bb..89957926a7b2f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema.hs @@ -61,9 +61,7 @@ data RunSQL } deriving (Show, Eq, Lift) $(deriveJSON (aesonDrop 1 snakeCase){omitNothingFields=True} ''RunSQL) -runRunSQL - :: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => RunSQL -> m EncJSON +runRunSQL :: (CacheBuildM m, UserInfoM m) => RunSQL -> m EncJSON runRunSQL (RunSQL t cascade mChkMDCnstcy) = do adminOnly isMDChkNeeded <- maybe (isAltrDropReplace t) return mChkMDCnstcy @@ -71,8 +69,7 @@ runRunSQL (RunSQL t cascade mChkMDCnstcy) = do where execRawSQL :: (MonadTx m) => Text -> m EncJSON execRawSQL = - fmap (encJFromJValue @RunSQLRes) . - liftTx . Q.multiQE rawSqlErrHandler . Q.fromText + fmap (encJFromJValue @RunSQLRes) . liftTx . Q.multiQE rawSqlErrHandler . Q.fromText where rawSqlErrHandler txe = let e = err400 PostgresError "query execution failed" diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs index 76d30d3bd20a8..7481707dce361 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs @@ -49,7 +49,8 @@ import Hasura.RQL.Types.Catalog import Hasura.RQL.Types.QueryCollection import Hasura.SQL.Types -type CacheBuildM m = (CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) +type CacheBuildM m + = (CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m, HasSystemDefined m) buildSchemaCache :: (CacheBuildM m) => m () buildSchemaCache = buildSchemaCacheWithOptions True diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs-boot b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs-boot index 277a141fab06c..f84c13b0ea555 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs-boot +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs-boot @@ -5,7 +5,8 @@ import Hasura.Prelude import Hasura.Db import Hasura.RQL.Types -type CacheBuildM m = (CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) +type CacheBuildM m + = (CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m, HasSystemDefined m) buildSchemaCacheStrict :: (CacheBuildM m) => m () buildSchemaCacheFor :: (CacheBuildM m) => MetadataObjId -> m () diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs index f14f4985cad9c..27de8b795e6a7 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs @@ -18,20 +18,20 @@ import Data.Aeson import Hasura.Db import Hasura.RQL.Types.Catalog import Hasura.RQL.Types.SchemaCache +import Hasura.RQL.Types.Common import Hasura.SQL.Types fetchCatalogData :: (MonadTx m) => m CatalogMetadata fetchCatalogData = liftTx $ Q.getAltJ . runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/catalog_metadata.sql") () True -saveTableToCatalog :: (MonadTx m) - => QualifiedTable -> Bool -> TableConfig -> m () -saveTableToCatalog (QualifiedObject sn tn) isEnum config = liftTx $ +saveTableToCatalog :: (MonadTx m) => QualifiedTable -> SystemDefined -> Bool -> TableConfig -> m () +saveTableToCatalog (QualifiedObject sn tn) systemDefined isEnum config = liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| INSERT INTO "hdb_catalog"."hdb_table" - (table_schema, table_name, is_enum, configuration) - VALUES ($1, $2, $3, $4) - |] (sn, tn, isEnum, configVal) False + (table_schema, table_name, is_system_defined, is_enum, configuration) + VALUES ($1, $2, $3, $4, $5) + |] (sn, tn, systemDefined, isEnum, configVal) False where configVal = Q.AltJ $ toJSON config diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs index 22b4849474a3f..94f11172778db 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Function.hs @@ -77,7 +77,7 @@ validateFuncArgs args = invalidArgs = filter (not . G.isValidName) $ map G.Name funcArgsText mkFunctionInfo - :: QErrM m => QualifiedFunction -> RawFuncInfo -> m FunctionInfo + :: (QErrM m, HasSystemDefined m) => QualifiedFunction -> RawFuncInfo -> m FunctionInfo mkFunctionInfo qf rawFuncInfo = do -- throw error if function has variadic arguments when hasVariadic $ throw400 NotSupported "function with \"VARIADIC\" parameters are not supported" @@ -93,20 +93,21 @@ mkFunctionInfo qf rawFuncInfo = do let funcArgs = mkFunctionArgs defArgsNo inpArgTyps inpArgNames validateFuncArgs funcArgs + systemDefined <- askSystemDefined let funcArgsSeq = Seq.fromList funcArgs dep = SchemaDependency (SOTable retTable) DRTable retTable = QualifiedObject retSn (TableName retN) - return $ FunctionInfo qf False funTy funcArgsSeq retTable [dep] descM + return $ FunctionInfo qf systemDefined funTy funcArgsSeq retTable [dep] descM where RawFuncInfo hasVariadic funTy retSn retN retTyTyp retSet inpArgTyps inpArgNames defArgsNo returnsTab descM = rawFuncInfo -saveFunctionToCatalog :: QualifiedFunction -> Bool -> Q.TxE QErr () -saveFunctionToCatalog (QualifiedObject sn fn) isSystemDefined = +saveFunctionToCatalog :: QualifiedFunction -> SystemDefined -> Q.TxE QErr () +saveFunctionToCatalog (QualifiedObject sn fn) systemDefined = Q.unitQE defaultTxErrorHandler [Q.sql| INSERT INTO "hdb_catalog"."hdb_function" VALUES ($1, $2, $3) - |] (sn, fn, isSystemDefined) False + |] (sn, fn, systemDefined) False delFunctionFromCatalog :: QualifiedFunction -> Q.TxE QErr () delFunctionFromCatalog (QualifiedObject sn fn) = @@ -135,7 +136,7 @@ trackFunctionP1 (TrackFunction qf) = do when (M.member qt $ scTables rawSchemaCache) $ throw400 NotSupported $ "table with name " <> qf <<> " already exists" -trackFunctionP2Setup :: (QErrM m, CacheRWM m, MonadTx m) +trackFunctionP2Setup :: (QErrM m, CacheRWM m, HasSystemDefined m, MonadTx m) => QualifiedFunction -> RawFuncInfo -> m () trackFunctionP2Setup qf rawfi = do fi <- mkFunctionInfo qf rawfi @@ -145,7 +146,7 @@ trackFunctionP2Setup qf rawfi = do void $ liftMaybe err $ M.lookup retTable $ scTables sc addFunctionToCache fi -trackFunctionP2 :: (QErrM m, CacheRWM m, MonadTx m) +trackFunctionP2 :: (QErrM m, CacheRWM m, HasSystemDefined m, MonadTx m) => QualifiedFunction -> m EncJSON trackFunctionP2 qf = do sc <- askSchemaCache @@ -167,7 +168,8 @@ trackFunctionP2 qf = do throw400 NotSupported $ "function " <> qf <<> " is overloaded. Overloaded functions are not supported" trackFunctionP2Setup qf rawfi - liftTx $ saveFunctionToCatalog qf False + systemDefined <- askSystemDefined + liftTx $ saveFunctionToCatalog qf systemDefined return successMsg where QualifiedObject sn fn = qf @@ -180,8 +182,8 @@ trackFunctionP2 qf = do |] (sn, fn) True runTrackFunc - :: ( QErrM m, CacheRWM m, MonadTx m - , UserInfoM m + :: ( QErrM m, CacheRWM m, HasSystemDefined m + , MonadTx m, UserInfoM m ) => TrackFunction -> m EncJSON runTrackFunc q = do diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs index 71b1c5c9625f6..f1869ba72c3ca 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Table.hs @@ -88,8 +88,7 @@ $(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''UntrackTable) -- | Track table/view, Phase 1: -- Validate table tracking operation. Fails if table is already being tracked, -- or if a function with the same name is being tracked. -trackExistingTableOrViewP1 - :: (CacheRM m, UserInfoM m, QErrM m) => QualifiedTable -> m () +trackExistingTableOrViewP1 :: (CacheBuildM m, UserInfoM m) => QualifiedTable -> m () trackExistingTableOrViewP1 qt = do adminOnly rawSchemaCache <- askSchemaCache @@ -128,20 +127,17 @@ validateTableConfig tableInfo (TableConfig rootFlds colFlds) = do where duplicateNames = duplicates $ M.elems colFlds -trackExistingTableOrViewP2 - :: (QErrM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => QualifiedTable -> Bool -> TableConfig -> m EncJSON +trackExistingTableOrViewP2 :: (CacheBuildM m) => QualifiedTable -> Bool -> TableConfig -> m EncJSON trackExistingTableOrViewP2 tableName isEnum config = do sc <- askSchemaCache let defGCtx = scDefaultRemoteGCtx sc GS.checkConflictingNode defGCtx $ GS.qualObjectToName tableName - saveTableToCatalog tableName isEnum config + systemDefined <- askSystemDefined + saveTableToCatalog tableName systemDefined isEnum config buildSchemaCacheFor (MOTable tableName) return successMsg -runTrackTableQ - :: (QErrM m, CacheRWM m, MonadTx m, UserInfoM m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => TrackTable -> m EncJSON +runTrackTableQ :: (CacheBuildM m, UserInfoM m) => TrackTable -> m EncJSON runTrackTableQ (TrackTable qt isEnum) = do trackExistingTableOrViewP1 qt trackExistingTableOrViewP2 qt isEnum emptyTableConfig @@ -153,16 +149,12 @@ data TrackTableV2 } deriving (Show, Eq, Lift) $(deriveJSON (aesonDrop 4 snakeCase) ''TrackTableV2) -runTrackTableV2Q - :: (QErrM m, CacheRWM m, MonadTx m, UserInfoM m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => TrackTableV2 -> m EncJSON +runTrackTableV2Q :: (CacheBuildM m, UserInfoM m) => TrackTableV2 -> m EncJSON runTrackTableV2Q (TrackTableV2 (TrackTable qt isEnum) config) = do trackExistingTableOrViewP1 qt trackExistingTableOrViewP2 qt isEnum config -runSetExistingTableIsEnumQ - :: (QErrM m, CacheRWM m, MonadTx m, UserInfoM m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => SetTableIsEnum -> m EncJSON +runSetExistingTableIsEnumQ :: (CacheBuildM m, UserInfoM m) => SetTableIsEnum -> m EncJSON runSetExistingTableIsEnumQ (SetTableIsEnum tableName isEnum) = do adminOnly void $ askTabInfo tableName -- assert that table is tracked @@ -185,9 +177,7 @@ instance FromJSON SetTableCustomFields where <*> o .:? "custom_root_fields" .!= GC.emptyCustomRootFields <*> o .:? "custom_column_names" .!= M.empty -runSetTableCustomFieldsQV2 - :: (QErrM m, CacheRWM m, MonadTx m, UserInfoM m, MonadIO m, HasHttpManager m, HasSQLGenCtx m) - => SetTableCustomFields -> m EncJSON +runSetTableCustomFieldsQV2 :: (CacheBuildM m, UserInfoM m) => SetTableCustomFields -> m EncJSON runSetTableCustomFieldsQV2 (SetTableCustomFields tableName rootFields columnNames) = do adminOnly void $ askTabInfo tableName @@ -204,7 +194,7 @@ unTrackExistingTableOrViewP1 (UntrackTable vn _) = do case M.lookup vn (scTables rawSchemaCache) of Just ti -> -- Check if table/view is system defined - when (_tiSystemDefined ti) $ throw400 NotSupported $ + when (isSystemDefined $ _tiSystemDefined ti) $ throw400 NotSupported $ vn <<> " is system defined, cannot untrack" Nothing -> throw400 AlreadyUntracked $ "view/table already untracked : " <>> vn @@ -373,7 +363,7 @@ buildTableCache = processTableCache <=< buildRawTableCache -- Step 1: Build the raw table cache from metadata information. buildRawTableCache :: [CatalogTable] -> m (TableCache PGRawColumnInfo) buildRawTableCache catalogTables = fmap (M.fromList . catMaybes) . for catalogTables $ - \(CatalogTable name isSystemDefined isEnum config maybeInfo) -> withTable name $ do + \(CatalogTable name systemDefined isEnum config maybeInfo) -> withTable name $ do catalogInfo <- onNothing maybeInfo $ throw400 NotExists $ "no such table/view exists in postgres: " <>> name @@ -389,7 +379,7 @@ buildTableCache = processTableCache <=< buildRawTableCache let info = TableInfo { _tiName = name - , _tiSystemDefined = isSystemDefined + , _tiSystemDefined = systemDefined , _tiFieldInfoMap = columnFields , _tiRolePermInfoMap = mempty , _tiUniqOrPrimConstraints = constraints diff --git a/server/src-lib/Hasura/RQL/Types.hs b/server/src-lib/Hasura/RQL/Types.hs index 07a303b792f9e..b11c2b3c5fdbe 100644 --- a/server/src-lib/Hasura/RQL/Types.hs +++ b/server/src-lib/Hasura/RQL/Types.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} - module Hasura.RQL.Types ( P1 , liftP1 @@ -15,6 +13,8 @@ module Hasura.RQL.Types , SQLGenCtx(..) , HasSQLGenCtx(..) + , HasSystemDefined(..) + , QCtx(..) , HasQCtx(..) , mkAdminQCtx @@ -50,7 +50,6 @@ import Hasura.RQL.Types.Metadata as R import Hasura.RQL.Types.Permission as R import Hasura.RQL.Types.RemoteSchema as R import Hasura.RQL.Types.SchemaCache as R - import Hasura.SQL.Types import qualified Hasura.GraphQL.Context as GC @@ -136,6 +135,9 @@ newtype SQLGenCtx class (Monad m) => HasSQLGenCtx m where askSQLGenCtx :: m SQLGenCtx +class (Monad m) => HasSystemDefined m where + askSystemDefined :: m SystemDefined + type ER e r = ExceptT e (Reader r) type P1 = ER QErr QCtx diff --git a/server/src-lib/Hasura/RQL/Types/Catalog.hs b/server/src-lib/Hasura/RQL/Types/Catalog.hs index bbb629f7386fb..d112d8dde8ea2 100644 --- a/server/src-lib/Hasura/RQL/Types/Catalog.hs +++ b/server/src-lib/Hasura/RQL/Types/Catalog.hs @@ -41,7 +41,7 @@ $(deriveJSON (aesonDrop 4 snakeCase) ''CatalogTableInfo) data CatalogTable = CatalogTable { _ctName :: !QualifiedTable - , _ctIsSystemDefined :: !Bool + , _ctIsSystemDefined :: !SystemDefined , _ctIsEnum :: !Bool , _ctConfiguration :: !TableConfig , _ctInfo :: !(Maybe CatalogTableInfo) diff --git a/server/src-lib/Hasura/RQL/Types/Common.hs b/server/src-lib/Hasura/RQL/Types/Common.hs index ad383216681a3..ef54835f64709 100644 --- a/server/src-lib/Hasura/RQL/Types/Common.hs +++ b/server/src-lib/Hasura/RQL/Types/Common.hs @@ -24,6 +24,8 @@ module Hasura.RQL.Types.Common , rootText , FunctionArgName(..) + , SystemDefined(..) + , isSystemDefined ) where import Hasura.Prelude @@ -185,3 +187,9 @@ newtype FunctionArgName = deriving (Show, Eq, ToJSON) type CustomColumnNames = HM.HashMap PGCol G.Name + +newtype SystemDefined = SystemDefined { unSystemDefined :: Bool } + deriving (Show, Eq, FromJSON, ToJSON, Q.ToPrepArg) + +isSystemDefined :: SystemDefined -> Bool +isSystemDefined = unSystemDefined diff --git a/server/src-lib/Hasura/RQL/Types/Error.hs b/server/src-lib/Hasura/RQL/Types/Error.hs index 16912f90ff403..af9352b065600 100644 --- a/server/src-lib/Hasura/RQL/Types/Error.hs +++ b/server/src-lib/Hasura/RQL/Types/Error.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ConstraintKinds #-} - module Hasura.RQL.Types.Error ( Code(..) , QErr(..) diff --git a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs index 8cafd906a4f28..d7736480b972e 100644 --- a/server/src-lib/Hasura/RQL/Types/SchemaCache.hs +++ b/server/src-lib/Hasura/RQL/Types/SchemaCache.hs @@ -353,7 +353,7 @@ data TableInfo columnInfo = TableInfo { _tiName :: !QualifiedTable , _tiDescription :: !(Maybe PGDescription) - , _tiSystemDefined :: !Bool + , _tiSystemDefined :: !SystemDefined , _tiFieldInfoMap :: !(FieldInfoMap columnInfo) , _tiRolePermInfoMap :: !RolePermInfoMap , _tiUniqOrPrimConstraints :: ![ConstraintName] @@ -408,7 +408,7 @@ $(deriveToJSON (aesonDrop 2 snakeCase) ''FunctionArg) data FunctionInfo = FunctionInfo { fiName :: !QualifiedFunction - , fiSystemDefined :: !Bool + , fiSystemDefined :: !SystemDefined , fiType :: !FunctionType , fiInputArgs :: !(Seq.Seq FunctionArg) , fiReturnType :: !QualifiedTable diff --git a/server/src-lib/Hasura/Server/App.hs b/server/src-lib/Hasura/Server/App.hs index b72b685de7944..f8ec3d21a54f6 100644 --- a/server/src-lib/Hasura/Server/App.hs +++ b/server/src-lib/Hasura/Server/App.hs @@ -313,7 +313,7 @@ v1QueryHandler query = do sqlGenCtx <- scSQLGenCtx . hcServerCtx <$> ask pgExecCtx <- scPGExecCtx . hcServerCtx <$> ask instanceId <- scInstanceId . hcServerCtx <$> ask - runQuery pgExecCtx instanceId userInfo schemaCache httpMgr sqlGenCtx query + runQuery pgExecCtx instanceId userInfo schemaCache httpMgr sqlGenCtx (SystemDefined False) query v1Alpha1GQHandler :: GH.GQLReqUnparsed -> Handler (HttpResponse EncJSON) v1Alpha1GQHandler query = do @@ -462,11 +462,11 @@ mkWaiApp isoLevel loggerCtx sqlGenCtx enableAL pool ci httpManager mode let pgExecCtx = PGExecCtx pool isoLevel pgExecCtxSer = PGExecCtx pool Q.Serializable + runCtx = RunCtx adminUserInfo httpManager sqlGenCtx $ SystemDefined False (cacheRef, cacheBuiltTime) <- do - pgResp <- runExceptT $ peelRun emptySchemaCache adminUserInfo - httpManager sqlGenCtx pgExecCtxSer $ do - buildSchemaCache - liftTx fetchLastUpdate + pgResp <- runExceptT $ peelRun emptySchemaCache runCtx pgExecCtxSer $ do + buildSchemaCache + liftTx fetchLastUpdate (time, sc) <- either initErrExit return pgResp scRef <- newIORef (sc, initSchemaCacheVer) return (scRef, snd <$> time) diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index dc74318f092f0..43506d4978251 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -137,12 +137,20 @@ $(deriveJSON ''RQLQueryV2 ) +data RunCtx + = RunCtx + { _rcUserInfo :: !UserInfo + , _rcHttpMgr :: !HTTP.Manager + , _rcSqlGenCtx :: !SQLGenCtx + , _rcSystemDefined :: !SystemDefined + } + newtype Run a - = Run {unRun :: StateT SchemaCache (ReaderT (UserInfo, HTTP.Manager, SQLGenCtx) (LazyTx QErr)) a} + = Run {unRun :: StateT SchemaCache (ReaderT RunCtx (LazyTx QErr)) a} deriving ( Functor, Applicative, Monad , MonadError QErr , MonadState SchemaCache - , MonadReader (UserInfo, HTTP.Manager, SQLGenCtx) + , MonadReader RunCtx , CacheRM , CacheRWM , MonadTx @@ -150,13 +158,16 @@ newtype Run a ) instance UserInfoM Run where - askUserInfo = asks _1 + askUserInfo = asks _rcUserInfo instance HasHttpManager Run where - askHttpManager = asks _2 + askHttpManager = asks _rcHttpMgr instance HasSQLGenCtx Run where - askSQLGenCtx = asks _3 + askSQLGenCtx = asks _rcSqlGenCtx + +instance HasSystemDefined Run where + askSystemDefined = asks _rcSystemDefined fetchLastUpdate :: Q.TxE QErr (Maybe (InstanceId, UTCTime)) fetchLastUpdate = do @@ -178,26 +189,25 @@ recordSchemaUpdate instanceId = peelRun :: SchemaCache - -> UserInfo - -> HTTP.Manager - -> SQLGenCtx + -> RunCtx -> PGExecCtx - -> Run a -> ExceptT QErr IO (a, SchemaCache) -peelRun sc userInfo httMgr sqlGenCtx pgExecCtx (Run m) = + -> Run a + -> ExceptT QErr IO (a, SchemaCache) +peelRun sc runCtx@(RunCtx userInfo _ _ _) pgExecCtx (Run m) = runLazyTx pgExecCtx $ withUserInfo userInfo lazyTx where - lazyTx = runReaderT (runStateT m sc) (userInfo, httMgr, sqlGenCtx) + lazyTx = runReaderT (runStateT m sc) runCtx runQuery :: (MonadIO m, MonadError QErr m) => PGExecCtx -> InstanceId -> UserInfo -> SchemaCache -> HTTP.Manager - -> SQLGenCtx -> RQLQuery -> m (EncJSON, SchemaCache) -runQuery pgExecCtx instanceId userInfo sc hMgr sqlGenCtx query = do - resE <- liftIO $ runExceptT $ - peelRun sc userInfo hMgr sqlGenCtx pgExecCtx $ runQueryM query + -> SQLGenCtx -> SystemDefined -> RQLQuery -> m (EncJSON, SchemaCache) +runQuery pgExecCtx instanceId userInfo sc hMgr sqlGenCtx systemDefined query = do + resE <- liftIO $ runExceptT $ peelRun sc runCtx pgExecCtx $ runQueryM query either throwError withReload resE where + runCtx = RunCtx userInfo hMgr sqlGenCtx systemDefined withReload r = do when (queryNeedsReload query) $ do e <- liftIO $ runExceptT $ runLazyTx pgExecCtx @@ -273,6 +283,7 @@ queryNeedsReload (RQV2 qi) = case qi of runQueryM :: ( QErrM m, CacheRWM m, UserInfoM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m + , HasSystemDefined m ) => RQLQuery -> m EncJSON diff --git a/server/src-lib/Hasura/Server/SchemaUpdate.hs b/server/src-lib/Hasura/Server/SchemaUpdate.hs index 1ed8c9d26af17..eafbcdf892d69 100644 --- a/server/src-lib/Hasura/Server/SchemaUpdate.hs +++ b/server/src-lib/Hasura/Server/SchemaUpdate.hs @@ -203,12 +203,13 @@ refreshSchemaCache refreshSchemaCache sqlGenCtx pool logger httpManager cacheRef threadType msg = do -- Reload schema cache from catalog resE <- liftIO $ runExceptT $ withSCUpdate cacheRef logger $ - peelRun emptySchemaCache adminUserInfo - httpManager sqlGenCtx (PGExecCtx pool PG.Serializable) buildSchemaCacheWithoutSetup + peelRun emptySchemaCache runCtx pgCtx buildSchemaCacheWithoutSetup case resE of - Left e -> logError logger threadType $ TEQueryError e - Right _ -> - logInfo logger threadType $ object ["message" .= msg] + Left e -> logError logger threadType $ TEQueryError e + Right _ -> logInfo logger threadType $ object ["message" .= msg] + where + runCtx = RunCtx adminUserInfo httpManager sqlGenCtx $ SystemDefined False + pgCtx = PGExecCtx pool PG.Serializable logInfo :: Logger -> ThreadType -> Value -> IO () logInfo logger threadType val = unLogger logger $ diff --git a/server/src-lib/Hasura/Server/Telemetry.hs b/server/src-lib/Hasura/Server/Telemetry.hs index b38bb826252e4..6f65471c277a9 100644 --- a/server/src-lib/Hasura/Server/Telemetry.hs +++ b/server/src-lib/Hasura/Server/Telemetry.hs @@ -147,12 +147,12 @@ computeMetrics sc = evtTriggers = Map.size $ Map.filter (not . Map.null) $ Map.map _tiEventTriggerInfoMap userTables rmSchemas = Map.size $ scRemoteSchemas sc - funcs = Map.size $ Map.filter (not . fiSystemDefined) $ scFunctions sc + funcs = Map.size $ Map.filter (not . isSystemDefined . fiSystemDefined) $ scFunctions sc in Metrics nTables nViews nEnumTables relMetrics permMetrics evtTriggers rmSchemas funcs where - userTables = Map.filter (not . _tiSystemDefined) $ scTables sc + userTables = Map.filter (not . isSystemDefined . _tiSystemDefined) $ scTables sc countUserTables predicate = length . filter predicate $ Map.elems userTables calcPerms :: (RolePermInfo -> Maybe a) -> [RolePermInfo] -> Int diff --git a/server/src-rsr/clear_system_metadata.sql b/server/src-rsr/clear_system_metadata.sql new file mode 100644 index 0000000000000..7ed40aebf278e --- /dev/null +++ b/server/src-rsr/clear_system_metadata.sql @@ -0,0 +1,9 @@ +DELETE FROM hdb_catalog.hdb_function WHERE is_system_defined = 'true'; + +DELETE FROM hdb_catalog.hdb_permission WHERE is_system_defined = 'true'; + +DELETE FROM hdb_catalog.hdb_relationship WHERE is_system_defined = 'true'; + +DELETE FROM hdb_catalog.hdb_table WHERE is_system_defined = 'true'; + +DELETE FROM hdb_catalog.hdb_query_collection WHERE is_system_defined = 'true'; diff --git a/server/src-rsr/migrate_from_08_to_1.sql b/server/src-rsr/migrate_from_08_to_1.sql new file mode 100644 index 0000000000000..8b4e9c7c56a03 --- /dev/null +++ b/server/src-rsr/migrate_from_08_to_1.sql @@ -0,0 +1,11 @@ +ALTER TABLE hdb_catalog.hdb_relationship + ADD COLUMN comment TEXT NULL; + +ALTER TABLE hdb_catalog.hdb_permission + ADD COLUMN comment TEXT NULL; + +ALTER TABLE hdb_catalog.hdb_query_template + ADD COLUMN comment TEXT NULL; + +UPDATE hdb_catalog.hdb_query_template + SET template_defn = json_build_object('type', 'select', 'args', template_defn->'select'); diff --git a/server/src-rsr/migrate_from_16_to_17.sql b/server/src-rsr/migrate_from_16_to_17.sql new file mode 100644 index 0000000000000..0d2ab29e9e172 --- /dev/null +++ b/server/src-rsr/migrate_from_16_to_17.sql @@ -0,0 +1,4 @@ +UPDATE hdb_catalog.hdb_table + SET is_system_defined = 'true' + WHERE table_schema = 'hdb_catalog' AND + table_name = 'hdb_allowlist'; diff --git a/server/src-rsr/migrate_from_1.sql b/server/src-rsr/migrate_from_1_to_2.sql similarity index 100% rename from server/src-rsr/migrate_from_1.sql rename to server/src-rsr/migrate_from_1_to_2.sql diff --git a/server/src-rsr/migrate_from_2_to_3.sql b/server/src-rsr/migrate_from_2_to_3.sql new file mode 100644 index 0000000000000..63ff0a497ea29 --- /dev/null +++ b/server/src-rsr/migrate_from_2_to_3.sql @@ -0,0 +1,9 @@ +ALTER TABLE hdb_catalog.event_triggers + ADD COLUMN headers JSON; + +ALTER TABLE hdb_catalog.event_log + ADD COLUMN next_retry_at TIMESTAMP; + +CREATE INDEX ON hdb_catalog.event_log (trigger_id); + +CREATE INDEX ON hdb_catalog.event_invocation_logs (event_id); diff --git a/server/src-rsr/migrate_metadata_from_1.yaml b/server/src-rsr/migrate_metadata_from_1.yaml deleted file mode 100644 index 37554127c25c5..0000000000000 --- a/server/src-rsr/migrate_metadata_from_1.yaml +++ /dev/null @@ -1,66 +0,0 @@ -type: bulk -args: -- type: add_existing_table_or_view - args: - schema: hdb_catalog - name: event_triggers - -- type: add_existing_table_or_view - args: - schema: hdb_catalog - name: event_log - -- type: add_existing_table_or_view - args: - schema: hdb_catalog - name: event_invocation_logs - -- type: create_object_relationship - args: - name: trigger - table: - schema: hdb_catalog - name: event_log - using: - manual_configuration: - remote_table: - schema: hdb_catalog - name: event_triggers - column_mapping: - trigger_id : id - -- type: create_array_relationship - args: - name: events - table: - schema: hdb_catalog - name: event_triggers - using: - manual_configuration: - remote_table: - schema: hdb_catalog - name: event_log - column_mapping: - id : trigger_id - -- type: create_object_relationship - args: - name: event - table: - schema: hdb_catalog - name: event_invocation_logs - using: - foreign_key_constraint_on: event_id - -- type: create_array_relationship - args: - name: logs - table: - schema: hdb_catalog - name: event_log - using: - foreign_key_constraint_on: - table: - schema: hdb_catalog - name: event_invocation_logs - column: event_id diff --git a/server/src-rsr/migrate_metadata_from_15_to_16.yaml b/server/src-rsr/migrate_metadata_from_15_to_16.yaml deleted file mode 100644 index 81056e8da567c..0000000000000 --- a/server/src-rsr/migrate_metadata_from_15_to_16.yaml +++ /dev/null @@ -1,10 +0,0 @@ -type: bulk -args: -- type: track_table - args: - schema: hdb_catalog - name: hdb_query_collection -- type: track_table - args: - schema: hdb_catalog - name: hdb_allowlist diff --git a/server/src-rsr/migrate_metadata_from_4_to_5.yaml b/server/src-rsr/migrate_metadata_from_4_to_5.yaml deleted file mode 100644 index a463b72cad901..0000000000000 --- a/server/src-rsr/migrate_metadata_from_4_to_5.yaml +++ /dev/null @@ -1,4 +0,0 @@ -type: add_existing_table_or_view -args: - schema: hdb_catalog - name: remote_schemas diff --git a/server/src-rsr/migrate_metadata_from_7_to_8.yaml b/server/src-rsr/migrate_metadata_from_7_to_8.yaml deleted file mode 100644 index fefe4bf08317f..0000000000000 --- a/server/src-rsr/migrate_metadata_from_7_to_8.yaml +++ /dev/null @@ -1,24 +0,0 @@ -type: bulk -args: -- type: track_table - args: - schema: hdb_catalog - name: hdb_function_agg -- type: track_table - args: - schema: hdb_catalog - name: hdb_function -- type: create_object_relationship - args: - name: return_table_info - table: - schema: hdb_catalog - name: hdb_function_agg - using: - manual_configuration: - remote_table: - schema: hdb_catalog - name: hdb_table - column_mapping: - return_type_schema: table_schema - return_type_name: table_name diff --git a/server/src-rsr/migrate_metadata_from_8_to_9.yaml b/server/src-rsr/migrate_metadata_from_8_to_9.yaml deleted file mode 100644 index 1898baea471da..0000000000000 --- a/server/src-rsr/migrate_metadata_from_8_to_9.yaml +++ /dev/null @@ -1,4 +0,0 @@ -type: track_table -args: - schema: hdb_catalog - name: hdb_version From 51fc5a8cd93864c57d3881b8829c5649f859fc5d Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 26 Sep 2019 16:26:21 -0500 Subject: [PATCH 02/10] wip: debug logging for migration problems in CI --- server/src-exec/Migrate.hs | 11 +++++++---- server/src-rsr/clear_system_metadata.sql | 4 ---- 2 files changed, 7 insertions(+), 8 deletions(-) diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 26af9bf5b288a..00f664bf965a7 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -9,7 +9,6 @@ module Migrate where import Data.Time.Clock (UTCTime) -import Language.Haskell.TH.Syntax (Q, TExp, unTypeQ) import Hasura.Prelude import Hasura.RQL.DDL.Schema @@ -22,6 +21,8 @@ import qualified Data.Yaml.TH as Y import qualified Database.PG.Query as Q +import Debug.Trace + type Migration m = ( MonadTx m @@ -82,12 +83,16 @@ migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion ] postMigrate = do + liftIO $ traceIO "postMigrate" -- update the catalog version updateVersion -- replace system metadata + liftIO $ traceIO "clearSystemMetadata" clearSystemMetadata + liftIO $ traceIO "createSystemMetadata" createSystemMetadata -- try building the schema cache + liftIO $ traceIO "buildSchemaCacheStrict" buildSchemaCacheStrict return $ "successfully migrated to " ++ show curCatalogVer @@ -105,9 +110,7 @@ clearSystemMetadata :: MonadTx m => m () clearSystemMetadata = runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") createSystemMetadata :: Migration m => m () -createSystemMetadata = void $ runQueryM rqlQuery - where - rqlQuery = $(unTypeQ (Y.decodeFile "src-rsr/hdb_metadata.yaml" :: Q (TExp RQLQuery))) +createSystemMetadata = void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") from08To1 :: MonadTx m => m () from08To1 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_08_to_1.sql") diff --git a/server/src-rsr/clear_system_metadata.sql b/server/src-rsr/clear_system_metadata.sql index 7ed40aebf278e..b6b1a9344830a 100644 --- a/server/src-rsr/clear_system_metadata.sql +++ b/server/src-rsr/clear_system_metadata.sql @@ -1,9 +1,5 @@ DELETE FROM hdb_catalog.hdb_function WHERE is_system_defined = 'true'; - DELETE FROM hdb_catalog.hdb_permission WHERE is_system_defined = 'true'; - DELETE FROM hdb_catalog.hdb_relationship WHERE is_system_defined = 'true'; - DELETE FROM hdb_catalog.hdb_table WHERE is_system_defined = 'true'; - DELETE FROM hdb_catalog.hdb_query_collection WHERE is_system_defined = 'true'; From 14141150406f4355c160d5c1b99bff36a44d1fa2 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Mon, 7 Oct 2019 17:18:44 -0500 Subject: [PATCH 03/10] Refactor Migrate.hs to generate list of migrations at compile-time --- server/graphql-engine.cabal | 4 +- server/src-exec/Main.hs | 2 +- server/src-exec/Migrate.hs | 304 ++++++------------ server/src-exec/Migrate/Version.hs | 10 + server/src-exec/Ops.hs | 4 +- .../08_to_1.sql} | 0 .../10_to_11.sql} | 0 .../11_to_12.sql} | 0 .../12_to_13.sql} | 0 .../13_to_14.sql} | 0 .../14_to_15.sql} | 0 .../15_to_16.sql} | 0 .../16_to_17.sql} | 0 server/src-rsr/migrations/17_to_18.sql | 4 + .../18_to_19.sql} | 0 .../19_to_20.sql} | 0 .../1_to_2.sql} | 0 server/src-rsr/migrations/20_to_21.sql | 1 + .../21_to_22.sql} | 0 .../22_to_23.sql} | 0 server/src-rsr/migrations/23_to_24.sql | 2 + .../2_to_3.sql} | 0 .../4_to_5.sql} | 0 .../5_to_6.sql} | 0 .../6_to_7.sql} | 0 .../7_to_8.sql} | 0 .../8_to_9.sql} | 0 .../9_to_10.sql} | 0 28 files changed, 120 insertions(+), 211 deletions(-) create mode 100644 server/src-exec/Migrate/Version.hs rename server/src-rsr/{migrate_from_08_to_1.sql => migrations/08_to_1.sql} (100%) rename server/src-rsr/{migrate_from_10_to_11.sql => migrations/10_to_11.sql} (100%) rename server/src-rsr/{migrate_from_11_to_12.sql => migrations/11_to_12.sql} (100%) rename server/src-rsr/{migrate_from_12_to_13.sql => migrations/12_to_13.sql} (100%) rename server/src-rsr/{migrate_from_13_to_14.sql => migrations/13_to_14.sql} (100%) rename server/src-rsr/{migrate_from_14_to_15.sql => migrations/14_to_15.sql} (100%) rename server/src-rsr/{migrate_from_15_to_16.sql => migrations/15_to_16.sql} (100%) rename server/src-rsr/{migrate_from_16_to_17.sql => migrations/16_to_17.sql} (100%) create mode 100644 server/src-rsr/migrations/17_to_18.sql rename server/src-rsr/{migrate_from_18_to_19.sql => migrations/18_to_19.sql} (100%) rename server/src-rsr/{migrate_from_19_to_20.sql => migrations/19_to_20.sql} (100%) rename server/src-rsr/{migrate_from_1_to_2.sql => migrations/1_to_2.sql} (100%) create mode 100644 server/src-rsr/migrations/20_to_21.sql rename server/src-rsr/{migrate_from_21_to_22.sql => migrations/21_to_22.sql} (100%) rename server/src-rsr/{migrate_from_22_to_23.sql => migrations/22_to_23.sql} (100%) create mode 100644 server/src-rsr/migrations/23_to_24.sql rename server/src-rsr/{migrate_from_2_to_3.sql => migrations/2_to_3.sql} (100%) rename server/src-rsr/{migrate_from_4_to_5.sql => migrations/4_to_5.sql} (100%) rename server/src-rsr/{migrate_from_5_to_6.sql => migrations/5_to_6.sql} (100%) rename server/src-rsr/{migrate_from_6_to_7.sql => migrations/6_to_7.sql} (100%) rename server/src-rsr/{migrate_from_7_to_8.sql => migrations/7_to_8.sql} (100%) rename server/src-rsr/{migrate_from_8_to_9.sql => migrations/8_to_9.sql} (100%) rename server/src-rsr/{migrate_from_9_to_10.sql => migrations/9_to_10.sql} (100%) diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index 17121b8ebc7d5..af836ccd7a30c 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -29,7 +29,6 @@ flag profile library hs-source-dirs: src-lib - , src-exec default-language: Haskell2010 build-depends: base , pg-client @@ -289,8 +288,6 @@ library , Hasura.SQL.Types , Hasura.SQL.Value , Network.URI.Extended - , Ops - , Migrate other-modules: Hasura.Server.Auth.JWT.Internal , Hasura.Server.Auth.JWT.Logging @@ -395,6 +392,7 @@ executable graphql-engine other-modules: Ops , Migrate + , Migrate.Version if flag(developer) ghc-prof-options: -rtsopts -fprof-auto -fno-prof-count-entries diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index 55cdfe321f3ac..5a135a0bbf22c 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -257,7 +257,7 @@ main = do -- migrate catalog if necessary migRes <- runAsAdmin pool sqlGenCtx httpMgr $ migrateCatalog currentTime - either printErrJExit (logger . mkGenericStrLog LevelInfo "db_migrate") migRes + either printErrJExit (logger . mkGenericLog LevelInfo "db_migrate") migRes -- retrieve database id eDbId <- runTx pool getDbId diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 00f664bf965a7..4ebafde545f9e 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -1,12 +1,17 @@ -{- | -Description: Migrations for Hasura catalog. --} - +-- | Migrations for the Hasura catalog. +-- +-- To add a new migration: +-- +-- 1. Bump the catalog version number in "Migrate.Version". +-- 2. Add a migration script in the @src-rsr/migrations/@ directory with the name +-- @_to_.sql@. +-- +-- The Template Haskell code in this module will automatically compile the new migration script into +-- the @graphql-engine@ executable. module Migrate - ( curCatalogVer + ( latestCatalogVersion , migrateCatalog - ) -where + ) where import Data.Time.Clock (UTCTime) @@ -18,218 +23,107 @@ import Hasura.Server.Query import qualified Data.Aeson as A import qualified Data.Text as T import qualified Data.Yaml.TH as Y - import qualified Database.PG.Query as Q +import qualified Language.Haskell.TH.Lib as TH +import qualified Language.Haskell.TH.Syntax as TH -import Debug.Trace - - -type Migration m = - ( MonadTx m - , HasHttpManager m - , HasSystemDefined m - , CacheRWM m - , UserInfoM m - , MonadIO m - , HasSQLGenCtx m - ) - -curCatalogVer :: T.Text -curCatalogVer = "24" +import Migrate.Version (latestCatalogVersion) -getCatalogVersion :: MonadTx m => m T.Text -getCatalogVersion = do - res <- liftTx $ Q.withQE defaultTxErrorHandler [Q.sql| - SELECT version FROM hdb_catalog.hdb_version |] () False - return $ runIdentity $ Q.getRow res +import Debug.Trace -migrateCatalog :: Migration m => UTCTime -> m String +migrateCatalog + :: forall m + . ( MonadTx m + , HasHttpManager m + , HasSystemDefined m + , CacheRWM m + , UserInfoM m + , MonadIO m + , HasSQLGenCtx m + ) + => UTCTime -> m T.Text migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion where + -- the old 0.8 catalog version is non-integral, so we store it in the database as a string + latestCatalogVersionString = T.pack $ show latestCatalogVersion + + getCatalogVersion = liftTx $ runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler + [Q.sql| SELECT version FROM hdb_catalog.hdb_version |] () False + + migrateFrom :: T.Text -> m T.Text migrateFrom previousVersion - | previousVersion == curCatalogVer = - return $ "already at the latest version. current version: " <> show curCatalogVer - | [] <- neededMigrations = - throw400 NotSupported $ "unsupported version : " <> previousVersion - | otherwise = - traverse_ snd neededMigrations *> postMigrate + | previousVersion == latestCatalogVersionString = pure $ + "already at the latest version. current version: " <> latestCatalogVersionString + | [] <- neededMigrations = throw400 NotSupported $ "unsupported version : " <> previousVersion + | otherwise = traverse_ snd neededMigrations *> postMigrate where neededMigrations = dropWhile ((/= previousVersion) . fst) migrations + + migrations :: [(T.Text, m ())] migrations = - [ ("0.8", from08To1) - , ("1", from1To2) - , ("2", from2To3) - , ("3", from3To4) - , ("4", from4To5) - , ("5", from5To6) - , ("6", from6To7) - , ("7", from7To8) - , ("8", from8To9) - , ("9", from9To10) - , ("10", from10To11) - , ("11", from11To12) - , ("12", from12To13) - , ("13", from13To14) - , ("14", from14To15) - , ("15", from15To16) - , ("16", from16To17) - , ("17", from17To18) - , ("18", from18To19) - , ("19", from19To20) - , ("20", from20To21) - , ("21", from21To22) - , ("22", from22To23) - , ("23", from23To24) - ] + -- We need to build the list of migrations at compile-time so that we can compile the SQL + -- directly into the executable using `Q.sqlFromFile`. The GHC stage restriction makes + -- doing this a little bit awkward (we can’t use any definitions in this module at + -- compile-time), but putting a `let` inside the splice itself is allowed. + $(let migrationFromFile from to = + let path = "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql" + in [| runTx $(Q.sqlFromFile path) |] + migrationsFromFile = map $ \(to :: Integer) -> + [| ( $(TH.lift $ T.pack (show to)) + , $(migrationFromFile (show (to - 1)) (show to)) + ) |] + in TH.listE + -- version 0.8 is the only non-integral catalog version + $ [| ("0.8", $(migrationFromFile "08" "1")) |] + : migrationsFromFile [2..3] + ++ [| ("3", from3To4) |] + : migrationsFromFile [5..latestCatalogVersion]) postMigrate = do liftIO $ traceIO "postMigrate" - -- update the catalog version - updateVersion - -- replace system metadata - liftIO $ traceIO "clearSystemMetadata" - clearSystemMetadata - liftIO $ traceIO "createSystemMetadata" - createSystemMetadata - -- try building the schema cache + updateCatalogVersion + replaceSystemMetadata liftIO $ traceIO "buildSchemaCacheStrict" buildSchemaCacheStrict - return $ "successfully migrated to " ++ show curCatalogVer - - updateVersion = - liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| - UPDATE "hdb_catalog"."hdb_version" - SET "version" = $1, - "upgraded_on" = $2 - |] (curCatalogVer, migrationTime) False - -runTx :: MonadTx m => Q.Query -> m () -runTx = liftTx . Q.multiQE defaultTxErrorHandler - -clearSystemMetadata :: MonadTx m => m () -clearSystemMetadata = runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") - -createSystemMetadata :: Migration m => m () -createSystemMetadata = void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") - -from08To1 :: MonadTx m => m () -from08To1 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_08_to_1.sql") - -from1To2 :: MonadTx m => m () -from1To2 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_1_to_2.sql") - -from2To3 :: MonadTx m => m () -from2To3 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_2_to_3.sql") - -from3To4 :: MonadTx m => m () -from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do - Q.unitQ [Q.sql| - ALTER TABLE hdb_catalog.event_triggers - ADD COLUMN configuration JSON |] () False - eventTriggers <- map uncurryEventTrigger <$> Q.listQ [Q.sql| - SELECT e.name, e.definition::json, e.webhook, e.num_retries, e.retry_interval, e.headers::json - FROM hdb_catalog.event_triggers e |] () False - forM_ eventTriggers updateEventTrigger3To4 - Q.unitQ [Q.sql| - ALTER TABLE hdb_catalog.event_triggers - DROP COLUMN definition, - DROP COLUMN query, - DROP COLUMN webhook, - DROP COLUMN num_retries, - DROP COLUMN retry_interval, - DROP COLUMN headers |] () False - where - uncurryEventTrigger (trn, Q.AltJ tDef, w, nr, rint, Q.AltJ headers) = - EventTriggerConf trn tDef (Just w) Nothing (RetryConf nr rint Nothing) headers - updateEventTrigger3To4 etc@(EventTriggerConf name _ _ _ _ _) = Q.unitQ [Q.sql| - UPDATE hdb_catalog.event_triggers - SET - configuration = $1 - WHERE name = $2 - |] (Q.AltJ $ A.toJSON etc, name) True + pure $ "successfully migrated to " <> latestCatalogVersionString -from4To5 :: MonadTx m => m () -from4To5 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_4_to_5.sql") + updateCatalogVersion = liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| + UPDATE "hdb_catalog"."hdb_version" + SET "version" = $1, + "upgraded_on" = $2 + |] (latestCatalogVersionString, migrationTime) False -from5To6 :: MonadTx m => m () -from5To6 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_5_to_6.sql") - -from6To7 :: MonadTx m => m () -from6To7 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_6_to_7.sql") - -from7To8 :: MonadTx m => m () -from7To8 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_7_to_8.sql") - -from8To9 :: MonadTx m => m () -from8To9 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_8_to_9.sql") - -from9To10 :: MonadTx m => m () -from9To10 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_9_to_10.sql") - -from10To11 :: MonadTx m => m () -from10To11 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_10_to_11.sql") - -from11To12 :: MonadTx m => m () -from11To12 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_11_to_12.sql") - -from12To13 :: MonadTx m => m () -from12To13 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_12_to_13.sql") - -from13To14 :: MonadTx m => m () -from13To14 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_13_to_14.sql") - -from14To15 :: MonadTx m => m () -from14To15 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_14_to_15.sql") - -from15To16 :: MonadTx m => m () -from15To16 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_15_to_16.sql") - -from16To17 :: MonadTx m => m () -from16To17 = runTx $(Q.sqlFromFile "src-rsr/migrate_from_16_to_17.sql") - -from17To18 :: MonadTx m => m () -from17To18 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - DELETE FROM hdb_catalog.hdb_table - WHERE table_schema = 'hdb_catalog' - AND table_name = 'hdb_query_template'; - DROP table hdb_catalog.hdb_query_template - |] - -from18To19 :: MonadTx m => m () -from18To19 = do - -- Migrate database - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_18_to_19.sql") - return () - -from19To20 :: (MonadTx m) => m () -from19To20 = do - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_19_to_20.sql") - pure () - -from20To21 :: (MonadTx m) => m () -from20To21 = liftTx $ Q.catchE defaultTxErrorHandler $ do - Q.unitQ "CREATE INDEX ON hdb_catalog.event_log (locked)" () False - -from21To22 :: (MonadTx m) => m () -from21To22 = do - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_21_to_22.sql") - pure () - -from22To23 :: (MonadTx m) => m () -from22To23 = do - Q.Discard () <- liftTx $ Q.multiQE defaultTxErrorHandler - $(Q.sqlFromFile "src-rsr/migrate_from_22_to_23.sql") - pure () - -from23To24 :: MonadTx m => m () -from23To24 = - liftTx $ Q.catchE defaultTxErrorHandler $ - Q.multiQ [Q.sql| - ALTER TABLE hdb_catalog.hdb_table - ADD COLUMN configuration JSONB NOT NULL DEFAULT '{}'::jsonb; - |] + replaceSystemMetadata = do + liftIO $ traceIO "clearSystemMetadata" + runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") + liftIO $ traceIO "createSystemMetadata" + void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") + + from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do + Q.unitQ [Q.sql| + ALTER TABLE hdb_catalog.event_triggers + ADD COLUMN configuration JSON |] () False + eventTriggers <- map uncurryEventTrigger <$> Q.listQ [Q.sql| + SELECT e.name, e.definition::json, e.webhook, e.num_retries, e.retry_interval, e.headers::json + FROM hdb_catalog.event_triggers e |] () False + forM_ eventTriggers updateEventTrigger3To4 + Q.unitQ [Q.sql| + ALTER TABLE hdb_catalog.event_triggers + DROP COLUMN definition, + DROP COLUMN query, + DROP COLUMN webhook, + DROP COLUMN num_retries, + DROP COLUMN retry_interval, + DROP COLUMN headers |] () False + where + uncurryEventTrigger (trn, Q.AltJ tDef, w, nr, rint, Q.AltJ headers) = + EventTriggerConf trn tDef (Just w) Nothing (RetryConf nr rint Nothing) headers + updateEventTrigger3To4 etc@(EventTriggerConf name _ _ _ _ _) = Q.unitQ [Q.sql| + UPDATE hdb_catalog.event_triggers + SET + configuration = $1 + WHERE name = $2 + |] (Q.AltJ $ A.toJSON etc, name) True + + runTx :: Q.Query -> m () + runTx = liftTx . Q.multiQE defaultTxErrorHandler diff --git a/server/src-exec/Migrate/Version.hs b/server/src-exec/Migrate/Version.hs new file mode 100644 index 0000000000000..865953cd80eef --- /dev/null +++ b/server/src-exec/Migrate/Version.hs @@ -0,0 +1,10 @@ +-- | A module that defines the current catalog version and nothing else. This is necessary to +-- circumvent the unfortunate “GHC stage restriction,” which prevents us from using a binding in a +-- compile-time splice unless it is defined in a different module. The actual migration code is in +-- "Migrate". +module Migrate.Version (latestCatalogVersion) where + +import Hasura.Prelude + +latestCatalogVersion :: Integer +latestCatalogVersion = 24 diff --git a/server/src-exec/Ops.hs b/server/src-exec/Ops.hs index 2e4321356dd90..24121c756ad84 100644 --- a/server/src-exec/Ops.hs +++ b/server/src-exec/Ops.hs @@ -6,7 +6,7 @@ module Ops import Data.Time.Clock (UTCTime) import Language.Haskell.TH.Syntax (Q, TExp, unTypeQ) -import Migrate (curCatalogVer) +import Migrate (latestCatalogVersion) import Hasura.EncJSON import Hasura.Prelude @@ -107,7 +107,7 @@ initCatalogStrict createSchema initTime = do Q.unitQ [Q.sql| INSERT INTO "hdb_catalog"."hdb_version" (version, upgraded_on) VALUES ($1, $2) - |] (curCatalogVer, modTime) False + |] (T.pack $ show latestCatalogVersion, modTime) False isExtAvailable :: T.Text -> Q.Tx Bool isExtAvailable sn = diff --git a/server/src-rsr/migrate_from_08_to_1.sql b/server/src-rsr/migrations/08_to_1.sql similarity index 100% rename from server/src-rsr/migrate_from_08_to_1.sql rename to server/src-rsr/migrations/08_to_1.sql diff --git a/server/src-rsr/migrate_from_10_to_11.sql b/server/src-rsr/migrations/10_to_11.sql similarity index 100% rename from server/src-rsr/migrate_from_10_to_11.sql rename to server/src-rsr/migrations/10_to_11.sql diff --git a/server/src-rsr/migrate_from_11_to_12.sql b/server/src-rsr/migrations/11_to_12.sql similarity index 100% rename from server/src-rsr/migrate_from_11_to_12.sql rename to server/src-rsr/migrations/11_to_12.sql diff --git a/server/src-rsr/migrate_from_12_to_13.sql b/server/src-rsr/migrations/12_to_13.sql similarity index 100% rename from server/src-rsr/migrate_from_12_to_13.sql rename to server/src-rsr/migrations/12_to_13.sql diff --git a/server/src-rsr/migrate_from_13_to_14.sql b/server/src-rsr/migrations/13_to_14.sql similarity index 100% rename from server/src-rsr/migrate_from_13_to_14.sql rename to server/src-rsr/migrations/13_to_14.sql diff --git a/server/src-rsr/migrate_from_14_to_15.sql b/server/src-rsr/migrations/14_to_15.sql similarity index 100% rename from server/src-rsr/migrate_from_14_to_15.sql rename to server/src-rsr/migrations/14_to_15.sql diff --git a/server/src-rsr/migrate_from_15_to_16.sql b/server/src-rsr/migrations/15_to_16.sql similarity index 100% rename from server/src-rsr/migrate_from_15_to_16.sql rename to server/src-rsr/migrations/15_to_16.sql diff --git a/server/src-rsr/migrate_from_16_to_17.sql b/server/src-rsr/migrations/16_to_17.sql similarity index 100% rename from server/src-rsr/migrate_from_16_to_17.sql rename to server/src-rsr/migrations/16_to_17.sql diff --git a/server/src-rsr/migrations/17_to_18.sql b/server/src-rsr/migrations/17_to_18.sql new file mode 100644 index 0000000000000..e97b55ceae08c --- /dev/null +++ b/server/src-rsr/migrations/17_to_18.sql @@ -0,0 +1,4 @@ +DELETE FROM hdb_catalog.hdb_table +WHERE table_schema = 'hdb_catalog' + AND table_name = 'hdb_query_template'; +DROP table hdb_catalog.hdb_query_template diff --git a/server/src-rsr/migrate_from_18_to_19.sql b/server/src-rsr/migrations/18_to_19.sql similarity index 100% rename from server/src-rsr/migrate_from_18_to_19.sql rename to server/src-rsr/migrations/18_to_19.sql diff --git a/server/src-rsr/migrate_from_19_to_20.sql b/server/src-rsr/migrations/19_to_20.sql similarity index 100% rename from server/src-rsr/migrate_from_19_to_20.sql rename to server/src-rsr/migrations/19_to_20.sql diff --git a/server/src-rsr/migrate_from_1_to_2.sql b/server/src-rsr/migrations/1_to_2.sql similarity index 100% rename from server/src-rsr/migrate_from_1_to_2.sql rename to server/src-rsr/migrations/1_to_2.sql diff --git a/server/src-rsr/migrations/20_to_21.sql b/server/src-rsr/migrations/20_to_21.sql new file mode 100644 index 0000000000000..812c215f7b05f --- /dev/null +++ b/server/src-rsr/migrations/20_to_21.sql @@ -0,0 +1 @@ +CREATE INDEX ON hdb_catalog.event_log (locked); diff --git a/server/src-rsr/migrate_from_21_to_22.sql b/server/src-rsr/migrations/21_to_22.sql similarity index 100% rename from server/src-rsr/migrate_from_21_to_22.sql rename to server/src-rsr/migrations/21_to_22.sql diff --git a/server/src-rsr/migrate_from_22_to_23.sql b/server/src-rsr/migrations/22_to_23.sql similarity index 100% rename from server/src-rsr/migrate_from_22_to_23.sql rename to server/src-rsr/migrations/22_to_23.sql diff --git a/server/src-rsr/migrations/23_to_24.sql b/server/src-rsr/migrations/23_to_24.sql new file mode 100644 index 0000000000000..6521b93079789 --- /dev/null +++ b/server/src-rsr/migrations/23_to_24.sql @@ -0,0 +1,2 @@ +ALTER TABLE hdb_catalog.hdb_table +ADD COLUMN configuration JSONB NOT NULL DEFAULT '{}'::jsonb; diff --git a/server/src-rsr/migrate_from_2_to_3.sql b/server/src-rsr/migrations/2_to_3.sql similarity index 100% rename from server/src-rsr/migrate_from_2_to_3.sql rename to server/src-rsr/migrations/2_to_3.sql diff --git a/server/src-rsr/migrate_from_4_to_5.sql b/server/src-rsr/migrations/4_to_5.sql similarity index 100% rename from server/src-rsr/migrate_from_4_to_5.sql rename to server/src-rsr/migrations/4_to_5.sql diff --git a/server/src-rsr/migrate_from_5_to_6.sql b/server/src-rsr/migrations/5_to_6.sql similarity index 100% rename from server/src-rsr/migrate_from_5_to_6.sql rename to server/src-rsr/migrations/5_to_6.sql diff --git a/server/src-rsr/migrate_from_6_to_7.sql b/server/src-rsr/migrations/6_to_7.sql similarity index 100% rename from server/src-rsr/migrate_from_6_to_7.sql rename to server/src-rsr/migrations/6_to_7.sql diff --git a/server/src-rsr/migrate_from_7_to_8.sql b/server/src-rsr/migrations/7_to_8.sql similarity index 100% rename from server/src-rsr/migrate_from_7_to_8.sql rename to server/src-rsr/migrations/7_to_8.sql diff --git a/server/src-rsr/migrate_from_8_to_9.sql b/server/src-rsr/migrations/8_to_9.sql similarity index 100% rename from server/src-rsr/migrate_from_8_to_9.sql rename to server/src-rsr/migrations/8_to_9.sql diff --git a/server/src-rsr/migrate_from_9_to_10.sql b/server/src-rsr/migrations/9_to_10.sql similarity index 100% rename from server/src-rsr/migrate_from_9_to_10.sql rename to server/src-rsr/migrations/9_to_10.sql From ebb3eba0576ef29790e116a55e436cde33f19a17 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 9 Oct 2019 01:50:54 -0500 Subject: [PATCH 04/10] wip: replace ginger with shakespeare --- server/graphql-engine.cabal | 2 +- server/src-exec/Migrate.hs | 5 +- server/src-lib/Hasura/GraphQL/RemoteServer.hs | 5 +- server/src-lib/Hasura/GraphQL/Schema.hs | 1 + server/src-lib/Hasura/RQL/DDL/EventTrigger.hs | 92 +++++++------------ server/src-lib/Hasura/RQL/DDL/Permission.hs | 3 +- .../Hasura/RQL/DDL/Permission/Triggers.hs | 40 +++----- server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs | 1 + server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs | 1 + .../src-lib/Hasura/RQL/DDL/Schema/Catalog.hs | 1 + server/src-lib/Hasura/Server/Query.hs | 2 + server/src-lib/Hasura/Server/Utils.hs | 15 --- ....sql.j2 => insert_trigger.sql.shakespeare} | 14 +-- ...trigger.sql.j2 => trigger.sql.shakespeare} | 18 ++-- server/stack.yaml | 5 +- server/stack.yaml.lock | 15 ++- 16 files changed, 92 insertions(+), 128 deletions(-) rename server/src-rsr/{insert_trigger.sql.j2 => insert_trigger.sql.shakespeare} (65%) rename server/src-rsr/{trigger.sql.j2 => trigger.sql.shakespeare} (52%) diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index af836ccd7a30c..a3b1b29a48935 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -107,8 +107,8 @@ library -- Templating , mustache - , ginger , file-embed + , shakespeare -- , data-has diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 4ebafde545f9e..cd96dc04df365 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -31,6 +31,7 @@ import Migrate.Version (latestCatalogVersion) import Debug.Trace +{-# SCC migrateCatalog #-} migrateCatalog :: forall m . ( MonadTx m @@ -95,9 +96,9 @@ migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion replaceSystemMetadata = do liftIO $ traceIO "clearSystemMetadata" - runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") + {-# SCC clearSystemMetadata #-} runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") liftIO $ traceIO "createSystemMetadata" - void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") + {-# SCC createSystemMetadata #-} void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do Q.unitQ [Q.sql| diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index f4aa1537b78b6..06125696053fd 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -31,6 +31,7 @@ import qualified Hasura.GraphQL.Validate.Types as VT introspectionQuery :: BL.ByteString introspectionQuery = $(embedStringFile "src-rsr/introspection.json") +{-# SCC fetchRemoteSchema #-} fetchRemoteSchema :: (MonadIO m, MonadError QErr m) => HTTP.Manager @@ -51,7 +52,7 @@ fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _ timeout) = , HTTP.requestBody = HTTP.RequestBodyLBS introspectionQuery , HTTP.responseTimeout = HTTP.responseTimeoutMicro (timeout * 1000000) } - res <- liftIO $ try $ HTTP.httpLbs req manager + res <- {-# SCC "fetchRemoteSchema/HTTP" #-} liftIO $ try $ HTTP.httpLbs req manager resp <- either throwHttpErr return res let respData = resp ^. Wreq.responseBody @@ -59,7 +60,7 @@ fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _ timeout) = when (statusCode /= 200) $ throwNon200 statusCode respData introspectRes :: (FromIntrospection IntrospectionResult) <- - either (remoteSchemaErr . T.pack) return $ J.eitherDecode respData + either (remoteSchemaErr . T.pack) return $ {-# SCC "fetchRemoteSchema/decodeJSON" #-} J.eitherDecode respData let (sDoc, qRootN, mRootN, sRootN) = fromIntrospection introspectRes typMap <- either remoteSchemaErr return $ VT.fromSchemaDoc sDoc $ diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index 7d54e8445e0f5..0b06a8774e811 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -647,6 +647,7 @@ mkGCtxMap tableCache functionCache = do return $ Map.keys query <> Map.keys mutation -- | build GraphQL schema from postgres tables and functions +{-# SCC buildGCtxMapPG #-} buildGCtxMapPG :: (QErrM m, CacheRWM m) => m () diff --git a/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs b/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs index 6ecc0c7c33fc6..62051ce5d0705 100644 --- a/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs +++ b/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs @@ -22,25 +22,19 @@ import Hasura.Prelude import Hasura.RQL.DDL.Headers import Hasura.RQL.DML.Internal import Hasura.RQL.Types -import Hasura.Server.Utils import Hasura.SQL.Types import System.Environment (lookupEnv) import qualified Hasura.SQL.DML as S -import qualified Data.FileEmbed as FE -import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import qualified Database.PG.Query as Q +import qualified Data.Text.Lazy as TL +import qualified Text.Shakespeare.Text as ST data OpVar = OLD | NEW deriving (Show) -triggerTmplt :: Maybe GingerTmplt -triggerTmplt = case parseGingerTmplt $(FE.embedStringFile "src-rsr/trigger.sql.j2") of - Left _ -> Nothing - Right tmplt -> Just tmplt - pgIdenTrigger:: Ops -> TriggerName -> T.Text pgIdenTrigger op trn = pgFmtIden . qualifyTriggerName op $ triggerNameToTxt trn where @@ -51,33 +45,42 @@ getDropFuncSql op trn = "DROP FUNCTION IF EXISTS" <> " hdb_views." <> pgIdenTrigger op trn <> "()" <> " CASCADE" -getTriggerSql - :: Ops - -> TriggerName +mkAllTriggersQ + :: TriggerName -> QualifiedTable -> [PGColumnInfo] -> Bool + -> TriggerOpsDef + -> Q.TxE QErr () +mkAllTriggersQ trn qt allCols strfyNum fullspec = do + let insertDef = tdInsert fullspec + updateDef = tdUpdate fullspec + deleteDef = tdDelete fullspec + onJust insertDef (mkTriggerQ trn qt allCols strfyNum INSERT) + onJust updateDef (mkTriggerQ trn qt allCols strfyNum UPDATE) + onJust deleteDef (mkTriggerQ trn qt allCols strfyNum DELETE) + +mkTriggerQ + :: TriggerName + -> QualifiedTable + -> [PGColumnInfo] + -> Bool + -> Ops -> SubscribeOpSpec - -> Maybe T.Text -getTriggerSql op trn qt allCols strfyNum spec = - let globalCtx = HashMap.fromList - [ (T.pack "NAME", triggerNameToTxt trn) - , (T.pack "QUALIFIED_TRIGGER_NAME", pgIdenTrigger op trn) - , (T.pack "QUALIFIED_TABLE", toSQLTxt qt) - ] - opCtx = createOpCtx op spec - context = HashMap.union globalCtx opCtx - in - renderGingerTmplt context <$> triggerTmplt + -> Q.TxE QErr () +mkTriggerQ trn qt allCols strfyNum op (SubscribeOpSpec columns payload) = + Q.multiQE defaultTxErrorHandler $ {-# SCC getTriggerSql #-} Q.fromText . TL.toStrict $ + let name = triggerNameToTxt trn + qualifiedTriggerName = pgIdenTrigger op trn + qualifiedTable = toSQLTxt qt + + operation = T.pack $ show op + oldRow = toSQLTxt $ renderRow OLD columns + newRow = toSQLTxt $ renderRow NEW columns + oldPayloadExpression = toSQLTxt . renderOldDataExp op $ fromMaybePayload payload + newPayloadExpression = toSQLTxt . renderNewDataExp op $ fromMaybePayload payload + in $(ST.stextFile "src-rsr/trigger.sql.shakespeare") where - createOpCtx op1 (SubscribeOpSpec columns payload) = - HashMap.fromList - [ (T.pack "OPERATION", T.pack $ show op1) - , (T.pack "OLD_ROW", toSQLTxt $ renderRow OLD columns ) - , (T.pack "NEW_ROW", toSQLTxt $ renderRow NEW columns ) - , (T.pack "OLD_PAYLOAD_EXPRESSION", toSQLTxt $ renderOldDataExp op1 $ fromMaybePayload payload ) - , (T.pack "NEW_PAYLOAD_EXPRESSION", toSQLTxt $ renderNewDataExp op1 $ fromMaybePayload payload ) - ] renderOldDataExp op2 scs = case op2 of INSERT -> S.SENull @@ -115,35 +118,6 @@ getTriggerSql op trn qt allCols strfyNum spec = fromMaybePayload = fromMaybe SubCStar -mkAllTriggersQ - :: TriggerName - -> QualifiedTable - -> [PGColumnInfo] - -> Bool - -> TriggerOpsDef - -> Q.TxE QErr () -mkAllTriggersQ trn qt allCols strfyNum fullspec = do - let insertDef = tdInsert fullspec - updateDef = tdUpdate fullspec - deleteDef = tdDelete fullspec - onJust insertDef (mkTriggerQ trn qt allCols strfyNum INSERT) - onJust updateDef (mkTriggerQ trn qt allCols strfyNum UPDATE) - onJust deleteDef (mkTriggerQ trn qt allCols strfyNum DELETE) - -mkTriggerQ - :: TriggerName - -> QualifiedTable - -> [PGColumnInfo] - -> Bool - -> Ops - -> SubscribeOpSpec - -> Q.TxE QErr () -mkTriggerQ trn qt allCols strfyNum op spec = do - let mTriggerSql = getTriggerSql op trn qt allCols strfyNum spec - case mTriggerSql of - Just sql -> Q.multiQE defaultTxErrorHandler (Q.fromText sql) - Nothing -> throw500 "no trigger sql generated" - delTriggerQ :: TriggerName -> Q.TxE QErr () delTriggerQ trn = mapM_ (\op -> Q.unitQE defaultTxErrorHandler diff --git a/server/src-lib/Hasura/RQL/DDL/Permission.hs b/server/src-lib/Hasura/RQL/DDL/Permission.hs index 279e33ff50a1b..cd6c6dfdf31b5 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission.hs @@ -156,8 +156,7 @@ buildInsPermInfo tabInfo (PermDef rn (InsPerm chk set mCols) _) = buildInsInfra :: QualifiedTable -> InsPermInfo -> Q.TxE QErr () buildInsInfra tn (InsPermInfo _ vn be _ _) = do resolvedBoolExp <- convAnnBoolExpPartialSQL sessVarFromCurrentSetting be - trigFnQ <- buildInsTrigFn vn tn $ - toSQLBoolExp (S.QualVar "NEW") resolvedBoolExp + let trigFnQ = buildInsTrigFn vn tn $ toSQLBoolExp (S.QualVar "NEW") resolvedBoolExp Q.catchE defaultTxErrorHandler $ do -- Create the view Q.unitQ (buildView tn vn) () False diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs index 12d11af69f4ea..785f95d7210a4 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs @@ -1,16 +1,17 @@ -module Hasura.RQL.DDL.Permission.Triggers where +module Hasura.RQL.DDL.Permission.Triggers + ( buildInsTrig + , dropInsTrigFn + , buildInsTrigFn + ) where import Hasura.Prelude -import Hasura.RQL.Types -import Hasura.Server.Utils import Hasura.SQL.Types import qualified Database.PG.Query as Q import qualified Hasura.SQL.DML as S -import qualified Data.Aeson as J -import qualified Data.FileEmbed as FE -import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Text.Shakespeare.Text as ST buildInsTrig :: QualifiedTable -> Q.Query buildInsTrig qt@(QualifiedObject _ tn) = @@ -25,23 +26,10 @@ dropInsTrigFn :: QualifiedTable -> Q.Query dropInsTrigFn fn = Q.fromBuilder $ "DROP FUNCTION " <> toSQL fn <> "()" -getInsTrigTmplt :: (MonadError QErr m) => m GingerTmplt -getInsTrigTmplt = - either throwErr return $ parseGingerTmplt trigFnSrc - where - trigFnSrc = $(FE.embedStringFile "src-rsr/insert_trigger.sql.j2") - - throwErr e = throw500 $ "cannot render insert trigger function template: " - <> T.pack e - -buildInsTrigFn - :: (MonadError QErr m) - => QualifiedTable -> QualifiedTable -> S.BoolExp -> m Q.Query -buildInsTrigFn fn tn be = do - insTmplt <- getInsTrigTmplt - return $ Q.fromText $ renderGingerTmplt tmpltVals insTmplt - where - tmpltVals = J.object [ "function_name" J..= toSQLTxt fn - , "table_name" J..= toSQLTxt tn - , "check_expression" J..= toSQLTxt be - ] +{-# SCC buildInsTrigFn #-} +buildInsTrigFn :: QualifiedTable -> QualifiedTable -> S.BoolExp -> Q.Query +buildInsTrigFn fn tn be = Q.fromText . TL.toStrict $ + let functionName = toSQLTxt fn + tableName = toSQLTxt tn + checkExpression = toSQLTxt be + in $(ST.stextFile "src-rsr/insert_trigger.sql.shakespeare") diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs index e51c1e9ce9004..51a093994355e 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs @@ -116,6 +116,7 @@ runReloadRemoteSchema (RemoteSchemaNameQuery name) = do return successMsg -- | build GraphQL schema +{-# SCC buildGCtxMap #-} buildGCtxMap :: (QErrM m, CacheRWM m) => m () buildGCtxMap = do diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs index 7481707dce361..208e3d658eaa7 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs @@ -58,6 +58,7 @@ buildSchemaCache = buildSchemaCacheWithOptions True buildSchemaCacheWithoutSetup :: (CacheBuildM m) => m () buildSchemaCacheWithoutSetup = buildSchemaCacheWithOptions False +{-# SCC buildSchemaCacheWithOptions #-} buildSchemaCacheWithOptions :: (CacheBuildM m) => Bool -> m () buildSchemaCacheWithOptions withSetup = do -- clean hdb_views diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs index 27de8b795e6a7..327e210e8986f 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs @@ -21,6 +21,7 @@ import Hasura.RQL.Types.SchemaCache import Hasura.RQL.Types.Common import Hasura.SQL.Types +{-# SCC fetchCatalogData #-} fetchCatalogData :: (MonadTx m) => m CatalogMetadata fetchCatalogData = liftTx $ Q.getAltJ . runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/catalog_metadata.sql") () True diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 43506d4978251..13f9942f83365 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -198,6 +198,7 @@ peelRun sc runCtx@(RunCtx userInfo _ _ _) pgExecCtx (Run m) = where lazyTx = runReaderT (runStateT m sc) runCtx +{-# SCC runQuery #-} runQuery :: (MonadIO m, MonadError QErr m) => PGExecCtx -> InstanceId @@ -280,6 +281,7 @@ queryNeedsReload (RQV2 qi) = case qi of RQV2TrackTable _ -> True RQV2SetTableCustomFields _ -> True +{-# SCC runQueryM #-} runQueryM :: ( QErrM m, CacheRWM m, UserInfoM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m diff --git a/server/src-lib/Hasura/Server/Utils.hs b/server/src-lib/Hasura/Server/Utils.hs index c85fc37b72ac2..8a8668ed16655 100644 --- a/server/src-lib/Hasura/Server/Utils.hs +++ b/server/src-lib/Hasura/Server/Utils.hs @@ -21,7 +21,6 @@ import qualified Data.UUID.V4 as UUID import qualified Language.Haskell.TH.Syntax as TH import qualified Network.HTTP.Client as HC import qualified Network.HTTP.Types as HTTP -import qualified Text.Ginger as TG import qualified Text.Regex.TDFA as TDFA import qualified Text.Regex.TDFA.ByteString as TDFA @@ -93,20 +92,6 @@ runScript fp = do ++ show exitCode ++ " and with error : " ++ stdErr TH.lift stdOut --- Ginger Templating -type GingerTmplt = TG.Template TG.SourcePos - -parseGingerTmplt :: TG.Source -> Either String GingerTmplt -parseGingerTmplt src = either parseE Right res - where - res = runIdentity $ TG.parseGinger' parserOptions src - parserOptions = TG.mkParserOptions resolver - resolver = const $ return Nothing - parseE e = Left $ TG.formatParserError (Just "") e - -renderGingerTmplt :: (ToJSON a) => a -> GingerTmplt -> T.Text -renderGingerTmplt v = TG.easyRender (toJSON v) - -- find duplicates duplicates :: Ord a => [a] -> [a] duplicates = mapMaybe greaterThanOne . group . sort diff --git a/server/src-rsr/insert_trigger.sql.j2 b/server/src-rsr/insert_trigger.sql.shakespeare similarity index 65% rename from server/src-rsr/insert_trigger.sql.j2 rename to server/src-rsr/insert_trigger.sql.shakespeare index da5128428caf6..1e8ce7c8e5250 100644 --- a/server/src-rsr/insert_trigger.sql.j2 +++ b/server/src-rsr/insert_trigger.sql.shakespeare @@ -1,14 +1,14 @@ -CREATE OR REPLACE FUNCTION {{function_name}}() RETURNS trigger LANGUAGE plpgsql AS $$ - DECLARE r {{table_name}}%ROWTYPE; +CREATE OR REPLACE FUNCTION #{functionName}() RETURNS trigger LANGUAGE plpgsql AS $$ + DECLARE r #{tableName}%ROWTYPE; DECLARE conflict_clause jsonb; DECLARE action text; DECLARE constraint_name text; DECLARE set_expression text; BEGIN conflict_clause = current_setting('hasura.conflict_clause')::jsonb; - IF ({{check_expression}}) THEN + IF (#{checkExpression}) THEN CASE - WHEN conflict_clause = 'null'::jsonb THEN INSERT INTO {{table_name}} VALUES (NEW.*) RETURNING * INTO r; + WHEN conflict_clause = 'null'::jsonb THEN INSERT INTO #{tableName} VALUES (NEW.*) RETURNING * INTO r; ELSE action = conflict_clause ->> 'action'; constraint_name = quote_ident(conflict_clause ->> 'constraint'); @@ -16,12 +16,12 @@ CREATE OR REPLACE FUNCTION {{function_name}}() RETURNS trigger LANGUAGE plpgsql IF action is NOT NULL THEN CASE WHEN action = 'ignore'::text AND constraint_name IS NULL THEN - INSERT INTO {{table_name}} VALUES (NEW.*) ON CONFLICT DO NOTHING RETURNING * INTO r; + INSERT INTO #{tableName} VALUES (NEW.*) ON CONFLICT DO NOTHING RETURNING * INTO r; WHEN action = 'ignore'::text AND constraint_name is NOT NULL THEN - EXECUTE 'INSERT INTO {{table_name}} VALUES ($1.*) ON CONFLICT ON CONSTRAINT ' || constraint_name || + EXECUTE 'INSERT INTO #{tableName} VALUES ($1.*) ON CONFLICT ON CONSTRAINT ' || constraint_name || ' DO NOTHING RETURNING *' INTO r USING NEW; ELSE - EXECUTE 'INSERT INTO {{table_name}} VALUES ($1.*) ON CONFLICT ON CONSTRAINT ' || constraint_name || + EXECUTE 'INSERT INTO #{tableName} VALUES ($1.*) ON CONFLICT ON CONSTRAINT ' || constraint_name || ' DO UPDATE ' || set_expression || ' RETURNING *' INTO r USING NEW; END CASE; ELSE diff --git a/server/src-rsr/trigger.sql.j2 b/server/src-rsr/trigger.sql.shakespeare similarity index 52% rename from server/src-rsr/trigger.sql.j2 rename to server/src-rsr/trigger.sql.shakespeare index 01adb8928b31d..2da5068d73a1f 100644 --- a/server/src-rsr/trigger.sql.j2 +++ b/server/src-rsr/trigger.sql.shakespeare @@ -1,4 +1,4 @@ -CREATE OR REPLACE function hdb_views.{{QUALIFIED_TRIGGER_NAME}}() RETURNS trigger +CREATE OR REPLACE function hdb_views.#{qualifiedTriggerName}() RETURNS trigger LANGUAGE plpgsql AS $$ DECLARE @@ -7,29 +7,29 @@ CREATE OR REPLACE function hdb_views.{{QUALIFIED_TRIGGER_NAME}}() RETURNS trigge _data json; BEGIN IF TG_OP = 'UPDATE' THEN - _old := {{OLD_ROW}}; - _new := {{NEW_ROW}}; + _old := #{oldRow}; + _new := #{newRow}; ELSE /* initialize _old and _new with dummy values for INSERT and UPDATE events*/ _old := row((select 1)); _new := row((select 1)); END IF; _data := json_build_object( - 'old', {{OLD_PAYLOAD_EXPRESSION}}, - 'new', {{NEW_PAYLOAD_EXPRESSION}} + 'old', #{oldPayloadExpression}, + 'new', #{newPayloadExpression} ); BEGIN IF (TG_OP <> 'UPDATE') OR (_old <> _new) THEN - PERFORM hdb_catalog.insert_event_log(CAST(TG_TABLE_SCHEMA AS text), CAST(TG_TABLE_NAME AS text), CAST('{{NAME}}' AS text), TG_OP, _data); + PERFORM hdb_catalog.insert_event_log(CAST(TG_TABLE_SCHEMA AS text), CAST(TG_TABLE_NAME AS text), CAST('#{name}' AS text), TG_OP, _data); END IF; EXCEPTION WHEN undefined_function THEN IF (TG_OP <> 'UPDATE') OR (_old *<> _new) THEN - PERFORM hdb_catalog.insert_event_log(CAST(TG_TABLE_SCHEMA AS text), CAST(TG_TABLE_NAME AS text), CAST('{{NAME}}' AS text), TG_OP, _data); + PERFORM hdb_catalog.insert_event_log(CAST(TG_TABLE_SCHEMA AS text), CAST(TG_TABLE_NAME AS text), CAST('#{name}' AS text), TG_OP, _data); END IF; END; RETURN NULL; END; $$; -DROP TRIGGER IF EXISTS {{QUALIFIED_TRIGGER_NAME}} ON {{QUALIFIED_TABLE}}; -CREATE TRIGGER {{QUALIFIED_TRIGGER_NAME}} AFTER {{OPERATION}} ON {{QUALIFIED_TABLE}} FOR EACH ROW EXECUTE PROCEDURE hdb_views.{{QUALIFIED_TRIGGER_NAME}}(); +DROP TRIGGER IF EXISTS #{qualifiedTriggerName} ON #{qualifiedTable}; +CREATE TRIGGER #{qualifiedTriggerName} AFTER #{operation} ON #{qualifiedTable} FOR EACH ROW EXECUTE PROCEDURE hdb_views.#{qualifiedTriggerName}(); diff --git a/server/stack.yaml b/server/stack.yaml index ca9a0bfca6b72..cb482453d1e38 100644 --- a/server/stack.yaml +++ b/server/stack.yaml @@ -22,7 +22,10 @@ extra-deps: commit: f3d9b645efd9adb143e2ad4c6b73bded1578a4e9 - git: https://github.com/hasura/ci-info-hs.git commit: ad6df731584dc89b72a6e131687d37ef01714fe8 -- ginger-0.8.4.0 + +# waiting on PR yesodweb/shakespeare#240 +- git: https://github.com/lexi-lambda/shakespeare.git + commit: afa3df51b018ab30ae6a12a51896ddf5d14daaa0 # extra dep for pg-client-hs - select-0.4.0.1 diff --git a/server/stack.yaml.lock b/server/stack.yaml.lock index b96d6052e3c17..0d4c7cb8aa4ff 100644 --- a/server/stack.yaml.lock +++ b/server/stack.yaml.lock @@ -47,12 +47,19 @@ packages: git: https://github.com/hasura/ci-info-hs.git commit: ad6df731584dc89b72a6e131687d37ef01714fe8 - completed: - hackage: ginger-0.8.4.0@sha256:21c3051af3c90af39c40a50400c9a1a0fcccb544528e37cde30bdd30048437d8,3151 + cabal-file: + size: 4674 + sha256: ef416f21e34db04be7920c0be5df12535f019ba4b4ccd06bed865fe58c7ec05c + name: shakespeare + version: 2.0.21 + git: https://github.com/lexi-lambda/shakespeare.git pantry-tree: - size: 1375 - sha256: f8a7cb091ea4d8011bd530f83a22941a009d97ee7ccd4c93d0528aa72f3636ea + size: 4129 + sha256: 62553f7c1b0705228a2526aef38c55dbdc0d28fcb5dd7956b592dc2dc5cb56aa + commit: afa3df51b018ab30ae6a12a51896ddf5d14daaa0 original: - hackage: ginger-0.8.4.0 + git: https://github.com/lexi-lambda/shakespeare.git + commit: afa3df51b018ab30ae6a12a51896ddf5d14daaa0 - completed: hackage: select-0.4.0.1@sha256:d409315752a069693bdd4169fa9a8ea7777d814da77cd8604f367cf0741de295,2492 pantry-tree: From 18ba16e9b23e88a7c8679adcd44e9ca73e8eb083 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 9 Oct 2019 05:16:49 -0500 Subject: [PATCH 05/10] wip: remove SCC pragmas --- server/src-exec/Migrate.hs | 11 ++--------- server/src-lib/Hasura/GraphQL/RemoteServer.hs | 5 ++--- server/src-lib/Hasura/GraphQL/Schema.hs | 1 - server/src-lib/Hasura/RQL/DDL/EventTrigger.hs | 2 +- server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs | 1 - server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs | 1 - server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs | 1 - server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs | 1 - server/src-lib/Hasura/Server/Query.hs | 2 -- 9 files changed, 5 insertions(+), 20 deletions(-) diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index cd96dc04df365..887ae55c3bf86 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -29,9 +29,6 @@ import qualified Language.Haskell.TH.Syntax as TH import Migrate.Version (latestCatalogVersion) -import Debug.Trace - -{-# SCC migrateCatalog #-} migrateCatalog :: forall m . ( MonadTx m @@ -81,10 +78,8 @@ migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion : migrationsFromFile [5..latestCatalogVersion]) postMigrate = do - liftIO $ traceIO "postMigrate" updateCatalogVersion replaceSystemMetadata - liftIO $ traceIO "buildSchemaCacheStrict" buildSchemaCacheStrict pure $ "successfully migrated to " <> latestCatalogVersionString @@ -95,10 +90,8 @@ migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion |] (latestCatalogVersionString, migrationTime) False replaceSystemMetadata = do - liftIO $ traceIO "clearSystemMetadata" - {-# SCC clearSystemMetadata #-} runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") - liftIO $ traceIO "createSystemMetadata" - {-# SCC createSystemMetadata #-} void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") + runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") + void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do Q.unitQ [Q.sql| diff --git a/server/src-lib/Hasura/GraphQL/RemoteServer.hs b/server/src-lib/Hasura/GraphQL/RemoteServer.hs index 06125696053fd..f4aa1537b78b6 100644 --- a/server/src-lib/Hasura/GraphQL/RemoteServer.hs +++ b/server/src-lib/Hasura/GraphQL/RemoteServer.hs @@ -31,7 +31,6 @@ import qualified Hasura.GraphQL.Validate.Types as VT introspectionQuery :: BL.ByteString introspectionQuery = $(embedStringFile "src-rsr/introspection.json") -{-# SCC fetchRemoteSchema #-} fetchRemoteSchema :: (MonadIO m, MonadError QErr m) => HTTP.Manager @@ -52,7 +51,7 @@ fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _ timeout) = , HTTP.requestBody = HTTP.RequestBodyLBS introspectionQuery , HTTP.responseTimeout = HTTP.responseTimeoutMicro (timeout * 1000000) } - res <- {-# SCC "fetchRemoteSchema/HTTP" #-} liftIO $ try $ HTTP.httpLbs req manager + res <- liftIO $ try $ HTTP.httpLbs req manager resp <- either throwHttpErr return res let respData = resp ^. Wreq.responseBody @@ -60,7 +59,7 @@ fetchRemoteSchema manager name def@(RemoteSchemaInfo url headerConf _ timeout) = when (statusCode /= 200) $ throwNon200 statusCode respData introspectRes :: (FromIntrospection IntrospectionResult) <- - either (remoteSchemaErr . T.pack) return $ {-# SCC "fetchRemoteSchema/decodeJSON" #-} J.eitherDecode respData + either (remoteSchemaErr . T.pack) return $ J.eitherDecode respData let (sDoc, qRootN, mRootN, sRootN) = fromIntrospection introspectRes typMap <- either remoteSchemaErr return $ VT.fromSchemaDoc sDoc $ diff --git a/server/src-lib/Hasura/GraphQL/Schema.hs b/server/src-lib/Hasura/GraphQL/Schema.hs index 0b06a8774e811..7d54e8445e0f5 100644 --- a/server/src-lib/Hasura/GraphQL/Schema.hs +++ b/server/src-lib/Hasura/GraphQL/Schema.hs @@ -647,7 +647,6 @@ mkGCtxMap tableCache functionCache = do return $ Map.keys query <> Map.keys mutation -- | build GraphQL schema from postgres tables and functions -{-# SCC buildGCtxMapPG #-} buildGCtxMapPG :: (QErrM m, CacheRWM m) => m () diff --git a/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs b/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs index 62051ce5d0705..108bbfa382204 100644 --- a/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs +++ b/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs @@ -69,7 +69,7 @@ mkTriggerQ -> SubscribeOpSpec -> Q.TxE QErr () mkTriggerQ trn qt allCols strfyNum op (SubscribeOpSpec columns payload) = - Q.multiQE defaultTxErrorHandler $ {-# SCC getTriggerSql #-} Q.fromText . TL.toStrict $ + Q.multiQE defaultTxErrorHandler $ Q.fromText . TL.toStrict $ let name = triggerNameToTxt trn qualifiedTriggerName = pgIdenTrigger op trn qualifiedTable = toSQLTxt qt diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs index 785f95d7210a4..c2e2539aafbb0 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs @@ -26,7 +26,6 @@ dropInsTrigFn :: QualifiedTable -> Q.Query dropInsTrigFn fn = Q.fromBuilder $ "DROP FUNCTION " <> toSQL fn <> "()" -{-# SCC buildInsTrigFn #-} buildInsTrigFn :: QualifiedTable -> QualifiedTable -> S.BoolExp -> Q.Query buildInsTrigFn fn tn be = Q.fromText . TL.toStrict $ let functionName = toSQLTxt fn diff --git a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs index 51a093994355e..e51c1e9ce9004 100644 --- a/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs +++ b/server/src-lib/Hasura/RQL/DDL/RemoteSchema.hs @@ -116,7 +116,6 @@ runReloadRemoteSchema (RemoteSchemaNameQuery name) = do return successMsg -- | build GraphQL schema -{-# SCC buildGCtxMap #-} buildGCtxMap :: (QErrM m, CacheRWM m) => m () buildGCtxMap = do diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs index 208e3d658eaa7..7481707dce361 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Cache.hs @@ -58,7 +58,6 @@ buildSchemaCache = buildSchemaCacheWithOptions True buildSchemaCacheWithoutSetup :: (CacheBuildM m) => m () buildSchemaCacheWithoutSetup = buildSchemaCacheWithOptions False -{-# SCC buildSchemaCacheWithOptions #-} buildSchemaCacheWithOptions :: (CacheBuildM m) => Bool -> m () buildSchemaCacheWithOptions withSetup = do -- clean hdb_views diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs index 327e210e8986f..27de8b795e6a7 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs @@ -21,7 +21,6 @@ import Hasura.RQL.Types.SchemaCache import Hasura.RQL.Types.Common import Hasura.SQL.Types -{-# SCC fetchCatalogData #-} fetchCatalogData :: (MonadTx m) => m CatalogMetadata fetchCatalogData = liftTx $ Q.getAltJ . runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler $(Q.sqlFromFile "src-rsr/catalog_metadata.sql") () True diff --git a/server/src-lib/Hasura/Server/Query.hs b/server/src-lib/Hasura/Server/Query.hs index 13f9942f83365..43506d4978251 100644 --- a/server/src-lib/Hasura/Server/Query.hs +++ b/server/src-lib/Hasura/Server/Query.hs @@ -198,7 +198,6 @@ peelRun sc runCtx@(RunCtx userInfo _ _ _) pgExecCtx (Run m) = where lazyTx = runReaderT (runStateT m sc) runCtx -{-# SCC runQuery #-} runQuery :: (MonadIO m, MonadError QErr m) => PGExecCtx -> InstanceId @@ -281,7 +280,6 @@ queryNeedsReload (RQV2 qi) = case qi of RQV2TrackTable _ -> True RQV2SetTableCustomFields _ -> True -{-# SCC runQueryM #-} runQueryM :: ( QErrM m, CacheRWM m, UserInfoM m, MonadTx m , MonadIO m, HasHttpManager m, HasSQLGenCtx m From 5650bcc11f5964b91b8d0300410de1747c751773 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Wed, 9 Oct 2019 05:21:44 -0500 Subject: [PATCH 06/10] wip: stylish-haskell --- server/src-exec/Main.hs | 3 ++- server/src-exec/Migrate.hs | 2 +- server/src-exec/Migrate/Version.hs | 2 +- server/src-lib/Hasura/RQL/DDL/EventTrigger.hs | 4 ++-- server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs | 6 +++--- server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs | 2 +- 6 files changed, 10 insertions(+), 9 deletions(-) diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index 5a135a0bbf22c..3114fdf035853 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -29,7 +29,8 @@ import Hasura.Logging import Hasura.Prelude import Hasura.RQL.DDL.Metadata (fetchMetadata) import Hasura.RQL.Types (SQLGenCtx (..), SchemaCache (..), - adminUserInfo, emptySchemaCache, SystemDefined(..)) + SystemDefined (..), adminUserInfo, + emptySchemaCache) import Hasura.Server.App (HasuraApp (..), SchemaCacheRef (..), getSCFromRef, logInconsObjs, mkWaiApp) diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 887ae55c3bf86..4ea0509ce9263 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -27,7 +27,7 @@ import qualified Database.PG.Query as Q import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH -import Migrate.Version (latestCatalogVersion) +import Migrate.Version (latestCatalogVersion) migrateCatalog :: forall m diff --git a/server/src-exec/Migrate/Version.hs b/server/src-exec/Migrate/Version.hs index 865953cd80eef..cdb70a6ee8e64 100644 --- a/server/src-exec/Migrate/Version.hs +++ b/server/src-exec/Migrate/Version.hs @@ -4,7 +4,7 @@ -- "Migrate". module Migrate.Version (latestCatalogVersion) where -import Hasura.Prelude +import Hasura.Prelude latestCatalogVersion :: Integer latestCatalogVersion = 24 diff --git a/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs b/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs index 108bbfa382204..1a6320be517ea 100644 --- a/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs +++ b/server/src-lib/Hasura/RQL/DDL/EventTrigger.hs @@ -28,9 +28,9 @@ import System.Environment (lookupEnv) import qualified Hasura.SQL.DML as S import qualified Data.Text as T +import qualified Data.Text.Lazy as TL import qualified Database.PG.Query as Q -import qualified Data.Text.Lazy as TL -import qualified Text.Shakespeare.Text as ST +import qualified Text.Shakespeare.Text as ST data OpVar = OLD | NEW deriving (Show) diff --git a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs index c2e2539aafbb0..63d2be11c3490 100644 --- a/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs +++ b/server/src-lib/Hasura/RQL/DDL/Permission/Triggers.hs @@ -7,10 +7,10 @@ module Hasura.RQL.DDL.Permission.Triggers import Hasura.Prelude import Hasura.SQL.Types -import qualified Database.PG.Query as Q -import qualified Hasura.SQL.DML as S +import qualified Database.PG.Query as Q +import qualified Hasura.SQL.DML as S -import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy as TL import qualified Text.Shakespeare.Text as ST buildInsTrig :: QualifiedTable -> Q.Query diff --git a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs index 27de8b795e6a7..34abb427e0ded 100644 --- a/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs +++ b/server/src-lib/Hasura/RQL/DDL/Schema/Catalog.hs @@ -17,8 +17,8 @@ import Data.Aeson import Hasura.Db import Hasura.RQL.Types.Catalog -import Hasura.RQL.Types.SchemaCache import Hasura.RQL.Types.Common +import Hasura.RQL.Types.SchemaCache import Hasura.SQL.Types fetchCatalogData :: (MonadTx m) => m CatalogMetadata From cd73efc7af709e9344e715b52c65fbe32d6f49a0 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 10 Oct 2019 01:29:31 -0500 Subject: [PATCH 07/10] wip: switch to shakespeare from hackage --- server/graphql-engine.cabal | 2 +- server/stack.yaml | 6 ++---- server/stack.yaml.lock | 21 +++++++-------------- 3 files changed, 10 insertions(+), 19 deletions(-) diff --git a/server/graphql-engine.cabal b/server/graphql-engine.cabal index a3b1b29a48935..c9de5c1f45bf2 100644 --- a/server/graphql-engine.cabal +++ b/server/graphql-engine.cabal @@ -108,7 +108,7 @@ library -- Templating , mustache , file-embed - , shakespeare + , shakespeare >= 2.0.22 -- , data-has diff --git a/server/stack.yaml b/server/stack.yaml index cb482453d1e38..4411b07169a4f 100644 --- a/server/stack.yaml +++ b/server/stack.yaml @@ -23,10 +23,6 @@ extra-deps: - git: https://github.com/hasura/ci-info-hs.git commit: ad6df731584dc89b72a6e131687d37ef01714fe8 -# waiting on PR yesodweb/shakespeare#240 -- git: https://github.com/lexi-lambda/shakespeare.git - commit: afa3df51b018ab30ae6a12a51896ddf5d14daaa0 - # extra dep for pg-client-hs - select-0.4.0.1 @@ -36,6 +32,8 @@ extra-deps: - reroute-0.5.0.0 - Spock-core-0.13.0.0 - monad-validate-1.2.0.0 +# needed for Text.Shakespeare.Text.stextFile; can be removed once the newer version is in stackage +- shakespeare-2.0.22 - brotli-0.0.0.0 diff --git a/server/stack.yaml.lock b/server/stack.yaml.lock index 0d4c7cb8aa4ff..9a58603f7176b 100644 --- a/server/stack.yaml.lock +++ b/server/stack.yaml.lock @@ -46,20 +46,6 @@ packages: original: git: https://github.com/hasura/ci-info-hs.git commit: ad6df731584dc89b72a6e131687d37ef01714fe8 -- completed: - cabal-file: - size: 4674 - sha256: ef416f21e34db04be7920c0be5df12535f019ba4b4ccd06bed865fe58c7ec05c - name: shakespeare - version: 2.0.21 - git: https://github.com/lexi-lambda/shakespeare.git - pantry-tree: - size: 4129 - sha256: 62553f7c1b0705228a2526aef38c55dbdc0d28fcb5dd7956b592dc2dc5cb56aa - commit: afa3df51b018ab30ae6a12a51896ddf5d14daaa0 - original: - git: https://github.com/lexi-lambda/shakespeare.git - commit: afa3df51b018ab30ae6a12a51896ddf5d14daaa0 - completed: hackage: select-0.4.0.1@sha256:d409315752a069693bdd4169fa9a8ea7777d814da77cd8604f367cf0741de295,2492 pantry-tree: @@ -109,6 +95,13 @@ packages: sha256: 8e049bd12ce2bd470909578f2ee8eb80b89d5ff88860afa30e29dd4eafecfa3e original: hackage: monad-validate-1.2.0.0 +- completed: + hackage: shakespeare-2.0.22@sha256:d6b154e21e3307d7ca30ae505bad865d0408efe317ec47eb81f559e6ae57ae81,4674 + pantry-tree: + size: 3585 + sha256: 3561f4c3121d05e5390c2b32f9e0a58b6408ecb5cfb74f234f3b8ca37b467a5e + original: + hackage: shakespeare-2.0.22 - completed: hackage: brotli-0.0.0.0@sha256:0a8232f028dbc6a1f9db291ef996a5abe74aa00c7c3dc00a741c41f3da75a4dc,2873 pantry-tree: From ab9d9d366df3a74dfcc04fbb2f45fd9b18aa3ebf Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 10 Oct 2019 01:58:17 -0500 Subject: [PATCH 08/10] wip: improve migration log messages --- server/src-exec/Main.hs | 5 +-- server/src-exec/Migrate.hs | 66 +++++++++++++++++++----------- server/src-exec/Migrate/Version.hs | 10 ++++- 3 files changed, 53 insertions(+), 28 deletions(-) diff --git a/server/src-exec/Main.hs b/server/src-exec/Main.hs index 3114fdf035853..dfcde6dff5e51 100644 --- a/server/src-exec/Main.hs +++ b/server/src-exec/Main.hs @@ -256,9 +256,8 @@ main = do either printErrJExit (logger . mkGenericStrLog LevelInfo "db_init") initRes -- migrate catalog if necessary - migRes <- runAsAdmin pool sqlGenCtx httpMgr $ - migrateCatalog currentTime - either printErrJExit (logger . mkGenericLog LevelInfo "db_migrate") migRes + migRes <- runAsAdmin pool sqlGenCtx httpMgr $ migrateCatalog currentTime + either printErrJExit logger migRes -- retrieve database id eDbId <- runTx pool getDbId diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 4ea0509ce9263..3004966edc7a5 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -9,8 +9,9 @@ -- The Template Haskell code in this module will automatically compile the new migration script into -- the @graphql-engine@ executable. module Migrate - ( latestCatalogVersion + ( MigrationResult(..) , migrateCatalog + , latestCatalogVersion ) where import Data.Time.Clock (UTCTime) @@ -27,7 +28,27 @@ import qualified Database.PG.Query as Q import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH -import Migrate.Version (latestCatalogVersion) +import Hasura.Logging (ToEngineLog(..), LogLevel(..)) +import Hasura.Server.Logging (StartupLog(..)) +import Migrate.Version (latestCatalogVersion, latestCatalogVersionString) + +data MigrationResult + = MRNothingToDo + | MRMigratedSuccessfully T.Text -- ^ old catalog version + deriving (Show, Eq) + +instance ToEngineLog MigrationResult where + toEngineLog result = toEngineLog $ StartupLog + { slLogLevel = LevelInfo + , slKind = "db_migrate" + , slInfo = A.toJSON $ case result of + MRNothingToDo -> + "Already at the latest catalog version (" <> latestCatalogVersionString + <> "); nothing to do." + MRMigratedSuccessfully oldVersion -> + "Successfully migrated from catalog version " <> oldVersion <> " to version " + <> latestCatalogVersionString <> "." + } migrateCatalog :: forall m @@ -39,21 +60,22 @@ migrateCatalog , MonadIO m , HasSQLGenCtx m ) - => UTCTime -> m T.Text + => UTCTime -> m MigrationResult migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion where -- the old 0.8 catalog version is non-integral, so we store it in the database as a string - latestCatalogVersionString = T.pack $ show latestCatalogVersion - getCatalogVersion = liftTx $ runIdentity . Q.getRow <$> Q.withQE defaultTxErrorHandler [Q.sql| SELECT version FROM hdb_catalog.hdb_version |] () False - migrateFrom :: T.Text -> m T.Text + migrateFrom :: T.Text -> m MigrationResult migrateFrom previousVersion - | previousVersion == latestCatalogVersionString = pure $ - "already at the latest version. current version: " <> latestCatalogVersionString - | [] <- neededMigrations = throw400 NotSupported $ "unsupported version : " <> previousVersion - | otherwise = traverse_ snd neededMigrations *> postMigrate + | previousVersion == latestCatalogVersionString = pure MRNothingToDo + | [] <- neededMigrations = throw400 NotSupported $ + "Cannot use database previously used with a newer version of graphql-engine (expected" + <> " a catalog version <=" <> latestCatalogVersionString <> ", but the current version" + <> " is " <> previousVersion <> ")." + | otherwise = + traverse_ snd neededMigrations *> postMigrate $> MRMigratedSuccessfully previousVersion where neededMigrations = dropWhile ((/= previousVersion) . fst) migrations @@ -77,21 +99,17 @@ migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion ++ [| ("3", from3To4) |] : migrationsFromFile [5..latestCatalogVersion]) - postMigrate = do - updateCatalogVersion - replaceSystemMetadata - buildSchemaCacheStrict - pure $ "successfully migrated to " <> latestCatalogVersionString - - updateCatalogVersion = liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| - UPDATE "hdb_catalog"."hdb_version" - SET "version" = $1, - "upgraded_on" = $2 - |] (latestCatalogVersionString, migrationTime) False + postMigrate = updateCatalogVersion *> replaceSystemMetadata *> buildSchemaCacheStrict + where + updateCatalogVersion = liftTx $ Q.unitQE defaultTxErrorHandler [Q.sql| + UPDATE "hdb_catalog"."hdb_version" + SET "version" = $1, + "upgraded_on" = $2 + |] (latestCatalogVersionString, migrationTime) False - replaceSystemMetadata = do - runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") - void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") + replaceSystemMetadata = do + runTx $(Q.sqlFromFile "src-rsr/clear_system_metadata.sql") + void $ runQueryM $$(Y.decodeFile "src-rsr/hdb_metadata.yaml") from3To4 = liftTx $ Q.catchE defaultTxErrorHandler $ do Q.unitQ [Q.sql| diff --git a/server/src-exec/Migrate/Version.hs b/server/src-exec/Migrate/Version.hs index cdb70a6ee8e64..4ff76205a5960 100644 --- a/server/src-exec/Migrate/Version.hs +++ b/server/src-exec/Migrate/Version.hs @@ -2,9 +2,17 @@ -- circumvent the unfortunate “GHC stage restriction,” which prevents us from using a binding in a -- compile-time splice unless it is defined in a different module. The actual migration code is in -- "Migrate". -module Migrate.Version (latestCatalogVersion) where +module Migrate.Version + ( latestCatalogVersion + , latestCatalogVersionString + ) where import Hasura.Prelude +import qualified Data.Text as T + latestCatalogVersion :: Integer latestCatalogVersion = 24 + +latestCatalogVersionString :: T.Text +latestCatalogVersionString = T.pack $ show latestCatalogVersion From 7b8170365a4d3285c763b30a8028cebdecde063e Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 10 Oct 2019 02:00:40 -0500 Subject: [PATCH 09/10] wip: stylish-haskell --- server/src-exec/Migrate.hs | 7 ++++--- server/src-exec/Migrate/Version.hs | 2 +- 2 files changed, 5 insertions(+), 4 deletions(-) diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 3004966edc7a5..6e58bf5eeb592 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -28,9 +28,10 @@ import qualified Database.PG.Query as Q import qualified Language.Haskell.TH.Lib as TH import qualified Language.Haskell.TH.Syntax as TH -import Hasura.Logging (ToEngineLog(..), LogLevel(..)) -import Hasura.Server.Logging (StartupLog(..)) -import Migrate.Version (latestCatalogVersion, latestCatalogVersionString) +import Hasura.Logging (LogLevel (..), ToEngineLog (..)) +import Hasura.Server.Logging (StartupLog (..)) +import Migrate.Version (latestCatalogVersion, + latestCatalogVersionString) data MigrationResult = MRNothingToDo diff --git a/server/src-exec/Migrate/Version.hs b/server/src-exec/Migrate/Version.hs index 4ff76205a5960..adc1da458bbd7 100644 --- a/server/src-exec/Migrate/Version.hs +++ b/server/src-exec/Migrate/Version.hs @@ -9,7 +9,7 @@ module Migrate.Version import Hasura.Prelude -import qualified Data.Text as T +import qualified Data.Text as T latestCatalogVersion :: Integer latestCatalogVersion = 24 From b9bfb0698fbe90047816d30634334826b208e339 Mon Sep 17 00:00:00 2001 From: Alexis King Date: Thu, 10 Oct 2019 23:42:23 -0500 Subject: [PATCH 10/10] wip: fix off-by-one error --- server/src-exec/Migrate.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/server/src-exec/Migrate.hs b/server/src-exec/Migrate.hs index 6e58bf5eeb592..d4d70cfbf4864 100644 --- a/server/src-exec/Migrate.hs +++ b/server/src-exec/Migrate.hs @@ -90,9 +90,10 @@ migrateCatalog migrationTime = migrateFrom =<< getCatalogVersion let path = "src-rsr/migrations/" <> from <> "_to_" <> to <> ".sql" in [| runTx $(Q.sqlFromFile path) |] migrationsFromFile = map $ \(to :: Integer) -> - [| ( $(TH.lift $ T.pack (show to)) - , $(migrationFromFile (show (to - 1)) (show to)) - ) |] + let from = to - 1 + in [| ( $(TH.lift $ T.pack (show from)) + , $(migrationFromFile (show from) (show to)) + ) |] in TH.listE -- version 0.8 is the only non-integral catalog version $ [| ("0.8", $(migrationFromFile "08" "1")) |]