hasura/graphql-engine
1
0
Fork 0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-25 00:13:11 +03:00
Code Issues Projects Releases Wiki Activity
1b7602a2a5
graphql-engine/server/src-lib/Hasura/RQL/DDL/Schema/Cache/Permission.hs
Auke Booij cdac24c79f server: delete the Cacheable type class in favor of Eq 
What is the `Cacheable` type class about?
```haskell
class Eq a => Cacheable a where
  unchanged :: Accesses -> a -> a -> Bool
  default unchanged :: (Generic a, GCacheable (Rep a)) => Accesses -> a -> a -> Bool
  unchanged accesses a b = gunchanged (from a) (from b) accesses
```
Its only method is an alternative to `(==)`. The added value of `unchanged` (and the additional `Accesses` argument) arises _only_ for one type, namely `Dependency`. Indeed, the `Cacheable (Dependency a)` instance is non-trivial, whereas every other `Cacheable` instance is completely boilerplate (and indeed either generated from `Generic`, or simply `unchanged _ = (==)`). The `Cacheable (Dependency a)` instance is the only one where the `Accesses` argument is not just passed onwards.

The only callsite of the `unchanged` method is in the `ArrowCache (Rule m)` method. That is to say that the `Cacheable` type class is used to decide when we can re-use parts of the schema cache between Metadata operations.

So what is the `Cacheable (Dependency a)` instance about? Normally, the output of a `Rule m a b` is re-used when the new input (of type `a`) is equal to the old one. But sometimes, that's too coarse: it might be that a certain `Rule m a b` only depends on a small part of its input of type `a`. A `Dependency` allows us to spell out what parts of `a` are being depended on, and these parts are recorded as values of types `Access a` in the state `Accesses`.

If the input `a` changes, but not in a way that touches the recorded `Accesses`, then the output `b` of that rule can be re-used without recomputing.

So now you understand _why_ we're passing `Accesses` to the `unchanged` method: `unchanged` is an equality check in disguise that just needs some additional context.

But we don't need to pass `Accesses` as a function argument. We can use the `reflection` package to pass it as type-level context. So the core of this PR is that we change the instance declaration from
```haskell
instance (Cacheable a) => Cacheable (Dependency a) where
```
to
```haskell
 instance (Given Accesses, Eq a) => Eq (Dependency a) where
```
and use `(==)` instead of `unchanged`.

If you haven't seen `reflection` before: it's like a `MonadReader`, but it doesn't require a `Monad`.

In order to pass the current `Accesses` value, instead of simply passing the `Accesses` as a function argument, we need to instantiate the `Given Accesses` context. We use the `give` method from the `reflection` package for that.
```haskell
give :: forall r. Accesses -> (Given Accesses => r) -> r

unchanged :: (Given Accesses => Eq a) => Accesses -> a -> a -> Bool
unchanged accesses a b = give accesses (a == b)
```
With these three components in place, we can delete the `Cacheable` type class entirely.

The remainder of this PR is just to remove the `Cacheable` type class and its instances.

PR-URL: https://github.com/hasura/graphql-engine-mono/pull/6877
GitOrigin-RevId: 7125f5e11d856e7672ab810a23d5bf5ad176e77f
2022-11-21 16:35:37 +00:00

355 lines
15 KiB
Haskell
Raw Blame History

{-# LANGUAGE Arrows #-}
module Hasura.RQL.DDL.Schema.Cache.Permission
( buildTablePermissions,
mkPermissionMetadataObject,
orderRoles,
OrderedRoles,
_unOrderedRoles,
mkBooleanPermissionMap,
resolveCheckPermission,
)
where
import Control.Arrow.Extended
import Control.Arrow.Interpret
import Data.Aeson
import Data.Graph qualified as G
import Data.HashMap.Strict qualified as M
import Data.Proxy
import Data.Sequence qualified as Seq
import Data.Text.Extended
import Hasura.Base.Error
import Hasura.Incremental qualified as Inc
import Hasura.Prelude
import Hasura.RQL.DDL.Permission
import Hasura.RQL.DDL.Schema.Cache.Common
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Metadata.Backend
import Hasura.RQL.Types.Metadata.Object
import Hasura.RQL.Types.Permission
import Hasura.RQL.Types.Relationships.Local
import Hasura.RQL.Types.Roles
import Hasura.RQL.Types.Roles.Internal
( CheckPermission (..),
CombineRolePermInfo (..),
rolePermInfoToCombineRolePermInfo,
)
import Hasura.RQL.Types.SchemaCache
import Hasura.RQL.Types.SchemaCache.Build
import Hasura.RQL.Types.SchemaCacheTypes
import Hasura.RQL.Types.Table
import Hasura.SQL.AnyBackend qualified as AB
import Hasura.Session
{- Note: [Inherited roles architecture for read queries]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1. Schema generation
--------------------
Schema generation for inherited roles is similar to the schema
generation of non-inherited roles. In the case of inherited roles,
we combine the `SelectPermInfo`s of the
inherited role's role set and a new `SelectPermInfo` will be generated
which will be the select permission of the inherited role.
Two `SelPermInfo`s will be combined in the following manner:
1. Columns - The `SelPermInfo` contains a hashset of the columns that are
accessible to the role. To combine two `SelPermInfo`s, every column of the
hashset is coupled with the boolean expression (filter) of the `SelPermInfo`
and a hash map of all the columns is created out of it, this hashmap is
generated for the `SelPermInfo`s that are going to be combined. These hashmaps
are then unioned and the values of these hashmaps are `OR`ed. When a column
is accessible to all the select permissions then the nullability of the column
is inferred from the DB column otherwise the column is explicitly marked as
nullable to accomodate cell-value nullification.
2. Scalar computed fields - Scalar computed fields work the same as Columns (#1)
3. Filter / Boolean expression - The filters are combined using a `BoolOr`
4. Limit - Limits are combined by taking the maximum of the two limits
5. Allow Aggregation - Aggregation is allowed, if any of the permissions allow it.
6. Request Headers - Request headers are concatenated
2. SQL generation
-----------------
See note [SQL generation for inherited roles]
3. Introspection
----------------
The columns accessible to an inherited role are explicitly set to
nullable irrespective of the nullability of the DB column to accomodate
cell value nullification.
-}
mkBooleanPermissionMap :: (RoleName -> a) -> HashMap RoleName a -> OrderedRoles -> HashMap RoleName a
mkBooleanPermissionMap constructorFn metadataPermissions orderedRoles =
foldl' combineBooleanPermission metadataPermissions $ _unOrderedRoles orderedRoles
where
combineBooleanPermission accumulatedPermMap (Role roleName (ParentRoles parentRoles)) =
case M.lookup roleName accumulatedPermMap of
-- We check if a permission for the given role exists in the metadata, if it
-- exists, we use that
Just _ -> accumulatedPermMap
-- 2. When the permission doesn't exist, we try to inherit the permission from its parent roles
-- For boolean permissions, if any of the parent roles have a permission to access an entity,
-- then the inherited role will also be able to access the entity.
Nothing ->
-- see Note [Roles Inheritance]
let canInheritPermission = any ((`M.member` accumulatedPermMap)) (toList parentRoles)
in if canInheritPermission
then M.insert roleName (constructorFn roleName) accumulatedPermMap
else accumulatedPermMap
-- | `OrderedRoles` is a data type to hold topologically sorted roles
-- according to each role's parent roles, see `orderRoles` for more details.
newtype OrderedRoles = OrderedRoles {_unOrderedRoles :: [Role]}
deriving (Eq, Generic)
-- | 'orderRoles' is used to order the roles, in such a way that given
-- a role R with n parent roles - PR1, PR2 .. PRn, then the 'orderRoles'
-- function will order the roles in such a way that all the parent roles
-- precede the role R. Note that the order of the parent roles itself doesn't
-- matter as long as they precede the roles on which they are dependent on.
--
-- For example, the orderRoles may return `[PR1, PR3, PR2, ... PRn, R]`
-- or `[PR5, PR3, PR1 ... R]`, both of them are correct because all
-- the parent roles precede the inherited role R, assuming the parent roles
-- themselves don't have any parents for the sake of this example.
orderRoles ::
MonadError QErr m =>
[Role] ->
m OrderedRoles
orderRoles allRoles = do
-- inherited roles can be created from other inherited and non-inherited roles
-- So, roles can be thought of as a graph where non-inherited roles don't have
-- any outgoing edges and inherited roles as nodes with edges to its parent roles
-- However, we can't allow cyclic roles since permissions built by a role is used
-- by the dependent roles to build their permissions and if cyclic roles were to be
-- allowed, the permissions building will be stuck in an infinite loop
let graphNodesList = [(role, _rRoleName role, toList (_unParentRoles . _rParentRoles $ role)) | role <- allRoles]
let orderedGraphNodes = G.stronglyConnComp graphNodesList -- topologically sort the nodes of the graph
cyclicRoles = filter checkCycle orderedGraphNodes
unless (null cyclicRoles) $ do
-- we're appending the first element of the list at the end, so that the error message will
-- contain the complete cycle of the roles
let roleCycles = map (tshow . map (roleNameToTxt . _rRoleName) . appendFirstElementAtEnd . G.flattenSCC) cyclicRoles
throw400 CyclicDependency $ "found cycle(s) in roles: " <> commaSeparated roleCycles
let allOrderedRoles = G.flattenSCCs orderedGraphNodes
pure $ OrderedRoles allOrderedRoles
where
checkCycle = \case
G.AcyclicSCC _ -> False
G.CyclicSCC _ -> True
appendFirstElementAtEnd [] = []
appendFirstElementAtEnd (x : xs) = (x : xs) ++ [x]
-- | `resolveCheckPermission` is a helper function which will convert the indermediate
-- type `CheckPermission` to its original type. It will record any metadata inconsistencies, if exists.
resolveCheckPermission ::
forall m p md.
(MonadWriter (Seq (Either InconsistentMetadata md)) m) =>
CheckPermission p ->
RoleName ->
InconsistentRoleEntity ->
m (Maybe p)
resolveCheckPermission checkPermission roleName inconsistentEntity = do
case checkPermission of
CPInconsistent -> do
let inconsistentObj =
-- check `Conflicts while inheriting permissions` in `rfcs/inherited-roles-improvements.md`
Left $
ConflictingInheritedPermission roleName inconsistentEntity
tell $ Seq.singleton inconsistentObj
pure Nothing
CPDefined permissionDefn -> pure $ Just permissionDefn
CPUndefined -> pure Nothing
resolveCheckTablePermission ::
forall b perm m.
( MonadWriter (Seq (Either InconsistentMetadata MetadataDependency)) m,
BackendMetadata b
) =>
CheckPermission perm ->
Maybe (RolePermInfo b) ->
(RolePermInfo b -> Maybe perm) ->
RoleName ->
SourceName ->
TableName b ->
PermType ->
m (Maybe perm)
resolveCheckTablePermission inheritedRolePermission accumulatedRolePermInfo permAcc roleName source table permType = do
-- when for a given entity and role, a permission exists in the metadata, we override the metadata permission
-- over the inherited permission
let checkPermission = maybe inheritedRolePermission CPDefined (permAcc =<< accumulatedRolePermInfo)
inconsistentRoleEntity = InconsistentTablePermission source (toTxt table) permType
resolveCheckPermission checkPermission roleName inconsistentRoleEntity
buildTablePermissions ::
forall b m arr.
( ArrowChoice arr,
Inc.ArrowDistribute arr,
Inc.ArrowCache m arr,
MonadError QErr m,
ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr,
BackendMetadata b,
GetAggregationPredicatesDeps b
) =>
( Proxy b,
SourceName,
Inc.Dependency (TableCoreCache b),
FieldInfoMap (FieldInfo b),
TablePermissionInputs b,
OrderedRoles
)
`arr` (RolePermInfoMap b)
buildTablePermissions = Inc.cache proc (proxy, source, tableCache, tableFields, tablePermissions, orderedRoles) -> do
let alignedPermissions = alignPermissions tablePermissions
table = _tpiTable tablePermissions
metadataRolePermissions <-
(|
Inc.keyed
( \_ (insertPermission, selectPermission, updatePermission, deletePermission) -> do
insert <- buildPermission -< (proxy, tableCache, source, table, tableFields, listToMaybe insertPermission)
select <- buildPermission -< (proxy, tableCache, source, table, tableFields, listToMaybe selectPermission)
update <- buildPermission -< (proxy, tableCache, source, table, tableFields, listToMaybe updatePermission)
delete <- buildPermission -< (proxy, tableCache, source, table, tableFields, listToMaybe deletePermission)
returnA -< RolePermInfo insert select update delete
)
|) alignedPermissions
(|
foldlA'
( \accumulatedRolePermMap (Role roleName (ParentRoles parentRoles)) -> do
parentRolePermissions <-
bindA
-< for (toList parentRoles) $ \role ->
onNothing (M.lookup role accumulatedRolePermMap) $
throw500 $
-- this error will ideally never be thrown, but if it's thrown then
-- it's possible that the permissions for the role do exist, but it's
-- not yet built due to wrong ordering of the roles, check `orderRoles`
"buildTablePermissions: table role permissions for role: " <> role <<> " not found"
let combinedParentRolePermInfo = mconcat $ fmap rolePermInfoToCombineRolePermInfo parentRolePermissions
selectPermissionsCount = length $ filter (isJust . _permSel) parentRolePermissions
let accumulatedRolePermission = M.lookup roleName accumulatedRolePermMap
let roleSelectPermission =
case (_permSel =<< accumulatedRolePermission) of
Just metadataSelectPerm -> Just metadataSelectPerm
Nothing -> combinedSelPermInfoToSelPermInfo selectPermissionsCount <$> (crpiSelPerm combinedParentRolePermInfo)
roleInsertPermission <- interpretWriter -< resolveCheckTablePermission (crpiInsPerm combinedParentRolePermInfo) accumulatedRolePermission _permIns roleName source table PTInsert
roleUpdatePermission <- interpretWriter -< resolveCheckTablePermission (crpiUpdPerm combinedParentRolePermInfo) accumulatedRolePermission _permUpd roleName source table PTUpdate
roleDeletePermission <- interpretWriter -< resolveCheckTablePermission (crpiDelPerm combinedParentRolePermInfo) accumulatedRolePermission _permDel roleName source table PTDelete
let rolePermInfo = RolePermInfo roleInsertPermission roleSelectPermission roleUpdatePermission roleDeletePermission
returnA -< M.insert roleName rolePermInfo accumulatedRolePermMap
)
|) metadataRolePermissions (_unOrderedRoles orderedRoles)
where
mkMap :: [PermDef b e] -> HashMap RoleName (PermDef b e)
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 b a.
(BackendMetadata b) =>
SourceName ->
TableName b ->
PermDef b a ->
MetadataObject
mkPermissionMetadataObject source table permDef =
let permType = reflectPermDefPermission (_pdPermission permDef)
objectId =
MOSourceObjId source $
AB.mkAnyBackend $
SMOTableObj @b table $
MTOPerm (_pdRole permDef) permType
definition = toJSON $ WithTable @b source table permDef
in MetadataObject objectId definition
withPermission ::
forall bknd a b c s arr.
(ArrowChoice arr, ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr, BackendMetadata bknd) =>
WriterA (Seq SchemaDependency) (ErrorA QErr arr) (a, s) b ->
( a,
((SourceName, TableName bknd, PermDef bknd c, Proxy bknd), s)
)
`arr` (Maybe b)
withPermission f = proc (e, ((source, table, permDef, _proxy), s)) -> do
let metadataObject = mkPermissionMetadataObject @bknd source table permDef
permType = reflectPermDefPermission (_pdPermission permDef)
roleName = _pdRole permDef
schemaObject =
SOSourceObj source $
AB.mkAnyBackend $
SOITableObj @bknd table $
TOPerm roleName permType
addPermContext err = "in permission for role " <> roleName <<> ": " <> err
(|
withRecordInconsistency
( (|
withRecordDependencies
( (|
modifyErrA
(f -< (e, s))
|) (addTableContext @bknd table . addPermContext)
)
|) metadataObject schemaObject
)
|) metadataObject
buildPermission ::
forall b a arr m.
( ArrowChoice arr,
ArrowWriter (Seq (Either InconsistentMetadata MetadataDependency)) arr,
Inc.ArrowCache m arr,
MonadError QErr m,
BackendMetadata b,
GetAggregationPredicatesDeps b
) =>
( Proxy b,
Inc.Dependency (TableCoreCache b),
SourceName,
TableName b,
FieldInfoMap (FieldInfo b),
Maybe (PermDef b a)
)
`arr` Maybe (PermInfo a b)
buildPermission = Inc.cache proc (proxy, tableCache, source, table, tableFields, maybePermission) -> do
case maybePermission of
Nothing -> returnA -< Nothing
Just permission -> do
(|
withPermission
( do
bindErrorA
-<
when (_pdRole permission == adminRoleName) $
throw400 ConstraintViolation "cannot define permission for admin role"
(info, dependencies) <-
liftEitherA <<< Inc.bindDepend
-<
runExceptT $
runTableCoreCacheRT
( buildPermInfo
source
table
tableFields
(_pdRole permission)
(_pdPermission permission)
)
(source, tableCache)
tellA -< Seq.fromList dependencies
returnA -< info
)
|) (source, table, permission, proxy)
Reference in New Issue View Git Blame Copy Permalink