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

module Hasura.RQL.DML.Internal where
-- ( mkAdminRolePermInfo
-- , SessVarBldr
-- ) where

import           Hasura.Prelude

import qualified Data.HashMap.Strict                        as M
import qualified Data.HashSet                               as HS
import qualified Data.Sequence                              as DS
import qualified Data.Text                                  as T
import qualified Database.PG.Query                          as Q

import           Control.Lens
import           Data.Aeson.Types
import           Data.Text.Extended

import qualified Hasura.Backends.Postgres.SQL.DML           as S

import           Hasura.Backends.Postgres.SQL.Error
import           Hasura.Backends.Postgres.SQL.Types         hiding (TableName)
import           Hasura.Backends.Postgres.SQL.Value
import           Hasura.Backends.Postgres.Translate.BoolExp
import           Hasura.Backends.Postgres.Translate.Column
import           Hasura.RQL.Types
import           Hasura.SQL.Types
import           Hasura.Session


newtype DMLP1T m a
  = DMLP1T { unDMLP1T :: StateT (DS.Seq Q.PrepArg) m a }
  deriving ( Functor, Applicative, Monad, MonadTrans
           , MonadState (DS.Seq Q.PrepArg), MonadError e
           , SourceM, TableCoreInfoRM b, TableInfoRM b, CacheRM, UserInfoM, HasServerConfigCtx
           )

runDMLP1T :: DMLP1T m a -> m (a, DS.Seq Q.PrepArg)
runDMLP1T = flip runStateT DS.empty . unDMLP1T

mkAdminRolePermInfo :: Backend b => TableCoreInfo b -> RolePermInfo b
mkAdminRolePermInfo ti =
  RolePermInfo (Just i) (Just s) (Just u) (Just d)
  where
    fields = _tciFieldInfoMap ti
    pgCols = map pgiColumn $ getCols fields
    scalarComputedFields = map _cfiName $ onlyScalarComputedFields $
                     getComputedFieldInfos fields

    tn = _tciName ti
    i = InsPermInfo (HS.fromList pgCols) annBoolExpTrue M.empty False []
    s = SelPermInfo (HS.fromList pgCols) (HS.fromList scalarComputedFields) annBoolExpTrue
        Nothing True []
    u = UpdPermInfo (HS.fromList pgCols) tn annBoolExpTrue Nothing M.empty []
    d = DelPermInfo tn annBoolExpTrue []

askPermInfo'
  :: (UserInfoM m)
  => PermAccessor 'Postgres c
  -> TableInfo 'Postgres
  -> m (Maybe c)
askPermInfo' pa tableInfo = do
  roleName <- askCurRole
  return $ getPermInfoMaybe roleName pa tableInfo

getPermInfoMaybe :: RoleName -> PermAccessor 'Postgres c -> TableInfo 'Postgres -> Maybe c
getPermInfoMaybe roleName pa tableInfo =
  getRolePermInfo roleName tableInfo >>= (^. permAccToLens pa)

getRolePermInfo :: Backend b => RoleName -> TableInfo b -> Maybe (RolePermInfo b)
getRolePermInfo roleName tableInfo
  | roleName == adminRoleName =
    Just $ mkAdminRolePermInfo (_tiCoreInfo tableInfo)
  | otherwise                 =
    M.lookup roleName (_tiRolePermInfoMap tableInfo)

askPermInfo
  :: (UserInfoM m, QErrM m)
  => PermAccessor 'Postgres c
  -> TableInfo 'Postgres
  -> m c
askPermInfo pa tableInfo = do
  roleName  <- askCurRole
  mPermInfo <- askPermInfo' pa tableInfo
  onNothing mPermInfo $ throw400 PermissionDenied $ mconcat
    [ pt <> " on " <>> _tciName (_tiCoreInfo tableInfo)
    , " for role " <>> roleName
    , " is not allowed. "
    ]
  where
    pt = permTypeToCode $ permAccToType pa

isTabUpdatable :: RoleName -> TableInfo 'Postgres -> Bool
isTabUpdatable role ti
  | role == adminRoleName = True
  | otherwise = isJust $ M.lookup role rpim >>= _permUpd
  where
    rpim = _tiRolePermInfoMap ti

askInsPermInfo
  :: (UserInfoM m, QErrM m)
  => TableInfo 'Postgres -> m (InsPermInfo 'Postgres)
askInsPermInfo = askPermInfo PAInsert

askSelPermInfo
  :: (UserInfoM m, QErrM m)
  => TableInfo 'Postgres -> m (SelPermInfo 'Postgres)
askSelPermInfo = askPermInfo PASelect

askUpdPermInfo
  :: (UserInfoM m, QErrM m)
  => TableInfo 'Postgres -> m (UpdPermInfo 'Postgres)
askUpdPermInfo = askPermInfo PAUpdate

askDelPermInfo
  :: (UserInfoM m, QErrM m)
  => TableInfo 'Postgres -> m (DelPermInfo 'Postgres)
askDelPermInfo = askPermInfo PADelete

verifyAsrns :: (MonadError QErr m) => [a -> m ()] -> [a] -> m ()
verifyAsrns preds xs = indexedForM_ xs $ \a -> mapM_ ($ a) preds

checkSelOnCol :: (UserInfoM m, QErrM m)
              => SelPermInfo 'Postgres -> PGCol -> m ()
checkSelOnCol selPermInfo =
  checkPermOnCol PTSelect (spiCols selPermInfo)

checkPermOnCol
  :: (UserInfoM m, QErrM m)
  => PermType
  -> HS.HashSet PGCol
  -> PGCol
  -> m ()
checkPermOnCol pt allowedCols pgCol = do
  roleName <- askCurRole
  unless (HS.member pgCol allowedCols) $
    throw400 PermissionDenied $ permErrMsg roleName
  where
    permErrMsg roleName
      | roleName == adminRoleName = "no such column exists : " <>> pgCol
      | otherwise = mconcat
        [ "role " <>> roleName
        , " does not have permission to "
        , permTypeToCode pt <> " column " <>> pgCol
        ]

binRHSBuilder :: (QErrM m) => ColumnType 'Postgres -> Value -> DMLP1T m S.SQLExp
binRHSBuilder colType val = do
  preparedArgs <- get
  scalarValue <- parsePGScalarValue colType val
  put (preparedArgs DS.|> binEncoder scalarValue)
  return $ toPrepParam (DS.length preparedArgs + 1) (unsafePGColumnToBackend colType)

fetchRelTabInfo
  :: (QErrM m, TableInfoRM 'Postgres m)
  => TableName 'Postgres -> m (TableInfo 'Postgres)
fetchRelTabInfo refTabName =
  -- Internal error
  modifyErrAndSet500 ("foreign " <> ) $
    askTabInfoSource refTabName

type SessVarBldr b m = SessionVarType b -> SessionVariable -> m (SQLExpression b)

fetchRelDet
  :: (UserInfoM m, QErrM m, TableInfoRM 'Postgres m)
  => RelName -> TableName 'Postgres
  -> m (FieldInfoMap (FieldInfo 'Postgres), SelPermInfo 'Postgres)
fetchRelDet relName refTabName = do
  roleName <- askCurRole
  -- Internal error
  refTabInfo <- fetchRelTabInfo refTabName
  -- Get the correct constraint that applies to the given relationship
  refSelPerm <- modifyErr (relPermErr refTabName roleName) $
                askSelPermInfo refTabInfo

  return (_tciFieldInfoMap $ _tiCoreInfo refTabInfo, refSelPerm)
  where
    relPermErr rTable roleName _ =
      mconcat
      [ "role " <>> roleName
      , " does not have permission to read relationship " <>> relName
      , "; no permission on"
      , " table " <>> rTable
      ]

checkOnColExp
  :: (UserInfoM m, QErrM m, TableInfoRM 'Postgres m)
  => SelPermInfo 'Postgres
  -> SessVarBldr 'Postgres m
  -> AnnBoolExpFldSQL 'Postgres
  -> m (AnnBoolExpFldSQL 'Postgres)
checkOnColExp spi sessVarBldr annFld = case annFld of
  AVCol colInfo _ -> do
    let cn = pgiColumn colInfo
    checkSelOnCol spi cn
    return annFld
  AVRel relInfo nesAnn -> do
    relSPI <- snd <$> fetchRelDet (riName relInfo) (riRTable relInfo)
    modAnn <- checkSelPerm relSPI sessVarBldr nesAnn
    resolvedFltr <- convAnnBoolExpPartialSQL sessVarBldr $ spiFilter relSPI
    return $ AVRel relInfo $ andAnnBoolExps modAnn resolvedFltr

convAnnBoolExpPartialSQL
  :: (Applicative f)
  => SessVarBldr backend f
  -> AnnBoolExpPartialSQL backend
  -> f (AnnBoolExpSQL backend)
convAnnBoolExpPartialSQL f =
  traverseAnnBoolExp (convPartialSQLExp f)

convPartialSQLExp
  :: (Applicative f)
  => SessVarBldr backend f
  -> PartialSQLExp backend
  -> f (SQLExpression backend)
convPartialSQLExp f = \case
  PSESQLExp sqlExp                 -> pure sqlExp
  PSESessVar colTy sessionVariable -> f colTy sessionVariable

sessVarFromCurrentSetting
  :: (Applicative f) => CollectableType PGScalarType -> SessionVariable -> f S.SQLExp
sessVarFromCurrentSetting pgType sessVar =
  pure $ sessVarFromCurrentSetting' pgType sessVar

sessVarFromCurrentSetting' :: CollectableType PGScalarType -> SessionVariable -> S.SQLExp
sessVarFromCurrentSetting' ty sessVar =
  flip S.SETyAnn (S.mkTypeAnn ty) $
  case ty of
    CollectableTypeScalar baseTy -> withConstructorFn baseTy sessVarVal
    CollectableTypeArray _       -> sessVarVal
  where
    sessVarVal = S.SEOpApp (S.SQLOp "->>")
                 [currentSession, S.SELit $ sessionVariableToText sessVar]

currentSession :: S.SQLExp
currentSession = S.SEUnsafe "current_setting('hasura.user')::json"

checkSelPerm
  :: (UserInfoM m, QErrM m, TableInfoRM 'Postgres m)
  => SelPermInfo 'Postgres
  -> SessVarBldr 'Postgres m
  -> AnnBoolExpSQL 'Postgres
  -> m (AnnBoolExpSQL 'Postgres)
checkSelPerm spi sessVarBldr =
  traverse (checkOnColExp spi sessVarBldr)

convBoolExp
  :: (UserInfoM m, QErrM m, TableInfoRM 'Postgres m)
  => FieldInfoMap (FieldInfo 'Postgres)
  -> SelPermInfo 'Postgres
  -> BoolExp 'Postgres
  -> SessVarBldr 'Postgres m
  -> (ColumnType 'Postgres -> Value -> m S.SQLExp)
  -> m (AnnBoolExpSQL 'Postgres)
convBoolExp cim spi be sessVarBldr prepValBldr = do
  abe <- annBoolExp rhsParser cim $ unBoolExp be
  checkSelPerm spi sessVarBldr abe
  where
    rhsParser pgType val = case pgType of
      CollectableTypeScalar ty  -> prepValBldr ty val
      CollectableTypeArray ofTy -> do
        -- for arrays, we don't use the prepared builder
        vals <- runAesonParser parseJSON val
        scalarValues <- parsePGScalarValues ofTy vals
        return $ S.SETyAnn
          (S.SEArray $ map (toTxtValue . ColumnValue ofTy) scalarValues)
          (S.mkTypeAnn $ CollectableTypeArray (unsafePGColumnToBackend ofTy))

dmlTxErrorHandler :: Q.PGTxErr -> QErr
dmlTxErrorHandler = mkTxErrorHandler $ \case
  PGIntegrityConstraintViolation _ -> True
  PGDataException _ -> True
  PGSyntaxErrorOrAccessRuleViolation (Just (PGErrorSpecific code)) -> code `elem`
    [ PGUndefinedObject
    , PGInvalidColumnReference ]
  _ -> False

toJSONableExp :: Bool -> ColumnType 'Postgres -> Bool -> S.SQLExp -> S.SQLExp
toJSONableExp strfyNum colTy asText expn
  | asText || (isScalarColumnWhere isBigNum colTy && strfyNum) =
    expn `S.SETyAnn` S.textTypeAnn
  | isScalarColumnWhere isGeoType colTy =
      S.SEFnApp "ST_AsGeoJSON"
      [ expn
      , S.SEUnsafe "15" -- max decimal digits
      , S.SEUnsafe "4"  -- to print out crs
      ] Nothing
      `S.SETyAnn` S.jsonTypeAnn
  | otherwise = expn

-- validate headers
validateHeaders :: (UserInfoM m, QErrM m) => [Text] -> m ()
validateHeaders depHeaders = do
  headers <- getSessionVariables . _uiSession <$> askUserInfo
  forM_ depHeaders $ \hdr ->
    unless (hdr `elem` map T.toLower headers) $
    throw400 NotFound $ hdr <<> " header is expected but not found"

-- validate limit and offset int values
onlyPositiveInt :: MonadError QErr m => Int -> m ()
onlyPositiveInt i = when (i < 0) $ throw400 NotSupported
  "unexpected negative value"