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

417 lines
13 KiB
Haskell
Raw Normal View History

2018-06-27 16:11:32 +03:00
module Hasura.RQL.DDL.Metadata
( TableMeta
2018-06-27 16:11:32 +03:00
, ReplaceMetadata(..)
, runReplaceMetadata
2018-06-27 16:11:32 +03:00
, ExportMetadata(..)
, runExportMetadata
2018-06-27 16:11:32 +03:00
, fetchMetadata
, ClearMetadata(..)
, runClearMetadata
, ReloadMetadata(..)
, runReloadMetadata
, DumpInternalState(..)
, runDumpInternalState
2018-06-27 16:11:32 +03:00
) where
import Control.Lens
import Data.Aeson
import Data.Aeson.Casing
import Data.Aeson.TH
import Language.Haskell.TH.Syntax (Lift)
2018-06-27 16:11:32 +03:00
import qualified Data.HashMap.Strict as M
import qualified Data.HashSet as HS
import qualified Data.List as L
import qualified Data.Text as T
2018-06-27 16:11:32 +03:00
import Hasura.GraphQL.Utils
2018-06-27 16:11:32 +03:00
import Hasura.Prelude
import Hasura.RQL.DDL.Utils
import Hasura.RQL.Types
import Hasura.SQL.Types
import qualified Database.PG.Query as Q
import qualified Hasura.RQL.DDL.Permission as DP
import qualified Hasura.RQL.DDL.QueryTemplate as DQ
import qualified Hasura.RQL.DDL.Relationship as DR
import qualified Hasura.RQL.DDL.RemoteSchema as DRS
import qualified Hasura.RQL.DDL.Schema.Table as DT
import qualified Hasura.RQL.DDL.Subscribe as DS
import qualified Hasura.RQL.Types.RemoteSchema as TRS
import qualified Hasura.RQL.Types.Subscribe as DTS
2018-06-27 16:11:32 +03:00
data TableMeta
= TableMeta
{ _tmTable :: !QualifiedTable
, _tmObjectRelationships :: ![DR.ObjRelDef]
, _tmArrayRelationships :: ![DR.ArrRelDef]
, _tmInsertPermissions :: ![DP.InsPermDef]
, _tmSelectPermissions :: ![DP.SelPermDef]
, _tmUpdatePermissions :: ![DP.UpdPermDef]
, _tmDeletePermissions :: ![DP.DelPermDef]
, _tmEventTriggers :: ![DTS.EventTriggerConf]
2018-06-27 16:11:32 +03:00
} deriving (Show, Eq, Lift)
mkTableMeta :: QualifiedTable -> TableMeta
mkTableMeta qt =
2018-09-05 14:26:46 +03:00
TableMeta qt [] [] [] [] [] [] []
2018-06-27 16:11:32 +03:00
makeLenses ''TableMeta
instance FromJSON TableMeta where
parseJSON (Object o) = do
unless (null unexpectedKeys) $
fail $ "unexpected keys when parsing TableMetadata : "
<> show (HS.toList unexpectedKeys)
TableMeta
<$> o .: tableKey
<*> o .:? orKey .!= []
<*> o .:? arKey .!= []
<*> o .:? ipKey .!= []
<*> o .:? spKey .!= []
<*> o .:? upKey .!= []
<*> o .:? dpKey .!= []
2018-09-05 14:26:46 +03:00
<*> o .:? etKey .!= []
2018-06-27 16:11:32 +03:00
where
tableKey = "table"
orKey = "object_relationships"
arKey = "array_relationships"
ipKey = "insert_permissions"
spKey = "select_permissions"
upKey = "update_permissions"
dpKey = "delete_permissions"
2018-09-05 14:26:46 +03:00
etKey = "event_triggers"
2018-06-27 16:11:32 +03:00
unexpectedKeys =
HS.fromList (M.keys o) `HS.difference` expectedKeySet
expectedKeySet =
HS.fromList [ tableKey, orKey, arKey, ipKey
2018-09-05 14:26:46 +03:00
, spKey, upKey, dpKey, etKey
2018-06-27 16:11:32 +03:00
]
parseJSON _ =
fail "expecting an Object for TableMetadata"
$(deriveToJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''TableMeta)
data ClearMetadata
= ClearMetadata
deriving (Show, Eq, Lift)
$(deriveToJSON defaultOptions ''ClearMetadata)
instance FromJSON ClearMetadata where
parseJSON _ = return ClearMetadata
clearMetadata :: Q.TxE QErr ()
clearMetadata = Q.catchE defaultTxErrorHandler $ do
Q.unitQ "DELETE FROM hdb_catalog.hdb_query_template 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_table WHERE is_system_defined <> 'true'" () False
Q.unitQ "DELETE FROM hdb_catalog.event_triggers" () False
Q.unitQ "DELETE FROM hdb_catalog.remote_schemas" () False
2018-09-05 14:26:46 +03:00
clearHdbViews
2018-06-27 16:11:32 +03:00
runClearMetadata
:: ( QErrM m, UserInfoM m, CacheRWM m, MonadTx m
, MonadIO m, HasHttpManager m)
=> ClearMetadata -> m RespBody
runClearMetadata _ = do
adminOnly
liftTx clearMetadata
DT.buildSchemaCache
return successMsg
2018-06-27 16:11:32 +03:00
data ReplaceMetadata
= ReplaceMetadata
{ aqTables :: ![TableMeta]
, aqQueryTemplates :: ![DQ.CreateQueryTemplate]
, aqRemoteSchemas :: !(Maybe [TRS.AddRemoteSchemaQuery])
2018-06-27 16:11:32 +03:00
} deriving (Show, Eq, Lift)
$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''ReplaceMetadata)
applyQP1
:: (QErrM m, UserInfoM m)
=> ReplaceMetadata -> m ()
applyQP1 (ReplaceMetadata tables templates mSchemas) = do
2018-06-27 16:11:32 +03:00
adminOnly
withPathK "tables" $ do
checkMultipleDecls "tables" $ map _tmTable tables
-- process each table
void $ indexedForM tables $ \table -> withTableName (table ^. tmTable) $ do
let allRels = map DR.rdName (table ^. tmObjectRelationships) <>
map DR.rdName (table ^. tmArrayRelationships)
insPerms = map DP.pdRole $ table ^. tmInsertPermissions
selPerms = map DP.pdRole $ table ^. tmSelectPermissions
updPerms = map DP.pdRole $ table ^. tmUpdatePermissions
delPerms = map DP.pdRole $ table ^. tmDeletePermissions
eventTriggers = map DTS.etcName $ table ^. tmEventTriggers
2018-06-27 16:11:32 +03:00
checkMultipleDecls "relationships" allRels
checkMultipleDecls "insert permissions" insPerms
checkMultipleDecls "select permissions" selPerms
checkMultipleDecls "update permissions" updPerms
checkMultipleDecls "delete permissions" delPerms
2018-09-05 14:26:46 +03:00
checkMultipleDecls "event triggers" eventTriggers
2018-06-27 16:11:32 +03:00
withPathK "queryTemplates" $
checkMultipleDecls "query templates" $ map DQ.cqtName templates
onJust mSchemas $ \schemas ->
withPathK "remote_schemas" $
checkMultipleDecls "remote schemas" $ map TRS._arsqName schemas
2018-06-27 16:11:32 +03:00
where
withTableName qt = withPathK (qualTableToTxt qt)
checkMultipleDecls t l = do
let dups = getDups l
unless (null dups) $
throw400 AlreadyExists $ "multiple declarations exist for the following " <> t <> " : "
<> T.pack (show dups)
getDups l =
l L.\\ HS.toList (HS.fromList l)
applyQP2
:: ( UserInfoM m
, CacheRWM m
, MonadTx m
, MonadIO m
, HasHttpManager m
)
=> ReplaceMetadata
-> m RespBody
applyQP2 (ReplaceMetadata tables templates mSchemas) = do
liftTx clearMetadata
DT.buildSchemaCache
2018-06-27 16:11:32 +03:00
withPathK "tables" $ do
-- tables and views
indexedForM_ (map _tmTable tables) $ \tableName ->
void $ DT.trackExistingTableOrViewP2 tableName False
2018-06-27 16:11:32 +03:00
-- Relationships
indexedForM_ tables $ \table -> do
withPathK "object_relationships" $
indexedForM_ (table ^. tmObjectRelationships) $ \objRel ->
DR.objRelP2 (table ^. tmTable) objRel
withPathK "array_relationships" $
indexedForM_ (table ^. tmArrayRelationships) $ \arrRel ->
DR.arrRelP2 (table ^. tmTable) arrRel
-- Permissions
indexedForM_ tables $ \table -> do
let tableName = table ^. tmTable
tabInfo <- modifyErrAndSet500 ("apply " <> ) $ askTabInfo tableName
withPathK "insert_permissions" $ processPerms tabInfo $
table ^. tmInsertPermissions
withPathK "select_permissions" $ processPerms tabInfo $
table ^. tmSelectPermissions
withPathK "update_permissions" $ processPerms tabInfo $
table ^. tmUpdatePermissions
withPathK "delete_permissions" $ processPerms tabInfo $
table ^. tmDeletePermissions
indexedForM_ tables $ \table ->
2018-09-05 14:26:46 +03:00
withPathK "event_triggers" $
indexedForM_ (table ^. tmEventTriggers) $ \etc ->
DS.subTableP2 (table ^. tmTable) False etc
2018-09-05 14:26:46 +03:00
2018-06-27 16:11:32 +03:00
-- query templates
withPathK "queryTemplates" $
indexedForM_ templates $ \template -> do
qti <- DQ.createQueryTemplateP1 template
void $ DQ.createQueryTemplateP2 template qti
-- remote schemas
onJust mSchemas $ \schemas ->
withPathK "remote_schemas" $
indexedForM_ schemas $ \conf ->
void $ DRS.addRemoteSchemaP2 conf
2018-06-27 16:11:32 +03:00
return successMsg
where
processPerms tabInfo perms =
indexedForM_ perms $ \permDef -> do
permInfo <- DP.addPermP1 tabInfo permDef
DP.addPermP2 (tiName tabInfo) permDef permInfo
runReplaceMetadata
:: (QErrM m, UserInfoM m, CacheRWM m, MonadTx m, MonadIO m, HasHttpManager m)
=> ReplaceMetadata -> m RespBody
runReplaceMetadata q = do
applyQP1 q
applyQP2 q
2018-06-27 16:11:32 +03:00
data ExportMetadata
= ExportMetadata
deriving (Show, Eq, Lift)
instance FromJSON ExportMetadata where
parseJSON _ = return ExportMetadata
$(deriveToJSON defaultOptions ''ExportMetadata)
fetchMetadata :: Q.TxE QErr ReplaceMetadata
fetchMetadata = do
tables <- Q.catchE defaultTxErrorHandler fetchTables
let qts = map (uncurry QualifiedTable) tables
tableMetaMap = M.fromList $ zip qts $ map mkTableMeta qts
-- 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 the query templates
qTmpltRows <- Q.catchE defaultTxErrorHandler fetchQTemplates
qTmpltDefs <- forM qTmpltRows $ \(qtn, Q.AltJ qtDefVal, mComment) -> do
qtDef <- decodeValue qtDefVal
return $ DQ.CreateQueryTemplate qtn qtDef mComment
2018-09-05 14:26:46 +03:00
-- Fetch all event triggers
eventTriggers <- Q.catchE defaultTxErrorHandler fetchEventTriggers
triggerMetaDefs <- mkTriggerMetaDefs eventTriggers
2018-06-27 16:11:32 +03:00
let (_, postRelMap) = flip runState tableMetaMap $ do
modMetaMap tmObjectRelationships objRelDefs
modMetaMap tmArrayRelationships arrRelDefs
modMetaMap tmInsertPermissions insPermDefs
modMetaMap tmSelectPermissions selPermDefs
modMetaMap tmUpdatePermissions updPermDefs
modMetaMap tmDeletePermissions delPermDefs
2018-09-05 14:26:46 +03:00
modMetaMap tmEventTriggers triggerMetaDefs
2018-06-27 16:11:32 +03:00
-- fetch all custom resolvers
schemas <- DRS.fetchRemoteSchemas
return $ ReplaceMetadata (M.elems postRelMap) qTmpltDefs (Just schemas)
2018-06-27 16:11:32 +03:00
where
modMetaMap l xs = do
st <- get
put $ foldr (\(qt, dfn) b -> b & at qt._Just.l %~ (:) 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 (QualifiedTable sn tn, DP.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 (QualifiedTable sn tn, DR.RelDef rn using mComment)
2018-09-05 14:26:46 +03:00
mkTriggerMetaDefs = mapM trigRowToDef
trigRowToDef (sn, tn, Q.AltJ configuration) = do
conf <- decodeValue configuration
return (QualifiedTable sn tn, conf::EventTriggerConf)
2018-09-05 14:26:46 +03:00
2018-06-27 16:11:32 +03:00
fetchTables =
Q.listQ [Q.sql|
SELECT table_schema, table_name from hdb_catalog.hdb_table
WHERE is_system_defined = 'false'
|] () 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'
|] () 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'
|] () False
fetchQTemplates =
Q.listQ [Q.sql|
SELECT template_name, template_defn :: json, comment
FROM hdb_catalog.hdb_query_template
WHERE is_system_defined = 'false'
|] () False
2018-09-05 14:26:46 +03:00
fetchEventTriggers =
Q.listQ [Q.sql|
SELECT e.schema_name, e.table_name, e.configuration::json
2018-09-05 14:26:46 +03:00
FROM hdb_catalog.event_triggers e
|] () False
runExportMetadata
:: (QErrM m, UserInfoM m, MonadTx m)
=> ExportMetadata -> m RespBody
runExportMetadata _ = do
adminOnly
encode <$> liftTx fetchMetadata
2018-06-27 16:11:32 +03:00
data ReloadMetadata
= ReloadMetadata
deriving (Show, Eq, Lift)
instance FromJSON ReloadMetadata where
parseJSON _ = return ReloadMetadata
$(deriveToJSON defaultOptions ''ReloadMetadata)
runReloadMetadata
:: ( QErrM m, UserInfoM m, CacheRWM m
, MonadTx m, MonadIO m, HasHttpManager m)
=> ReloadMetadata -> m RespBody
runReloadMetadata _ = do
adminOnly
liftTx $ Q.catchE defaultTxErrorHandler clearHdbViews
DT.buildSchemaCache
return successMsg
2018-06-27 16:11:32 +03:00
data DumpInternalState
= DumpInternalState
deriving (Show, Eq, Lift)
instance FromJSON DumpInternalState where
parseJSON _ = return DumpInternalState
$(deriveToJSON defaultOptions ''DumpInternalState)
runDumpInternalState
:: (QErrM m, UserInfoM m, CacheRM m)
=> DumpInternalState -> m RespBody
runDumpInternalState _ = do
adminOnly
encode <$> askSchemaCache