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

{-# LANGUAGE QuasiQuotes            #-}
{-# LANGUAGE RankNTypes             #-}
{-# LANGUAGE TypeApplications       #-}
{-# LANGUAGE TypeFamilies           #-}
{-# LANGUAGE TypeFamilyDependencies #-}

module Hasura.RQL.DDL.Permission.Internal where

import           Control.Lens               hiding ((.=))
import           Data.Aeson.Casing
import           Data.Aeson.TH
import           Data.Aeson.Types
import           Instances.TH.Lift          ()
import           Language.Haskell.TH.Syntax (Lift)

import qualified Data.HashMap.Strict        as M
import qualified Data.Text.Extended         as T
import qualified Hasura.SQL.DML             as S

import           Hasura.EncJSON
import           Hasura.Incremental         (Cacheable)
import           Hasura.Prelude
import           Hasura.RQL.GBoolExp
import           Hasura.RQL.Types
import           Hasura.Server.Utils
import           Hasura.SQL.Types
import           Hasura.SQL.Value

import qualified Database.PG.Query          as Q

data PermColSpec
  = PCStar
  | PCCols ![PGCol]
  deriving (Show, Eq, Lift, Generic)
instance Cacheable PermColSpec

instance FromJSON PermColSpec where
  parseJSON (String "*") = return PCStar
  parseJSON x            = PCCols <$> parseJSON x

instance ToJSON PermColSpec where
  toJSON (PCCols cols) = toJSON cols
  toJSON PCStar        = "*"

convColSpec :: FieldInfoMap FieldInfo -> PermColSpec -> [PGCol]
convColSpec _ (PCCols cols) = cols
convColSpec cim PCStar      = map pgiColumn $ getCols cim

-- FIXME: move check into collecting code for addPermP1 (probably buildSchemaCache)
assertPermNotDefined
  :: (MonadError QErr m)
  => RoleName
  -> PermAccessor a
  -> TableInfo
  -> m ()
assertPermNotDefined roleName pa tableInfo =
  when (permissionIsDefined rpi pa || roleName == adminRole)
  $ throw400 AlreadyExists $ mconcat
  [ "'" <> T.pack (show $ permAccToType pa) <> "'"
  , " permission on " <>> _tciName (_tiCoreInfo tableInfo)
  , " for role " <>> roleName
  , " already exists"
  ]
  where
    rpi = M.lookup roleName $ _tiRolePermInfoMap tableInfo

permissionIsDefined
  :: Maybe RolePermInfo -> PermAccessor a -> Bool
permissionIsDefined rpi pa =
  isJust $ join $ rpi ^? _Just.permAccToLens pa

assertPermDefined
  :: (MonadError QErr m)
  => RoleName
  -> PermAccessor a
  -> TableInfo
  -> m ()
assertPermDefined roleName pa tableInfo =
  unless (permissionIsDefined rpi pa) $ throw400 PermissionDenied $ mconcat
  [ "'" <> T.pack (show $ permAccToType pa) <> "'"
  , " permission on " <>> _tciName (_tiCoreInfo tableInfo)
  , " for role " <>> roleName
  , " does not exist"
  ]
  where
    rpi = M.lookup roleName $ _tiRolePermInfoMap tableInfo

askPermInfo
  :: (MonadError QErr m)
  => TableInfo
  -> RoleName
  -> PermAccessor c
  -> m c
askPermInfo tabInfo roleName pa =
  case M.lookup roleName rpim >>= (^. paL) of
    Just c  -> return c
    Nothing -> throw400 PermissionDenied $ mconcat
               [ pt <> " permission on " <>> _tciName (_tiCoreInfo tabInfo)
               , " for role " <>> roleName
               , " does not exist"
               ]
  where
    paL = permAccToLens pa
    pt = permTypeToCode $ permAccToType pa
    rpim = _tiRolePermInfoMap tabInfo

savePermToCatalog
  :: (ToJSON a)
  => PermType
  -> QualifiedTable
  -> PermDef a
  -> SystemDefined
  -> Q.TxE QErr ()
savePermToCatalog pt (QualifiedObject sn tn) (PermDef  rn qdef mComment) systemDefined =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           INSERT INTO
               hdb_catalog.hdb_permission
               (table_schema, table_name, role_name, perm_type, perm_def, comment, is_system_defined)
           VALUES ($1, $2, $3, $4, $5 :: jsonb, $6, $7)
                |] (sn, tn, rn, permTypeToCode pt, Q.AltJ qdef, mComment, systemDefined) True

updatePermDefInCatalog
  :: (ToJSON a)
  => PermType
  -> QualifiedTable
  -> RoleName
  -> a
  -> Q.TxE QErr ()
updatePermDefInCatalog pt (QualifiedObject sn tn) rn qdef =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           UPDATE hdb_catalog.hdb_permission
              SET perm_def = $1 :: jsonb
             WHERE table_schema = $2 AND table_name = $3
               AND role_name = $4 AND perm_type = $5
           |] (Q.AltJ qdef, sn, tn, rn, permTypeToCode pt) True

dropPermFromCatalog
  :: QualifiedTable
  -> RoleName
  -> PermType
  -> Q.TxE QErr ()
dropPermFromCatalog (QualifiedObject sn tn) rn pt =
  Q.unitQE defaultTxErrorHandler [Q.sql|
           DELETE FROM
               hdb_catalog.hdb_permission
           WHERE
               table_schema = $1
               AND table_name = $2
               AND role_name = $3
               AND perm_type = $4
                |] (sn, tn, rn, permTypeToCode pt) True

type CreatePerm a = WithTable (PermDef a)

data PermDef a =
  PermDef
  { pdRole       :: !RoleName
  , pdPermission :: !a
  , pdComment    :: !(Maybe T.Text)
  } deriving (Show, Eq, Lift, Generic)
instance (Cacheable a) => Cacheable (PermDef a)
$(deriveFromJSON (aesonDrop 2 snakeCase){omitNothingFields=True} ''PermDef)

instance (ToJSON a) => ToJSON (PermDef a) where
  toJSON = object . toAesonPairs

instance (ToJSON a) => ToAesonPairs (PermDef a) where
 toAesonPairs (PermDef rn perm comment) =
  [ "role" .= rn
  , "permission" .= perm
  , "comment" .= comment
  ]

data CreatePermP1Res a
  = CreatePermP1Res
  { cprInfo :: !a
  , cprDeps :: ![SchemaDependency]
  } deriving (Show, Eq)

procBoolExp
  :: (QErrM m, TableCoreInfoRM m)
  => QualifiedTable
  -> FieldInfoMap FieldInfo
  -> BoolExp
  -> m (AnnBoolExpPartialSQL, [SchemaDependency])
procBoolExp tn fieldInfoMap be = do
  abe <- annBoolExp valueParser fieldInfoMap $ unBoolExp be
  let deps = getBoolExpDeps tn abe
  return (abe, deps)

isReqUserId :: T.Text -> Bool
isReqUserId = (== "req_user_id") . T.toLower

getDepHeadersFromVal :: Value -> [T.Text]
getDepHeadersFromVal val = case val of
  Object o -> parseObject o
  _        -> parseOnlyString val
  where
    parseOnlyString v = case v of
      (String t)
        | isUserVar t -> [T.toLower t]
        | isReqUserId t -> [userIdHeader]
        | otherwise -> []
      _ -> []
    parseObject o =
      concatMap getDepHeadersFromVal (M.elems o)

getDependentHeaders :: BoolExp -> [T.Text]
getDependentHeaders (BoolExp boolExp) =
  flip foldMap boolExp $ \(ColExp _ v) -> getDepHeadersFromVal v

valueParser
  :: (MonadError QErr m)
  => PGType PGColumnType -> Value -> m PartialSQLExp
valueParser pgType = \case
  -- When it is a special variable
  String t
    | isUserVar t   -> return $ mkTypedSessionVar pgType t
    | isReqUserId t -> return $ mkTypedSessionVar pgType userIdHeader
  -- Typical value as Aeson's value
  val -> case pgType of
    PGTypeScalar columnType -> PSESQLExp . toTxtValue <$> parsePGScalarValue columnType val
    PGTypeArray ofType -> do
      vals <- runAesonParser parseJSON val
      WithScalarType scalarType scalarValues <- parsePGScalarValues ofType vals
      return . PSESQLExp $ S.SETyAnn
        (S.SEArray $ map (toTxtValue . WithScalarType scalarType) scalarValues)
        (S.mkTypeAnn $ PGTypeArray scalarType)

injectDefaults :: QualifiedTable -> QualifiedTable -> Q.Query
injectDefaults qv qt =
  Q.fromText $ mconcat
  [ "SELECT hdb_catalog.inject_table_defaults("
  , pgFmtLit vsn
  , ", "
  , pgFmtLit vn
  , ", "
  , pgFmtLit tsn
  , ", "
  , pgFmtLit tn
  , ");"
  ]

  where
    QualifiedObject (SchemaName vsn) (TableName vn) = qv
    QualifiedObject (SchemaName tsn) (TableName tn) = qt

data DropPerm a
  = DropPerm
  { dipTable :: !QualifiedTable
  , dipRole  :: !RoleName
  } deriving (Show, Eq, Lift)

$(deriveJSON (aesonDrop 3 snakeCase){omitNothingFields=True} ''DropPerm)

type family PermInfo a = r | r -> a

class (ToJSON a) => IsPerm a where

  type DropPermP1Res a

  permAccessor
    :: PermAccessor (PermInfo a)

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

  addPermP2Setup
    :: (MonadTx m) => QualifiedTable -> PermDef a -> PermInfo a -> m ()

  buildDropPermP1Res
    :: (QErrM m, CacheRM m, UserInfoM m)
    => DropPerm a
    -> m (DropPermP1Res a)

  dropPermP2Setup :: (MonadTx m) => DropPerm a -> DropPermP1Res a -> m ()

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

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

-- FIXME: Push into addPermP1
validateViewPerm
  :: (IsPerm a, QErrM m) => PermDef a -> TableCoreInfo -> m ()
validateViewPerm permDef tableInfo =
  case permAcc of
    PASelect -> return ()
    PAInsert -> mutableView tn viIsInsertable viewInfo "insertable"
    PAUpdate -> mutableView tn viIsUpdatable viewInfo "updatable"
    PADelete -> mutableView tn viIsDeletable viewInfo "deletable"
  where
    tn = _tciName tableInfo
    viewInfo = _tciViewInfo tableInfo
    permAcc = getPermAcc1 permDef

addPermP2 :: (IsPerm a, MonadTx m, HasSystemDefined m) => QualifiedTable -> PermDef a -> m ()
addPermP2 tn pd = do
  let pt = permAccToType $ getPermAcc1 pd
  systemDefined <- askSystemDefined
  liftTx $ savePermToCatalog pt tn pd systemDefined

runCreatePerm
  :: (UserInfoM m, CacheRWM m, IsPerm a, MonadTx m, HasSystemDefined m)
  => CreatePerm a -> m EncJSON
runCreatePerm (WithTable tn pd) = do
  adminOnly
  addPermP2 tn pd
  let pt = permAccToType $ getPermAcc1 pd
  buildSchemaCacheFor $ MOTableObj tn (MTOPerm (pdRole pd) pt)
  pure successMsg

dropPermP1
  :: (QErrM m, CacheRM m, IsPerm a)
  => DropPerm a -> m (PermInfo a)
dropPermP1 dp@(DropPerm tn rn) = do
  tabInfo <- askTabInfo tn
  askPermInfo tabInfo rn $ getPermAcc2 dp

dropPermP2 :: (MonadTx m, IsPerm a) => DropPerm a -> DropPermP1Res a -> m ()
dropPermP2 dp@(DropPerm tn rn) p1Res = do
  dropPermP2Setup dp p1Res
  liftTx $ dropPermFromCatalog tn rn pt
  where
    pa = getPermAcc2 dp
    pt = permAccToType pa

runDropPerm
  :: (IsPerm a, UserInfoM m, CacheRWM m, MonadTx m)
  => DropPerm a -> m EncJSON
runDropPerm defn = do
  permInfo <- buildDropPermP1Res defn
  dropPermP2 defn permInfo
  withNewInconsistentObjsCheck buildSchemaCache
  return successMsg