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

module Hasura.RQL.DDL.Permission
    ( CreatePerm
    , runCreatePerm
    , PermDef(..)

    , InsPerm(..)
    , InsPermDef
    , CreateInsPerm
    , buildInsPermInfo

    , SelPerm(..)
    , SelPermDef
    , CreateSelPerm
    , buildSelPermInfo

    , UpdPerm(..)
    , UpdPermDef
    , CreateUpdPerm
    , buildUpdPermInfo

    , DelPerm(..)
    , DelPermDef
    , CreateDelPerm
    , buildDelPermInfo

    , IsPerm(..)

    , DropPerm
    , runDropPerm
    , dropPermissionInMetadata

    , SetPermComment(..)
    , runSetPermComment
    ) where

import           Hasura.Prelude

import qualified Data.HashMap.Strict                as HM
import qualified Data.HashMap.Strict.InsOrd         as OMap
import qualified Data.HashSet                       as HS

import           Control.Lens                       ((.~))
import           Data.Aeson
import           Data.Aeson.TH
import           Data.Text.Extended

import           Hasura.Backends.Postgres.SQL.Types
import           Hasura.EncJSON
import           Hasura.RQL.DDL.Permission.Internal
import           Hasura.RQL.DML.Internal            hiding (askPermInfo)
import           Hasura.RQL.Types
import           Hasura.SQL.Types
import           Hasura.Session



{- Note [Backend only permissions]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
As of writing this note, Hasura permission system is meant to be used by the
frontend. After introducing "Actions", the webhook handlers now can make GraphQL
mutations to the server with some backend logic. These mutations shouldn't be
exposed to frontend for any user since they'll bypass the business logic.

For example:-

We've a table named "user" and it has a "email" column. We need to validate the
email address. So we define an action "create_user" and it expects the same inputs
as "insert_user" mutation (generated by Hasura). Now, a role has permission for both
actions and insert operation on the table. If the insert permission is not marked
as "backend_only: true" then it visible to the frontend client along with "creat_user".

Backend only permissions adds an additional privilege to Hasura generated operations.
Those are accessable only if the request is made with `x-hasura-admin-secret`
(if authorization is configured), `x-hasura-use-backend-only-permissions`
(value must be set to "true"), `x-hasura-role` to identify the role and other
required session variables.

backend_only   `x-hasura-admin-secret`   `x-hasura-use-backend-only-permissions`  Result
------------    ---------------------     -------------------------------------   ------
FALSE           ANY                       ANY                                    Mutation is always visible
TRUE            FALSE                     ANY                                    Mutation is always hidden
TRUE            TRUE (OR NOT-SET)         FALSE                                  Mutation is hidden
TRUE            TRUE (OR NOT-SET)         TRUE                                   Mutation is shown
-}

type CreateInsPerm b = CreatePerm (InsPerm b)

procSetObj
  :: (QErrM m)
  => SourceName
  -> QualifiedTable
  -> FieldInfoMap (FieldInfo 'Postgres)
  -> Maybe (ColumnValues Value)
  -> m (PreSetColsPartial 'Postgres, [Text], [SchemaDependency])
procSetObj source tn fieldInfoMap mObj = do
  (setColTups, deps) <- withPathK "set" $
    fmap unzip $ forM (HM.toList setObj) $ \(pgCol, val) -> do
      ty <- askPGType fieldInfoMap pgCol $
        "column " <> pgCol <<> " not found in table " <>> tn
      sqlExp <- valueParser (CollectableTypeScalar ty) val
      let dep = mkColDep (getDepReason sqlExp) source tn pgCol
      return ((pgCol, sqlExp), dep)
  return (HM.fromList setColTups, depHeaders, deps)
  where
    setObj = fromMaybe mempty mObj
    depHeaders = getDepHeadersFromVal $ Object $ mapKeys getPGColTxt setObj

    getDepReason = bool DRSessionVariable DROnType . isStaticValue

class (ToJSON a) => IsPerm a where

  permAccessor
    :: PermAccessor 'Postgres (PermInfo a)

  buildPermInfo
    :: (QErrM m, TableCoreInfoRM 'Postgres m)
    => SourceName
    -> QualifiedTable
    -> FieldInfoMap (FieldInfo 'Postgres)
    -> PermDef a
    -> m (WithDeps (PermInfo a))

  getPermAcc1
    :: PermDef a -> PermAccessor 'Postgres (PermInfo a)
  getPermAcc1 _ = permAccessor

  getPermAcc2
    :: DropPerm a -> PermAccessor 'Postgres (PermInfo a)
  getPermAcc2 _ = permAccessor

  addPermToMetadata
    :: PermDef a -> TableMetadata -> TableMetadata

runCreatePerm
  :: (UserInfoM m, CacheRWM m, IsPerm a, MonadError QErr m, MetadataM m)
  => CreatePerm a -> m EncJSON
runCreatePerm (WithTable source tn pd) = do
  tableInfo <- askTabInfo source tn
  let permAcc = getPermAcc1 pd
      pt = permAccToType permAcc
      ptText = permTypeToCode pt
      role = _pdRole pd
      metadataObject = MOSourceObjId source $ SMOTableObj tn $ MTOPerm role pt
  onJust (getPermInfoMaybe role permAcc tableInfo) $ const $ throw400 AlreadyExists $
    ptText <> " permission already defined on table " <> tn <<> " with role " <>> role
  buildSchemaCacheFor metadataObject
    $ MetadataModifier
    $ tableMetadataSetter source tn %~ addPermToMetadata pd
  pure successMsg

runDropPerm
  :: (IsPerm a, UserInfoM m, CacheRWM m, MonadError QErr m, MetadataM m)
  => DropPerm a -> m EncJSON
runDropPerm dp@(DropPerm source table role) = do
  tabInfo <- askTabInfo source table
  let permType = permAccToType $ getPermAcc2 dp
  void $ askPermInfo tabInfo role $ getPermAcc2 dp
  withNewInconsistentObjsCheck
    $ buildSchemaCache
    $ MetadataModifier
    $ tableMetadataSetter source table %~ dropPermissionInMetadata role permType
  return successMsg

dropPermissionInMetadata
  :: RoleName -> PermType -> TableMetadata -> TableMetadata
dropPermissionInMetadata rn = \case
  PTInsert -> tmInsertPermissions %~ OMap.delete rn
  PTSelect -> tmSelectPermissions %~ OMap.delete rn
  PTDelete -> tmDeletePermissions %~ OMap.delete rn
  PTUpdate -> tmUpdatePermissions %~ OMap.delete rn

buildInsPermInfo
  :: (QErrM m, TableCoreInfoRM 'Postgres m)
  => SourceName
  -> QualifiedTable
  -> FieldInfoMap (FieldInfo 'Postgres)
  -> PermDef (InsPerm 'Postgres)
  -> m (WithDeps (InsPermInfo 'Postgres))
buildInsPermInfo source tn fieldInfoMap (PermDef _rn (InsPerm checkCond set mCols mBackendOnly) _) =
  withPathK "permission" $ do
    (be, beDeps) <- withPathK "check" $ procBoolExp source tn fieldInfoMap checkCond
    (setColsSQL, setHdrs, setColDeps) <- procSetObj source tn fieldInfoMap set
    void $ withPathK "columns" $ indexedForM insCols $ \col ->
           askPGType fieldInfoMap col ""
    let fltrHeaders = getDependentHeaders checkCond
        reqHdrs = fltrHeaders `union` setHdrs
        insColDeps = map (mkColDep DRUntyped source tn) insCols
        deps = mkParentDep source tn : beDeps ++ setColDeps ++ insColDeps
        insColsWithoutPresets = insCols \\ HM.keys setColsSQL
    return (InsPermInfo (HS.fromList insColsWithoutPresets) be setColsSQL backendOnly reqHdrs, deps)
  where
    backendOnly = Just True == mBackendOnly
    allCols = map pgiColumn $ getCols fieldInfoMap
    insCols = maybe allCols (convColSpec fieldInfoMap) mCols

-- TODO this is a dirty hack, hardcoding permissions to postgres.  When
-- implementing support for other backends, the type family 'PermInfo' probably
-- needs to be refactored.
type instance PermInfo (InsPerm b) = InsPermInfo b

instance IsPerm (InsPerm 'Postgres) where
  permAccessor = PAInsert
  buildPermInfo = buildInsPermInfo

  addPermToMetadata permDef =
    tmInsertPermissions %~ OMap.insert (_pdRole permDef) permDef

buildSelPermInfo
  :: (QErrM m, TableCoreInfoRM 'Postgres m)
  => SourceName
  -> QualifiedTable
  -> FieldInfoMap (FieldInfo 'Postgres)
  -> SelPerm 'Postgres
  -> m (WithDeps (SelPermInfo 'Postgres))
buildSelPermInfo source tn fieldInfoMap sp = withPathK "permission" $ do
  let pgCols     = convColSpec fieldInfoMap $ spColumns sp

  (be, beDeps) <- withPathK "filter" $
    procBoolExp source tn fieldInfoMap  $ spFilter sp

  -- check if the columns exist
  void $ withPathK "columns" $ indexedForM pgCols $ \pgCol ->
    askPGType fieldInfoMap pgCol autoInferredErr

  -- validate computed fields
  scalarComputedFields <-
    withPathK "computed_fields" $ indexedForM computedFields $ \fieldName -> do
      computedFieldInfo <- askComputedFieldInfo fieldInfoMap fieldName
      case _cfiReturnType computedFieldInfo of
        CFRScalar _               -> pure fieldName
        CFRSetofTable returnTable -> throw400 NotSupported $
          "select permissions on computed field " <> fieldName
          <<> " are auto-derived from the permissions on its returning table "
          <> returnTable <<> " and cannot be specified manually"

  let deps = mkParentDep source tn : beDeps ++ map (mkColDep DRUntyped source tn) pgCols
             ++ map (mkComputedFieldDep DRUntyped source tn) scalarComputedFields
      depHeaders = getDependentHeaders $ spFilter sp
      mLimit = spLimit sp

  withPathK "limit" $ mapM_ onlyPositiveInt mLimit

  return ( SelPermInfo (HS.fromList pgCols) (HS.fromList computedFields)
                        be mLimit allowAgg depHeaders
         , deps
         )
  where
    allowAgg = spAllowAggregations sp
    computedFields = spComputedFields sp
    autoInferredErr = "permissions for relationships are automatically inferred"

type CreateSelPerm b = CreatePerm (SelPerm b)

-- TODO see TODO for PermInfo above.
type instance PermInfo (SelPerm b) = SelPermInfo b

instance IsPerm (SelPerm 'Postgres) where
  permAccessor = PASelect
  buildPermInfo source tn fieldInfoMap (PermDef _ a _) =
    buildSelPermInfo source tn fieldInfoMap a

  addPermToMetadata permDef =
    tmSelectPermissions %~ OMap.insert (_pdRole permDef) permDef

type CreateUpdPerm b = CreatePerm (UpdPerm b)

buildUpdPermInfo
  :: (QErrM m, TableCoreInfoRM 'Postgres m)
  => SourceName
  -> QualifiedTable
  -> FieldInfoMap (FieldInfo 'Postgres)
  -> UpdPerm 'Postgres
  -> m (WithDeps (UpdPermInfo 'Postgres))
buildUpdPermInfo source tn fieldInfoMap (UpdPerm colSpec set fltr check) = do
  (be, beDeps) <- withPathK "filter" $
    procBoolExp source tn fieldInfoMap fltr

  checkExpr <- traverse (withPathK "check" . procBoolExp source tn fieldInfoMap) check

  (setColsSQL, setHeaders, setColDeps) <- procSetObj source tn fieldInfoMap set

  -- check if the columns exist
  void $ withPathK "columns" $ indexedForM updCols $ \updCol ->
       askPGType fieldInfoMap updCol relInUpdErr

  let updColDeps = map (mkColDep DRUntyped source tn) updCols
      deps = mkParentDep source tn : beDeps ++ maybe [] snd checkExpr ++ updColDeps ++ setColDeps
      depHeaders = getDependentHeaders fltr
      reqHeaders = depHeaders `union` setHeaders
      updColsWithoutPreSets = updCols \\ HM.keys setColsSQL

  return (UpdPermInfo (HS.fromList updColsWithoutPreSets) tn be (fst <$> checkExpr) setColsSQL reqHeaders, deps)

  where
    updCols     = convColSpec fieldInfoMap colSpec
    relInUpdErr = "relationships can't be used in update"

-- TODO see TODO for PermInfo above
type instance PermInfo (UpdPerm b) = UpdPermInfo b

instance IsPerm (UpdPerm 'Postgres) where
  permAccessor = PAUpdate
  buildPermInfo source tn fieldInfoMap (PermDef _ a _) =
    buildUpdPermInfo source tn fieldInfoMap a

  addPermToMetadata permDef =
    tmUpdatePermissions %~ OMap.insert (_pdRole permDef) permDef

type CreateDelPerm b = CreatePerm (DelPerm b)

buildDelPermInfo
  :: (QErrM m, TableCoreInfoRM 'Postgres m)
  => SourceName
  -> QualifiedTable
  -> FieldInfoMap (FieldInfo 'Postgres)
  -> DelPerm 'Postgres
  -> m (WithDeps (DelPermInfo 'Postgres))
buildDelPermInfo source tn fieldInfoMap (DelPerm fltr) = do
  (be, beDeps) <- withPathK "filter" $
    procBoolExp source tn fieldInfoMap  fltr
  let deps = mkParentDep source tn : beDeps
      depHeaders = getDependentHeaders fltr
  return (DelPermInfo tn be depHeaders, deps)

-- TODO see TODO for PermInfo above
type instance PermInfo (DelPerm b) = DelPermInfo b

instance IsPerm (DelPerm 'Postgres) where
  permAccessor = PADelete
  buildPermInfo source tn fieldInfoMap (PermDef _ a _) =
    buildDelPermInfo source tn fieldInfoMap a

  addPermToMetadata permDef =
    tmDeletePermissions %~ OMap.insert (_pdRole permDef) permDef

data SetPermComment
  = SetPermComment
  { apSource     :: !SourceName
  , apTable      :: !QualifiedTable
  , apRole       :: !RoleName
  , apPermission :: !PermType
  , apComment    :: !(Maybe Text)
  } deriving (Show, Eq)

$(deriveToJSON hasuraJSON ''SetPermComment)

instance FromJSON SetPermComment where
  parseJSON = withObject "Object" $ \o ->
    SetPermComment
      <$> o .:? "source" .!= defaultSource
      <*> o .: "table"
      <*> o .: "role"
      <*> o .: "permission"
      <*> o .:? "comment"

runSetPermComment
  :: (QErrM m, CacheRWM m, MetadataM m)
  => SetPermComment -> m EncJSON
runSetPermComment (SetPermComment source table role permType comment) =  do
  tableInfo <- askTabInfo source table

  -- assert permission exists and return appropriate permission modifier
  permModifier <- case permType of
    PTInsert -> do
      assertPermDefined role PAInsert tableInfo
      pure $ tmInsertPermissions.ix role.pdComment .~ comment
    PTSelect -> do
      assertPermDefined role PASelect tableInfo
      pure $ tmSelectPermissions.ix role.pdComment .~ comment
    PTUpdate -> do
      assertPermDefined role PAUpdate tableInfo
      pure $ tmUpdatePermissions.ix role.pdComment .~ comment
    PTDelete -> do
      assertPermDefined role PADelete tableInfo
      pure $ tmDeletePermissions.ix role.pdComment .~ comment

  let metadataObject = MOSourceObjId source $
                       SMOTableObj table $ MTOPerm role permType
  buildSchemaCacheFor metadataObject
    $ MetadataModifier
    $ tableMetadataSetter source table %~ permModifier
  pure successMsg