graphql-engine/server/src-lib/Hasura/GraphQL/Schema/OrderBy.hs

{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE TemplateHaskellQuotes #-}

module Hasura.GraphQL.Schema.OrderBy
  ( orderByExp,
  )
where

import Data.Has
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.Text.Casing qualified as C
import Data.Text.Extended
import Hasura.GraphQL.Parser.Class
import Hasura.GraphQL.Schema.Backend
import Hasura.GraphQL.Schema.Common
import Hasura.GraphQL.Schema.NamingCase
import Hasura.GraphQL.Schema.Parser
  ( InputFieldsParser,
    Kind (..),
    Parser,
  )
import Hasura.GraphQL.Schema.Parser qualified as P
import Hasura.GraphQL.Schema.Table
import Hasura.GraphQL.Schema.Typename
import Hasura.Name qualified as Name
import Hasura.Prelude
import Hasura.RQL.IR.OrderBy qualified as IR
import Hasura.RQL.IR.Select qualified as IR
import Hasura.RQL.IR.Value qualified as IR
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.Column
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.ComputedField
import Hasura.RQL.Types.Function
import Hasura.RQL.Types.Relationships.Local
import Hasura.RQL.Types.SchemaCache hiding (askTableInfo)
import Hasura.RQL.Types.Source
import Hasura.RQL.Types.SourceCustomization
import Hasura.RQL.Types.Table
import Language.GraphQL.Draft.Syntax qualified as G

{-# INLINE orderByOperator #-}
orderByOperator ::
  forall b n.
  (BackendSchema b, MonadParse n) =>
  NamingCase ->
  SourceInfo b ->
  Parser 'Both n (Maybe (BasicOrderType b, NullsOrderType b))
orderByOperator tCase sourceInfo = case tCase of
  HasuraCase -> orderByOperatorsHasuraCase @b sourceInfo
  GraphqlCase -> orderByOperatorsGraphqlCase @b sourceInfo

-- | Corresponds to an object type for an order by.
--
-- > input table_order_by {
-- >   col1: order_by
-- >   col2: order_by
-- >   .     .
-- >   .     .
-- >   coln: order_by
-- >   obj-rel: <remote-table>_order_by
-- > }
orderByExp ::
  forall b r m n.
  MonadBuildSchema b r m n =>
  SourceInfo b ->
  TableInfo b ->
  SchemaT r m (Parser 'Input n [IR.AnnotatedOrderByItemG b (IR.UnpreparedValue b)])
orderByExp sourceInfo tableInfo = P.memoizeOn 'orderByExp (_siName sourceInfo, tableInfoName tableInfo) $ do
  tCase <- asks getter
  tableGQLName <- getTableIdentifierName tableInfo
  name <- mkTypename $ applyTypeNameCaseIdentifier tCase $ mkTableOrderByTypeName tableGQLName
  let description =
        G.Description $
          "Ordering options when selecting data from " <> tableInfoName tableInfo <<> "."
  tableFields <- tableSelectFields sourceInfo tableInfo
  fieldParsers <- sequenceA . catMaybes <$> traverse (mkField tCase) tableFields
  pure $ concat . catMaybes <$> P.object name (Just description) fieldParsers
  where
    mkField ::
      NamingCase ->
      FieldInfo b ->
      SchemaT r m (Maybe (InputFieldsParser n (Maybe [IR.AnnotatedOrderByItemG b (IR.UnpreparedValue b)])))
    mkField tCase fieldInfo = runMaybeT $ do
      roleName <- retrieve scRole
      case fieldInfo of
        FIColumn columnInfo -> do
          let !fieldName = ciName columnInfo
          pure $
            P.fieldOptional
              fieldName
              Nothing
              (orderByOperator @b tCase sourceInfo)
              <&> fmap (pure . mkOrderByItemG @b (IR.AOCColumn columnInfo)) . join
        FIRelationship relationshipInfo -> do
          remoteTableInfo <- askTableInfo sourceInfo $ riRTable relationshipInfo
          perms <- hoistMaybe $ tableSelectPermissions roleName remoteTableInfo
          fieldName <- hoistMaybe $ G.mkName $ relNameToTxt $ riName relationshipInfo
          let newPerms = fmap partialSQLExpToUnpreparedValue <$> spiFilter perms
          case riType relationshipInfo of
            ObjRel -> do
              otherTableParser <- lift $ orderByExp sourceInfo remoteTableInfo
              pure $ do
                otherTableOrderBy <- join <$> P.fieldOptional fieldName Nothing (P.nullable otherTableParser)
                pure $ fmap (map $ fmap $ IR.AOCObjectRelation relationshipInfo newPerms) otherTableOrderBy
            ArrRel -> do
              let aggregateFieldName = applyFieldNameCaseIdentifier tCase $ C.fromAutogeneratedTuple (fieldName, [G.convertNameToSuffix Name._aggregate])
              aggregationParser <- lift $ orderByAggregation sourceInfo remoteTableInfo
              pure $ do
                aggregationOrderBy <- join <$> P.fieldOptional aggregateFieldName Nothing (P.nullable aggregationParser)
                pure $ fmap (map $ fmap $ IR.AOCArrayAggregation relationshipInfo newPerms) aggregationOrderBy
        FIComputedField ComputedFieldInfo {..} -> do
          let ComputedFieldFunction {..} = _cfiFunction
              mkComputedFieldOrderBy =
                let functionArgs =
                      flip FunctionArgsExp mempty $
                        fromComputedFieldImplicitArguments @b IR.UVSession _cffComputedFieldImplicitArgs
                 in IR.ComputedFieldOrderBy _cfiXComputedFieldInfo _cfiName _cffName functionArgs
          fieldName <- hoistMaybe $ G.mkName $ toTxt _cfiName
          guard $ _cffInputArgs == mempty -- No input arguments other than table row and session argument
          case computedFieldReturnType @b _cfiReturnType of
            ReturnsScalar scalarType -> do
              let computedFieldOrderBy = mkComputedFieldOrderBy $ IR.CFOBEScalar scalarType
              pure $
                P.fieldOptional
                  fieldName
                  Nothing
                  (orderByOperator @b tCase sourceInfo)
                  <&> fmap (pure . mkOrderByItemG @b (IR.AOCComputedField computedFieldOrderBy)) . join
            ReturnsTable table -> do
              let aggregateFieldName = applyFieldNameCaseIdentifier tCase $ C.fromAutogeneratedTuple (fieldName, [G.convertNameToSuffix Name._aggregate])
              tableInfo' <- askTableInfo sourceInfo table
              perms <- hoistMaybe $ tableSelectPermissions roleName tableInfo'
              let newPerms = fmap partialSQLExpToUnpreparedValue <$> spiFilter perms
              aggregationParser <- lift $ orderByAggregation sourceInfo tableInfo'
              pure $ do
                aggregationOrderBy <- join <$> P.fieldOptional aggregateFieldName Nothing (P.nullable aggregationParser)
                pure $
                  fmap
                    ( map $
                        fmap $
                          IR.AOCComputedField
                            . mkComputedFieldOrderBy
                            . IR.CFOBETableAggregation table newPerms
                    )
                    aggregationOrderBy
            ReturnsOthers -> empty
        FIRemoteRelationship _ -> empty

-- FIXME!
-- those parsers are directly using Postgres' SQL representation of
-- order, rather than using a general intermediary representation

orderByAggregation ::
  forall b r m n.
  MonadBuildSchema b r m n =>
  SourceInfo b ->
  TableInfo b ->
  SchemaT r m (Parser 'Input n [IR.OrderByItemG b (IR.AnnotatedAggregateOrderBy b)])
orderByAggregation sourceInfo tableInfo = P.memoizeOn 'orderByAggregation (_siName sourceInfo, tableName) do
  -- WIP NOTE
  -- there is heavy duplication between this and Select.tableAggregationFields
  -- it might be worth putting some of it in common, just to avoid issues when
  -- we change one but not the other?
  tableGQLName <- getTableGQLName @b tableInfo
  tCase <- asks getter
  tableIdentifierName <- getTableIdentifierName @b tableInfo
  allColumns <- tableSelectColumns sourceInfo tableInfo
  makeTypename <- asks getter
  let numColumns = mkAgOpsFields tCase $ onlyNumCols allColumns
      compColumns = mkAgOpsFields tCase $ onlyComparableCols allColumns
      numOperatorsAndColumns = HashMap.fromList $ (,numColumns) <$> numericAggOperators
      compOperatorsAndColumns = HashMap.fromList $ (,compColumns) <$> comparisonAggOperators
      customOperatorsAndColumns =
        getCustomAggOpsColumns tCase allColumns <$> getCustomAggregateOperators @b (_siConfiguration sourceInfo)
      allOperatorsAndColumns =
        HashMap.catMaybes $
          HashMap.unionsWith (<>) [numOperatorsAndColumns, compOperatorsAndColumns, customOperatorsAndColumns]
      aggFields =
        fmap (concat . catMaybes . concat) $
          sequenceA $
            catMaybes
              [ -- count
                Just $
                  P.fieldOptional
                    Name._count
                    Nothing
                    (orderByOperator @b tCase sourceInfo)
                    <&> pure . fmap (pure . mkOrderByItemG @b IR.AAOCount) . join,
                -- other operators
                if null allOperatorsAndColumns
                  then Nothing
                  else Just $
                    for (HashMap.toList allOperatorsAndColumns) \(operator, fields) -> do
                      parseOperator makeTypename operator tableGQLName fields
              ]
  objectName <- mkTypename $ applyTypeNameCaseIdentifier tCase $ mkTableAggregateOrderByTypeName tableIdentifierName
  let description = G.Description $ "order by aggregate values of table " <>> tableName
  pure $ P.object objectName (Just description) aggFields
  where
    tableName = tableInfoName tableInfo

    -- Build an InputFieldsParser only if the column list is non-empty
    mkAgOpsFields ::
      NamingCase ->
      [ColumnInfo b] ->
      Maybe (InputFieldsParser n [(ColumnInfo b, (BasicOrderType b, NullsOrderType b))])
    mkAgOpsFields tCase =
      fmap (fmap (catMaybes . toList) . traverse (mkField tCase)) . nonEmpty

    getCustomAggOpsColumns ::
      NamingCase ->
      [ColumnInfo b] ->
      HashMap (ScalarType b) v ->
      Maybe (InputFieldsParser n [(ColumnInfo b, (BasicOrderType b, NullsOrderType b))])
    getCustomAggOpsColumns tCase columnInfos typeMap =
      columnInfos
        & filter
          ( \ColumnInfo {..} ->
              case ciType of
                ColumnEnumReference _ -> False
                ColumnScalar scalarType ->
                  HashMap.member scalarType typeMap
          )
        & mkAgOpsFields tCase

    mkField :: NamingCase -> ColumnInfo b -> InputFieldsParser n (Maybe (ColumnInfo b, (BasicOrderType b, NullsOrderType b)))
    mkField tCase columnInfo =
      P.fieldOptional
        (ciName columnInfo)
        (ciDescription columnInfo)
        (orderByOperator @b tCase sourceInfo)
        <&> fmap (columnInfo,) . join

    parseOperator ::
      MkTypename ->
      G.Name ->
      G.Name ->
      InputFieldsParser n [(ColumnInfo b, (BasicOrderType b, NullsOrderType b))] ->
      InputFieldsParser n (Maybe [IR.OrderByItemG b (IR.AnnotatedAggregateOrderBy b)])
    parseOperator makeTypename operator tableGQLName columns =
      let opText = G.unName operator
          objectName = runMkTypename makeTypename $ tableGQLName <> Name.__ <> operator <> Name.__order_by
          objectDesc = Just $ G.Description $ "order by " <> opText <> "() on columns of table " <>> tableName
       in P.fieldOptional operator Nothing (P.object objectName objectDesc columns)
            `mapField` map (\(col, info) -> mkOrderByItemG (IR.AAOOp opText col) info)

orderByOperatorsHasuraCase ::
  forall b n.
  (BackendSchema b, MonadParse n) =>
  SourceInfo b ->
  Parser 'Both n (Maybe (BasicOrderType b, NullsOrderType b))
orderByOperatorsHasuraCase = orderByOperator' @b HasuraCase

orderByOperatorsGraphqlCase ::
  forall b n.
  (BackendSchema b, MonadParse n) =>
  SourceInfo b ->
  Parser 'Both n (Maybe (BasicOrderType b, NullsOrderType b))
orderByOperatorsGraphqlCase = orderByOperator' @b GraphqlCase

orderByOperator' ::
  forall b n.
  (BackendSchema b, MonadParse n) =>
  NamingCase ->
  SourceInfo b ->
  Parser 'Both n (Maybe (BasicOrderType b, NullsOrderType b))
orderByOperator' tCase sourceInfo =
  let (sourcePrefix, orderOperators) = orderByOperators @b sourceInfo tCase
   in P.nullable $ P.enum (applyTypeNameCaseCust tCase sourcePrefix) (Just "column ordering options") $ orderOperators

mkOrderByItemG :: forall b a. a -> (BasicOrderType b, NullsOrderType b) -> IR.OrderByItemG b a
mkOrderByItemG column (orderType, nullsOrder) =
  IR.OrderByItemG
    { obiType = Just orderType,
      obiColumn = column,
      obiNulls = Just nullsOrder
    }