graphql-engine/server/src-lib/Hasura/RQL/DDL/Relationship.hs
2019-11-26 17:44:21 +05:30

365 lines
12 KiB
Haskell

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