graphql-engine/server/src-lib/Hasura/Function/Cache.hs

{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE UndecidableInstances #-}

-- | types and helpers for user-defined-functions after they have been resolved
-- in the schema cache
module Hasura.Function.Cache
  ( DBFunctionsMetadata,
    FunctionOverloads (..),
    FunctionArgName (..),
    FunctionCache,
    FunctionConfig (..),
    FunctionCustomRootFields (..),
    FunctionExposedAs (..),
    FunctionInfo (..),
    FunctionInputArgument,
    FunctionPermissionInfo (..),
    FunctionPermissionsMap,
    FunctionVolatility (..),
    InputArgument (..),
    FunctionArgsExpG (..),
    FunctionArgsExp,
    emptyFunctionConfig,
    emptyFunctionCustomRootFields,
    funcTypToTxt,
    emptyFunctionArgsExp,
  )
where

import Autodocodec
  ( HasCodec (codec),
    bimapCodec,
    dimapCodec,
    optionalField',
    optionalFieldWith',
    optionalFieldWithDefault',
    requiredField',
    stringConstCodec,
  )
import Autodocodec qualified as AC
import Autodocodec.Extended (graphQLFieldNameCodec)
import Control.Lens
import Data.Aeson
import Data.Aeson.Casing
import Data.Char (toLower)
import Data.HashMap.Strict qualified as HashMap
import Data.List.Extended as LE
import Data.Sequence qualified as Seq
import Data.Text qualified as T
import Data.Text.Extended
import Hasura.Prelude
import Hasura.RQL.Types.Backend
import Hasura.RQL.Types.BackendType
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Roles (RoleName)
import Language.GraphQL.Draft.Syntax qualified as G
import Language.Haskell.TH.Syntax

-- | https://www.postgresql.org/docs/current/xfunc-volatility.html
data FunctionVolatility
  = FTVOLATILE
  | FTIMMUTABLE
  | FTSTABLE
  deriving (Eq, Generic)

instance NFData FunctionVolatility

instance FromJSON FunctionVolatility where
  parseJSON = genericParseJSON defaultOptions {constructorTagModifier = drop 2}

instance ToJSON FunctionVolatility where
  toJSON = genericToJSON defaultOptions {constructorTagModifier = drop 2}
  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = drop 2}

funcTypToTxt :: FunctionVolatility -> Text
funcTypToTxt FTVOLATILE = "VOLATILE"
funcTypToTxt FTIMMUTABLE = "IMMUTABLE"
funcTypToTxt FTSTABLE = "STABLE"

instance Show FunctionVolatility where
  show = T.unpack . funcTypToTxt

newtype FunctionArgName = FunctionArgName {getFuncArgNameTxt :: Text}
  deriving (Show, Eq, Ord, NFData, ToJSON, ToJSONKey, FromJSON, FromJSONKey, ToTxt, IsString, Generic, Hashable, Lift, Data)

instance HasCodec FunctionArgName where
  codec = dimapCodec FunctionArgName getFuncArgNameTxt codec

data InputArgument a
  = IAUserProvided a
  | IASessionVariables FunctionArgName
  deriving (Show, Eq, Functor, Generic)

instance ToJSON a => ToJSON (InputArgument a) where
  toJSON = genericToJSON defaultOptions {constructorTagModifier = snakeCase . drop 2, sumEncoding = TaggedObject "type" "argument"}
  toEncoding = genericToEncoding defaultOptions {constructorTagModifier = snakeCase . drop 2, sumEncoding = TaggedObject "type" "argument"}

type FunctionInputArgument b = InputArgument (FunctionArgument b)

-- | Indicates whether the user requested the corresponding function to be
-- tracked as a mutation or a query/subscription, in @track_function@.
data FunctionExposedAs = FEAQuery | FEAMutation
  deriving (Show, Eq, Generic)

instance NFData FunctionExposedAs

instance HasCodec FunctionExposedAs where
  codec = stringConstCodec [(FEAQuery, "query"), (FEAMutation, "mutation")]

instance FromJSON FunctionExposedAs where
  parseJSON = genericParseJSON defaultOptions {sumEncoding = UntaggedValue, constructorTagModifier = map toLower . drop 3}

instance ToJSON FunctionExposedAs where
  toJSON = genericToJSON defaultOptions {sumEncoding = UntaggedValue, constructorTagModifier = map toLower . drop 3}
  toEncoding = genericToEncoding defaultOptions {sumEncoding = UntaggedValue, constructorTagModifier = map toLower . drop 3}

newtype FunctionPermissionInfo = FunctionPermissionInfo
  { _fpmRole :: RoleName
  }
  deriving (Show, Eq, Generic)

instance HasCodec FunctionPermissionInfo where
  codec =
    AC.object "FunctionPermissionInfo" $
      FunctionPermissionInfo <$> requiredField' "role" AC..= _fpmRole

instance FromJSON FunctionPermissionInfo where
  parseJSON = genericParseJSON hasuraJSON

instance ToJSON FunctionPermissionInfo where
  toJSON = genericToJSON hasuraJSON
  toEncoding = genericToEncoding hasuraJSON

type FunctionPermissionsMap = HashMap RoleName FunctionPermissionInfo

-- | Custom root fields for functions. When set, will be the names exposed
--   to the user in the schema.
--
--   See rfcs/function-root-field-customisation.md for more information.
data FunctionCustomRootFields = FunctionCustomRootFields
  { _fcrfFunction :: Maybe G.Name,
    _fcrfFunctionAggregate :: Maybe G.Name
  }
  deriving (Show, Eq, Generic)

instance NFData FunctionCustomRootFields

instance HasCodec FunctionCustomRootFields where
  codec =
    bimapCodec checkForDup id $
      AC.object "FunctionCustomRootFields" $
        FunctionCustomRootFields
          <$> optionalFieldWith' "function" graphQLFieldNameCodec AC..= _fcrfFunction
          <*> optionalFieldWith' "function_aggregate" graphQLFieldNameCodec AC..= _fcrfFunctionAggregate
    where
      checkForDup (FunctionCustomRootFields (Just f) (Just fa))
        | f == fa =
            Left $
              T.unpack $
                "the following custom root field names are duplicated: " <> toTxt f <<> " and " <>> toTxt fa
      checkForDup fields = Right fields

instance ToJSON FunctionCustomRootFields where
  toJSON = genericToJSON hasuraJSON {omitNothingFields = True}
  toEncoding = genericToEncoding hasuraJSON {omitNothingFields = True}

instance FromJSON FunctionCustomRootFields where
  parseJSON = withObject "Object" $ \obj -> do
    function <- obj .:? "function"
    functionAggregate <- obj .:? "function_aggregate"

    case (function, functionAggregate) of
      (Just f, Just fa)
        | f == fa ->
            fail $
              T.unpack $
                "the following custom root field names are duplicated: "
                  <> toTxt f <<> " and " <>> toTxt fa
      _ ->
        pure ()

    pure $ FunctionCustomRootFields function functionAggregate

-- | A function custom root fields without custom names set. This is the default.
emptyFunctionCustomRootFields :: FunctionCustomRootFields
emptyFunctionCustomRootFields =
  FunctionCustomRootFields
    { _fcrfFunction = Nothing,
      _fcrfFunctionAggregate = Nothing
    }

-- | Tracked SQL function metadata. See 'buildFunctionInfo'.
data FunctionInfo (b :: BackendType) = FunctionInfo
  { _fiSQLName :: FunctionName b,
    _fiGQLName :: G.Name,
    _fiGQLArgsName :: G.Name,
    _fiGQLAggregateName :: G.Name,
    _fiSystemDefined :: SystemDefined,
    _fiVolatility :: FunctionVolatility,
    -- | In which part of the schema should this function be exposed?
    --
    -- See 'mkFunctionInfo' and '_fcExposedAs'.
    _fiExposedAs :: FunctionExposedAs,
    _fiInputArgs :: Seq.Seq (FunctionInputArgument b),
    -- | NOTE: when a table is created, a new composite type of the same name is
    -- automatically created; so strictly speaking this field means "the function
    -- returns the composite type corresponding to this table".
    _fiReturnType :: TableName b,
    -- | this field represents the description of the function as present on the database
    _fiDescription :: Maybe Text,
    -- | Roles to which the function is accessible
    _fiPermissions :: FunctionPermissionsMap,
    _fiJsonAggSelect :: JsonAggSelect,
    _fiComment :: Maybe Text
  }
  deriving (Generic)

deriving instance Backend b => Show (FunctionInfo b)

deriving instance Backend b => Eq (FunctionInfo b)

instance (Backend b) => ToJSON (FunctionInfo b) where
  toJSON = genericToJSON hasuraJSON

type FunctionCache b = HashMap (FunctionName b) (FunctionInfo b) -- info of all functions

-- Metadata requests related types

-- | Tracked function configuration, and payload of the 'pg_track_function' and
-- 'pg_set_function_customization' API calls.
data FunctionConfig = FunctionConfig
  { _fcSessionArgument :: Maybe FunctionArgName,
    -- | In which top-level field should we expose this function?
    --
    -- The user might omit this, in which case we'll infer the location from the
    -- SQL functions volatility. See 'mkFunctionInfo' or the @track_function@ API
    -- docs for details of validation, etc.
    _fcExposedAs :: Maybe FunctionExposedAs,
    _fcCustomRootFields :: FunctionCustomRootFields,
    _fcCustomName :: Maybe G.Name
  }
  deriving (Show, Eq, Generic)

instance NFData FunctionConfig

instance HasCodec FunctionConfig where
  codec =
    AC.object "FunctionConfig" $
      FunctionConfig
        <$> optionalField' "session_argument" AC..= _fcSessionArgument
        <*> optionalField' "exposed_as" AC..= _fcExposedAs
        <*> optionalFieldWithDefault' "custom_root_fields" emptyFunctionCustomRootFields AC..= _fcCustomRootFields
        <*> optionalFieldWith' "custom_name" graphQLFieldNameCodec AC..= _fcCustomName

instance FromJSON FunctionConfig where
  parseJSON = withObject "FunctionConfig" $ \obj ->
    FunctionConfig
      <$> obj .:? "session_argument"
      <*> obj .:? "exposed_as"
      <*> obj .:? "custom_root_fields" .!= emptyFunctionCustomRootFields
      <*> obj .:? "custom_name"

instance ToJSON FunctionConfig where
  toJSON = genericToJSON hasuraJSON {omitNothingFields = True}
  toEncoding = genericToEncoding hasuraJSON {omitNothingFields = True}

-- | The default function config; v1 of the API implies this.
emptyFunctionConfig :: FunctionConfig
emptyFunctionConfig = FunctionConfig Nothing Nothing emptyFunctionCustomRootFields Nothing

type DBFunctionsMetadata b = HashMap (FunctionName b) (FunctionOverloads b)

newtype FunctionOverloads b = FunctionOverloads {getFunctionOverloads :: NonEmpty (RawFunctionInfo b)}

deriving newtype instance Backend b => Eq (FunctionOverloads b)

deriving newtype instance FromJSON (RawFunctionInfo b) => FromJSON (FunctionOverloads b)

data FunctionArgsExpG a = FunctionArgsExp
  { _faePositional :: [a],
    _faeNamed :: (HashMap.HashMap Text a)
  }
  deriving stock (Show, Eq, Functor, Foldable, Traversable, Generic)

instance (Hashable a) => Hashable (FunctionArgsExpG a)

instance (NFData a) => NFData (FunctionArgsExpG a)

type FunctionArgsExp b v = FunctionArgsExpG (FunctionArgumentExp b v)

emptyFunctionArgsExp :: FunctionArgsExpG a
emptyFunctionArgsExp = FunctionArgsExp [] HashMap.empty