graphql-engine/server/src-dc-api/Hasura/Backends/DataConnector/API/V0/ConfigSchema.hs

{-# LANGUAGE ViewPatterns #-}

module Hasura.Backends.DataConnector.API.V0.ConfigSchema
  ( Config (..),
    ConfigSchemaResponse (..),
    validateConfigAgainstConfigSchema,
  )
where

import Autodocodec qualified
import Control.DeepSeq (NFData)
import Control.Lens ((%~), (&), (.~), (^?))
import Data.Aeson (FromJSON (..), Object, ToJSON (..), Value (..), eitherDecode, encode, object, withObject, (.:), (.=), (<?>))
import Data.Aeson.Lens (AsPrimitive (..), key, members, values)
import Data.Aeson.Types (JSONPathElement (..))
import Data.Bifunctor (first)
import Data.ByteString.Lazy qualified as BSL
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Hashable (Hashable)
import Data.Maybe (fromMaybe)
import Data.OpenApi (AdditionalProperties (..), Definitions, NamedSchema (..), OpenApiItems (..), OpenApiType (..), Reference (..), Referenced (..), Schema (..), ToParamSchema (..), ToSchema (..), ValidationError)
import Data.OpenApi qualified as OpenApi
import Data.OpenApi.Declare (Declare, MonadDeclare (..))
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Servant.API (FromHttpApiData (..), ToHttpApiData (..))
import Prelude

newtype Config = Config {unConfig :: Object}
  deriving stock (Eq, Show, Ord)
  deriving newtype (Hashable, NFData, ToJSON, FromJSON)

instance FromHttpApiData Config where
  parseUrlPiece = first Text.pack . eitherDecode . BSL.fromStrict . Text.encodeUtf8
  parseHeader = first Text.pack . eitherDecode . BSL.fromStrict

instance ToHttpApiData Config where
  toUrlPiece (Config val) = Text.decodeUtf8 . BSL.toStrict $ encode val
  toHeader (Config val) = BSL.toStrict $ encode val

instance ToParamSchema Config where
  toParamSchema _ =
    mempty
      { _schemaType = Just OpenApiObject,
        _schemaNullable = Just False,
        _schemaAdditionalProperties = Just (AdditionalPropertiesAllowed True)
      }

data ConfigSchemaResponse = ConfigSchemaResponse
  { _csrConfigSchema :: Schema,
    _csrOtherSchemas :: Definitions Schema
  }
  deriving (Show, Eq)

instance FromJSON ConfigSchemaResponse where
  parseJSON = withObject "ConfigSchemaResponse" $ \obj -> do
    configSchemaValue <- obj .: "config_schema"
    (otherSchemaValues :: Object) <- obj .: "other_schemas"
    _csrConfigSchema <- parseJSON (rewriteConfigSchemaRefsToOpenApiRefs configSchemaValue) <?> Key "config_schema"
    _csrOtherSchemas <- (<?> Key "other_schemas") . parseJSON . Object $ rewriteConfigSchemaRefsToOpenApiRefs <$> otherSchemaValues
    pure ConfigSchemaResponse {..}

instance ToJSON ConfigSchemaResponse where
  toJSON ConfigSchemaResponse {..} =
    let configSchemaValue = rewriteOpenApiRefsToConfigSchemaRefs $ toJSON _csrConfigSchema
        otherSchemasValue = rewriteOpenApiRefsToConfigSchemaRefs . toJSON <$> _csrOtherSchemas
     in object
          [ "config_schema" .= configSchemaValue,
            "other_schemas" .= otherSchemasValue
          ]

instance Autodocodec.HasCodec ConfigSchemaResponse where
  codec = Autodocodec.codecViaAeson "Configuration schemas"

instance ToSchema ConfigSchemaResponse where
  declareNamedSchema _ = do
    openApiSchemaRef <- declareOpenApiSchema
    let otherSchemasSchema =
          mempty
            { _schemaType = Just OpenApiObject,
              _schemaNullable = Just False,
              _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema openApiSchemaRef
            }
    let schema =
          mempty
            { _schemaType = Just OpenApiObject,
              _schemaNullable = Just False,
              _schemaRequired = ["config_schema", "other_schemas"],
              _schemaProperties =
                InsOrdHashMap.fromList
                  [ ("config_schema", openApiSchemaRef),
                    ("other_schemas", Inline otherSchemasSchema)
                  ]
            }
    pure $ NamedSchema (Just "ConfigSchemaResponse") schema

-- | Declares the schema for the OpenAPI Schema type (and its dependent types) and
-- returns a reference that can be used to refer to it from other schemas.
--
-- This is a transcription of the schemas defined here:
-- https://raw.githubusercontent.com/OAI/OpenAPI-Specification/80c781e479f85ac67001ceb3e7e410e25d2a561b/schemas/v3.0/schema.json#/definitions/Schema
--
-- Unfortunately using external references to the above schema tends to make many
-- OpenAPI type generators choke, so importing the relevant schemas into our spec
-- is a pragmatic workaround.
declareOpenApiSchema :: Declare (Definitions Schema) (Referenced Schema)
declareOpenApiSchema = do
  declare $
    InsOrdHashMap.fromList
      [ openApiSchema,
        openApiReference,
        openApiDiscriminator,
        openApiExternalDocumentation,
        openApiXml
      ]
  pure . Ref $ Reference "OpenApiSchema"
  where
    openApiSchema :: (Text, Schema)
    openApiSchema =
      ( "OpenApiSchema",
        mempty
          { _schemaType = Just OpenApiObject,
            _schemaProperties =
              InsOrdHashMap.fromList
                [ ("title", Inline mempty {_schemaType = Just OpenApiString}),
                  ("multipleOf", Inline mempty {_schemaType = Just OpenApiNumber, _schemaMinimum = Just 0, _schemaExclusiveMinimum = Just True}),
                  ("maximum", Inline mempty {_schemaType = Just OpenApiNumber}),
                  ("exclusiveMaximum", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("minimum", Inline mempty {_schemaType = Just OpenApiNumber}),
                  ("exclusiveMinimum", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("maxLength", Inline mempty {_schemaType = Just OpenApiInteger, _schemaMinimum = Just 0}),
                  ("minLength", Inline mempty {_schemaType = Just OpenApiInteger, _schemaMinimum = Just 0, _schemaDefault = Just $ Number 0}),
                  ("pattern", Inline mempty {_schemaType = Just OpenApiString, _schemaFormat = Just "regex"}),
                  ("maxItems", Inline mempty {_schemaType = Just OpenApiInteger, _schemaMinimum = Just 0}),
                  ("minItems", Inline mempty {_schemaType = Just OpenApiInteger, _schemaMinimum = Just 0, _schemaDefault = Just $ Number 0}),
                  ("uniqueItems", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("maxProperties", Inline mempty {_schemaType = Just OpenApiInteger, _schemaMinimum = Just 0}),
                  ("minProperties", Inline mempty {_schemaType = Just OpenApiInteger, _schemaMinimum = Just 0, _schemaDefault = Just $ Number 0}),
                  ( "required",
                    Inline
                      mempty
                        { _schemaType = Just OpenApiArray,
                          _schemaItems = Just . OpenApiItemsObject $ Inline mempty {_schemaType = Just OpenApiString},
                          _schemaMinItems = Just 1,
                          _schemaUniqueItems = Just True
                        }
                  ),
                  ( "enum",
                    Inline
                      mempty
                        { _schemaType = Just OpenApiArray,
                          _schemaItems = Just . OpenApiItemsObject $ Inline mempty,
                          _schemaMinItems = Just 1,
                          _schemaUniqueItems = Just False
                        }
                  ),
                  ("type", Inline mempty {_schemaType = Just OpenApiString, _schemaEnum = Just ["array", "boolean", "integer", "number", "object", "string"]}),
                  ("not", Inline mempty {_schemaOneOf = Just schemaOrReference}),
                  ("allOf", Inline mempty {_schemaType = Just OpenApiArray, _schemaItems = Just . OpenApiItemsObject $ Inline mempty {_schemaOneOf = Just schemaOrReference}}),
                  ("oneOf", Inline mempty {_schemaType = Just OpenApiArray, _schemaItems = Just . OpenApiItemsObject $ Inline mempty {_schemaOneOf = Just schemaOrReference}}),
                  ("anyOf", Inline mempty {_schemaType = Just OpenApiArray, _schemaItems = Just . OpenApiItemsObject $ Inline mempty {_schemaOneOf = Just schemaOrReference}}),
                  ("items", Inline mempty {_schemaOneOf = Just schemaOrReference}),
                  ("properties", Inline mempty {_schemaType = Just OpenApiObject, _schemaAdditionalProperties = Just . AdditionalPropertiesSchema $ Inline mempty {_schemaOneOf = Just schemaOrReference}}),
                  ( "additionalProperties",
                    Inline
                      mempty
                        { _schemaAdditionalProperties = Just . AdditionalPropertiesSchema $ Inline mempty {_schemaOneOf = Just $ schemaOrReference <> [Inline mempty {_schemaType = Just OpenApiBoolean}]},
                          _schemaDefault = Just $ Bool True
                        }
                  ),
                  ("description", Inline mempty {_schemaType = Just OpenApiString}),
                  ("format", Inline mempty {_schemaType = Just OpenApiString}),
                  ("default", Inline mempty),
                  ("nullable", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("discriminator", Ref . Reference $ fst openApiDiscriminator),
                  ("readOnly", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("writeOnly", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("example", Inline mempty),
                  ("externalDocs", Ref . Reference $ fst openApiExternalDocumentation),
                  ("deprecated", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("xml", Ref . Reference $ fst openApiXml)
                ],
            -- Note: Technically OpenAPI schemas should be able to define extension properties but since OpenAPI itself doesn't
            -- support defining patternProperties, I can't define them here. 😢
            -- "patternProperties": { "^x-": {} }
            -- _schemaPatternProperties =
            _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed False
          }
      )

    openApiReference :: (Text, Schema)
    openApiReference =
      ( "OpenApiReference",
        mempty
          { _schemaType = Just OpenApiObject,
            _schemaRequired = ["$ref"],
            -- Note: This is technically defined using "patternProperties" with the property name regex ^\$ref$
            -- but OpenAPI doesn't support patternProperties ironically, so this is close enough
            _schemaProperties = InsOrdHashMap.fromList [("$ref", Inline mempty {_schemaType = Just OpenApiString, _schemaFormat = Just "uri-reference"})]
          }
      )

    schemaOrReference :: [Referenced Schema]
    schemaOrReference = [Ref . Reference $ fst openApiSchema, Ref . Reference $ fst openApiReference]

    openApiDiscriminator :: (Text, Schema)
    openApiDiscriminator =
      ( "OpenApiDiscriminator",
        mempty
          { _schemaType = Just OpenApiObject,
            _schemaRequired = ["propertyName"],
            _schemaProperties =
              InsOrdHashMap.fromList
                [ ("propertyName", Inline mempty {_schemaType = Just OpenApiString}),
                  ("mapping", Inline mempty {_schemaType = Just OpenApiObject, _schemaAdditionalProperties = Just . AdditionalPropertiesSchema $ Inline mempty {_schemaType = Just OpenApiString}})
                ]
          }
      )

    openApiExternalDocumentation :: (Text, Schema)
    openApiExternalDocumentation =
      ( "OpenApiExternalDocumentation",
        mempty
          { _schemaType = Just OpenApiObject,
            _schemaRequired = ["url"],
            _schemaProperties =
              InsOrdHashMap.fromList
                [ ("description", Inline mempty {_schemaType = Just OpenApiString}),
                  ("url", Inline mempty {_schemaType = Just OpenApiString, _schemaFormat = Just "uri-reference"})
                ],
            -- Note: Technically external docs should be able to define extension properties but since OpenAPI itself doesn't
            -- support defining patternProperties, I can't define them here. 😢
            -- "patternProperties": { "^x-": {} }
            -- _schemaPatternProperties =
            _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed False
          }
      )

    openApiXml :: (Text, Schema)
    openApiXml =
      ( "OpenApiXml",
        mempty
          { _schemaType = Just OpenApiObject,
            _schemaProperties =
              InsOrdHashMap.fromList
                [ ("name", Inline mempty {_schemaType = Just OpenApiString}),
                  ("namespace", Inline mempty {_schemaType = Just OpenApiString, _schemaFormat = Just "uri"}),
                  ("prefix", Inline mempty {_schemaType = Just OpenApiString}),
                  ("attribute", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False}),
                  ("wrapped", Inline mempty {_schemaType = Just OpenApiBoolean, _schemaDefault = Just $ Bool False})
                ],
            -- Note: Technically XML should be able to define extension properties but since OpenAPI itself doesn't
            -- support defining patternProperties, I can't define them here. 😢
            -- "patternProperties": { "^x-": {} }
            -- _schemaPatternProperties =
            _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed False
          }
      )

-- | Rewrites the config schema internal refs to the form that openapi3 expects when it deserialized them
--
-- This works around a limitation of the openapi3 library where it expects that all refs will be pointing
-- to the place in the overall document where those particular things are normally stored on specifically
-- the 'OpenApi' type and nothing else.
-- This means that it cannot understand refs like #/otherSchemas/Thing, and must see #/components/schemas/Thing
-- to correctly deserialise
rewriteConfigSchemaRefsToOpenApiRefs :: Value -> Value
rewriteConfigSchemaRefsToOpenApiRefs = rewriteSchemaRefs configSchemaToOpenApiSchemaRef

configSchemaToOpenApiSchemaRef :: Text -> Text
configSchemaToOpenApiSchemaRef = \case
  (Text.stripPrefix "#/other_schemas/" -> Just suffix) -> "#/components/schemas/" <> suffix
  other -> other

-- | Rewrites the refs that openapi3 serializes to their proper pathing given their actual location
-- in the 'ConfigSchemaResponse' type.
--
-- This works around a limitation of the openapi3 library where it expects that all refs will be pointing
-- to the place in the overall document where those particular things are normally stored on specifically
-- the 'OpenApi' type and nothing else.
rewriteOpenApiRefsToConfigSchemaRefs :: Value -> Value
rewriteOpenApiRefsToConfigSchemaRefs = rewriteSchemaRefs openApiSchemaToConfigSchemaRef

openApiSchemaToConfigSchemaRef :: Text -> Text
openApiSchemaToConfigSchemaRef = \case
  (Text.stripPrefix "#/components/schemas/" -> Just suffix) -> "#/other_schemas/" <> suffix
  other -> other

rewriteSchemaRefs :: (Text -> Text) -> Value -> Value
rewriteSchemaRefs rewriteRefText schemaObj =
  schemaObj
    & key "allOf" . values %~ rewriteRef
    & key "oneOf" . values %~ rewriteRef
    & key "not" %~ rewriteRef
    & key "anyOf" . values %~ rewriteRef
    & key "properties" . members %~ rewriteRef
    & key "additionalProperties" %~ rewriteRef
    & key "items" %~ rewriteRef -- if its an Object
    & key "items" . values %~ rewriteRef -- if its an Array
  where
    rewriteRef :: Value -> Value
    rewriteRef refOrInlineSchema =
      -- If its $ref rewrite it, otherwise it's an inline schema, so recurse
      fromMaybe (rewriteSchemaRefs rewriteRefText refOrInlineSchema) $ tryRewriteRef refOrInlineSchema

    tryRewriteRef :: Value -> Maybe Value
    tryRewriteRef refOrInlineSchema = do
      refText <- refOrInlineSchema ^? key "$ref" . _String
      pure $ refOrInlineSchema & key "$ref" . _String .~ rewriteRefText refText

validateConfigAgainstConfigSchema :: ConfigSchemaResponse -> Config -> [ValidationError]
validateConfigAgainstConfigSchema ConfigSchemaResponse {..} (Config config) =
  OpenApi.validateJSON _csrOtherSchemas _csrConfigSchema (Object config)