{-# 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 HashMap import Data.HashMap.Strict.InsOrd.Extended qualified as InsOrdHashMap 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' (InsOrdHashMap.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 (InsOrdHashMap.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 $ InsOrdHashMap.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 {..}) <- sortOn fst $ HashMap.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 = HashMap.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 (InsOrdHashMap.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 .~ InsOrdHashMap.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 InsOrdHashMap.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 (HashMap.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 .~ InsOrdHashMap.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 $ HashMap.toList fields pure $ mempty & content .~ InsOrdHashMap.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 .~ InsOrdHashMap.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 $ HashMap.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 $ InsOrdHashMap.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