graphql-engine/server/src-lib/Hasura/Server/OpenAPI.hs

{-# LANGUAGE ViewPatterns #-}
-- This prevents hlint errors on the "pattern" lens.
{-# LANGUAGE NoPatternSynonyms #-}

module Hasura.Server.OpenAPI (buildOpenAPI) where

import Control.Lens
import Control.Monad.Circular
import Data.Aeson qualified as J
import Data.HashMap.Strict qualified as Map
import Data.HashMap.Strict.InsOrd.Extended qualified as OMap
import Data.HashMap.Strict.Multi qualified as MMap
import Data.Monoid (Any (..))
import Data.OpenApi
import Data.OpenApi.Declare
import Data.Text qualified as T
import Data.Text.NonEmpty
import Data.Trie qualified as Trie
import Hasura.Base.Error
import Hasura.Base.Instances ()
import Hasura.GraphQL.Analyse
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.Prelude hiding (get, put)
import Hasura.RQL.Types.Endpoint
import Hasura.RQL.Types.QueryCollection
import Hasura.RQL.Types.SchemaCache hiding (FieldInfo)
import Language.GraphQL.Draft.Syntax qualified as G
import Network.HTTP.Media.MediaType ((//))

--------------------------------------------------------------------------------
-- API

buildOpenAPI :: (MonadError QErr m, MonadFix m) => SchemaCache -> m OpenApi
buildOpenAPI schemaCache = do
  (defs, spec) <- flip runDeclareT mempty do
    endpoints <- buildAllEndpoints schemaCache (scAdminIntrospection schemaCache)
    pure $
      mempty
        & paths .~ fmap fst endpoints
        & info . title .~ "Rest Endpoints"
        & info . description
          ?~ "This OpenAPI specification is automatically generated by Hasura." <> foldMap snd endpoints
  pure $ spec & components . schemas .~ defs

--------------------------------------------------------------------------------
-- Endpoint

buildAllEndpoints ::
  (MonadError QErr m, MonadFix m) =>
  SchemaCache ->
  G.SchemaIntrospection ->
  DeclareM m (InsOrdHashMap String (PathItem, Text))
buildAllEndpoints schemaCache schemaTypes =
  foldl' (OMap.unionWith (<>)) mempty <$> sequence do
    -- for each path in the trie of endpoints
    endpointMap <- Trie.elems $ scEndpoints schemaCache
    -- for each method at that path
    (method, metadataList) <- MMap.toList endpointMap
    -- for each metadata associated with that method
    metadata <- metadataList
    -- build the corresponding path item and list of messages
    pure $ buildEndpoint schemaTypes method metadata

buildEndpoint ::
  (MonadError QErr m, MonadFix m) =>
  G.SchemaIntrospection ->
  EndpointMethod ->
  EndpointMetadata GQLQueryWithText ->
  DeclareM m (InsOrdHashMap String (PathItem, Text))
buildEndpoint schemaTypes method EndpointMetadata {..} = do
  let -- extracting endpoint info
      GQLQueryWithText (queryText, GQLQuery queryDocument) = _edQuery _ceDefinition
  singleOperation <- lift $ getSingleOperation (GQLReq Nothing (GQLExecDoc (G.getExecutableDefinitions queryDocument)) Nothing)
  let (fromMaybe (Structure mempty mempty) -> analysis, messages) = analyzeGraphQLQuery schemaTypes singleOperation

      -- extracting endpoint url and name
      pathComponents = splitPath formatVariable id _ceUrl
      -- TODO: why are we doing this? we are dropping references to variables IIUC?
      formatVariable variable = "{" <> T.drop 1 variable <> "}"
      endpointURL = "/api/rest/" <> T.intercalate "/" pathComponents

      -- building endpoint properties
      endpointVarList = collectParams analysis _ceUrl
      endpointDescription =
        fold _ceComment
          <> "***\nThe GraphQl query for this endpoint is:\n``` graphql\n"
          <> queryText
          <> "\n```"
      endpointName = unNonEmptyText $ unEndpointName _ceName
  reqBody <- buildRequestBody analysis
  response <- buildResponse analysis method endpointURL

  let -- building the PathItem
      operation =
        mempty
          & description ?~ endpointDescription
          & summary ?~ endpointName
          & parameters .~ (Inline xHasuraAdminSecret : endpointVarList)
          & requestBody .~ reqBody
          & responses .~ Responses Nothing (OMap.singleton 200 $ Inline response)
      pathItem =
        mempty & case method of
          GET -> get ?~ operation
          PUT -> put ?~ operation
          POST -> post ?~ operation
          PATCH -> patch ?~ operation
          DELETE -> delete ?~ operation

      -- making summary of errors
      formattedMessages =
        if null messages
          then ""
          else "\n\nEndpoint \"" <> endpointName <> "\":" <> foldMap ("\n- ⚠️ " <>) messages

  pure $ OMap.singleton (T.unpack endpointURL) (pathItem, formattedMessages)

--------------------------------------------------------------------------------
-- Parameters

-- | Given the 'Structure' of a query, generate the corresponding parameters.
--
-- We expect one optional parameter per known scalar variable.
collectParams :: Structure -> EndpointUrl -> [Referenced Param]
collectParams (Structure _ vars) eURL = do
  (G.unName -> varName, VariableInfo {..}) <- Map.toList vars
  case _viTypeInfo of
    -- we do not allow input objects or enums in parameters
    InputFieldObjectInfo _ -> empty
    InputFieldEnumInfo _ -> empty
    InputFieldScalarInfo _ -> case _viType of
      -- we do not allow arrays in parameters
      G.TypeList _ _ -> empty
      G.TypeNamed nullability typeName -> case getReferenceScalarInfo typeName of
        -- we do not allow unknown scalars in parameters
        Nothing -> empty
        Just (refType, typePattern, _shouldInline) -> do
          -- TODO: there's duplication between this piece of the code and the request body
          -- do we want to ensure consistency by deduplicating?
          let isRequired = not $ G.unNullability nullability || isJust _viDefaultValue
              desc =
                if isRequired
                  then Just $ "_\"" <> varName <> "\" is required (enter it either in parameters or request body)_"
                  else Nothing
              -- TODO: document this
              -- NOTE: URL Variable name ':' prefix is removed for `elem` lookup.
              pathVars = map (T.drop 1) $ concat $ splitPath pure (const []) eURL
          pure $
            -- We always inline the schema, since we might need to add the default value.
            Inline $
              mempty
                & name .~ varName
                & description .~ desc
                & in_ .~ (if varName `elem` pathVars then ParamPath else ParamQuery)
                & schema
                  ?~ Inline
                    ( mempty
                        & default_ .~ (gqlToJsonValue <$> _viDefaultValue)
                        & type_ ?~ refType
                        & pattern .~ typePattern
                    )

--------------------------------------------------------------------------------
-- Request body

-- | Given the 'Structure' of a query, generate the corresponding 'RequestBody'.
--
-- We always expect an object that has a field per variable of the query if
-- there is at least one variable in the query; otherwise we don't expect a
-- request body.
buildRequestBody ::
  (MonadError QErr m, MonadFix m) =>
  Structure ->
  DeclareM m (Maybe (Referenced RequestBody))
buildRequestBody Structure {..} = do
  let vars = Map.toList _stVariables
  if null vars
    then pure Nothing
    else do
      (varProperties, Any isBodyRequired) <-
        runCircularT $
          mconcat <$> for vars \(varName, varInfo) -> do
            (resolvedVarInfo, isVarRequired) <- buildVariableSchema varInfo
            pure (OMap.singleton (G.unName varName) resolvedVarInfo, Any isVarRequired)
      pure $
        Just $
          Inline $
            mempty
              & description ?~ "Query parameters can also be provided in the request body as a JSON object"
              & required ?~ isBodyRequired
              & content
                .~ OMap.singleton
                  ("application" // "json")
                  ( mempty
                      & schema
                        ?~ Inline
                          ( mempty
                              & type_ ?~ OpenApiObject
                              & properties .~ varProperties
                          )
                  )

-- | Given the information about a variable, build the corresponding schema.
--
-- Returns the generated schema, and a boolean indicating whether the variable
-- is required.
buildVariableSchema ::
  (MonadError QErr m, MonadFix m) =>
  VariableInfo ->
  CircularT (G.Name, G.Nullability) (Referenced Schema) (DeclareM m) (Referenced Schema, Bool)
buildVariableSchema VariableInfo {..} = do
  -- a variable is optional if:
  --   - it has a default value
  --   - it's nullable
  --   - it's a known scalar (it will be available as a parameter)
  let hasDefaultValue = isJust _viDefaultValue
      isNullable = G.isNullable _viType
      isKnownScalar = case _viType of
        G.TypeNamed _ typeName -> isJust (getReferenceScalarInfo typeName)
        _ -> False
      isOptional = hasDefaultValue || isNullable || isKnownScalar

  baseSchema <- buildInputFieldSchema _viType _viTypeInfo
  varSchema <- case _viDefaultValue of
    -- If we don't need to modify the schema by adding a default value, we leave
    -- it unchanged (which means it might be a reference rather than inlined).
    Nothing -> pure baseSchema
    -- If we need to modify it, then we might have to dereference it.
    Just defaultValue -> do
      varSchema <- case baseSchema of
        Inline varSchema -> pure varSchema
        Ref (Reference refName) -> do
          -- We introspect the declarations to retrieve the underlying
          -- schema. we know the type will have a corresponding declaration
          -- since all references are created by 'declareType'. This might
          -- result in an unnecessary component declaration if here is the only
          -- place the reference would have been used.
          declarations <- lift look
          OMap.lookup refName declarations
            -- DeclareT doesn't have a MonadError instance, hence the need for
            -- explicit lifting.
            `onNothing` lift (lift $ throw500 "internal error: declareType returned an invalid reference")
      pure $ Inline $ varSchema & default_ ?~ gqlToJsonValue defaultValue

  pure (varSchema, not isOptional)

-- | Given the information about an input type, build the corresponding schema.
buildInputFieldSchema ::
  MonadFix m =>
  G.GType ->
  InputFieldInfo ->
  CircularT (G.Name, G.Nullability) (Referenced Schema) (DeclareM m) (Referenced Schema)
buildInputFieldSchema gType = \case
  -- this input field is a scalar: we attempt to declare it
  InputFieldScalarInfo scalarInfo ->
    lift $ applyModifiers gType $ buildScalarSchema scalarInfo
  -- this input field is an enum: we declare it
  InputFieldEnumInfo enumInfo ->
    lift $ applyModifiers gType $ buildEnumSchema enumInfo
  -- this input field is an object: we declare it
  InputFieldObjectInfo InputObjectInfo {..} ->
    applyModifiers gType \typeName nullability -> withCircular (typeName, nullability) do
      fields <-
        for (Map.toList _ioiFields) \(fieldName, (fieldType, fieldTypeInfo)) -> do
          fieldSchema <- buildInputFieldSchema fieldType fieldTypeInfo
          pure (G.unName fieldName, fieldSchema)
      let objectSchema =
            mempty
              & title ?~ G.unName typeName
              & description .~ fmap G.unDescription (G._iotdDescription _ioiTypeDefinition)
              & properties .~ OMap.fromList fields
              & type_ ?~ OpenApiObject
              & nullable ?~ G.unNullability nullability
      lift $ declareType typeName nullability objectSchema

--------------------------------------------------------------------------------
-- Response

-- | Given the 'Structure' of a query, generate the corresponding 'Response'.
buildResponse ::
  Monad m =>
  Structure ->
  EndpointMethod ->
  Text ->
  DeclareM m Response
buildResponse (Structure fields _) endpointMethod endpointURL = do
  fs <- buildSelectionSchema $ Map.toList fields
  pure $
    mempty
      & content .~ OMap.singleton ("application" // "json") (mempty & schema ?~ Inline fs)
      & description .~ "Responses for " <> tshow endpointMethod <> " " <> endpointURL

-- | Given a list of fields and their types, build a corresponding schema.
buildSelectionSchema ::
  Monad m =>
  [(G.Name, FieldInfo)] ->
  DeclareM m Schema
buildSelectionSchema fields = do
  props <- for fields \(fieldName, fieldInfo) -> do
    fieldSchema <- buildFieldSchema fieldInfo
    pure (G.unName fieldName, fieldSchema)
  pure $ mempty & properties .~ OMap.fromList props

-- | Build the schema for a given output type.
buildFieldSchema ::
  Monad m =>
  FieldInfo ->
  DeclareM m (Referenced Schema)
buildFieldSchema = \case
  -- this output field is a scalar: we attempt to declare it
  FieldScalarInfo gType scalarInfo -> applyModifiers gType $ buildScalarSchema scalarInfo
  -- this output field is an enum: we declare it
  FieldEnumInfo gType scalarInfo -> applyModifiers gType $ buildEnumSchema scalarInfo
  -- this output field is an object: we inline it
  FieldObjectInfo gType ObjectInfo {..} -> applyModifiers gType $ \typeName nullability -> do
    objectSchema <- buildSelectionSchema $ Map.toList _oiSelection
    pure $
      Inline $
        objectSchema
          & title ?~ G.unName typeName
          & description .~ fmap G.unDescription (G._otdDescription _oiTypeDefinition)
          & type_ ?~ OpenApiObject
          & nullable ?~ G.unNullability nullability

--------------------------------------------------------------------------------
-- Scalars

-- | Craft the OpenAPI 'Schema' for a given scalar. Any non-standard scalar will
-- instead be declared, and returned by reference.
buildScalarSchema ::
  Monad m =>
  ScalarInfo ->
  G.Name ->
  G.Nullability ->
  DeclareM m (Referenced Schema)
buildScalarSchema ScalarInfo {..} scalarName nullability = do
  case getReferenceScalarInfo scalarName of
    -- there is an existing OpenAPI scalar we can map this to: we inline if we can
    Just (refType, refPattern, shouldInline) -> do
      let resultSchema =
            baseSchema
              & type_ ?~ refType
              & pattern .~ refPattern
      if shouldInline
        then pure $ Inline resultSchema
        else declareType scalarName nullability resultSchema
    -- there isn't: we declare that type and return a reference to it
    Nothing ->
      declareType scalarName nullability $
        baseSchema
          & description .~ fmap G.unDescription (G._stdDescription _siTypeDefinition)
  where
    baseSchema =
      mempty
        & title ?~ G.unName scalarName
        & nullable ?~ G.unNullability nullability

-- | Retrieve info associated with a given scalar, if it can be mapped to a
-- built-in OpenAPI scalar. On a match, we return a tuple indiciating which
-- scalar should be used, a pattern, and a boolean indicating whether this type
-- should be inlined.
getReferenceScalarInfo :: G.Name -> Maybe (OpenApiType, Maybe Pattern, Bool)
getReferenceScalarInfo =
  G.unName >>> T.toLower >>> \case
    "int" -> Just (OpenApiInteger, Nothing, True)
    "float" -> Just (OpenApiNumber, Nothing, True)
    "double" -> Just (OpenApiNumber, Nothing, True)
    "uuid" -> Just (OpenApiString, Just "[a-f0-9]{8}-[a-f0-9]{4}-4[a-f0-9]{3}-[89aAbB][a-f0-9]{3}-[a-f0-9]{12}", False)
    "bool" -> Just (OpenApiBoolean, Nothing, True)
    "boolean" -> Just (OpenApiBoolean, Nothing, True)
    "string" -> Just (OpenApiString, Nothing, True)
    "id" -> Just (OpenApiString, Nothing, True)
    _ -> Nothing

--------------------------------------------------------------------------------
-- Enums

-- | Craft the OpenAPI 'Schema' for a given enum.
buildEnumSchema ::
  Monad m =>
  EnumInfo ->
  G.Name ->
  G.Nullability ->
  DeclareM m (Referenced Schema)
buildEnumSchema EnumInfo {..} enumName nullability =
  declareType enumName nullability $
    mempty
      & title ?~ G.unName enumName
      & enum_ ?~ enumValues
      & nullable ?~ G.unNullability nullability
      & description .~ fmap G.unDescription (G._etdDescription _eiTypeDefinition)
  where
    enumValues :: [J.Value]
    enumValues =
      G._etdValueDefinitions _eiTypeDefinition <&> \G.EnumValueDefinition {..} ->
        J.String $ G.unName $ G.unEnumValue _evdName

--------------------------------------------------------------------------------
-- Declaring GraphQL types

-- | Given an annotated GraphQL type (such as @[[Foo!]]!@ and a callback
-- function to be used on the actual underlying type, construct a 'Schema' by
-- recursively applying modifiers.
applyModifiers ::
  Monad m =>
  G.GType ->
  (G.Name -> G.Nullability -> m (Referenced Schema)) ->
  m (Referenced Schema)
applyModifiers gtype fun = case gtype of
  G.TypeNamed nullability typeName -> fun typeName nullability
  G.TypeList nullability innerType -> do
    s <- applyModifiers innerType fun
    pure $
      Inline $
        mempty
          & nullable ?~ G.unNullability nullability
          & type_ ?~ OpenApiArray
          & items ?~ OpenApiItemsObject s

-- | Adds a declaration for the given type, returns a schema that references it.
declareType :: Monad m => G.Name -> G.Nullability -> Schema -> DeclareM m (Referenced Schema)
declareType typeName nullability s = do
  let refName = mkReferenceName typeName nullability
  declare $ OMap.singleton refName s
  pure $ Ref $ Reference refName

-- | Crafts a reference name for a given type.
--
-- We use the fact that JSON references allow characters that GraphQL types
-- don't: we make a different reference for non-nullable type by using the
-- GraphQL convention of suffixing the name by @!@.
--
-- See Note [Nullable types in OpenAPI].
mkReferenceName :: G.Name -> G.Nullability -> Text
mkReferenceName (G.unName -> typeName) (G.Nullability isNullable) =
  if isNullable
    then typeName
    else typeName <> "!"

--------------------------------------------------------------------------------
-- Local helpers

type DeclareM = DeclareT (Definitions Schema)

-- | Variable definition for x-hasura-admin-secret
xHasuraAdminSecret :: Param
xHasuraAdminSecret =
  mempty
    & name .~ "x-hasura-admin-secret"
    & description ?~ "Your x-hasura-admin-secret will be used for authentication of the API request."
    & in_ .~ ParamHeader
    & schema ?~ Inline (mempty & type_ ?~ OpenApiString)

-- | Convert a GraphQL value to an equivalent JSON representation.
--
-- TODO: can we deduplicate this?
gqlToJsonValue :: G.Value Void -> J.Value
gqlToJsonValue = \case
  G.VNull -> J.Null
  G.VInt n -> J.toJSON n
  G.VFloat sci -> J.toJSON sci
  G.VString txt -> J.toJSON txt
  G.VBoolean b -> J.toJSON b
  G.VEnum ev -> J.toJSON ev
  G.VList lst -> J.toJSON $ gqlToJsonValue <$> lst
  G.VObject obj -> J.toJSON $ gqlToJsonValue <$> obj