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

{-# LANGUAGE DeriveLift        #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes       #-}
{-# LANGUAGE TemplateHaskell   #-}
{-# LANGUAGE TypeFamilies      #-}

module Hasura.RQL.DDL.Permission
    ( CreatePerm
    , SetPermComment(..)
    , purgePerm
    , PermDef(..)


    , InsPerm(..)
    , InsPermDef
    , CreateInsPerm
    , clearInsInfra
    , buildInsInfra
    , buildInsPermInfo
    , DropInsPerm
    , dropInsPermP2

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

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

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

    , IsPerm(..)
    , addPermP1
    , addPermP2
    ) where

import           Hasura.RQL.DDL.Permission.Internal
import           Hasura.RQL.Types
import           Hasura.SQL.Types
import           Hasura.Prelude

import qualified Database.PG.Query                 as Q
import qualified Hasura.SQL.DML                     as S

import           Data.Aeson.Casing
import           Data.Aeson.TH
import           Language.Haskell.TH.Syntax        (Lift)

import qualified Data.ByteString.Builder           as BB
import qualified Data.HashSet                      as HS
import qualified Data.Text                         as T

-- Insert permission
data InsPerm
  = InsPerm
  { icCheck       :: !BoolExp
  , icAllowUpsert :: !(Maybe Bool)
  } deriving (Show, Eq, Lift)

$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''InsPerm)

type InsPermDef = PermDef InsPerm
type CreateInsPerm = CreatePerm InsPerm

buildViewName :: QualifiedTable -> RoleName -> PermType -> QualifiedTable
buildViewName (QualifiedTable sn tn) (RoleName rTxt) pt =
  QualifiedTable hdbViewsSchema $ TableName
  (rTxt <> "__" <> T.pack (show pt) <> "__" <> snTxt <> "__" <> tnTxt)
  where
    hdbViewsSchema = SchemaName "hdb_views"
    snTxt = getSchemaTxt sn
    tnTxt = getTableTxt tn

buildView :: QualifiedTable -> QualifiedTable -> Q.Query
buildView tn vn =
  Q.fromBuilder $ mconcat
  [ BB.string7 "CREATE VIEW " <> toSQL vn
  , BB.string7 " AS SELECT * FROM " <> toSQL tn
  ]

dropView :: QualifiedTable -> Q.Tx ()
dropView vn =
  Q.unitQ dropViewS () False
  where
    dropViewS = Q.fromBuilder $
      BB.string7 "DROP VIEW " <> toSQL vn

buildInsTrig :: QualifiedTable -> Q.Query
buildInsTrig qt@(QualifiedTable _ tn) =
  Q.fromBuilder $ mconcat
  [ BB.string7 "CREATE TRIGGER " <> toSQL tn
  , BB.string7 " INSTEAD OF INSERT ON " <> toSQL qt
  , BB.string7 " FOR EACH ROW EXECUTE PROCEDURE "
  , toSQL qt <> BB.string7 "();"
  ]

dropInsTrigFn :: QualifiedTable -> Q.Query
dropInsTrigFn fn =
  Q.fromBuilder $ BB.string7 "DROP FUNCTION " <> toSQL fn <> "()"

buildInsTrigFn :: QualifiedTable -> QualifiedTable -> S.BoolExp -> Q.Query
buildInsTrigFn fn tn be =
  Q.fromBuilder $ mconcat
  [ BB.string7 "CREATE OR REPLACE FUNCTION " <> toSQL fn
  , BB.string7 "() RETURNS trigger LANGUAGE plpgsql AS $$ "
  , BB.string7 "DECLARE r " <> toSQL tn <> "%ROWTYPE; "
  , BB.string7 "BEGIN "
  , BB.string7 "IF (" <> toSQL be <> BB.string7 ") "
  , BB.string7 "THEN INSERT INTO " <> toSQL tn
  , BB.string7 " VALUES (NEW.*) RETURNING * INTO r; RETURN r; "
  , BB.string7 "ELSE RAISE check_violation using message = 'insert check constraint failed'; return NULL;"
  , BB.string7 "END IF; "
  , BB.string7 "END "
  , BB.string7 "$$;"
  ]

buildInsPermInfo
  :: (QErrM m, CacheRM m)
  => TableInfo
  -> PermDef InsPerm
  -> m InsPermInfo
buildInsPermInfo tabInfo (PermDef rn (InsPerm chk upsrt) _) = do
  (be, beDeps) <- withPathK "check" $
    procBoolExp tn fieldInfoMap (S.QualVar "NEW") chk
  let deps = mkParentDep tn : beDeps
      depHeaders = getDependentHeaders chk
  return $ InsPermInfo vn be (fromMaybe False upsrt) deps depHeaders
  where
    fieldInfoMap = tiFieldInfoMap tabInfo
    tn = tiName tabInfo
    vn = buildViewName tn rn PTInsert

buildInsInfra :: QualifiedTable -> InsPermInfo -> Q.TxE QErr ()
buildInsInfra tn (InsPermInfo vn be _ _ _) =
  Q.catchE defaultTxErrorHandler $ do
    -- Create the view
    Q.unitQ (buildView tn vn) () False
    -- Inject defaults on the view
    Q.discardQ (injectDefaults vn tn) () False
    -- Construct a trigger function
    Q.unitQ (buildInsTrigFn vn tn be) () False
    -- Add trigger for check expression
    Q.unitQ (buildInsTrig vn) () False

clearInsInfra :: QualifiedTable -> Q.TxE QErr ()
clearInsInfra vn =
  Q.catchE defaultTxErrorHandler $ do
    dropView vn
    Q.unitQ (dropInsTrigFn vn) () False

type DropInsPerm = DropPerm InsPerm

dropInsPermP2 :: (P2C m) => DropInsPerm -> QualifiedTable -> m ()
dropInsPermP2 = dropPermP2

type instance PermInfo InsPerm = InsPermInfo

instance IsPerm InsPerm where

  type DropPermP1Res InsPerm = QualifiedTable

  permAccessor = PAInsert

  buildPermInfo = buildInsPermInfo

  addPermP2Setup qt _ permInfo =
    liftTx $ buildInsInfra qt permInfo

  buildDropPermP1Res dp =
    ipiView <$> dropPermP1 dp

  dropPermP2Setup _ vn =
    liftTx $ clearInsInfra vn

-- Select constraint
data SelPerm
  = SelPerm
  { spColumns :: !PermColSpec       -- Allowed columns
  , spFilter  :: !BoolExp   -- Filter expression
  } deriving (Show, Eq, Lift)

$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''SelPerm)

buildSelPermInfo
  :: (QErrM m, CacheRM m)
  => TableInfo
  -> SelPerm
  -> m SelPermInfo
buildSelPermInfo tabInfo sp = do
  let pgCols     = convColSpec fieldInfoMap $ spColumns sp

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

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

  let deps = mkParentDep tn : beDeps ++ map (mkColDep "untyped" tn) pgCols
      depHeaders = getDependentHeaders $ spFilter sp

  return $ SelPermInfo (HS.fromList pgCols) tn be deps depHeaders

  where
    tn = tiName tabInfo
    fieldInfoMap = tiFieldInfoMap tabInfo
    autoInferredErr = "permissions for relationships are automatically inferred"

type SelPermDef = PermDef SelPerm
type CreateSelPerm = CreatePerm SelPerm
type DropSelPerm = DropPerm SelPerm

type instance PermInfo SelPerm = SelPermInfo

dropSelPermP2 :: (P2C m) => DropSelPerm -> m ()
dropSelPermP2 dp = dropPermP2 dp ()

instance IsPerm SelPerm where

  type DropPermP1Res SelPerm = ()

  permAccessor = PASelect

  buildPermInfo ti (PermDef _ a _) =
    buildSelPermInfo ti a

  buildDropPermP1Res =
    void . dropPermP1

  addPermP2Setup _ _ _ = return ()

  dropPermP2Setup _ _ = return ()

-- Update constraint
data UpdPerm
  = UpdPerm
  { ucColumns :: !PermColSpec -- Allowed columns
  , ucFilter  :: !BoolExp     -- Filter expression
  } deriving (Show, Eq, Lift)

$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''UpdPerm)

type UpdPermDef = PermDef UpdPerm
type CreateUpdPerm = CreatePerm UpdPerm

buildUpdPermInfo
  :: (QErrM m, CacheRM m)
  => TableInfo
  -> UpdPerm
  -> m UpdPermInfo
buildUpdPermInfo tabInfo (UpdPerm colSpec fltr) = do
  (be, beDeps) <- withPathK "filter" $
    procBoolExp tn fieldInfoMap (S.mkQual tn) fltr

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

  let deps = mkParentDep tn : beDeps ++ map (mkColDep "untyped" tn) updCols
      depHeaders = getDependentHeaders fltr

  return $ UpdPermInfo (HS.fromList updCols) tn be deps depHeaders

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

type instance PermInfo UpdPerm = UpdPermInfo

type DropUpdPerm = DropPerm UpdPerm

dropUpdPermP2 :: (P2C m) => DropUpdPerm -> m ()
dropUpdPermP2 dp = dropPermP2 dp ()

instance IsPerm UpdPerm where

  type DropPermP1Res UpdPerm = ()

  permAccessor = PAUpdate

  buildPermInfo ti (PermDef _ a _) =
    buildUpdPermInfo ti a

  addPermP2Setup _ _ _ = return ()

  buildDropPermP1Res =
    void . dropPermP1

  dropPermP2Setup _ _ = return ()

-- Delete permission
data DelPerm
  = DelPerm { dcFilter :: !BoolExp }
  deriving (Show, Eq, Lift)

$(deriveJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''DelPerm)

type DelPermDef = PermDef DelPerm
type CreateDelPerm = CreatePerm DelPerm

buildDelPermInfo
  :: (QErrM m, CacheRM m)
  => TableInfo
  -> DelPerm
  -> m DelPermInfo
buildDelPermInfo tabInfo (DelPerm fltr) = do
  (be, beDeps) <- withPathK "filter" $
    procBoolExp tn fieldInfoMap  (S.mkQual tn) fltr
  let deps = mkParentDep tn : beDeps
      depHeaders = getDependentHeaders fltr
  return $ DelPermInfo tn be deps depHeaders
  where
    tn = tiName tabInfo
    fieldInfoMap = tiFieldInfoMap tabInfo

type DropDelPerm = DropPerm DelPerm

dropDelPermP2 :: (P2C m) => DropDelPerm -> m ()
dropDelPermP2 dp = dropPermP2 dp ()

type instance PermInfo DelPerm = DelPermInfo

instance IsPerm DelPerm where

  type DropPermP1Res DelPerm = ()

  permAccessor = PADelete

  buildPermInfo ti (PermDef _ a _) =
    buildDelPermInfo ti a

  addPermP2Setup _ _ _ = return ()

  buildDropPermP1Res =
    void . dropPermP1

  dropPermP2Setup _ _ = return ()

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

$(deriveJSON (aesonDrop 2 snakeCase) ''SetPermComment)

setPermCommentP1 :: (P1C m) => SetPermComment -> m ()
setPermCommentP1 (SetPermComment qt rn pt _) = do
  adminOnly
  tabInfo <- askTabInfo qt
  action tabInfo
  where
    action tabInfo = case pt of
      PTInsert -> assertPermDefined rn PAInsert tabInfo
      PTSelect -> assertPermDefined rn PASelect tabInfo
      PTUpdate -> assertPermDefined rn PAUpdate tabInfo
      PTDelete -> assertPermDefined rn PADelete tabInfo

setPermCommentP2 :: (P2C m) => SetPermComment -> m RespBody
setPermCommentP2 apc = do
  liftTx $ setPermCommentTx apc
  return successMsg

instance HDBQuery SetPermComment where

  type Phase1Res SetPermComment = ()
  phaseOne = setPermCommentP1

  phaseTwo q _ = setPermCommentP2 q

  schemaCachePolicy = SCPNoChange

setPermCommentTx
  :: SetPermComment
  -> Q.TxE QErr ()
setPermCommentTx (SetPermComment (QualifiedTable sn tn) rn pt comment) =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           UPDATE hdb_catalog.hdb_permission
           SET comment = $1
           WHERE table_schema =  $2
             AND table_name = $3
             AND role_name = $4
             AND perm_type = $5
                |] (comment, sn, tn, rn, permTypeToCode pt) True

purgePerm :: (P2C m) => QualifiedTable -> RoleName -> PermType -> m ()
purgePerm qt rn pt =
  case pt of
    PTInsert -> dropInsPermP2 dp $ buildViewName qt rn PTInsert
    PTSelect -> dropSelPermP2 dp
    PTUpdate -> dropUpdPermP2 dp
    PTDelete -> dropDelPermP2 dp
  where
    dp :: DropPerm a
    dp = DropPerm qt rn