mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-16 18:42:30 +03:00
5920134dcb
### Motivation #2338 introduced a way to validate REST queries against the metadata after a change, to properly report any inconsistency that would emerge from a change in the underlying structure of our schema. However, the way this was done was quite complex and error-prone. Namely: we would use the generated schema parsers to statically execute an introspection query, similar to the one we use for remote schemas, then parse the resulting bytestring as it were coming from a remote schema. This led to several issues: the code was using remote schema primitives, and was associated with remote schema code, despite being unrelated, which led to absurd situations like creating fake `Variable`s whose type was also their name. A lot of the code had to deal with the fact that we might fail to re-parse our own schema. Additionally, some of it was dead code, that for some reason GHC did not warn about? But more fundamentally, this architecture decision creates a dependency between unrelated pieces of the engine: modifying the internal processing of root fields or the introspection of remote schemas now risks impacting the unrelated `OpenAPI` feature. ### Description This PR decouples that process from the remote schema introspection logic and from the execution engine by making `Analyse` and `OpenAPI` work on the generic `G.SchemaIntrospection` instead. To accomplish this, it: - adds `GraphQL.Parser.Schema.Convert`, to convert from our "live" schema back to a flat `SchemaIntrospection` - persists in the schema cache the `admin` introspection generated when building the schema, and uses it both for validation and for generating the `OpenAPI`. ### Known issues and limitations This adds a bit of memory pressure to the engine, as we persist the entire schema in the schema cache. This might be acceptable in the short-term, but we have several potential ideas going forward should this be a problem: - cache the result of `Analyze`: when it becomes possible to build the `OpenAPI` purely with the result of `Analyze` without any additional schema information, then we could cache that instead, reducing the footprint - caching the `OpenAPI`: if it doesn't need to change every time the endpoint is queried, then it should be possible to cache the entire `OpenAPI` object instead of the schema - cache a copy of the `FieldParsers` used to generate the schema: as those are persisted through the GraphQL `Context`, and are the only input required to generate the `Schema`, making them accessible in the schema cache would allow us to have the exact same feature with no additional memory cost, at the price of a slightly slower and more complicated process (need to rebuild the `Schema` every time we query the OpenAPI endpoint) - cache nothing at all, and rebuild the admin schema from scratch every time. PR-URL: https://github.com/hasura/graphql-engine-mono/pull/3962 Co-authored-by: paritosh-08 <85472423+paritosh-08@users.noreply.github.com> GitOrigin-RevId: a8b9808170b231fdf6787983b4a9ed286cde27e0
573 lines
25 KiB
Haskell
573 lines
25 KiB
Haskell
-- |
|
|
-- Module : Hasura.Server.OpenAPI
|
|
-- Description : Builds an OpenAPI specification for the REST endpoints from a SchemaCache via the `declareOpenApiSpec` function.
|
|
--
|
|
-- The implementation currently iterates over the endpoints building up `EndpointData` for each then exposes this as an OpenAPI Schema.
|
|
--
|
|
-- Most functions are in the `Declare` monad so that they can add new component definitions on the fly that can be referenced.
|
|
-- This is especially useful for the params and request body documentation.
|
|
--
|
|
-- The response body recurses over the SelectionSet Fields associated with an endpoint and looks up types by name in
|
|
-- a `SchemaIntrospection` result generated from the `SchemaCache`.
|
|
--
|
|
-- Response bodies are mostly delcared inline, since the associated query will likely be unique and determine the fields
|
|
-- contained in the response.
|
|
module Hasura.Server.OpenAPI (serveJSON) where
|
|
|
|
import Control.Lens
|
|
import Data.Aeson qualified as J
|
|
import Data.HashMap.Strict qualified as Map
|
|
import Data.HashMap.Strict.InsOrd qualified as OMap
|
|
import Data.HashMap.Strict.Multi qualified as MMap
|
|
import Data.HashSet qualified as Set
|
|
import Data.List.NonEmpty qualified as NE
|
|
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.GraphQL.Analyse
|
|
import Hasura.Prelude hiding (get, put)
|
|
import Hasura.RQL.Types.Endpoint
|
|
import Hasura.RQL.Types.QueryCollection
|
|
import Hasura.RQL.Types.SchemaCache
|
|
import Language.GraphQL.Draft.Syntax qualified as G
|
|
import Network.HTTP.Media.MediaType ((//))
|
|
|
|
data EndpointData = EndpointData
|
|
{ _edUrl :: String,
|
|
_edMethod :: HashSet EndpointMethod,
|
|
_edVarList :: [Referenced Param],
|
|
_edProperties :: InsOrdHashMap Text (Referenced Schema),
|
|
_edResponse :: HashMap EndpointMethod Response,
|
|
_edDescription :: Text, -- contains API comments and graphql query
|
|
_edName :: Text,
|
|
_edErrs :: [Text]
|
|
}
|
|
deriving (Show)
|
|
|
|
-- * Response Body Related Functions.
|
|
|
|
{-
|
|
|
|
Example stepthrough initiated by call to getSelectionSchema:
|
|
|
|
* Endpoint insert_foo
|
|
* getExecutableDefinitions -> List (Normally 1 entry)
|
|
* ExecutableDefinitionOperation -> OperationDefinitionTyped -> TypedOperationDefinition (_todType = OperationTypeMutation)
|
|
* _todSelectionSet ->
|
|
[SelectionField
|
|
(Field{ _fName = Name{unName = "insert_foo"},
|
|
_fSelectionSet
|
|
= [SelectionField
|
|
(Field{ _fName = Name{unName = "returning"},
|
|
_fSelectionSet
|
|
= [..., SelectionField
|
|
(Field{ _fName = Name{unName = "id"},
|
|
_fSelectionSet = []}),
|
|
* Lookup introspection schema, Under mutation_root (inferred from operationtype = OperationTypeMutation)
|
|
SchemaIntrospection
|
|
(fromList
|
|
[..., (Name{unName = "mutation_root"},
|
|
TypeDefinitionObject
|
|
(ObjectTypeDefinition{_otdDescription =
|
|
Just (Description{unDescription = "mutation root"}),
|
|
_otdName = Name{unName = "mutation_root"},
|
|
_otdImplementsInterfaces = [], _otdDirectives = [],
|
|
_otdFieldsDefinition =
|
|
[..., FieldDefinition{_fldDescription = Just (Description{unDescription = "insert data into the table: \"foo\""}),
|
|
_fldName = Name{unName = "insert_foo"},
|
|
_fldType = TypeNamed (Nullability{unNullability = True}) (Name{unName = "foo_mutation_response"}),
|
|
* Find that type for insert_foo field in mutation_root is named type "foo_mutation_response"
|
|
* Look up "foo_mutation_response" in introspection schema:
|
|
(Name{unName = "foo_mutation_response"},
|
|
TypeDefinitionObject
|
|
(ObjectTypeDefinition{_otdDescription = Just (Description{unDescription = "response of any mutation on the table \"foo\""}),
|
|
_otdName = Name{unName = "foo_mutation_response"},
|
|
_otdFieldsDefinition =
|
|
[..., FieldDefinition{_fldDescription =
|
|
Just
|
|
(Description{unDescription =
|
|
"data from the rows affected by the mutation"}),
|
|
_fldName = Name{unName = "returning"},
|
|
_fldArgumentsDefinition = [],
|
|
_fldType =
|
|
TypeList (Nullability{unNullability = False})
|
|
(TypeNamed
|
|
(Nullability{unNullability = False})
|
|
(Name{unName = "foo"})),
|
|
_fldDirectives = []}]})),
|
|
* Find first referenced sub-field "returning"
|
|
* It has type (TypeNamed (Name{unName = "foo"})),
|
|
* Look up "foo" in Introspection Schema: ...,
|
|
(Name{unName = "foo"},
|
|
TypeDefinitionObject
|
|
(ObjectTypeDefinition{_otdDescription = Just (Description{unDescription = "columns and relationships of \"foo\""}),
|
|
_otdName = Name{unName = "foo"}, _otdImplementsInterfaces = [],
|
|
_otdFieldsDefinition =
|
|
[ ..., FieldDefinition{_fldDescription = Nothing,
|
|
_fldName = Name{unName = "id"},
|
|
_fldType = TypeNamed (Nullability{unNullability = False}) (Name{unName = "uuid"}),
|
|
* Lookup first sub-sub field by SelectionSet field name "id"
|
|
* See that it has type: TypeNamed (Name{unName = "uuid"})
|
|
* See that there are no sub-sub-sub fields
|
|
* declare type uuid by looking up its definition
|
|
(Name{unName = "uuid"},
|
|
TypeDefinitionScalar
|
|
(ScalarTypeDefinition{_stdDescription = Nothing,
|
|
_stdName = Name{unName = "uuid"}, _stdDirectives = []})),
|
|
* reference type name from components in output
|
|
|
|
... Proceed with other sub-fields and fields
|
|
|
|
-}
|
|
|
|
-- FIXME: There should only be one definition associated. Find a way to signal an error here otherwise.
|
|
mdDefinitions :: EndpointMetadata GQLQueryWithText -> [G.ExecutableDefinition G.Name]
|
|
mdDefinitions = G.getExecutableDefinitions . unGQLQuery . getGQLQuery . _edQuery . _ceDefinition
|
|
|
|
mkResponse :: EndpointMethod -> String -> G.SchemaIntrospection -> Analysis G.Name -> Declare (Definitions Schema) (Maybe Response)
|
|
mkResponse epMethod epUrl rs Analysis {..} = do
|
|
fs <- getSelectionSchema rs (OMap.toList _aFields)
|
|
pure $
|
|
Just $
|
|
mempty
|
|
& content .~ OMap.singleton ("application" // "json") (mempty & schema ?~ Inline fs)
|
|
& description .~ "Responses for " <> tshow epMethod <> " " <> T.pack epUrl
|
|
|
|
getSelectionSchema :: G.SchemaIntrospection -> [(G.Name, (FieldDef, Maybe (FieldAnalysis var)))] -> Declare (Definitions Schema) Schema
|
|
getSelectionSchema rs fields = do
|
|
ps <- traverse (pure . G.unName . fst &&&& (\(fN, (td, fA)) -> getDefinitionSchema rs fN td fA {- (\(fN,(td,fA)) -> pure $ (G.unName fN,) $ getDefinitionSchema rs td fA) -})) fields
|
|
pure $ mempty & properties .~ OMap.fromList (map (second Inline) ps)
|
|
|
|
-- | A helper function to set the pattern field in Schema
|
|
-- Why not lens `pattern`? hlint doesn't like the name `pattern`
|
|
-- https://github.com/ndmitchell/hlint/issues/607
|
|
setPattern :: Maybe Pattern -> Schema -> Schema
|
|
setPattern p s = s {_schemaPattern = p}
|
|
|
|
getDefinitionSchema ::
|
|
G.SchemaIntrospection ->
|
|
G.Name ->
|
|
FieldDef ->
|
|
Maybe (FieldAnalysis var) ->
|
|
Declare (Definitions Schema) Schema
|
|
getDefinitionSchema rs tn fd fA =
|
|
typeToSchemaM
|
|
fd
|
|
( \case
|
|
(G.TypeDefinitionInterface _) -> pure $ mempty & description ?~ "Unsupported field type TypeDefinitionInterface: " <> G.unName tn
|
|
(G.TypeDefinitionUnion _) -> pure $ mempty & description ?~ "Unsupported field type TypeDefinitionUnion: " <> G.unName tn
|
|
(G.TypeDefinitionEnum _) -> pure $ mempty & description ?~ "Unsupported field type TypeDefinitionEnum: " <> G.unName tn
|
|
(G.TypeDefinitionInputObject _) -> pure $ mempty & description ?~ "Unsupported field type TypeDefinitionInputObject: " <> G.unName tn
|
|
(G.TypeDefinitionObject _) ->
|
|
case fA of
|
|
Nothing -> pure $ mempty & description ?~ "Field analysis not found"
|
|
Just FieldAnalysis {..} -> do
|
|
ps <- traverse (pure . G.unName . fst &&&& (\(fN, (td', fA')) -> getDefinitionSchema rs fN td' fA')) (OMap.toList _fFields)
|
|
pure $
|
|
mempty
|
|
& properties .~ OMap.fromList (map (second Inline) ps)
|
|
& type_ ?~ OpenApiObject
|
|
(G.TypeDefinitionScalar std) -> do
|
|
let (refType, patt) = referenceType True (T.toLower $ G.unName $ G._stdName std)
|
|
pure $
|
|
mempty
|
|
& title ?~ G.unName (G._stdName std)
|
|
& description .~ (G.unDescription <$> G._stdDescription std)
|
|
& type_ .~ refType
|
|
& setPattern patt
|
|
)
|
|
|
|
typeToSchemaM :: Monad m => FieldDef -> (G.TypeDefinition [G.Name] G.InputValueDefinition -> m Schema) -> m Schema
|
|
typeToSchemaM (FieldInfo _nullability tName) k = k tName
|
|
typeToSchemaM (FieldList n t) k = do
|
|
t' <- typeToSchemaM t k
|
|
pure $
|
|
mempty
|
|
& nullable ?~ G.unNullability n
|
|
& type_ ?~ OpenApiArray
|
|
& items ?~ OpenApiItemsObject (Inline t') -- TODO: Why do we assume objects here?
|
|
|
|
infixl 7 &&&&
|
|
|
|
(&&&&) :: Applicative f => (t -> f a1) -> (t -> f a2) -> t -> f (a1, a2)
|
|
f &&&& g = \a -> (,) <$> f a <*> g a
|
|
|
|
-- * URL / Query Params and Request Body Functions
|
|
|
|
-- There could be an additional partitioning scheme besides referentiality to support more types in Params
|
|
getParams :: Analysis G.Name -> EndpointUrl -> [Referenced Param]
|
|
getParams Analysis {..} eURL = varDetails =<< Map.toList _aVars
|
|
where
|
|
pathVars = map T.tail $ concat $ splitPath pure (const []) eURL -- NOTE: URL Variable name ':' prefix is removed for `elem` lookup.
|
|
varDetails (_vdName, (_vdType, _vdDefaultValue)) =
|
|
let vName = G.unName _vdName
|
|
isRequired = not $ G.isNullable _vdType
|
|
in case getType _vdType of
|
|
Left _foo -> [] -- Complex types are not allowed as params
|
|
Right (vdType, patt) ->
|
|
pure $
|
|
Inline $
|
|
mkParam
|
|
vName
|
|
(if isRequired then Just $ "_\"" <> vName <> "\" is required (enter it either in parameters or request body)_" else Nothing)
|
|
Nothing
|
|
(if vName `elem` pathVars then ParamPath else ParamQuery)
|
|
Nothing
|
|
(gqlToJsonValue <$> _vdDefaultValue)
|
|
(Just vdType)
|
|
patt
|
|
|
|
getType :: G.GType -> Either G.GType (OpenApiType, Maybe Pattern)
|
|
getType gt@(G.TypeNamed _ na) = case referenceType True t of
|
|
(Nothing, _) -> Left gt
|
|
(Just typ, patt) -> Right (typ, patt)
|
|
where
|
|
t = T.toLower $ G.unName na
|
|
getType t = Left t -- Non scalar types are deferred to reference types for processing using introspection
|
|
|
|
mkProperties :: G.SchemaIntrospection -> Analysis G.Name -> Declare (Definitions Schema) (InsOrdHashMap Text (Referenced Schema))
|
|
mkProperties (G.SchemaIntrospection sd) Analysis {..} = OMap.fromList <$> traverse (mkProperty sdMap) ds
|
|
where
|
|
ds = Map.toList _aVars
|
|
sdMap = OMap.fromList $ map (first G.unName) $ Map.toList sd
|
|
|
|
mkProperty :: InsOrdHashMap Text (G.TypeDefinition [G.Name] G.InputValueDefinition) -> (G.Name, (G.GType, Maybe (G.Value Void))) -> Declare (Definitions Schema) (Text, Referenced Schema)
|
|
mkProperty sd (_vdName, (_vdType, _vdDefaultValue)) = do
|
|
d <- case getType _vdType of
|
|
Left t -> handleRefType sd t
|
|
Right (vdType, patt) ->
|
|
pure $
|
|
Inline $
|
|
mempty
|
|
& nullable ?~ G.isNullable _vdType
|
|
& type_ ?~ vdType
|
|
& default_ .~ fmap gqlToJsonValue _vdDefaultValue
|
|
& setPattern patt
|
|
|
|
pure (G.unName _vdName, d)
|
|
|
|
handleRefType :: OMap.InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> G.GType -> Declare (Definitions Schema) (Referenced Schema)
|
|
handleRefType sd = \case
|
|
G.TypeNamed nullability nameWrapper -> do
|
|
let n = G.unName nameWrapper
|
|
declareReference nullability n sd
|
|
pure $ Ref $ Reference n
|
|
G.TypeList nullability subType -> do
|
|
st <- handleRefType sd subType
|
|
pure $
|
|
Inline $
|
|
mempty
|
|
& nullable ?~ (G.unNullability nullability && G.isNullable subType)
|
|
& type_ ?~ OpenApiArray
|
|
& items ?~ OpenApiItemsObject st
|
|
|
|
-- TODO: No reference types should be nullable and only references to reference types
|
|
|
|
declareReference :: G.Nullability -> Text -> OMap.InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> Declare (Definitions Schema) ()
|
|
declareReference nullability n ts = do
|
|
isAvailable <- referenceAvailable n
|
|
unless isAvailable do
|
|
for_ (OMap.lookup n ts) \t -> do
|
|
let properties' = getPropertyReferences ts (typeProperties t)
|
|
|
|
result <-
|
|
declare $
|
|
OMap.singleton n $
|
|
let (refType, patt) = referenceType (null properties') (T.toLower n)
|
|
in mempty
|
|
& nullable ?~ G.unNullability nullability
|
|
& description .~ typeDescription t
|
|
& properties .~ properties'
|
|
& type_ .~ refType
|
|
& setPattern patt
|
|
void $ processProperties ts (typeProperties t)
|
|
pure result
|
|
|
|
referenceAvailable :: Text -> DeclareT (Definitions Schema) Identity Bool
|
|
referenceAvailable n = OMap.member n <$> look
|
|
|
|
getPropertyReferences :: InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> Maybe [G.InputValueDefinition] -> InsOrdHashMap Text (Referenced Schema)
|
|
getPropertyReferences _ Nothing = mempty
|
|
getPropertyReferences sd (Just ds) =
|
|
let ds' = fmap (processProperty' sd) ds
|
|
in OMap.fromList ds'
|
|
|
|
processProperty' :: InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> G.InputValueDefinition -> (Text, Referenced Schema)
|
|
processProperty' sd d =
|
|
let n = G._ivdName d
|
|
t = G._ivdType d
|
|
rt = handleRefType' sd t
|
|
in (G.unName n, rt)
|
|
|
|
handleRefType' :: OMap.InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> G.GType -> Referenced Schema
|
|
handleRefType' sd = \case
|
|
G.TypeNamed _nullability nameWrapper ->
|
|
let n = G.unName nameWrapper
|
|
in Ref $ Reference n
|
|
G.TypeList nullability subType ->
|
|
let st = handleRefType' sd subType
|
|
in Inline $
|
|
mempty
|
|
& nullable ?~ (G.unNullability nullability && G.isNullable subType)
|
|
& type_ ?~ OpenApiArray
|
|
& items ?~ OpenApiItemsObject st
|
|
|
|
typeDescription :: G.TypeDefinition possibleTypes inputType -> Maybe Text
|
|
typeDescription = \case
|
|
(G.TypeDefinitionScalar o) -> G.unDescription <$> G._stdDescription o
|
|
(G.TypeDefinitionObject o) -> G.unDescription <$> G._otdDescription o
|
|
(G.TypeDefinitionInterface o) -> G.unDescription <$> G._itdDescription o
|
|
(G.TypeDefinitionUnion o) -> G.unDescription <$> G._utdDescription o
|
|
(G.TypeDefinitionEnum o) -> G.unDescription <$> G._etdDescription o
|
|
(G.TypeDefinitionInputObject o) -> G.unDescription <$> G._iotdDescription o
|
|
|
|
typeProperties :: G.TypeDefinition possibleTypes G.InputValueDefinition -> Maybe [G.InputValueDefinition]
|
|
typeProperties = \case
|
|
(G.TypeDefinitionScalar _) -> Nothing
|
|
(G.TypeDefinitionInterface _) -> Nothing
|
|
(G.TypeDefinitionUnion _) -> Nothing
|
|
(G.TypeDefinitionEnum _) -> Nothing
|
|
(G.TypeDefinitionInputObject o) -> Just $ G._iotdValueDefinitions o
|
|
(G.TypeDefinitionObject _) -> Nothing
|
|
|
|
-- TODO: Can we reuse something from rest module to handle this?
|
|
-- TODO: referenceType could be improved, instead of using Bool (to indicate if it is object or scalar),
|
|
-- we can do something better
|
|
referenceType :: Bool -> Text -> (Maybe OpenApiType, Maybe Pattern)
|
|
referenceType False = const (Just OpenApiObject, Nothing)
|
|
referenceType True = \case
|
|
"int" -> (Just OpenApiInteger, Nothing)
|
|
"float" -> (Just OpenApiNumber, Nothing)
|
|
"double" -> (Just OpenApiNumber, Nothing)
|
|
"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}")
|
|
"bool" -> (Just OpenApiBoolean, Nothing)
|
|
"boolean" -> (Just OpenApiBoolean, Nothing)
|
|
"string" -> (Just OpenApiString, Nothing)
|
|
"id" -> (Just OpenApiString, Nothing)
|
|
_ -> (Nothing, Nothing)
|
|
|
|
processProperties :: InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> Maybe [G.InputValueDefinition] -> DeclareT (Definitions Schema) Identity (InsOrdHashMap Text (Referenced Schema))
|
|
processProperties _ Nothing = pure mempty
|
|
processProperties sd (Just ds) = do
|
|
ds' <- traverse (processProperty sd) ds
|
|
pure $ OMap.fromList ds'
|
|
|
|
processProperty :: InsOrdHashMap Text (G.TypeDefinition a G.InputValueDefinition) -> G.InputValueDefinition -> DeclareT (Definitions Schema) Identity (Text, Referenced Schema)
|
|
processProperty sd d = do
|
|
let n = G._ivdName d
|
|
t = G._ivdType d
|
|
rt <- handleRefType sd t
|
|
pure (G.unName n, rt)
|
|
|
|
getGQLQueryFromTrie :: EndpointMetadata GQLQueryWithText -> Text
|
|
getGQLQueryFromTrie = getGQLQueryText . _edQuery . _ceDefinition
|
|
|
|
mkParam :: Text -> Maybe Text -> Maybe Bool -> ParamLocation -> Maybe Bool -> Maybe J.Value -> Maybe OpenApiType -> Maybe Pattern -> Param
|
|
mkParam nameP desc req loc allowEmpty def varType patt =
|
|
mempty
|
|
& name .~ nameP
|
|
& description .~ desc
|
|
& required .~ req
|
|
& in_ .~ loc
|
|
& allowEmptyValue .~ allowEmpty
|
|
& schema
|
|
?~ Inline
|
|
( mempty
|
|
& default_ .~ def
|
|
& type_ .~ varType
|
|
& setPattern patt
|
|
)
|
|
|
|
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
|
|
|
|
-- * Top level schema construction
|
|
|
|
getComment :: EndpointMetadata GQLQueryWithText -> Text
|
|
getComment d = comment
|
|
where
|
|
gql = getGQLQueryFromTrie d
|
|
comment = case _ceComment d of
|
|
(Just c) -> c <> "\n***\nThe GraphQl query for this endpoint is:\n``` graphql\n" <> gql <> "\n```"
|
|
Nothing -> "***\nThe GraphQl query for this endpoint is:\n``` graphql\n" <> gql <> "\n```"
|
|
|
|
getURL :: EndpointMetadata GQLQueryWithText -> Text
|
|
getURL d =
|
|
"/api/rest/" <> T.intercalate "/" pathComponents
|
|
where
|
|
pathComponents = splitPath formatVariable id . _ceUrl $ d
|
|
formatVariable variable = "{" <> dropColonPrefix variable <> "}"
|
|
dropColonPrefix = T.drop 1
|
|
|
|
extractEndpointInfo :: G.SchemaIntrospection -> EndpointMethod -> EndpointMetadata GQLQueryWithText -> Declare (Definitions Schema) EndpointData
|
|
extractEndpointInfo sd method d = do
|
|
_edProperties <- mkProperties sd _analysis
|
|
_edResponse <- foldMap (Map.singleton method) <$> mkResponse method _edUrl sd _analysis
|
|
pure EndpointData {..}
|
|
where
|
|
_eDef = mdDefinitions d
|
|
-- mdDefinition returns a list, but there should only be one definition associated, so it is safe to fold
|
|
_analysis = fromMaybe mempty (foldMap (\e -> analyzeGraphqlQuery e sd) _eDef)
|
|
_edUrl = T.unpack . getURL $ d
|
|
_edVarList = getParams _analysis (_ceUrl d)
|
|
_edDescription = getComment d
|
|
_edName = unNonEmptyText $ unEndpointName $ _ceName d
|
|
_edMethod = Set.singleton method -- NOTE: Methods are grouped with into matching endpoints - Name used for grouping.
|
|
_edErrs = getAllAnalysisErrs _analysis
|
|
|
|
getEndpointsData ::
|
|
G.SchemaIntrospection ->
|
|
SchemaCache ->
|
|
Declare (Definitions Schema) [EndpointData]
|
|
getEndpointsData sd sc = do
|
|
let endpointTrie = scEndpoints sc
|
|
methodMaps = Trie.elems endpointTrie
|
|
endpointsWithMethods = concatMap (\(m, s) -> map (m,) s) $ concatMap MMap.toList methodMaps
|
|
|
|
endpointsWithInfo <- traverse (uncurry (extractEndpointInfo sd)) endpointsWithMethods
|
|
|
|
let endpointsGrouped = NE.groupBy (\a b -> _edName a == _edName b) endpointsWithInfo
|
|
|
|
pure $ map squashEndpointGroup endpointsGrouped
|
|
|
|
squashEndpointGroup :: NonEmpty EndpointData -> EndpointData
|
|
squashEndpointGroup g =
|
|
(NE.head g)
|
|
{ _edMethod = foldMap _edMethod g,
|
|
_edResponse = foldMap _edResponse g
|
|
}
|
|
|
|
serveJSON :: SchemaCache -> OpenApi
|
|
serveJSON sc = spec & components . schemas .~ defs
|
|
where
|
|
(defs, spec) = runDeclare (declareOpenApiSpec sc) mempty
|
|
|
|
-- | If all variables are scalar or optional then the entire request body can be marked as optional
|
|
isRequestBodyRequired :: EndpointData -> Bool
|
|
isRequestBodyRequired ed = not $ all isNotRequired (_edProperties ed)
|
|
where
|
|
-- The use of isNotRequired here won't work with list types since they are inline, but contain references
|
|
isNotRequired (Inline Schema {..}) = isScalarType _schemaType || (Just True == _schemaNullable)
|
|
isNotRequired (Ref _) = False -- Not all `Ref` are non nullable, imagine two endpoints using the same Ref one being nullable and other not
|
|
isScalarType :: Maybe OpenApiType -> Bool
|
|
isScalarType Nothing = False
|
|
isScalarType (Just t) = case t of
|
|
OpenApiString -> True
|
|
OpenApiNumber -> True
|
|
OpenApiInteger -> True
|
|
OpenApiBoolean -> True
|
|
OpenApiArray -> False
|
|
OpenApiNull -> False
|
|
OpenApiObject -> False
|
|
|
|
-- * Entry point
|
|
|
|
declareOpenApiSpec :: SchemaCache -> Declare (Definitions Schema) OpenApi
|
|
declareOpenApiSpec sc = do
|
|
let _schemaIntrospection = scAdminIntrospection sc
|
|
mkRequestBody :: EndpointData -> RequestBody
|
|
mkRequestBody ed =
|
|
mempty
|
|
& description ?~ "Query parameters can also be provided in the request body as a JSON object"
|
|
& required ?~ isRequestBodyRequired ed
|
|
& content
|
|
.~ OMap.singleton
|
|
("application" // "json")
|
|
( mempty
|
|
& schema
|
|
?~ Inline
|
|
( mempty
|
|
& type_ ?~ OpenApiObject
|
|
& properties .~ _edProperties ed
|
|
)
|
|
)
|
|
|
|
mkOperation :: EndpointMethod -> EndpointData -> Operation
|
|
mkOperation method ed =
|
|
mempty
|
|
& description ?~ _edDescription ed
|
|
& summary ?~ _edName ed
|
|
& parameters .~ (Inline xHasuraAdminSecret : _edVarList ed)
|
|
& requestBody .~ toMaybe (not (null (_edProperties ed))) (Inline (mkRequestBody ed))
|
|
& responses .~ Responses Nothing (maybe mempty (OMap.singleton 200 . Inline) $ Map.lookup method $ _edResponse ed)
|
|
where
|
|
toMaybe b a = if b then Just a else Nothing
|
|
|
|
getOPName :: EndpointData -> EndpointMethod -> Maybe Operation
|
|
getOPName ed methodType =
|
|
if methodType `Set.member` _edMethod ed
|
|
then Just $ mkOperation methodType ed
|
|
else Nothing
|
|
|
|
xHasuraAdminSecret :: Param
|
|
xHasuraAdminSecret =
|
|
mkParam
|
|
"x-hasura-admin-secret"
|
|
(Just "Your x-hasura-admin-secret will be used for authentication of the API request.")
|
|
Nothing
|
|
ParamHeader
|
|
Nothing
|
|
Nothing
|
|
(Just OpenApiString)
|
|
Nothing
|
|
|
|
generatePathItem :: EndpointData -> PathItem
|
|
generatePathItem ed =
|
|
let pathData =
|
|
mempty
|
|
& get .~ getOPName ed GET
|
|
& post .~ getOPName ed POST
|
|
& put .~ getOPName ed PUT
|
|
& delete .~ getOPName ed DELETE
|
|
& patch .~ getOPName ed PATCH
|
|
completePathData =
|
|
if pathData == mempty
|
|
then
|
|
mempty
|
|
& post
|
|
?~ mkOperation
|
|
POST
|
|
ed
|
|
{ _edDescription =
|
|
"⚠️ Method("
|
|
<> tshow (_edMethod ed)
|
|
<> ") not supported, defaulting to POST\n\n"
|
|
<> _edDescription ed
|
|
}
|
|
else pathData
|
|
in completePathData
|
|
|
|
endpointLst <- getEndpointsData _schemaIntrospection sc
|
|
|
|
let mkOpenAPISchema :: [EndpointData] -> InsOrdHashMap FilePath PathItem
|
|
mkOpenAPISchema edLst = foldl (\hm ed -> OMap.insertWith (<>) (_edUrl ed) (generatePathItem ed) hm) mempty edLst
|
|
|
|
openAPIPaths = mkOpenAPISchema endpointLst
|
|
|
|
allWarnings = foldl addEndpointWarnings "" endpointLst
|
|
addEndpointWarnings :: Text -> EndpointData -> Text
|
|
addEndpointWarnings oldWarn EndpointData {..} =
|
|
if null _edErrs
|
|
then oldWarn
|
|
else
|
|
oldWarn <> "\n\nEndpoint \""
|
|
<> _edName
|
|
<> "\":\n"
|
|
<> foldl (\w err -> w <> "\n- ⚠️ " <> err) "" _edErrs
|
|
|
|
return $
|
|
mempty
|
|
& paths .~ openAPIPaths
|
|
& info . title .~ "Rest Endpoints"
|
|
& info . description ?~ "This OpenAPI specification is automatically generated by Hasura." <> allWarnings
|