AccessControl.hs

-- | Applies access control lists to the current role to determine whether should be granted
{-# LANGUAGE RankNTypes #-}
module ProjectM36.AccessControl where
import ProjectM36.Base
import ProjectM36.Error
import ProjectM36.AccessControlList
import ProjectM36.TransactionGraph
import ProjectM36.RelationalExpression
import ProjectM36.DatabaseContext.Types
import ProjectM36.RelationVariablesMentioned
import ProjectM36.IsomorphicSchema
import ProjectM36.Function
import Control.Monad.Except
import Control.Monad (when, forM_)

applyACLRelationalExpr :: Show a => [RoleId] -> RelVarAccessControlList -> RelationalExprBase a -> Either RelationalError ()
applyACLRelationalExpr roleIds acl' expr = do
  let checkPerm perm =
        if hasAccess roleIds perm acl' then
          pure ()
          else
          Left (AccessDeniedError (SomeRelVarPermission perm))
  when (mentionsRelVar expr) (checkPerm AccessRelVarsPermission)

applyACLAlterTransGraphExpr :: [RoleId] -> AlterTransGraphAccessControlList -> AlterTransactionGraphExpr -> Either RelationalError ()
applyACLAlterTransGraphExpr roleIds acl' _alterExpr =
  if hasAccess roleIds CommitTransactionPermission acl' then
    pure ()
    else
    Left (AccessDeniedError (SomeAlterTransGraphPermission CommitTransactionPermission))

-- we should probably have finer-grained permission here
applyACLDatabaseContextIOExpr :: [RoleId] -> DatabaseContextIOExpr -> DatabaseContextIOEvalMonad ()
applyACLDatabaseContextIOExpr roleIds _expr = do
   acl' <- resolveIODBC acl  
   if hasAccess roleIds AlterFunctionPermission (dbcFunctionsACL acl') then
     pure ()
     else
     throwError (AccessDeniedError (SomeFunctionPermission AlterFunctionPermission))

applyACLDatabaseContextExpr :: [RoleId] -> DatabaseContextExpr' -> DatabaseContextEvalMonad ()
applyACLDatabaseContextExpr roleIds expr = do
  dbcAcl <- resolveDBC acl
  dbcFuncs <- resolveDBC dbcFunctions
  let checkRVPerm perm acl' =
        if hasAccess roleIds perm acl' then
          pure ()
        else
          dbErr (AccessDeniedError (SomeRelVarPermission perm))
{-      checkFuncPerm perm acl' =
        if hasAccess roleIds perm acl' then
          pure ()
        else
          dbErr (AccessDeniedError (SomeFunctionPermission perm))-}
      checkACLPerm perm acl' =
          if hasAccess roleIds perm acl' then
            pure ()
          else
            dbErr (AccessDeniedError (SomeACLPermission perm))
      checkFuncPerm perm acl' = do 
        -- check dbc-function-level permissions
        if hasAccess roleIds perm acl' then
          pure ()
          else
          dbErr (AccessDeniedError (SomeFunctionPermission perm))
      checkDBCFuncPerm fname perm = do
        -- check specific function-level permissions
          case functionForName fname dbcFuncs of
            Left err -> dbErr err
            Right func ->
              if hasAccess roleIds perm (funcACL func) then 
                pure ()
              else
                dbErr (AccessDeniedError (SomeDBCFunctionPermission perm))
      rvAcl = relvarsACL dbcAcl
      aclAcl = aclACL dbcAcl
      funcAcl = dbcFunctionsACL dbcAcl
  case expr of
    NoOperation -> pure ()
    Define{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    Undefine{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    Assign{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    Insert{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    Delete{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    Update{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    AddInclusionDependency{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    RemoveInclusionDependency{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    AddNotification{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    RemoveNotification{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    AddTypeConstructor{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    RemoveTypeConstructor{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    RemoveAtomFunction{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    RemoveDatabaseContextFunction fname -> do
      checkFuncPerm AlterFunctionPermission funcAcl
      checkDBCFuncPerm fname AlterDBCFunctionPermission 
    ExecuteDatabaseContextFunction fname _args -> do
      checkFuncPerm ExecuteFunctionPermission funcAcl
      checkDBCFuncPerm fname ExecuteDBCFunctionPermission       
    AddRegisteredQuery{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    RemoveRegisteredQuery{} ->
      checkRVPerm AccessRelVarsPermission rvAcl
    AlterACL{} ->
      checkACLPerm AlterACLPermission aclAcl
    MultipleExpr exprs ->
      mapM_ (applyACLDatabaseContextExpr roleIds) exprs
{-
applyACLTransGraphRelationalExpr :: [RoleId] -> RelVarAccessControlList -> TransGraphRelationalExpr -> Either RelationalError ()
applyACLTransGraphRelationalExpr roleIds acl' expr =
  when (mentionsRelVar expr) $
    if hasAccess roleIds AccessRelVarsPermission acl' then
      pure ()
      else
      Left (AccessDeniedError (SomeRelVarPermission AccessRelVarsPermission))
-}

-- | Validate that any reference to a relvar within a transaction has AccessRelVarsPermission at that transactionId. Pass relevant access control lists extracted from the original expression which reference relvars at specific transaction ids.
applyACLGraphRefRelationalExpr :: [RoleId] -> [RelVarAccessControlList] -> Either RelationalError ()
applyACLGraphRefRelationalExpr roleIds transACLs =
  forM_ transACLs $ \acl' -> applyACLRelationalExpr roleIds acl' (RelationVariable "true" ())
    
applyACLSchemaExpr :: [RoleId] -> SchemaAccessControlList -> SchemaExpr -> Either RelationalError ()
applyACLSchemaExpr roleIds acl' _expr =
  if hasAccess roleIds AlterSchemaPermission acl' then
    pure ()
    else
    Left (AccessDeniedError (SomeAlterSchemaPermission AlterSchemaPermission))