mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-18 04:51:35 +03:00
3c3ed55914
This PR makes a bunch of schema generation code in Hasura.GraphQL.Schema backend-agnostic, by moving the backend-specific parts into a new BackendSchema type class. This way, the schema generation code can be reused for other backends, simply by implementing new instances of the BackendSchema type class. This work is now in a state where the schema generators are sufficiently generic to accept the implementation of a new backend. That means that we can start exposing MS SQL schema. Execution is not implemented yet, of course. The branch currently does not support computed fields or Relay. This is, in a sense, intentional: computed field support is normally baked into the schema generation (through the fieldSelection schema generator), and so this branch shows a programming technique that allows us to expose certain GraphQL schema depending on backend support. We can write support for computed fields and Relay at a later stage. Co-authored-by: Antoine Leblanc <antoine@hasura.io> GitOrigin-RevId: df369fc3d189cbda1b931d31678e9450a6601314
107 lines
4.6 KiB
Haskell
107 lines
4.6 KiB
Haskell
{-# LANGUAGE Arrows #-}
|
|
|
|
module Hasura.RQL.DDL.Schema.Cache.Permission
|
|
( buildTablePermissions
|
|
, mkPermissionMetadataObject
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import qualified Data.HashMap.Strict.Extended as M
|
|
import qualified Data.Sequence as Seq
|
|
|
|
import Control.Arrow.Extended
|
|
import Data.Aeson
|
|
import Data.Text.Extended
|
|
|
|
import qualified Hasura.Incremental as Inc
|
|
|
|
import Hasura.Backends.Postgres.Connection
|
|
import Hasura.Backends.Postgres.SQL.Types
|
|
import Hasura.RQL.DDL.Permission
|
|
import Hasura.RQL.DDL.Permission.Internal
|
|
import Hasura.RQL.DDL.Schema.Cache.Common
|
|
import Hasura.RQL.Types
|
|
import Hasura.RQL.Types.Catalog
|
|
import Hasura.Session
|
|
|
|
buildTablePermissions
|
|
:: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
|
|
, ArrowWriter (Seq CollectedInfo) arr, MonadTx m )
|
|
=> ( Inc.Dependency (TableCoreCache 'Postgres)
|
|
, QualifiedTable
|
|
, FieldInfoMap (FieldInfo 'Postgres)
|
|
, HashSet CatalogPermission
|
|
) `arr` RolePermInfoMap 'Postgres
|
|
buildTablePermissions = Inc.cache proc (tableCache, tableName, tableFields, tablePermissions) ->
|
|
(| Inc.keyed (\_ rolePermissions -> do
|
|
let (insertPerms, selectPerms, updatePerms, deletePerms) =
|
|
partitionPermissions rolePermissions
|
|
|
|
insertPermInfo <- buildPermission -< (tableCache, tableName, tableFields, insertPerms)
|
|
selectPermInfo <- buildPermission -< (tableCache, tableName, tableFields, selectPerms)
|
|
updatePermInfo <- buildPermission -< (tableCache, tableName, tableFields, updatePerms)
|
|
deletePermInfo <- buildPermission -< (tableCache, tableName, tableFields, deletePerms)
|
|
|
|
returnA -< RolePermInfo
|
|
{ _permIns = insertPermInfo
|
|
, _permSel = selectPermInfo
|
|
, _permUpd = updatePermInfo
|
|
, _permDel = deletePermInfo
|
|
})
|
|
|) (M.groupOn _cpRole tablePermissions)
|
|
where
|
|
partitionPermissions = flip foldr ([], [], [], []) $
|
|
\perm (insertPerms, selectPerms, updatePerms, deletePerms) -> case _cpPermType perm of
|
|
PTInsert -> (perm:insertPerms, selectPerms, updatePerms, deletePerms)
|
|
PTSelect -> (insertPerms, perm:selectPerms, updatePerms, deletePerms)
|
|
PTUpdate -> (insertPerms, selectPerms, perm:updatePerms, deletePerms)
|
|
PTDelete -> (insertPerms, selectPerms, updatePerms, perm:deletePerms)
|
|
|
|
mkPermissionMetadataObject :: CatalogPermission -> MetadataObject
|
|
mkPermissionMetadataObject (CatalogPermission qt rn pt pDef cmnt) =
|
|
let objectId = MOTableObj qt $ MTOPerm rn pt
|
|
definition = toJSON $ WithTable qt $ PermDef rn pDef cmnt
|
|
in MetadataObject objectId definition
|
|
|
|
withPermission
|
|
:: (ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr)
|
|
=> WriterA (Seq SchemaDependency) (ErrorA QErr arr) (a, s) b
|
|
-> arr (a, (CatalogPermission, s)) (Maybe b)
|
|
withPermission f = proc (e, (permission, s)) -> do
|
|
let CatalogPermission tableName roleName permType _ _ = permission
|
|
metadataObject = mkPermissionMetadataObject permission
|
|
schemaObject = SOTableObj tableName $ TOPerm roleName permType
|
|
addPermContext err = "in permission for role " <> roleName <<> ": " <> err
|
|
(| withRecordInconsistency (
|
|
(| withRecordDependencies (
|
|
(| modifyErrA (f -< (e, s))
|
|
|) (addTableContext tableName . addPermContext))
|
|
|) metadataObject schemaObject)
|
|
|) metadataObject
|
|
|
|
buildPermission
|
|
:: ( ArrowChoice arr, Inc.ArrowCache m arr
|
|
, ArrowWriter (Seq CollectedInfo) arr
|
|
, MonadTx m, IsPerm a, FromJSON a
|
|
)
|
|
=> ( Inc.Dependency (TableCoreCache 'Postgres)
|
|
, QualifiedTable
|
|
, FieldInfoMap (FieldInfo 'Postgres)
|
|
, [CatalogPermission]
|
|
) `arr` Maybe (PermInfo a)
|
|
buildPermission = Inc.cache proc (tableCache, tableName, tableFields, permissions) -> do
|
|
(permissions >- noDuplicates mkPermissionMetadataObject)
|
|
>-> (| traverseA (\permission@(CatalogPermission _ roleName _ pDef _) ->
|
|
(| withPermission (do
|
|
bindErrorA -< when (roleName == adminRoleName) $
|
|
throw400 ConstraintViolation "cannot define permission for admin role"
|
|
perm <- bindErrorA -< decodeValue pDef
|
|
let permDef = PermDef roleName perm Nothing
|
|
(info, dependencies) <- liftEitherA <<< Inc.bindDepend -< runExceptT $
|
|
runTableCoreCacheRT (buildPermInfo tableName tableFields permDef) tableCache
|
|
tellA -< Seq.fromList dependencies
|
|
returnA -< info)
|
|
|) permission) |)
|
|
>-> (\info -> join info >- returnA)
|