{-# 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 :: forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
SchemaCache -> m OpenApi
buildOpenAPI SchemaCache
schemaCache = do
  (Definitions Schema
defs, OpenApi
spec) <- (DeclareT (Definitions Schema) m OpenApi
 -> Definitions Schema -> m (Definitions Schema, OpenApi))
-> Definitions Schema
-> DeclareT (Definitions Schema) m OpenApi
-> m (Definitions Schema, OpenApi)
forall a b c. (a -> b -> c) -> b -> a -> c
flip DeclareT (Definitions Schema) m OpenApi
-> Definitions Schema -> m (Definitions Schema, OpenApi)
forall d (m :: * -> *) a. DeclareT d m a -> d -> m (d, a)
runDeclareT Definitions Schema
forall a. Monoid a => a
mempty do
    InsOrdHashMap String (PathItem, Text)
endpoints <- SchemaCache
-> SchemaIntrospection
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
SchemaCache
-> SchemaIntrospection
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
buildAllEndpoints SchemaCache
schemaCache (SchemaCache -> SchemaIntrospection
scAdminIntrospection SchemaCache
schemaCache)
    OpenApi -> DeclareT (Definitions Schema) m OpenApi
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (OpenApi -> DeclareT (Definitions Schema) m OpenApi)
-> OpenApi -> DeclareT (Definitions Schema) m OpenApi
forall a b. (a -> b) -> a -> b
$ OpenApi
forall a. Monoid a => a
mempty
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap String PathItem
 -> Identity (InsOrdHashMap String PathItem))
-> OpenApi -> Identity OpenApi
forall s a. HasPaths s a => Lens' s a
Lens' OpenApi (InsOrdHashMap String PathItem)
paths ((InsOrdHashMap String PathItem
  -> Identity (InsOrdHashMap String PathItem))
 -> OpenApi -> Identity OpenApi)
-> InsOrdHashMap String PathItem -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ((PathItem, Text) -> PathItem)
-> InsOrdHashMap String (PathItem, Text)
-> InsOrdHashMap String PathItem
forall a b.
(a -> b) -> InsOrdHashMap String a -> InsOrdHashMap String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PathItem, Text) -> PathItem
forall a b. (a, b) -> a
fst InsOrdHashMap String (PathItem, Text)
endpoints
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Info -> Identity Info) -> OpenApi -> Identity OpenApi
forall s a. HasInfo s a => Lens' s a
Lens' OpenApi Info
info ((Info -> Identity Info) -> OpenApi -> Identity OpenApi)
-> ((Text -> Identity Text) -> Info -> Identity Info)
-> (Text -> Identity Text)
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Identity Text) -> Info -> Identity Info
forall s a. HasTitle s a => Lens' s a
Lens' Info Text
title ((Text -> Identity Text) -> OpenApi -> Identity OpenApi)
-> Text -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Rest Endpoints"
      OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Info -> Identity Info) -> OpenApi -> Identity OpenApi
forall s a. HasInfo s a => Lens' s a
Lens' OpenApi Info
info ((Info -> Identity Info) -> OpenApi -> Identity OpenApi)
-> ((Maybe Text -> Identity (Maybe Text)) -> Info -> Identity Info)
-> (Maybe Text -> Identity (Maybe Text))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe Text -> Identity (Maybe Text)) -> Info -> Identity Info
forall s a. HasDescription s a => Lens' s a
Lens' Info (Maybe Text)
description
        ((Maybe Text -> Identity (Maybe Text))
 -> OpenApi -> Identity OpenApi)
-> Text -> OpenApi -> OpenApi
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"This OpenAPI specification is automatically generated by Hasura." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ((PathItem, Text) -> Text)
-> InsOrdHashMap String (PathItem, Text) -> Text
forall m a. Monoid m => (a -> m) -> InsOrdHashMap String a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (PathItem, Text) -> Text
forall a b. (a, b) -> b
snd InsOrdHashMap String (PathItem, Text)
endpoints
  OpenApi -> m OpenApi
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (OpenApi -> m OpenApi) -> OpenApi -> m OpenApi
forall a b. (a -> b) -> a -> b
$ OpenApi
spec OpenApi -> (OpenApi -> OpenApi) -> OpenApi
forall a b. a -> (a -> b) -> b
& (Components -> Identity Components) -> OpenApi -> Identity OpenApi
forall s a. HasComponents s a => Lens' s a
Lens' OpenApi Components
components ((Components -> Identity Components)
 -> OpenApi -> Identity OpenApi)
-> ((Definitions Schema -> Identity (Definitions Schema))
    -> Components -> Identity Components)
-> (Definitions Schema -> Identity (Definitions Schema))
-> OpenApi
-> Identity OpenApi
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Definitions Schema -> Identity (Definitions Schema))
-> Components -> Identity Components
forall s a. HasSchemas s a => Lens' s a
Lens' Components (Definitions Schema)
schemas ((Definitions Schema -> Identity (Definitions Schema))
 -> OpenApi -> Identity OpenApi)
-> Definitions Schema -> OpenApi -> OpenApi
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Definitions Schema
defs

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

buildAllEndpoints ::
  (MonadError QErr m, MonadFix m) =>
  SchemaCache ->
  G.SchemaIntrospection ->
  DeclareM m (InsOrdHashMap String (PathItem, Text))
buildAllEndpoints :: forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
SchemaCache
-> SchemaIntrospection
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
buildAllEndpoints SchemaCache
schemaCache SchemaIntrospection
schemaTypes =
  (InsOrdHashMap String (PathItem, Text)
 -> InsOrdHashMap String (PathItem, Text)
 -> InsOrdHashMap String (PathItem, Text))
-> InsOrdHashMap String (PathItem, Text)
-> [InsOrdHashMap String (PathItem, Text)]
-> InsOrdHashMap String (PathItem, Text)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (((PathItem, Text) -> (PathItem, Text) -> (PathItem, Text))
-> InsOrdHashMap String (PathItem, Text)
-> InsOrdHashMap String (PathItem, Text)
-> InsOrdHashMap String (PathItem, Text)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v)
-> InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.unionWith (PathItem, Text) -> (PathItem, Text) -> (PathItem, Text)
forall a. Semigroup a => a -> a -> a
(<>)) InsOrdHashMap String (PathItem, Text)
forall a. Monoid a => a
mempty ([InsOrdHashMap String (PathItem, Text)]
 -> InsOrdHashMap String (PathItem, Text))
-> DeclareT
     (Definitions Schema) m [InsOrdHashMap String (PathItem, Text)]
-> DeclareT
     (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [DeclareT
   (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))]
-> DeclareT
     (Definitions Schema) m [InsOrdHashMap String (PathItem, Text)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence do
    -- for each path in the trie of endpoints
    MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText)
endpointMap <- Trie
  (PathComponent Text)
  (MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText))
-> [MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText)]
forall k v. Trie k v -> [v]
Trie.elems (Trie
   (PathComponent Text)
   (MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText))
 -> [MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText)])
-> Trie
     (PathComponent Text)
     (MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText))
-> [MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText)]
forall a b. (a -> b) -> a -> b
$ SchemaCache
-> Trie
     (PathComponent Text)
     (MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText))
scEndpoints SchemaCache
schemaCache
    -- for each method at that path
    (EndpointMethod
method, [EndpointMetadata GQLQueryWithText]
metadataList) <- MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText)
-> [(EndpointMethod, [EndpointMetadata GQLQueryWithText])]
forall k v. MultiMap k v -> [(k, [v])]
MMap.toList MultiMap EndpointMethod (EndpointMetadata GQLQueryWithText)
endpointMap
    -- for each metadata associated with that method
    EndpointMetadata GQLQueryWithText
metadata <- [EndpointMetadata GQLQueryWithText]
metadataList
    -- build the corresponding path item and list of messages
    DeclareT
  (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))
-> [DeclareT
      (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DeclareT
   (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))
 -> [DeclareT
       (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))])
-> DeclareT
     (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))
-> [DeclareT
      (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))]
forall a b. (a -> b) -> a -> b
$ SchemaIntrospection
-> EndpointMethod
-> EndpointMetadata GQLQueryWithText
-> DeclareT
     (Definitions Schema) m (InsOrdHashMap String (PathItem, Text))
forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
SchemaIntrospection
-> EndpointMethod
-> EndpointMetadata GQLQueryWithText
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
buildEndpoint SchemaIntrospection
schemaTypes EndpointMethod
method EndpointMetadata GQLQueryWithText
metadata

buildEndpoint ::
  (MonadError QErr m, MonadFix m) =>
  G.SchemaIntrospection ->
  EndpointMethod ->
  EndpointMetadata GQLQueryWithText ->
  DeclareM m (InsOrdHashMap String (PathItem, Text))
buildEndpoint :: forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
SchemaIntrospection
-> EndpointMethod
-> EndpointMetadata GQLQueryWithText
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
buildEndpoint SchemaIntrospection
schemaTypes EndpointMethod
method EndpointMetadata {Maybe Text
NonEmpty EndpointMethod
EndpointUrl
EndpointName
EndpointDef GQLQueryWithText
_ceName :: EndpointName
_ceUrl :: EndpointUrl
_ceMethods :: NonEmpty EndpointMethod
_ceDefinition :: EndpointDef GQLQueryWithText
_ceComment :: Maybe Text
_ceName :: forall query. EndpointMetadata query -> EndpointName
_ceUrl :: forall query. EndpointMetadata query -> EndpointUrl
_ceMethods :: forall query. EndpointMetadata query -> NonEmpty EndpointMethod
_ceDefinition :: forall query. EndpointMetadata query -> EndpointDef query
_ceComment :: forall query. EndpointMetadata query -> Maybe Text
..} = do
  let -- extracting endpoint info
      GQLQueryWithText (Text
queryText, GQLQuery ExecutableDocument Name
queryDocument) = EndpointDef GQLQueryWithText -> GQLQueryWithText
forall query. EndpointDef query -> query
_edQuery EndpointDef GQLQueryWithText
_ceDefinition
  SingleOperation
singleOperation <- m SingleOperation
-> DeclareT (Definitions Schema) m SingleOperation
forall (m :: * -> *) a.
Monad m =>
m a -> DeclareT (Definitions Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m SingleOperation
 -> DeclareT (Definitions Schema) m SingleOperation)
-> m SingleOperation
-> DeclareT (Definitions Schema) m SingleOperation
forall a b. (a -> b) -> a -> b
$ GQLReqParsed -> m SingleOperation
forall (m :: * -> *).
MonadError QErr m =>
GQLReqParsed -> m SingleOperation
getSingleOperation (Maybe OperationName
-> GQLExecDoc -> Maybe (HashMap Name Value) -> GQLReqParsed
forall a.
Maybe OperationName -> a -> Maybe (HashMap Name Value) -> GQLReq a
GQLReq Maybe OperationName
forall a. Maybe a
Nothing ([ExecutableDefinition Name] -> GQLExecDoc
GQLExecDoc (ExecutableDocument Name -> [ExecutableDefinition Name]
forall var. ExecutableDocument var -> [ExecutableDefinition var]
G.getExecutableDefinitions ExecutableDocument Name
queryDocument)) Maybe (HashMap Name Value)
forall a. Maybe a
Nothing)
  let (Structure -> Maybe Structure -> Structure
forall a. a -> Maybe a -> a
fromMaybe (HashMap Name FieldInfo -> HashMap Name VariableInfo -> Structure
Structure HashMap Name FieldInfo
forall a. Monoid a => a
mempty HashMap Name VariableInfo
forall a. Monoid a => a
mempty) -> Structure
analysis, [Text]
messages) = SchemaIntrospection -> SingleOperation -> (Maybe Structure, [Text])
analyzeGraphQLQuery SchemaIntrospection
schemaTypes SingleOperation
singleOperation

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

      -- building endpoint properties
      endpointVarList :: [Referenced Param]
endpointVarList = Structure -> EndpointUrl -> [Referenced Param]
collectParams Structure
analysis EndpointUrl
_ceUrl
      endpointDescription :: Text
endpointDescription =
        Maybe Text -> Text
forall m. Monoid m => Maybe m -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold Maybe Text
_ceComment
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"***\nThe GraphQl query for this endpoint is:\n``` graphql\n"
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
queryText
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n```"
      endpointName :: Text
endpointName = NonEmptyText -> Text
unNonEmptyText (NonEmptyText -> Text) -> NonEmptyText -> Text
forall a b. (a -> b) -> a -> b
$ EndpointName -> NonEmptyText
unEndpointName EndpointName
_ceName
  Maybe (Referenced RequestBody)
reqBody <- Structure -> DeclareM m (Maybe (Referenced RequestBody))
forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
Structure -> DeclareM m (Maybe (Referenced RequestBody))
buildRequestBody Structure
analysis
  Response
response <- Structure -> EndpointMethod -> Text -> DeclareM m Response
forall (m :: * -> *).
Monad m =>
Structure -> EndpointMethod -> Text -> DeclareM m Response
buildResponse Structure
analysis EndpointMethod
method Text
endpointURL

  let -- building the PathItem
      operation :: Operation
operation =
        Operation
forall a. Monoid a => a
mempty
          Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> Operation -> Identity Operation
forall s a. HasDescription s a => Lens' s a
Lens' Operation (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> Operation -> Identity Operation)
-> Text -> Operation -> Operation
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
endpointDescription
          Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> Operation -> Identity Operation
forall s a. HasSummary s a => Lens' s a
Lens' Operation (Maybe Text)
summary ((Maybe Text -> Identity (Maybe Text))
 -> Operation -> Identity Operation)
-> Text -> Operation -> Operation
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
endpointName
          Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& ([Referenced Param] -> Identity [Referenced Param])
-> Operation -> Identity Operation
forall s a. HasParameters s a => Lens' s a
Lens' Operation [Referenced Param]
parameters (([Referenced Param] -> Identity [Referenced Param])
 -> Operation -> Identity Operation)
-> [Referenced Param] -> Operation -> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Param -> Referenced Param
forall a. a -> Referenced a
Inline Param
xHasuraAdminSecret Referenced Param -> [Referenced Param] -> [Referenced Param]
forall a. a -> [a] -> [a]
: [Referenced Param]
endpointVarList)
          Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced RequestBody)
 -> Identity (Maybe (Referenced RequestBody)))
-> Operation -> Identity Operation
forall s a. HasRequestBody s a => Lens' s a
Lens' Operation (Maybe (Referenced RequestBody))
requestBody ((Maybe (Referenced RequestBody)
  -> Identity (Maybe (Referenced RequestBody)))
 -> Operation -> Identity Operation)
-> Maybe (Referenced RequestBody) -> Operation -> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Referenced RequestBody)
reqBody
          Operation -> (Operation -> Operation) -> Operation
forall a b. a -> (a -> b) -> b
& (Responses -> Identity Responses)
-> Operation -> Identity Operation
forall s a. HasResponses s a => Lens' s a
Lens' Operation Responses
responses ((Responses -> Identity Responses)
 -> Operation -> Identity Operation)
-> Responses -> Operation -> Operation
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe (Referenced Response)
-> InsOrdHashMap HttpStatusCode (Referenced Response) -> Responses
Responses Maybe (Referenced Response)
forall a. Maybe a
Nothing (HttpStatusCode
-> Referenced Response
-> InsOrdHashMap HttpStatusCode (Referenced Response)
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton HttpStatusCode
200 (Referenced Response
 -> InsOrdHashMap HttpStatusCode (Referenced Response))
-> Referenced Response
-> InsOrdHashMap HttpStatusCode (Referenced Response)
forall a b. (a -> b) -> a -> b
$ Response -> Referenced Response
forall a. a -> Referenced a
Inline Response
response)
      pathItem :: PathItem
pathItem =
        PathItem
forall a. Monoid a => a
mempty PathItem -> (PathItem -> PathItem) -> PathItem
forall a b. a -> (a -> b) -> b
& case EndpointMethod
method of
          EndpointMethod
GET -> (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
forall s a. HasGet s a => Lens' s a
Lens' PathItem (Maybe Operation)
get ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Operation
operation
          EndpointMethod
PUT -> (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
forall s a. HasPut s a => Lens' s a
Lens' PathItem (Maybe Operation)
put ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Operation
operation
          EndpointMethod
POST -> (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
forall s a. HasPost s a => Lens' s a
Lens' PathItem (Maybe Operation)
post ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Operation
operation
          EndpointMethod
PATCH -> (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
forall s a. HasPatch s a => Lens' s a
Lens' PathItem (Maybe Operation)
patch ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Operation
operation
          EndpointMethod
DELETE -> (Maybe Operation -> Identity (Maybe Operation))
-> PathItem -> Identity PathItem
forall s a. HasDelete s a => Lens' s a
Lens' PathItem (Maybe Operation)
delete ((Maybe Operation -> Identity (Maybe Operation))
 -> PathItem -> Identity PathItem)
-> Operation -> PathItem -> PathItem
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Operation
operation

      -- making summary of errors
      formattedMessages :: Text
formattedMessages =
        if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
messages
          then Text
""
          else Text
"\n\nEndpoint \"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
endpointName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text) -> [Text] -> Text
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Text
"\n- ⚠️ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) [Text]
messages

  InsOrdHashMap String (PathItem, Text)
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (InsOrdHashMap String (PathItem, Text)
 -> DeclareM m (InsOrdHashMap String (PathItem, Text)))
-> InsOrdHashMap String (PathItem, Text)
-> DeclareM m (InsOrdHashMap String (PathItem, Text))
forall a b. (a -> b) -> a -> b
$ String -> (PathItem, Text) -> InsOrdHashMap String (PathItem, Text)
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton (Text -> String
T.unpack Text
endpointURL) (PathItem
pathItem, Text
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 -> EndpointUrl -> [Referenced Param]
collectParams (Structure HashMap Name FieldInfo
_ HashMap Name VariableInfo
vars) EndpointUrl
eURL = do
  (Name -> Text
G.unName -> Text
varName, VariableInfo {Maybe (Value Void)
GType
InputFieldInfo
_viType :: GType
_viTypeInfo :: InputFieldInfo
_viDefaultValue :: Maybe (Value Void)
_viType :: VariableInfo -> GType
_viTypeInfo :: VariableInfo -> InputFieldInfo
_viDefaultValue :: VariableInfo -> Maybe (Value Void)
..}) <- ((Name, VariableInfo) -> Name)
-> [(Name, VariableInfo)] -> [(Name, VariableInfo)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Name, VariableInfo) -> Name
forall a b. (a, b) -> a
fst ([(Name, VariableInfo)] -> [(Name, VariableInfo)])
-> [(Name, VariableInfo)] -> [(Name, VariableInfo)]
forall a b. (a -> b) -> a -> b
$ HashMap Name VariableInfo -> [(Name, VariableInfo)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name VariableInfo
vars
  case InputFieldInfo
_viTypeInfo of
    -- we do not allow input objects or enums in parameters
    InputFieldObjectInfo InputObjectInfo
_ -> [Referenced Param]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
    InputFieldEnumInfo EnumInfo
_ -> [Referenced Param]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
    InputFieldScalarInfo ScalarInfo
_ -> case GType
_viType of
      -- we do not allow arrays in parameters
      G.TypeList Nullability
_ GType
_ -> [Referenced Param]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
      G.TypeNamed Nullability
nullability Name
typeName -> case Name -> Maybe (OpenApiType, Maybe Text, Bool)
getReferenceScalarInfo Name
typeName of
        -- we do not allow unknown scalars in parameters
        Maybe (OpenApiType, Maybe Text, Bool)
Nothing -> [Referenced Param]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
        Just (OpenApiType
refType, Maybe Text
typePattern, Bool
_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 :: Bool
isRequired = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Nullability -> Bool
G.unNullability Nullability
nullability Bool -> Bool -> Bool
|| Maybe (Value Void) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Value Void)
_viDefaultValue
              desc :: Maybe Text
desc =
                if Bool
isRequired
                  then Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text
"_\"" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
varName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\" is required (enter it either in parameters or request body)_"
                  else Maybe Text
forall a. Maybe a
Nothing
              -- TODO: document this
              -- NOTE: URL Variable name ':' prefix is removed for `elem` lookup.
              pathVars :: [Text]
pathVars = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (HttpStatusCode -> Text -> Text
T.drop HttpStatusCode
1) ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> [Text]) -> [[Text]] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> [Text]) -> (Text -> [Text]) -> EndpointUrl -> [[Text]]
forall a. (Text -> a) -> (Text -> a) -> EndpointUrl -> [a]
splitPath Text -> [Text]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Text] -> Text -> [Text]
forall a b. a -> b -> a
const []) EndpointUrl
eURL
          Referenced Param -> [Referenced Param]
forall a. a -> [a]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            (Referenced Param -> [Referenced Param])
-> Referenced Param -> [Referenced Param]
forall a b. (a -> b) -> a -> b
$
            -- We always inline the schema, since we might need to add the default value.
            Param -> Referenced Param
forall a. a -> Referenced a
Inline
            (Param -> Referenced Param) -> Param -> Referenced Param
forall a b. (a -> b) -> a -> b
$ Param
forall a. Monoid a => a
mempty
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Param -> Identity Param
forall s a. HasName s a => Lens' s a
Lens' Param Text
name ((Text -> Identity Text) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
varName
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param
forall s a. HasDescription s a => Lens' s a
Lens' Param (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param)
-> Maybe Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Text
desc
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (ParamLocation -> Identity ParamLocation)
-> Param -> Identity Param
forall s a. HasIn s a => Lens' s a
Lens' Param ParamLocation
in_ ((ParamLocation -> Identity ParamLocation)
 -> Param -> Identity Param)
-> ParamLocation -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (if Text
varName Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text]
pathVars then ParamLocation
ParamPath else ParamLocation
ParamQuery)
            Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> Param -> Identity Param
forall s a. HasSchema s a => Lens' s a
Lens' Param (Maybe (Referenced Schema))
schema
              ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Param -> Identity Param)
-> Referenced Schema -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline
                ( Schema
forall a. Monoid a => a
mempty
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasDefault s a => Lens' s a
Lens' Schema (Maybe Value)
default_ ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Maybe Value -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Value Void -> Value
gqlToJsonValue (Value Void -> Value) -> Maybe (Value Void) -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Value Void)
_viDefaultValue)
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
refType
                    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasPattern s a => Lens' s a
Lens' Schema (Maybe Text)
pattern ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Text
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 :: forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
Structure -> DeclareM m (Maybe (Referenced RequestBody))
buildRequestBody Structure {HashMap Name VariableInfo
HashMap Name FieldInfo
_stSelection :: HashMap Name FieldInfo
_stVariables :: HashMap Name VariableInfo
_stSelection :: Structure -> HashMap Name FieldInfo
_stVariables :: Structure -> HashMap Name VariableInfo
..} = do
  let vars :: [(Name, VariableInfo)]
vars = HashMap Name VariableInfo -> [(Name, VariableInfo)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name VariableInfo
_stVariables
  if [(Name, VariableInfo)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, VariableInfo)]
vars
    then Maybe (Referenced RequestBody)
-> DeclareM m (Maybe (Referenced RequestBody))
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Referenced RequestBody)
forall a. Maybe a
Nothing
    else do
      (InsOrdHashMap Text (Referenced Schema)
varProperties, Any Bool
isBodyRequired) <-
        CircularT
  (Name, Nullability)
  (Referenced Schema)
  (DeclareT (Definitions Schema) m)
  (InsOrdHashMap Text (Referenced Schema), Any)
-> DeclareT
     (Definitions Schema)
     m
     (InsOrdHashMap Text (Referenced Schema), Any)
forall k (m :: * -> *) v a.
(Hashable k, MonadFix m) =>
CircularT k v m a -> m a
runCircularT
          (CircularT
   (Name, Nullability)
   (Referenced Schema)
   (DeclareT (Definitions Schema) m)
   (InsOrdHashMap Text (Referenced Schema), Any)
 -> DeclareT
      (Definitions Schema)
      m
      (InsOrdHashMap Text (Referenced Schema), Any))
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     (InsOrdHashMap Text (Referenced Schema), Any)
-> DeclareT
     (Definitions Schema)
     m
     (InsOrdHashMap Text (Referenced Schema), Any)
forall a b. (a -> b) -> a -> b
$ [(InsOrdHashMap Text (Referenced Schema), Any)]
-> (InsOrdHashMap Text (Referenced Schema), Any)
forall a. Monoid a => [a] -> a
mconcat
          ([(InsOrdHashMap Text (Referenced Schema), Any)]
 -> (InsOrdHashMap Text (Referenced Schema), Any))
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     [(InsOrdHashMap Text (Referenced Schema), Any)]
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     (InsOrdHashMap Text (Referenced Schema), Any)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Name, VariableInfo)]
-> ((Name, VariableInfo)
    -> CircularT
         (Name, Nullability)
         (Referenced Schema)
         (DeclareT (Definitions Schema) m)
         (InsOrdHashMap Text (Referenced Schema), Any))
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     [(InsOrdHashMap Text (Referenced Schema), Any)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Name, VariableInfo)]
vars \(Name
varName, VariableInfo
varInfo) -> do
            (Referenced Schema
resolvedVarInfo, Bool
isVarRequired) <- VariableInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     (Referenced Schema, Bool)
forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
VariableInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema, Bool)
buildVariableSchema VariableInfo
varInfo
            (InsOrdHashMap Text (Referenced Schema), Any)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     (InsOrdHashMap Text (Referenced Schema), Any)
forall a.
a
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareT (Definitions Schema) m)
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Referenced Schema -> InsOrdHashMap Text (Referenced Schema)
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton (Name -> Text
G.unName Name
varName) Referenced Schema
resolvedVarInfo, Bool -> Any
Any Bool
isVarRequired)
      Maybe (Referenced RequestBody)
-> DeclareM m (Maybe (Referenced RequestBody))
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        (Maybe (Referenced RequestBody)
 -> DeclareM m (Maybe (Referenced RequestBody)))
-> Maybe (Referenced RequestBody)
-> DeclareM m (Maybe (Referenced RequestBody))
forall a b. (a -> b) -> a -> b
$ Referenced RequestBody -> Maybe (Referenced RequestBody)
forall a. a -> Maybe a
Just
        (Referenced RequestBody -> Maybe (Referenced RequestBody))
-> Referenced RequestBody -> Maybe (Referenced RequestBody)
forall a b. (a -> b) -> a -> b
$ RequestBody -> Referenced RequestBody
forall a. a -> Referenced a
Inline
        (RequestBody -> Referenced RequestBody)
-> RequestBody -> Referenced RequestBody
forall a b. (a -> b) -> a -> b
$ RequestBody
forall a. Monoid a => a
mempty
        RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text))
-> RequestBody -> Identity RequestBody
forall s a. HasDescription s a => Lens' s a
Lens' RequestBody (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> RequestBody -> Identity RequestBody)
-> Text -> RequestBody -> RequestBody
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"Query parameters can also be provided in the request body as a JSON object"
        RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool))
-> RequestBody -> Identity RequestBody
forall s a. HasRequired s a => Lens' s a
Lens' RequestBody (Maybe Bool)
required ((Maybe Bool -> Identity (Maybe Bool))
 -> RequestBody -> Identity RequestBody)
-> Bool -> RequestBody -> RequestBody
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Bool
isBodyRequired
        RequestBody -> (RequestBody -> RequestBody) -> RequestBody
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> RequestBody -> Identity RequestBody
forall s a. HasContent s a => Lens' s a
Lens' RequestBody (InsOrdHashMap MediaType MediaTypeObject)
content
          ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> RequestBody -> Identity RequestBody)
-> InsOrdHashMap MediaType MediaTypeObject
-> RequestBody
-> RequestBody
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton
            (ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json")
            ( MediaTypeObject
forall a. Monoid a => a
mempty
                MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
schema
                  ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline
                    ( Schema
forall a. Monoid a => a
mempty
                        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
                        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ InsOrdHashMap Text (Referenced Schema)
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 :: forall (m :: * -> *).
(MonadError QErr m, MonadFix m) =>
VariableInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema, Bool)
buildVariableSchema VariableInfo {Maybe (Value Void)
GType
InputFieldInfo
_viType :: VariableInfo -> GType
_viTypeInfo :: VariableInfo -> InputFieldInfo
_viDefaultValue :: VariableInfo -> Maybe (Value Void)
_viType :: GType
_viTypeInfo :: InputFieldInfo
_viDefaultValue :: Maybe (Value Void)
..} = 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 :: Bool
hasDefaultValue = Maybe (Value Void) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Value Void)
_viDefaultValue
      isNullable :: Bool
isNullable = GType -> Bool
G.isNullable GType
_viType
      isKnownScalar :: Bool
isKnownScalar = case GType
_viType of
        G.TypeNamed Nullability
_ Name
typeName -> Maybe (OpenApiType, Maybe Text, Bool) -> Bool
forall a. Maybe a -> Bool
isJust (Name -> Maybe (OpenApiType, Maybe Text, Bool)
getReferenceScalarInfo Name
typeName)
        GType
_ -> Bool
False
      isOptional :: Bool
isOptional = Bool
hasDefaultValue Bool -> Bool -> Bool
|| Bool
isNullable Bool -> Bool -> Bool
|| Bool
isKnownScalar

  Referenced Schema
baseSchema <- GType
-> InputFieldInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall (m :: * -> *).
MonadFix m =>
GType
-> InputFieldInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
buildInputFieldSchema GType
_viType InputFieldInfo
_viTypeInfo
  Referenced Schema
varSchema <- case Maybe (Value Void)
_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).
    Maybe (Value Void)
Nothing -> Referenced Schema
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall a.
a
-> CircularT (Name, Nullability) (Referenced Schema) (DeclareM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Referenced Schema
baseSchema
    -- If we need to modify it, then we might have to dereference it.
    Just Value Void
defaultValue -> do
      Schema
varSchema <- case Referenced Schema
baseSchema of
        Inline Schema
varSchema -> Schema
-> CircularT
     (Name, Nullability) (Referenced Schema) (DeclareM m) Schema
forall a.
a
-> CircularT (Name, Nullability) (Referenced Schema) (DeclareM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Schema
varSchema
        Ref (Reference Text
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.
          Definitions Schema
declarations <- DeclareM m (Definitions Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Definitions Schema)
forall (m :: * -> *) a.
Monad m =>
m a -> CircularT (Name, Nullability) (Referenced Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift DeclareM m (Definitions Schema)
forall d (m :: * -> *). MonadDeclare d m => m d
look
          Text -> Definitions Schema -> Maybe Schema
forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup Text
refName Definitions Schema
declarations
            -- DeclareT doesn't have a MonadError instance, hence the need for
            -- explicit lifting.
            Maybe Schema
-> CircularT
     (Name, Nullability) (Referenced Schema) (DeclareM m) Schema
-> CircularT
     (Name, Nullability) (Referenced Schema) (DeclareM m) Schema
forall (m :: * -> *) a. Applicative m => Maybe a -> m a -> m a
`onNothing` DeclareM m Schema
-> CircularT
     (Name, Nullability) (Referenced Schema) (DeclareM m) Schema
forall (m :: * -> *) a.
Monad m =>
m a -> CircularT (Name, Nullability) (Referenced Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Schema -> DeclareM m Schema
forall (m :: * -> *) a.
Monad m =>
m a -> DeclareT (Definitions Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Schema -> DeclareM m Schema) -> m Schema -> DeclareM m Schema
forall a b. (a -> b) -> a -> b
$ Text -> m Schema
forall (m :: * -> *) a. QErrM m => Text -> m a
throw500 Text
"internal error: declareType returned an invalid reference")
      Referenced Schema
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall a.
a
-> CircularT (Name, Nullability) (Referenced Schema) (DeclareM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema
 -> CircularT
      (Name, Nullability)
      (Referenced Schema)
      (DeclareM m)
      (Referenced Schema))
-> Referenced Schema
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
varSchema Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Value -> Identity (Maybe Value))
-> Schema -> Identity Schema
forall s a. HasDefault s a => Lens' s a
Lens' Schema (Maybe Value)
default_ ((Maybe Value -> Identity (Maybe Value))
 -> Schema -> Identity Schema)
-> Value -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Value Void -> Value
gqlToJsonValue Value Void
defaultValue

  (Referenced Schema, Bool)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema, Bool)
forall a.
a
-> CircularT (Name, Nullability) (Referenced Schema) (DeclareM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema
varSchema, Bool -> Bool
not Bool
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 :: forall (m :: * -> *).
MonadFix m =>
GType
-> InputFieldInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
buildInputFieldSchema GType
gType = \case
  -- this input field is a scalar: we attempt to declare it
  InputFieldScalarInfo ScalarInfo
scalarInfo ->
    DeclareM m (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall (m :: * -> *) a.
Monad m =>
m a -> CircularT (Name, Nullability) (Referenced Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DeclareM m (Referenced Schema)
 -> CircularT
      (Name, Nullability)
      (Referenced Schema)
      (DeclareM m)
      (Referenced Schema))
-> DeclareM m (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ GType
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gType ((Name -> Nullability -> DeclareM m (Referenced Schema))
 -> DeclareM m (Referenced Schema))
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ ScalarInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
ScalarInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
buildScalarSchema ScalarInfo
scalarInfo
  -- this input field is an enum: we declare it
  InputFieldEnumInfo EnumInfo
enumInfo ->
    DeclareM m (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall (m :: * -> *) a.
Monad m =>
m a -> CircularT (Name, Nullability) (Referenced Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DeclareM m (Referenced Schema)
 -> CircularT
      (Name, Nullability)
      (Referenced Schema)
      (DeclareM m)
      (Referenced Schema))
-> DeclareM m (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ GType
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gType ((Name -> Nullability -> DeclareM m (Referenced Schema))
 -> DeclareM m (Referenced Schema))
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ EnumInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
EnumInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
buildEnumSchema EnumInfo
enumInfo
  -- this input field is an object: we declare it
  InputFieldObjectInfo InputObjectInfo {HashMap Name (GType, InputFieldInfo)
InputObjectTypeDefinition InputValueDefinition
_ioiTypeDefinition :: InputObjectTypeDefinition InputValueDefinition
_ioiFields :: HashMap Name (GType, InputFieldInfo)
_ioiTypeDefinition :: InputObjectInfo -> InputObjectTypeDefinition InputValueDefinition
_ioiFields :: InputObjectInfo -> HashMap Name (GType, InputFieldInfo)
..} ->
    GType
-> (Name
    -> Nullability
    -> CircularT
         (Name, Nullability)
         (Referenced Schema)
         (DeclareM m)
         (Referenced Schema))
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gType \Name
typeName Nullability
nullability -> (Name, Nullability)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall k (m :: * -> *) v.
(Hashable k, MonadFix m) =>
k -> CircularT k v m v -> CircularT k v m v
withCircular (Name
typeName, Nullability
nullability) do
      [(Text, Referenced Schema)]
fields <-
        [(Name, (GType, InputFieldInfo))]
-> ((Name, (GType, InputFieldInfo))
    -> CircularT
         (Name, Nullability)
         (Referenced Schema)
         (DeclareM m)
         (Text, Referenced Schema))
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     [(Text, Referenced Schema)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (HashMap Name (GType, InputFieldInfo)
-> [(Name, (GType, InputFieldInfo))]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name (GType, InputFieldInfo)
_ioiFields) \(Name
fieldName, (GType
fieldType, InputFieldInfo
fieldTypeInfo)) -> do
          Referenced Schema
fieldSchema <- GType
-> InputFieldInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall (m :: * -> *).
MonadFix m =>
GType
-> InputFieldInfo
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
buildInputFieldSchema GType
fieldType InputFieldInfo
fieldTypeInfo
          (Text, Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Text, Referenced Schema)
forall a.
a
-> CircularT (Name, Nullability) (Referenced Schema) (DeclareM m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Text
G.unName Name
fieldName, Referenced Schema
fieldSchema)
      let objectSchema :: Schema
objectSchema =
            Schema
forall a. Monoid a => a
mempty
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasTitle s a => Lens' s a
Lens' Schema (Maybe Text)
title ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Name -> Text
G.unName Name
typeName
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Description -> Text) -> Maybe Description -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Description -> Text
G.unDescription (InputObjectTypeDefinition InputValueDefinition -> Maybe Description
forall inputType.
InputObjectTypeDefinition inputType -> Maybe Description
G._iotdDescription InputObjectTypeDefinition InputValueDefinition
_ioiTypeDefinition)
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList [(Text, Referenced Schema)]
fields
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasNullable s a => Lens' s a
Lens' Schema (Maybe Bool)
nullable ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Nullability -> Bool
G.unNullability Nullability
nullability
      DeclareM m (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall (m :: * -> *) a.
Monad m =>
m a -> CircularT (Name, Nullability) (Referenced Schema) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DeclareM m (Referenced Schema)
 -> CircularT
      (Name, Nullability)
      (Referenced Schema)
      (DeclareM m)
      (Referenced Schema))
-> DeclareM m (Referenced Schema)
-> CircularT
     (Name, Nullability)
     (Referenced Schema)
     (DeclareM m)
     (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
declareType Name
typeName Nullability
nullability Schema
objectSchema

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

-- | Given the 'Structure' of a query, generate the corresponding 'Response'.
buildResponse ::
  (Monad m) =>
  Structure ->
  EndpointMethod ->
  Text ->
  DeclareM m Response
buildResponse :: forall (m :: * -> *).
Monad m =>
Structure -> EndpointMethod -> Text -> DeclareM m Response
buildResponse (Structure HashMap Name FieldInfo
fields HashMap Name VariableInfo
_) EndpointMethod
endpointMethod Text
endpointURL = do
  Schema
fs <- [(Name, FieldInfo)] -> DeclareM m Schema
forall (m :: * -> *).
Monad m =>
[(Name, FieldInfo)] -> DeclareM m Schema
buildSelectionSchema ([(Name, FieldInfo)] -> DeclareM m Schema)
-> [(Name, FieldInfo)] -> DeclareM m Schema
forall a b. (a -> b) -> a -> b
$ HashMap Name FieldInfo -> [(Name, FieldInfo)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name FieldInfo
fields
  Response -> DeclareM m Response
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (Response -> DeclareM m Response)
-> Response -> DeclareM m Response
forall a b. (a -> b) -> a -> b
$ Response
forall a. Monoid a => a
mempty
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap MediaType MediaTypeObject
 -> Identity (InsOrdHashMap MediaType MediaTypeObject))
-> Response -> Identity Response
forall s a. HasContent s a => Lens' s a
Lens' Response (InsOrdHashMap MediaType MediaTypeObject)
content ((InsOrdHashMap MediaType MediaTypeObject
  -> Identity (InsOrdHashMap MediaType MediaTypeObject))
 -> Response -> Identity Response)
-> InsOrdHashMap MediaType MediaTypeObject -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ MediaType
-> MediaTypeObject -> InsOrdHashMap MediaType MediaTypeObject
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton (ByteString
"application" ByteString -> ByteString -> MediaType
// ByteString
"json") (MediaTypeObject
forall a. Monoid a => a
mempty MediaTypeObject
-> (MediaTypeObject -> MediaTypeObject) -> MediaTypeObject
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> MediaTypeObject -> Identity MediaTypeObject
forall s a. HasSchema s a => Lens' s a
Lens' MediaTypeObject (Maybe (Referenced Schema))
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> MediaTypeObject -> Identity MediaTypeObject)
-> Referenced Schema -> MediaTypeObject -> MediaTypeObject
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
fs)
    Response -> (Response -> Response) -> Response
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Response -> Identity Response
forall s a. HasDescription s a => Lens' s a
Lens' Response Text
description ((Text -> Identity Text) -> Response -> Identity Response)
-> Text -> Response -> Response
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"Responses for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> EndpointMethod -> Text
forall a. Show a => a -> Text
tshow EndpointMethod
endpointMethod Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
endpointURL

-- | Given a list of fields and their types, build a corresponding schema.
buildSelectionSchema ::
  (Monad m) =>
  [(G.Name, FieldInfo)] ->
  DeclareM m Schema
buildSelectionSchema :: forall (m :: * -> *).
Monad m =>
[(Name, FieldInfo)] -> DeclareM m Schema
buildSelectionSchema [(Name, FieldInfo)]
fields = do
  [(Text, Referenced Schema)]
props <- [(Name, FieldInfo)]
-> ((Name, FieldInfo)
    -> DeclareT (Definitions Schema) m (Text, Referenced Schema))
-> DeclareT (Definitions Schema) m [(Text, Referenced Schema)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [(Name, FieldInfo)]
fields \(Name
fieldName, FieldInfo
fieldInfo) -> do
    Referenced Schema
fieldSchema <- FieldInfo -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
FieldInfo -> DeclareM m (Referenced Schema)
buildFieldSchema FieldInfo
fieldInfo
    (Text, Referenced Schema)
-> DeclareT (Definitions Schema) m (Text, Referenced Schema)
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name -> Text
G.unName Name
fieldName, Referenced Schema
fieldSchema)
  Schema -> DeclareM m Schema
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Schema -> DeclareM m Schema) -> Schema -> DeclareM m Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (InsOrdHashMap Text (Referenced Schema)
 -> Identity (InsOrdHashMap Text (Referenced Schema)))
-> Schema -> Identity Schema
forall s a. HasProperties s a => Lens' s a
Lens' Schema (InsOrdHashMap Text (Referenced Schema))
properties ((InsOrdHashMap Text (Referenced Schema)
  -> Identity (InsOrdHashMap Text (Referenced Schema)))
 -> Schema -> Identity Schema)
-> InsOrdHashMap Text (Referenced Schema) -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [(Text, Referenced Schema)]
-> InsOrdHashMap Text (Referenced Schema)
forall k v. (Eq k, Hashable k) => [(k, v)] -> InsOrdHashMap k v
InsOrdHashMap.fromList [(Text, Referenced Schema)]
props

-- | Build the schema for a given output type.
buildFieldSchema ::
  (Monad m) =>
  FieldInfo ->
  DeclareM m (Referenced Schema)
buildFieldSchema :: forall (m :: * -> *).
Monad m =>
FieldInfo -> DeclareM m (Referenced Schema)
buildFieldSchema = \case
  -- this output field is a scalar: we attempt to declare it
  FieldScalarInfo GType
gType ScalarInfo
scalarInfo -> GType
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gType ((Name -> Nullability -> DeclareM m (Referenced Schema))
 -> DeclareM m (Referenced Schema))
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ ScalarInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
ScalarInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
buildScalarSchema ScalarInfo
scalarInfo
  -- this output field is an enum: we declare it
  FieldEnumInfo GType
gType EnumInfo
scalarInfo -> GType
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gType ((Name -> Nullability -> DeclareM m (Referenced Schema))
 -> DeclareM m (Referenced Schema))
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ EnumInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
EnumInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
buildEnumSchema EnumInfo
scalarInfo
  -- this output field is an object: we inline it
  FieldObjectInfo GType
gType ObjectInfo {HashMap Name FieldInfo
ObjectTypeDefinition InputValueDefinition
_oiTypeDefinition :: ObjectTypeDefinition InputValueDefinition
_oiSelection :: HashMap Name FieldInfo
_oiTypeDefinition :: ObjectInfo -> ObjectTypeDefinition InputValueDefinition
_oiSelection :: ObjectInfo -> HashMap Name FieldInfo
..} -> GType
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gType ((Name -> Nullability -> DeclareM m (Referenced Schema))
 -> DeclareM m (Referenced Schema))
-> (Name -> Nullability -> DeclareM m (Referenced Schema))
-> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ \Name
typeName Nullability
nullability -> do
    Schema
objectSchema <- [(Name, FieldInfo)] -> DeclareM m Schema
forall (m :: * -> *).
Monad m =>
[(Name, FieldInfo)] -> DeclareM m Schema
buildSelectionSchema ([(Name, FieldInfo)] -> DeclareM m Schema)
-> [(Name, FieldInfo)] -> DeclareM m Schema
forall a b. (a -> b) -> a -> b
$ HashMap Name FieldInfo -> [(Name, FieldInfo)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap Name FieldInfo
_oiSelection
    Referenced Schema -> DeclareM m (Referenced Schema)
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Referenced Schema -> DeclareM m (Referenced Schema))
-> Referenced Schema -> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline
      (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
objectSchema
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasTitle s a => Lens' s a
Lens' Schema (Maybe Text)
title ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Name -> Text
G.unName Name
typeName
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Description -> Text) -> Maybe Description -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Description -> Text
G.unDescription (ObjectTypeDefinition InputValueDefinition -> Maybe Description
forall inputType.
ObjectTypeDefinition inputType -> Maybe Description
G._otdDescription ObjectTypeDefinition InputValueDefinition
_oiTypeDefinition)
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiObject
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasNullable s a => Lens' s a
Lens' Schema (Maybe Bool)
nullable ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Nullability -> Bool
G.unNullability Nullability
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 :: forall (m :: * -> *).
Monad m =>
ScalarInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
buildScalarSchema ScalarInfo {ScalarTypeDefinition
_siTypeDefinition :: ScalarTypeDefinition
_siTypeDefinition :: ScalarInfo -> ScalarTypeDefinition
..} Name
scalarName Nullability
nullability = do
  case Name -> Maybe (OpenApiType, Maybe Text, Bool)
getReferenceScalarInfo Name
scalarName of
    -- there is an existing OpenAPI scalar we can map this to: we inline if we can
    Just (OpenApiType
refType, Maybe Text
refPattern, Bool
shouldInline) -> do
      let resultSchema :: Schema
resultSchema =
            Schema
baseSchema
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
refType
              Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasPattern s a => Lens' s a
Lens' Schema (Maybe Text)
pattern ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Maybe Text
refPattern
      if Bool
shouldInline
        then Referenced Schema -> DeclareM m (Referenced Schema)
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema -> DeclareM m (Referenced Schema))
-> Referenced Schema -> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline Schema
resultSchema
        else Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
declareType Name
scalarName Nullability
nullability Schema
resultSchema
    -- there isn't: we declare that type and return a reference to it
    Maybe (OpenApiType, Maybe Text, Bool)
Nothing ->
      Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
declareType Name
scalarName Nullability
nullability
        (Schema -> DeclareM m (Referenced Schema))
-> Schema -> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema
baseSchema
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Description -> Text) -> Maybe Description -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Description -> Text
G.unDescription (ScalarTypeDefinition -> Maybe Description
G._stdDescription ScalarTypeDefinition
_siTypeDefinition)
  where
    baseSchema :: Schema
baseSchema =
      Schema
forall a. Monoid a => a
mempty
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasTitle s a => Lens' s a
Lens' Schema (Maybe Text)
title ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Name -> Text
G.unName Name
scalarName
        Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasNullable s a => Lens' s a
Lens' Schema (Maybe Bool)
nullable ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Nullability -> Bool
G.unNullability Nullability
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 :: Name -> Maybe (OpenApiType, Maybe Text, Bool)
getReferenceScalarInfo =
  Name -> Text
G.unName (Name -> Text)
-> (Text -> Maybe (OpenApiType, Maybe Text, Bool))
-> Name
-> Maybe (OpenApiType, Maybe Text, Bool)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Text
T.toLower (Text -> Text)
-> (Text -> Maybe (OpenApiType, Maybe Text, Bool))
-> Text
-> Maybe (OpenApiType, Maybe Text, Bool)
forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> \case
    Text
"int" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiInteger, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
"float" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiNumber, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
"double" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiNumber, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
"uuid" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiString, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"[a-f0-9]{8}-[a-f0-9]{4}-4[a-f0-9]{3}-[89aAbB][a-f0-9]{3}-[a-f0-9]{12}", Bool
False)
    Text
"bool" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiBoolean, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
"boolean" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiBoolean, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
"string" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiString, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
"id" -> (OpenApiType, Maybe Text, Bool)
-> Maybe (OpenApiType, Maybe Text, Bool)
forall a. a -> Maybe a
Just (OpenApiType
OpenApiString, Maybe Text
forall a. Maybe a
Nothing, Bool
True)
    Text
_ -> Maybe (OpenApiType, Maybe Text, Bool)
forall a. Maybe a
Nothing

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

-- | Craft the OpenAPI 'Schema' for a given enum.
buildEnumSchema ::
  (Monad m) =>
  EnumInfo ->
  G.Name ->
  G.Nullability ->
  DeclareM m (Referenced Schema)
buildEnumSchema :: forall (m :: * -> *).
Monad m =>
EnumInfo -> Name -> Nullability -> DeclareM m (Referenced Schema)
buildEnumSchema EnumInfo {EnumTypeDefinition
_eiTypeDefinition :: EnumTypeDefinition
_eiTypeDefinition :: EnumInfo -> EnumTypeDefinition
..} Name
enumName Nullability
nullability =
  Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
declareType Name
enumName Nullability
nullability
    (Schema -> DeclareM m (Referenced Schema))
-> Schema -> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasTitle s a => Lens' s a
Lens' Schema (Maybe Text)
title ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Text -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Name -> Text
G.unName Name
enumName
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe [Value] -> Identity (Maybe [Value]))
-> Schema -> Identity Schema
forall s a. HasEnum s a => Lens' s a
Lens' Schema (Maybe [Value])
enum_ ((Maybe [Value] -> Identity (Maybe [Value]))
 -> Schema -> Identity Schema)
-> [Value] -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ [Value]
enumValues
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasNullable s a => Lens' s a
Lens' Schema (Maybe Bool)
nullable ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Nullability -> Bool
G.unNullability Nullability
nullability
    Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Schema -> Identity Schema
forall s a. HasDescription s a => Lens' s a
Lens' Schema (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text))
 -> Schema -> Identity Schema)
-> Maybe Text -> Schema -> Schema
forall s t a b. ASetter s t a b -> b -> s -> t
.~ (Description -> Text) -> Maybe Description -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Description -> Text
G.unDescription (EnumTypeDefinition -> Maybe Description
G._etdDescription EnumTypeDefinition
_eiTypeDefinition)
  where
    enumValues :: [J.Value]
    enumValues :: [Value]
enumValues =
      EnumTypeDefinition -> [EnumValueDefinition]
G._etdValueDefinitions EnumTypeDefinition
_eiTypeDefinition [EnumValueDefinition] -> (EnumValueDefinition -> Value) -> [Value]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \G.EnumValueDefinition {[Directive Void]
Maybe Description
EnumValue
_evdDescription :: Maybe Description
_evdName :: EnumValue
_evdDirectives :: [Directive Void]
_evdDescription :: EnumValueDefinition -> Maybe Description
_evdName :: EnumValueDefinition -> EnumValue
_evdDirectives :: EnumValueDefinition -> [Directive Void]
..} ->
        Text -> Value
J.String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ Name -> Text
G.unName (Name -> Text) -> Name -> Text
forall a b. (a -> b) -> a -> b
$ EnumValue -> Name
G.unEnumValue EnumValue
_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 :: forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
gtype Name -> Nullability -> m (Referenced Schema)
fun = case GType
gtype of
  G.TypeNamed Nullability
nullability Name
typeName -> Name -> Nullability -> m (Referenced Schema)
fun Name
typeName Nullability
nullability
  G.TypeList Nullability
nullability GType
innerType -> do
    Referenced Schema
s <- GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
forall (m :: * -> *).
Monad m =>
GType
-> (Name -> Nullability -> m (Referenced Schema))
-> m (Referenced Schema)
applyModifiers GType
innerType Name -> Nullability -> m (Referenced Schema)
fun
    Referenced Schema -> m (Referenced Schema)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      (Referenced Schema -> m (Referenced Schema))
-> Referenced Schema -> m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline
      (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Schema
forall a. Monoid a => a
mempty
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe Bool -> Identity (Maybe Bool)) -> Schema -> Identity Schema
forall s a. HasNullable s a => Lens' s a
Lens' Schema (Maybe Bool)
nullable ((Maybe Bool -> Identity (Maybe Bool))
 -> Schema -> Identity Schema)
-> Bool -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Nullability -> Bool
G.unNullability Nullability
nullability
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiArray
      Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
-> Schema -> Identity Schema
forall s a. HasItems s a => Lens' s a
Lens' Schema (Maybe OpenApiItems)
items ((Maybe OpenApiItems -> Identity (Maybe OpenApiItems))
 -> Schema -> Identity Schema)
-> OpenApiItems -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced Schema -> OpenApiItems
OpenApiItemsObject Referenced Schema
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 :: forall (m :: * -> *).
Monad m =>
Name -> Nullability -> Schema -> DeclareM m (Referenced Schema)
declareType Name
typeName Nullability
nullability Schema
s = do
  let refName :: Text
refName = Name -> Nullability -> Text
mkReferenceName Name
typeName Nullability
nullability
  Definitions Schema -> DeclareT (Definitions Schema) m ()
forall d (m :: * -> *). MonadDeclare d m => d -> m ()
declare (Definitions Schema -> DeclareT (Definitions Schema) m ())
-> Definitions Schema -> DeclareT (Definitions Schema) m ()
forall a b. (a -> b) -> a -> b
$ Text -> Schema -> Definitions Schema
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton Text
refName Schema
s
  Referenced Schema -> DeclareM m (Referenced Schema)
forall a. a -> DeclareT (Definitions Schema) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Referenced Schema -> DeclareM m (Referenced Schema))
-> Referenced Schema -> DeclareM m (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Reference -> Referenced Schema
forall a. Reference -> Referenced a
Ref (Reference -> Referenced Schema) -> Reference -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Text -> Reference
Reference Text
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 :: Name -> Nullability -> Text
mkReferenceName (Name -> Text
G.unName -> Text
typeName) (G.Nullability Bool
isNullable) =
  if Bool
isNullable
    then Text
typeName
    else Text
typeName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"!"

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

type DeclareM = DeclareT (Definitions Schema)

-- | Variable definition for x-hasura-admin-secret
xHasuraAdminSecret :: Param
xHasuraAdminSecret :: Param
xHasuraAdminSecret =
  Param
forall a. Monoid a => a
mempty
    Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Text -> Identity Text) -> Param -> Identity Param
forall s a. HasName s a => Lens' s a
Lens' Param Text
name ((Text -> Identity Text) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ Text
"x-hasura-admin-secret"
    Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param
forall s a. HasDescription s a => Lens' s a
Lens' Param (Maybe Text)
description ((Maybe Text -> Identity (Maybe Text)) -> Param -> Identity Param)
-> Text -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Text
"Your x-hasura-admin-secret will be used for authentication of the API request."
    Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (ParamLocation -> Identity ParamLocation)
-> Param -> Identity Param
forall s a. HasIn s a => Lens' s a
Lens' Param ParamLocation
in_ ((ParamLocation -> Identity ParamLocation)
 -> Param -> Identity Param)
-> ParamLocation -> Param -> Param
forall s t a b. ASetter s t a b -> b -> s -> t
.~ ParamLocation
ParamHeader
    Param -> (Param -> Param) -> Param
forall a b. a -> (a -> b) -> b
& (Maybe (Referenced Schema) -> Identity (Maybe (Referenced Schema)))
-> Param -> Identity Param
forall s a. HasSchema s a => Lens' s a
Lens' Param (Maybe (Referenced Schema))
schema ((Maybe (Referenced Schema)
  -> Identity (Maybe (Referenced Schema)))
 -> Param -> Identity Param)
-> Referenced Schema -> Param -> Param
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema
forall a. Monoid a => a
mempty Schema -> (Schema -> Schema) -> Schema
forall a b. a -> (a -> b) -> b
& (Maybe OpenApiType -> Identity (Maybe OpenApiType))
-> Schema -> Identity Schema
forall s a. HasType s a => Lens' s a
Lens' Schema (Maybe OpenApiType)
type_ ((Maybe OpenApiType -> Identity (Maybe OpenApiType))
 -> Schema -> Identity Schema)
-> OpenApiType -> Schema -> Schema
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ OpenApiType
OpenApiString)

-- | Convert a GraphQL value to an equivalent JSON representation.
--
-- TODO: can we deduplicate this?
gqlToJsonValue :: G.Value Void -> J.Value
gqlToJsonValue :: Value Void -> Value
gqlToJsonValue = \case
  Value Void
G.VNull -> Value
J.Null
  G.VInt Integer
n -> Integer -> Value
forall a. ToJSON a => a -> Value
J.toJSON Integer
n
  G.VFloat Scientific
sci -> Scientific -> Value
forall a. ToJSON a => a -> Value
J.toJSON Scientific
sci
  G.VString Text
txt -> Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON Text
txt
  G.VBoolean Bool
b -> Bool -> Value
forall a. ToJSON a => a -> Value
J.toJSON Bool
b
  G.VEnum EnumValue
ev -> EnumValue -> Value
forall a. ToJSON a => a -> Value
J.toJSON EnumValue
ev
  G.VList [Value Void]
lst -> [Value] -> Value
forall a. ToJSON a => a -> Value
J.toJSON ([Value] -> Value) -> [Value] -> Value
forall a b. (a -> b) -> a -> b
$ Value Void -> Value
gqlToJsonValue (Value Void -> Value) -> [Value Void] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value Void]
lst
  G.VObject HashMap Name (Value Void)
obj -> HashMap Name Value -> Value
forall a. ToJSON a => a -> Value
J.toJSON (HashMap Name Value -> Value) -> HashMap Name Value -> Value
forall a b. (a -> b) -> a -> b
$ Value Void -> Value
gqlToJsonValue (Value Void -> Value)
-> HashMap Name (Value Void) -> HashMap Name Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap Name (Value Void)
obj