graphql-engine/server/src-lib/Hasura/RQL/DDL/Schema/Cache/Permission.hs

{-# 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.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.Session

buildTablePermissions
  :: ( ArrowChoice arr, Inc.ArrowDistribute arr, Inc.ArrowCache m arr
     , MonadError QErr m, ArrowWriter (Seq CollectedInfo) arr)
  => ( Inc.Dependency (TableCoreCache 'Postgres)
     , FieldInfoMap (FieldInfo 'Postgres)
     , TablePermissionInputs
     ) `arr` (RolePermInfoMap 'Postgres)
buildTablePermissions = Inc.cache proc (tableCache, tableFields, tablePermissions) -> do
  let alignedPermissions = alignPermissions tablePermissions
      table = _tpiTable tablePermissions

  (| Inc.keyed (\_ (insertPermission, selectPermission, updatePermission, deletePermission) -> do
       insert <- buildPermission -< (tableCache, table, tableFields, listToMaybe insertPermission)
       select <- buildPermission -< (tableCache, table, tableFields, listToMaybe selectPermission)
       update <- buildPermission -< (tableCache, table, tableFields, listToMaybe updatePermission)
       delete <- buildPermission -< (tableCache, table, tableFields, listToMaybe deletePermission)
       returnA -< RolePermInfo insert select update delete)
   |) alignedPermissions
  where
    mkMap :: [PermDef a] -> HashMap RoleName (PermDef a)
    mkMap = mapFromL _pdRole

    alignPermissions TablePermissionInputs{..} =
      let insertsMap = M.map (\a -> ([a], [], [], [])) (mkMap _tpiInsert)
          selectsMap = M.map (\a -> ([], [a], [], [])) (mkMap _tpiSelect)
          updatesMap = M.map (\a -> ([], [], [a], [])) (mkMap _tpiUpdate)
          deletesMap = M.map (\a -> ([], [], [], [a])) (mkMap _tpiDelete)
          unionMap   = M.unionWith (<>)
      in insertsMap `unionMap` selectsMap `unionMap` updatesMap `unionMap` deletesMap

mkPermissionMetadataObject
  :: forall a. (IsPerm a)
  => QualifiedTable -> PermDef a -> MetadataObject
mkPermissionMetadataObject table permDef =
  let permType = permAccToType (permAccessor :: PermAccessor 'Postgres (PermInfo a))
      objectId = MOTableObj table $ MTOPerm (_pdRole permDef) permType
      definition = toJSON $ WithTable table permDef
  in MetadataObject objectId definition

withPermission
  :: forall a b c s arr. (ArrowChoice arr, ArrowWriter (Seq CollectedInfo) arr, IsPerm c)
  => WriterA (Seq SchemaDependency) (ErrorA QErr arr) (a, s) b
  -> arr (a, ((QualifiedTable, PermDef c), s)) (Maybe b)
withPermission f = proc (e, ((table, permission), s)) -> do
  let metadataObject = mkPermissionMetadataObject table permission
      permType = permAccToType (permAccessor :: PermAccessor 'Postgres (PermInfo c))
      roleName = _pdRole permission
      schemaObject = SOTableObj table $
                     TOPerm roleName permType
      addPermContext err = "in permission for role " <> roleName <<> ": " <> err
  (| withRecordInconsistency (
     (| withRecordDependencies (
        (| modifyErrA (f -< (e, s))
        |) (addTableContext table . addPermContext))
     |) metadataObject schemaObject)
   |) metadataObject

buildPermission
  :: ( ArrowChoice arr, Inc.ArrowCache m arr
     , ArrowWriter (Seq CollectedInfo) arr
     , MonadError QErr m, IsPerm a
     , Inc.Cacheable a
     )
  => ( Inc.Dependency (TableCoreCache 'Postgres)
     , QualifiedTable
     , FieldInfoMap (FieldInfo 'Postgres)
     , Maybe (PermDef a)
     ) `arr` Maybe (PermInfo a)
buildPermission = Inc.cache proc (tableCache, table, tableFields, maybePermission) -> do
  (| traverseA ( \permission ->
    (| withPermission (do
         bindErrorA -< when (_pdRole permission == adminRoleName) $
           throw400 ConstraintViolation "cannot define permission for admin role"
         (info, dependencies) <- liftEitherA <<< Inc.bindDepend -< runExceptT $
           runTableCoreCacheRT (buildPermInfo table tableFields permission) (tableCache)
         tellA -< Seq.fromList dependencies
         returnA -< info)
     |) (table, permission))
   |) maybePermission
  >-> (\info -> join info >- returnA)