graphql-engine/server/src-lib/Hasura/RQL/DDL/Metadata.hs

{-# LANGUAGE RecordWildCards #-}
module Hasura.RQL.DDL.Metadata
  ( runReplaceMetadata
  , runExportMetadata
  , fetchMetadataFromHdbTables
  , runClearMetadata
  , runReloadMetadata
  , runDumpInternalState
  , runGetInconsistentMetadata
  , runDropInconsistentMetadata

  , module Hasura.RQL.DDL.Metadata.Types
  ) where

import           Hasura.Prelude

import qualified Data.Aeson.Ordered                 as AO
import qualified Data.HashMap.Strict                as HM
import qualified Data.HashMap.Strict.InsOrd         as HMIns
import qualified Data.HashSet                       as HS
import qualified Data.HashSet.InsOrd                as HSIns
import qualified Data.List                          as L
import qualified Database.PG.Query                  as Q

import           Control.Lens                       hiding ((.=))
import           Data.Aeson

import qualified Hasura.RQL.DDL.Action              as Action
import qualified Hasura.RQL.DDL.ComputedField       as ComputedField
import qualified Hasura.RQL.DDL.CustomTypes         as CustomTypes
import qualified Hasura.RQL.DDL.Permission          as Permission
import qualified Hasura.RQL.DDL.QueryCollection     as Collection
import qualified Hasura.RQL.DDL.Relationship        as Relationship
import qualified Hasura.RQL.DDL.RemoteRelationship  as RemoteRelationship
import qualified Hasura.RQL.DDL.Schema              as Schema

import           Hasura.Backends.Postgres.SQL.Types
import           Hasura.EncJSON
import           Hasura.RQL.DDL.ComputedField       (dropComputedFieldFromCatalog)
import           Hasura.RQL.DDL.EventTrigger        (delEventTriggerFromCatalog,
                                                     replaceEventTriggersInCatalog)
import           Hasura.RQL.DDL.Metadata.Types
import           Hasura.RQL.DDL.Permission.Internal (dropPermFromCatalog)
import           Hasura.RQL.DDL.RemoteSchema        (addRemoteSchemaToCatalog,
                                                     removeRemoteSchemaFromCatalog)
import           Hasura.RQL.DDL.ScheduledTrigger    (addCronTriggerToCatalog,
                                                     deleteCronTriggerFromCatalog)
import           Hasura.RQL.DDL.Schema.Catalog      (saveTableToCatalog)
import           Hasura.RQL.Types

-- | Purge all user-defined metadata; metadata with is_system_defined = false
clearUserMetadata :: MonadTx m => m ()
clearUserMetadata = liftTx $ Q.catchE defaultTxErrorHandler $ do
  -- Note: we don’t drop event triggers here because we update them a different
  -- way; see Note [Diff-and-patch event triggers on replace] in Hasura.RQL.DDL.EventTrigger.
  Q.unitQ "DELETE FROM hdb_catalog.hdb_function WHERE is_system_defined <> 'true'" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_permission WHERE is_system_defined <> 'true'" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_relationship WHERE is_system_defined <> 'true'" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_computed_field" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_remote_relationship" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_table WHERE is_system_defined <> 'true'" () False
  Q.unitQ "DELETE FROM hdb_catalog.remote_schemas" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_allowlist" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_query_collection WHERE is_system_defined <> 'true'" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_custom_types" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_action_permission" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_action WHERE is_system_defined <> 'true'" () False
  Q.unitQ "DELETE FROM hdb_catalog.hdb_cron_triggers WHERE include_in_metadata" () False

runClearMetadata
  :: (MonadTx m, CacheRWM m)
  => ClearMetadata -> m EncJSON
runClearMetadata _ = do
  clearUserMetadata
  replaceEventTriggersInCatalog mempty
  buildSchemaCacheStrict
  return successMsg

saveMetadata :: (MonadTx m, HasSystemDefined m) => Metadata -> m ()
saveMetadata (Metadata tables functions
              schemas collections allowlist customTypes actions cronTriggers) = do

  withPathK "tables" $ do
    indexedForM_ tables $ \TableMetadata{..} -> do
      -- Save table
      saveTableToCatalog _tmTable _tmIsEnum _tmConfiguration

      -- Relationships
      withPathK "object_relationships" $
        indexedForM_ _tmObjectRelationships $ \objRel ->
        Relationship.insertRelationshipToCatalog _tmTable ObjRel objRel
      withPathK "array_relationships" $
        indexedForM_ _tmArrayRelationships $ \arrRel ->
        Relationship.insertRelationshipToCatalog _tmTable ArrRel arrRel

      -- Computed Fields
      withPathK "computed_fields" $
        indexedForM_ _tmComputedFields $
          \(ComputedFieldMetadata name definition comment) ->
            ComputedField.addComputedFieldToCatalog $
              ComputedField.AddComputedField _tmTable name definition comment

      -- Remote Relationships
      withPathK "remote_relationships" $
        indexedForM_ _tmRemoteRelationships $
          \(RemoteRelationshipMetadata name def) -> do
             let RemoteRelationshipDef rs hf rf = def
             liftTx $ RemoteRelationship.persistRemoteRelationship $
                      RemoteRelationship name _tmTable hf rs rf

      -- Permissions
      withPathK "insert_permissions" $ processPerms _tmTable _tmInsertPermissions
      withPathK "select_permissions" $ processPerms _tmTable _tmSelectPermissions
      withPathK "update_permissions" $ processPerms _tmTable _tmUpdatePermissions
      withPathK "delete_permissions" $ processPerms _tmTable _tmDeletePermissions

    -- Event triggers
    let allEventTriggers = HMIns.elems tables & map \table ->
          (_tmTable table,) <$> HMIns.toHashMap (_tmEventTriggers table)
    replaceEventTriggersInCatalog $ HM.unions allEventTriggers

  -- sql functions
  withPathK "functions" $ indexedForM_ functions $
    \(FunctionMetadata function config) -> Schema.saveFunctionToCatalog function config

  -- query collections
  systemDefined <- askSystemDefined
  withPathK "query_collections" $
    indexedForM_ collections $ \c -> liftTx $ Collection.addCollectionToCatalog c systemDefined

  -- allow list
  withPathK "allowlist" $ do
    indexedForM_ allowlist $ \(Collection.CollectionReq name) ->
      liftTx $ Collection.addCollectionToAllowlistCatalog name

  -- remote schemas
  withPathK "remote_schemas" $
    indexedMapM_ (liftTx . addRemoteSchemaToCatalog) schemas

  -- custom types
  withPathK "custom_types" $
    CustomTypes.persistCustomTypes customTypes

  -- cron triggers
  withPathK "cron_triggers" $
    indexedForM_ cronTriggers $ \ct -> liftTx $ do
    addCronTriggerToCatalog ct

  -- actions
  withPathK "actions" $
    indexedForM_ actions $ \action -> do
      let createAction =
            CreateAction (_amName action) (_amDefinition action) (_amComment action)
      Action.persistCreateAction createAction
      withPathK "permissions" $
        indexedForM_ (_amPermissions action) $ \permission -> do
          let createActionPermission = CreateActionPermission (_amName action)
                                       (_apmRole permission) Nothing (_apmComment permission)
          Action.persistCreateActionPermission createActionPermission

  where
    processPerms tableName perms = indexedForM_ perms $ Permission.addPermP2 tableName

runReplaceMetadata
  :: ( MonadTx m
     , CacheRWM m
     , HasSystemDefined m
     )
  => Metadata -> m EncJSON
runReplaceMetadata metadata = do
  clearUserMetadata
  saveMetadata metadata
  buildSchemaCacheStrict
  pure successMsg

fetchMetadataFromHdbTables :: MonadTx m => m Metadata
fetchMetadataFromHdbTables = liftTx do
  tables <- Q.catchE defaultTxErrorHandler fetchTables
  let tableMetaMap = HMIns.fromList . flip map tables $
        \(schema, name, isEnum, maybeConfig) ->
          let qualifiedName = QualifiedObject schema name
              configuration = maybe emptyTableConfig Q.getAltJ maybeConfig
          in (qualifiedName, mkTableMeta qualifiedName isEnum configuration)

  -- Fetch all the relationships
  relationships <- Q.catchE defaultTxErrorHandler fetchRelationships

  objRelDefs <- mkRelDefs ObjRel relationships
  arrRelDefs <- mkRelDefs ArrRel relationships

  -- Fetch all the permissions
  permissions <- Q.catchE defaultTxErrorHandler fetchPermissions

  -- Parse all the permissions
  insPermDefs <- mkPermDefs PTInsert permissions
  selPermDefs <- mkPermDefs PTSelect permissions
  updPermDefs <- mkPermDefs PTUpdate permissions
  delPermDefs <- mkPermDefs PTDelete permissions

  -- Fetch all event triggers
  eventTriggers <- Q.catchE defaultTxErrorHandler fetchEventTriggers
  triggerMetaDefs <- mkTriggerMetaDefs eventTriggers

  -- Fetch all computed fields
  computedFields <- fetchComputedFields

  -- Fetch all remote relationships
  remoteRelationships <- Q.catchE defaultTxErrorHandler fetchRemoteRelationships

  let (_, fullTableMetaMap) = flip runState tableMetaMap $ do
        modMetaMap tmObjectRelationships _rdName objRelDefs
        modMetaMap tmArrayRelationships _rdName arrRelDefs
        modMetaMap tmInsertPermissions _pdRole insPermDefs
        modMetaMap tmSelectPermissions _pdRole selPermDefs
        modMetaMap tmUpdatePermissions _pdRole updPermDefs
        modMetaMap tmDeletePermissions _pdRole delPermDefs
        modMetaMap tmEventTriggers etcName triggerMetaDefs
        modMetaMap tmComputedFields _cfmName computedFields
        modMetaMap tmRemoteRelationships _rrmName remoteRelationships

  -- fetch all functions
  functions <- Q.catchE defaultTxErrorHandler fetchFunctions

  -- fetch all remote schemas
  remoteSchemas <- oMapFromL _arsqName <$> fetchRemoteSchemas

  -- fetch all collections
  collections <- oMapFromL _ccName <$> fetchCollections

  -- fetch allow list
  allowlist <- HSIns.fromList . map CollectionReq <$> fetchAllowlists

  customTypes <- fetchCustomTypes

  -- fetch actions
  actions <- oMapFromL _amName <$> fetchActions

  cronTriggers <- fetchCronTriggers

  pure $ Metadata fullTableMetaMap functions remoteSchemas collections
                  allowlist customTypes actions cronTriggers

  where
    modMetaMap l f xs = do
      st <- get
      put $ foldl' (\b (qt, dfn) -> b & at qt._Just.l %~ HMIns.insert (f dfn) dfn) st xs

    mkPermDefs pt = mapM permRowToDef . filter (\pr -> pr ^. _4 == pt)

    permRowToDef (sn, tn, rn, _, Q.AltJ pDef, mComment) = do
      perm <- decodeValue pDef
      return (QualifiedObject sn tn,  PermDef rn perm mComment)

    mkRelDefs rt = mapM relRowToDef . filter (\rr -> rr ^. _4 == rt)

    relRowToDef (sn, tn, rn, _, Q.AltJ rDef, mComment) = do
      using <- decodeValue rDef
      return (QualifiedObject sn tn, RelDef rn using mComment)

    mkTriggerMetaDefs = mapM trigRowToDef

    trigRowToDef (sn, tn, Q.AltJ configuration) = do
      conf <- decodeValue configuration
      return (QualifiedObject sn tn, conf::EventTriggerConf)

    fetchTables =
      Q.listQ [Q.sql|
                SELECT table_schema, table_name, is_enum, configuration::json
                FROM hdb_catalog.hdb_table
                 WHERE is_system_defined = 'false'
                ORDER BY table_schema ASC, table_name ASC
                    |] () False

    fetchRelationships =
      Q.listQ [Q.sql|
                SELECT table_schema, table_name, rel_name, rel_type, rel_def::json, comment
                  FROM hdb_catalog.hdb_relationship
                 WHERE is_system_defined = 'false'
                ORDER BY table_schema ASC, table_name ASC, rel_name ASC
                    |] () False

    fetchPermissions =
      Q.listQ [Q.sql|
                SELECT table_schema, table_name, role_name, perm_type, perm_def::json, comment
                  FROM hdb_catalog.hdb_permission
                 WHERE is_system_defined = 'false'
                ORDER BY table_schema ASC, table_name ASC, role_name ASC, perm_type ASC
                    |] () False

    fetchEventTriggers =
     Q.listQ [Q.sql|
              SELECT e.schema_name, e.table_name, e.configuration::json
               FROM hdb_catalog.event_triggers e
              ORDER BY e.schema_name ASC, e.table_name ASC, e.name ASC
              |] () False

    fetchFunctions = do
      l <- Q.listQ [Q.sql|
                SELECT function_schema, function_name, configuration::json
                FROM hdb_catalog.hdb_function
                WHERE is_system_defined = 'false'
                ORDER BY function_schema ASC, function_name ASC
                    |] () False
      pure $ oMapFromL _fmFunction $
        flip map l $ \(sn, fn, Q.AltJ config) ->
                       FunctionMetadata (QualifiedObject sn fn) config

    fetchRemoteSchemas =
      map fromRow <$> Q.listQE defaultTxErrorHandler
        [Q.sql|
         SELECT name, definition, comment
           FROM hdb_catalog.remote_schemas
         ORDER BY name ASC
         |] () True
      where
        fromRow (name, Q.AltJ def, comment) =
          AddRemoteSchemaQuery name def comment


    fetchCollections =
      map fromRow <$> Q.listQE defaultTxErrorHandler [Q.sql|
               SELECT collection_name, collection_defn::json, comment
                 FROM hdb_catalog.hdb_query_collection
                 WHERE is_system_defined = 'false'
               ORDER BY collection_name ASC
              |] () False
      where
        fromRow (name, Q.AltJ defn, mComment) =
          CreateCollection name defn mComment

    fetchAllowlists = map runIdentity <$>
      Q.listQE defaultTxErrorHandler [Q.sql|
          SELECT collection_name
            FROM hdb_catalog.hdb_allowlist
          ORDER BY collection_name ASC
         |] () False

    fetchComputedFields = do
      r <- Q.listQE defaultTxErrorHandler [Q.sql|
              SELECT table_schema, table_name, computed_field_name,
                     definition::json, comment
                FROM hdb_catalog.hdb_computed_field
             |] () False
      pure $ flip map r $ \(schema, table, name, Q.AltJ definition, comment) ->
                          ( QualifiedObject schema table
                          , ComputedFieldMetadata name definition comment
                          )

    fetchCronTriggers =
      (oMapFromL ctName . map uncurryCronTrigger)
              <$> Q.listQE defaultTxErrorHandler
      [Q.sql|
       SELECT ct.name, ct.webhook_conf, ct.cron_schedule, ct.payload,
             ct.retry_conf, ct.header_conf, ct.include_in_metadata, ct.comment
        FROM hdb_catalog.hdb_cron_triggers ct
        WHERE include_in_metadata
      |] () False
      where
        uncurryCronTrigger
          (name, webhook, schedule, payload, retryConfig, headerConfig, includeMetadata, comment) =
          CronTriggerMetadata
          { ctName = name,
            ctWebhook = Q.getAltJ webhook,
            ctSchedule = schedule,
            ctPayload = Q.getAltJ <$> payload,
            ctRetryConf = Q.getAltJ retryConfig,
            ctHeaders = Q.getAltJ headerConfig,
            ctIncludeInMetadata = includeMetadata,
            ctComment = comment
          }

    fetchCustomTypes :: Q.TxE QErr CustomTypes
    fetchCustomTypes =
      Q.getAltJ . runIdentity . Q.getRow <$>
      Q.rawQE defaultTxErrorHandler [Q.sql|
         select coalesce((select custom_types::json from hdb_catalog.hdb_custom_types), '{}'::json)
         |] [] False

    fetchActions =
      Q.getAltJ . runIdentity . Q.getRow <$> Q.rawQE defaultTxErrorHandler [Q.sql|
        select
          coalesce(
            json_agg(
              json_build_object(
                'name', a.action_name,
                'definition', a.action_defn,
                'comment', a.comment,
                'permissions', ap.permissions
              ) order by a.action_name asc
            ),
            '[]'
          )
        from
          hdb_catalog.hdb_action as a
          left outer join lateral (
            select
              coalesce(
                json_agg(
                  json_build_object(
                    'role', ap.role_name,
                    'comment', ap.comment
                  ) order by ap.role_name asc
                ),
                '[]'
              ) as permissions
            from
              hdb_catalog.hdb_action_permission ap
            where
              ap.action_name = a.action_name
          ) ap on true;
                            |] [] False

    fetchRemoteRelationships = do
      r <- Q.listQ [Q.sql|
                SELECT table_schema, table_name,
                       remote_relationship_name, definition::json
                FROM hdb_catalog.hdb_remote_relationship
             |] () False
      pure $ flip map r $ \(schema, table, name, Q.AltJ definition) ->
                          ( QualifiedObject schema table
                          , RemoteRelationshipMetadata name definition
                          )

runExportMetadata
  :: (QErrM m, MonadTx m)
  => ExportMetadata -> m EncJSON
runExportMetadata _ =
  AO.toEncJSON . metadataToOrdJSON <$> fetchMetadataFromHdbTables

runReloadMetadata :: (QErrM m, CacheRWM m) => ReloadMetadata -> m EncJSON
runReloadMetadata (ReloadMetadata reloadRemoteSchemas) = do
  sc <- askSchemaCache
  let remoteSchemaInvalidations =
        if reloadRemoteSchemas then HS.fromList (getAllRemoteSchemas sc) else mempty
  buildSchemaCacheWithOptions CatalogUpdate CacheInvalidations
                                            { ciMetadata = True
                                            , ciRemoteSchemas = remoteSchemaInvalidations
                                            }
  pure successMsg

runDumpInternalState
  :: (QErrM m, CacheRM m)
  => DumpInternalState -> m EncJSON
runDumpInternalState _ =
  encJFromJValue <$> askSchemaCache


runGetInconsistentMetadata
  :: (QErrM m, CacheRM m)
  => GetInconsistentMetadata -> m EncJSON
runGetInconsistentMetadata _ = do
  inconsObjs <- scInconsistentObjs <$> askSchemaCache
  return $ encJFromJValue $ object
                [ "is_consistent" .= null inconsObjs
                , "inconsistent_objects" .= inconsObjs
                ]

runDropInconsistentMetadata
  :: (QErrM m, CacheRWM m, MonadTx m)
  => DropInconsistentMetadata -> m EncJSON
runDropInconsistentMetadata _ = do
  sc <- askSchemaCache
  let inconsSchObjs = L.nub . concatMap imObjectIds $ scInconsistentObjs sc
  -- Note: when building the schema cache, we try to put dependents after their dependencies in the
  -- list of inconsistent objects, so reverse the list to start with dependents first. This is not
  -- perfect — a completely accurate solution would require performing a topological sort — but it
  -- seems to work well enough for now.
  mapM_ purgeMetadataObj (reverse inconsSchObjs)
  buildSchemaCacheStrict
  return successMsg

purgeMetadataObj :: MonadTx m => MetadataObjId -> m ()
purgeMetadataObj = liftTx . \case
  MOTable qt                               -> Schema.deleteTableFromCatalog qt
  MOFunction qf                            -> Schema.delFunctionFromCatalog qf
  MORemoteSchema rsn                       -> removeRemoteSchemaFromCatalog rsn
  MOTableObj qt (MTORel rn _)              -> Relationship.delRelFromCatalog qt rn
  MOTableObj qt (MTOPerm rn pt)            -> dropPermFromCatalog qt rn pt
  MOTableObj _ (MTOTrigger trn)            -> delEventTriggerFromCatalog trn
  MOTableObj qt (MTOComputedField ccn)     -> dropComputedFieldFromCatalog qt ccn
  MOTableObj qt (MTORemoteRelationship rn) -> RemoteRelationship.delRemoteRelFromCatalog qt rn
  MOCustomTypes                            -> CustomTypes.clearCustomTypes
  MOAction action                          -> Action.deleteActionFromCatalog action Nothing
  MOActionPermission action role           -> Action.deleteActionPermissionFromCatalog action role
  MOCronTrigger ctName                     -> deleteCronTriggerFromCatalog ctName