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

module Hasura.RQL.DDL.Relationship
  ( validateObjRel
  , objRelP2Setup
  , objRelP2
  , validateArrRel
  , arrRelP2Setup
  , arrRelP2
  , delRelFromCatalog
  , validateRelP1
  , runCreateObjRel
  , runCreateArrRel
  , runDropRel
  , runSetRelComment
  , module Hasura.RQL.DDL.Relationship.Types
  )
where

import qualified Database.PG.Query                 as Q

import           Hasura.EncJSON
import           Hasura.Prelude
import           Hasura.RQL.DDL.Deps
import           Hasura.RQL.DDL.Permission         (purgePerm)
import           Hasura.RQL.DDL.Relationship.Types
import           Hasura.RQL.Types
import           Hasura.SQL.Types

import           Data.Aeson.Types
import qualified Data.HashMap.Strict               as HM
import qualified Data.HashSet                      as HS
import qualified Data.Map.Strict                   as M
import qualified Data.Text                         as T
import           Data.Tuple                        (swap)
import           Instances.TH.Lift                 ()

validateManualConfig
  :: (QErrM m, CacheRM m)
  => FieldInfoMap PGColumnInfo
  -> RelManualConfig
  -> m ()
validateManualConfig fim rm = do
  let colMapping = M.toList $ rmColumns rm
      remoteQt = rmTable rm
  remoteTabInfo <- askTabInfo remoteQt
  let remoteFim = _tiFieldInfoMap remoteTabInfo
  forM_ colMapping $ \(lCol, rCol) -> do
    assertPGCol fim "" lCol
    assertPGCol remoteFim "" rCol
    -- lColType <- askPGType fim lCol ""
    -- rColType <- askPGType remoteFim rCol ""
    -- when (lColType /= rColType) $
    --   throw400 $ mconcat
    --   [ "the types of columns " <> lCol <<> ", " <>> rCol
    --   , " do not match"
    --   ]

persistRel :: QualifiedTable
           -> RelName
           -> RelType
           -> Value
           -> Maybe T.Text
           -> SystemDefined
           -> Q.TxE QErr ()
persistRel (QualifiedObject sn tn) rn relType relDef comment systemDefined =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           INSERT INTO
                  hdb_catalog.hdb_relationship
                  (table_schema, table_name, rel_name, rel_type, rel_def, comment, is_system_defined)
           VALUES ($1, $2, $3, $4, $5 :: jsonb, $6, $7)
                |] (sn, tn, rn, relTypeToTxt relType, Q.AltJ relDef, comment, systemDefined) True

validateObjRel
  :: (QErrM m, CacheRM m)
  => QualifiedTable
  -> ObjRelDef
  -> m ()
validateObjRel qt (RelDef rn ru _) = do
  tabInfo <- askTabInfo qt
  checkForFieldConflict tabInfo (fromRel rn)
  let fim = _tiFieldInfoMap tabInfo
  case ru of
    RUFKeyOn cn                      -> assertPGCol fim "" cn
    RUManual (ObjRelManualConfig rm) -> validateManualConfig fim rm

createObjRelP1
  :: (QErrM m, CacheRM m)
  => CreateObjRel
  -> m ()
createObjRelP1 (WithTable qt rd) =
  validateObjRel qt rd

objRelP2Setup
  :: (QErrM m, CacheRWM m)
  => QualifiedTable -> HS.HashSet ForeignKey -> RelDef ObjRelUsing -> m ()
objRelP2Setup qt fkeys (RelDef rn ru _) = do
  (relInfo, deps) <- case ru of
    RUManual (ObjRelManualConfig rm) -> do
      let refqt = rmTable rm
          (lCols, rCols) = unzip $ M.toList $ rmColumns rm
          deps  = map (\c -> SchemaDependency (SOTableObj qt $ TOCol c) DRLeftColumn) lCols
                  <> map (\c -> SchemaDependency (SOTableObj refqt $ TOCol c) DRRightColumn) rCols
      return (RelInfo rn ObjRel (zip lCols rCols) refqt True, deps)
    RUFKeyOn cn -> do
      -- TODO: validation should account for this too
      ForeignKey _ refqt _ consName colMap <-
        getRequiredFkey cn fkeys $ \fk -> _fkTable fk == qt

      let deps = [ SchemaDependency (SOTableObj qt $ TOCons consName) DRFkey
                 , SchemaDependency (SOTableObj qt $ TOCol cn) DRUsingColumn
                 -- this needs to be added explicitly to handle the remote table
                 -- being untracked. In this case, neither the using_col nor
                 -- the constraint name will help.
                 , SchemaDependency (SOTable refqt) DRRemoteTable
                 ]
          colMapping = HM.toList colMap
      void $ askTabInfo refqt
      return (RelInfo rn ObjRel colMapping refqt False, deps)
  addRelToCache rn relInfo deps qt

objRelP2
  :: ( QErrM m
     , CacheRWM m
     , MonadTx m
     , HasSystemDefined m
     )
  => QualifiedTable
  -> ObjRelDef
  -> m ()
objRelP2 qt rd@(RelDef rn ru comment) = do
  fkeys <- liftTx $ fetchTableFkeys qt
  objRelP2Setup qt fkeys rd
  systemDefined <- askSystemDefined
  liftTx $ persistRel qt rn ObjRel (toJSON ru) comment systemDefined

createObjRelP2
  :: ( QErrM m
     , CacheRWM m
     , MonadTx m
     , HasSystemDefined m
     )
  => CreateObjRel -> m EncJSON
createObjRelP2 (WithTable qt rd) = do
  objRelP2 qt rd
  return successMsg

runCreateObjRel
  :: ( UserInfoM m
     , CacheRWM m
     , MonadTx m
     , HasSystemDefined m
     )
  => CreateObjRel -> m EncJSON
runCreateObjRel defn = do
  createObjRelP1 defn
  createObjRelP2 defn

createArrRelP1 :: (QErrM m, CacheRM m) => CreateArrRel -> m ()
createArrRelP1 (WithTable qt rd) =
  validateArrRel qt rd

validateArrRel
  :: (QErrM m, CacheRM m)
  => QualifiedTable -> ArrRelDef -> m ()
validateArrRel qt (RelDef rn ru _) = do
  tabInfo <- askTabInfo qt
  checkForFieldConflict tabInfo (fromRel rn)
  let fim = _tiFieldInfoMap tabInfo
  case ru of
    RUFKeyOn (ArrRelUsingFKeyOn remoteQt rcn) -> do
      remoteTabInfo <- askTabInfo remoteQt
      let rfim = _tiFieldInfoMap remoteTabInfo
      -- Check if 'using' column exists
      assertPGCol rfim "" rcn
    RUManual (ArrRelManualConfig rm) ->
      validateManualConfig fim rm

arrRelP2Setup
  :: (QErrM m, CacheRWM m)
  => QualifiedTable -> HS.HashSet ForeignKey -> ArrRelDef -> m ()
arrRelP2Setup qt fkeys (RelDef rn ru _) = do
  (relInfo, deps) <- case ru of
    RUManual (ArrRelManualConfig rm) -> do
      let refqt = rmTable rm
          (lCols, rCols) = unzip $ M.toList $ rmColumns rm
          deps  = map (\c -> SchemaDependency (SOTableObj qt $ TOCol c) DRLeftColumn) lCols
                  <> map (\c -> SchemaDependency (SOTableObj refqt $ TOCol c) DRRightColumn) rCols
      return (RelInfo rn ArrRel (zip lCols rCols) refqt True, deps)
    RUFKeyOn (ArrRelUsingFKeyOn refqt refCol) -> do
      -- TODO: validation should account for this too
      ForeignKey _ _ _ consName colMap <- getRequiredFkey refCol fkeys $
        \fk -> _fkTable fk == refqt && _fkRefTable fk == qt
      let deps = [ SchemaDependency (SOTableObj refqt $ TOCons consName) DRRemoteFkey
                 , SchemaDependency (SOTableObj refqt $ TOCol refCol) DRUsingColumn
                 -- we don't need to necessarily track the remote table like we did in
                 -- case of obj relationships as the remote table is indirectly
                 -- tracked by tracking the constraint name and 'using_col'
                 , SchemaDependency (SOTable refqt) DRRemoteTable
                 ]
          mapping = HM.toList colMap
      return (RelInfo rn ArrRel (map swap mapping) refqt False, deps)
  addRelToCache rn relInfo deps qt

arrRelP2
  :: ( QErrM m
     , CacheRWM m
     , MonadTx m
     , HasSystemDefined m
     )
  => QualifiedTable -> ArrRelDef -> m ()
arrRelP2 qt rd@(RelDef rn u comment) = do
  fkeys <- liftTx $ fetchFkeysAsRemoteTable qt
  arrRelP2Setup qt fkeys rd
  systemDefined <- askSystemDefined
  liftTx $ persistRel qt rn ArrRel (toJSON u) comment systemDefined

createArrRelP2
  :: ( QErrM m
     , CacheRWM m
     , MonadTx m
     , HasSystemDefined m
     )
  => CreateArrRel -> m EncJSON
createArrRelP2 (WithTable qt rd) = do
  arrRelP2 qt rd
  return successMsg

runCreateArrRel
  :: ( UserInfoM m
     , CacheRWM m
     , MonadTx m
     , HasSystemDefined m
     )
  => CreateArrRel -> m EncJSON
runCreateArrRel defn = do
  createArrRelP1 defn
  createArrRelP2 defn

dropRelP1 :: (UserInfoM m, QErrM m, CacheRM m) => DropRel -> m [SchemaObjId]
dropRelP1 (DropRel qt rn cascade) = do
  tabInfo <- askTabInfo qt
  _       <- askRelType (_tiFieldInfoMap tabInfo) rn ""
  sc      <- askSchemaCache
  let depObjs = getDependentObjs sc relObjId
  when (depObjs /= [] && not (or cascade)) $ reportDeps depObjs
  return depObjs
  where
    relObjId = SOTableObj qt $ TORel rn

purgeRelDep
  :: (CacheRWM m, MonadTx m) => SchemaObjId -> m ()
purgeRelDep (SOTableObj tn (TOPerm rn pt)) =
  purgePerm tn rn pt
purgeRelDep d = throw500 $ "unexpected dependency of relationship : "
                <> reportSchemaObj d

dropRelP2
  :: (QErrM m, CacheRWM m, MonadTx m)
  => DropRel -> [SchemaObjId] -> m EncJSON
dropRelP2 (DropRel qt rn _) depObjs = do
  mapM_ purgeRelDep depObjs
  delRelFromCache rn qt
  liftTx $ delRelFromCatalog qt rn
  return successMsg

runDropRel
  :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m)
  => DropRel -> m EncJSON
runDropRel defn = do
  depObjs <- dropRelP1 defn
  dropRelP2 defn depObjs

delRelFromCatalog
  :: QualifiedTable
  -> RelName
  -> Q.TxE QErr ()
delRelFromCatalog (QualifiedObject sn tn) rn =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           DELETE FROM
                  hdb_catalog.hdb_relationship
           WHERE table_schema =  $1
             AND table_name = $2
             AND rel_name = $3
                |] (sn, tn, rn) True

validateRelP1
  :: (UserInfoM m, QErrM m, CacheRM m)
  => QualifiedTable -> RelName -> m RelInfo
validateRelP1 qt rn = do
  tabInfo <- askTabInfo qt
  askRelType (_tiFieldInfoMap tabInfo) rn ""

setRelCommentP2
  :: (QErrM m, MonadTx m)
  => SetRelComment -> m EncJSON
setRelCommentP2 arc = do
  liftTx $ setRelComment arc
  return successMsg

runSetRelComment
  :: (QErrM m, CacheRWM m, MonadTx m , UserInfoM m)
  => SetRelComment -> m EncJSON
runSetRelComment defn = do
  void $ validateRelP1 qt rn
  setRelCommentP2 defn
  where
    SetRelComment qt rn _ = defn

setRelComment :: SetRelComment
              -> Q.TxE QErr ()
setRelComment (SetRelComment (QualifiedObject sn tn) rn comment) =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           UPDATE hdb_catalog.hdb_relationship
           SET comment = $1
           WHERE table_schema =  $2
             AND table_name = $3
             AND rel_name = $4
                |] (comment, sn, tn, rn) True

getRequiredFkey
  :: (QErrM m)
  => PGCol
  -> HS.HashSet ForeignKey
  -> (ForeignKey -> Bool)
  -> m ForeignKey
getRequiredFkey col fkeySet preCondition =
  case filterFkeys of
    []  -> throw400 ConstraintError
          "no foreign constraint exists on the given column"
    [k] -> return k
    _   -> throw400 ConstraintError
           "more than one foreign key constraint exists on the given column"
  where
    filterFkeys = HS.toList $ HS.filter filterFn fkeySet
    filterFn k = preCondition k && HM.keys (_fkColumnMapping k) == [col]

fetchTableFkeys :: QualifiedTable -> Q.TxE QErr (HS.HashSet ForeignKey)
fetchTableFkeys qt@(QualifiedObject sn tn) = do
  r <- Q.listQE defaultTxErrorHandler [Q.sql|
          SELECT f.constraint_name,
                 f.ref_table_table_schema,
                 f.ref_table,
                 f.constraint_oid,
                 f.column_mapping
            FROM hdb_catalog.hdb_foreign_key_constraint f
           WHERE f.table_schema = $1 AND f.table_name = $2
          |] (sn, tn) True
  fmap HS.fromList $
    forM r $ \(constr, refsn, reftn, oid, Q.AltJ colMapping) ->
    return $ ForeignKey qt (QualifiedObject refsn reftn) oid constr colMapping

fetchFkeysAsRemoteTable :: QualifiedTable -> Q.TxE QErr (HS.HashSet ForeignKey)
fetchFkeysAsRemoteTable rqt@(QualifiedObject rsn rtn) = do
  r <- Q.listQE defaultTxErrorHandler [Q.sql|
          SELECT f.table_schema,
                 f.table_name,
                 f.constraint_name,
                 f.constraint_oid,
                 f.column_mapping
            FROM hdb_catalog.hdb_foreign_key_constraint f
           WHERE f.ref_table_table_schema = $1 AND f.ref_table = $2
          |] (rsn, rtn) True
  fmap HS.fromList $
    forM r $ \(sn, tn, constr, oid, Q.AltJ colMapping) ->
    return $ ForeignKey (QualifiedObject sn tn) rqt oid constr colMapping