{-# LANGUAGE TemplateHaskell #-}

module Hasura.GraphQL.RemoteServer
  ( fetchRemoteSchema,
    stitchRemoteSchema,
    execRemoteGQ,
    FromIntrospection (..),
  )
where

import Control.Arrow.Extended (left)
import Control.Exception (try)
import Control.Lens (set, (^.))
import Control.Monad.Memoize
import Data.Aeson ((.:), (.:?))
import Data.Aeson qualified as J
import Data.ByteString.Lazy qualified as BL
import Data.Environment qualified as Env
import Data.FileEmbed (makeRelativeToProject)
import Data.HashMap.Strict.Extended qualified as HashMap
import Data.HashSet qualified as Set
import Data.List.Extended (duplicates)
import Data.Text qualified as T
import Data.Text.Extended (dquoteList, (<<>))
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Monad (Parse)
import Hasura.GraphQL.Parser.Name qualified as GName
import Hasura.GraphQL.Schema.Common
import Hasura.GraphQL.Schema.Remote (buildRemoteParser)
import Hasura.GraphQL.Schema.Typename
import Hasura.GraphQL.Transport.HTTP.Protocol
import Hasura.HTTP
import Hasura.Prelude
import Hasura.RQL.DDL.Headers (makeHeadersFromConf)
import Hasura.RQL.Types.Common
import Hasura.RQL.Types.Roles (adminRoleName)
import Hasura.RemoteSchema.Metadata
import Hasura.RemoteSchema.SchemaCache.Types
import Hasura.Server.Utils
import Hasura.Services.Network
import Hasura.Session (UserInfo, adminUserInfo, sessionVariablesToHeaders, _uiSession)
import Hasura.Tracing qualified as Tracing
import Language.GraphQL.Draft.Parser qualified as G
import Language.GraphQL.Draft.Syntax qualified as G
import Language.Haskell.TH.Syntax qualified as TH
import Network.HTTP.Client.Transformable qualified as HTTP
import Network.URI (URI)
import Network.Wreq qualified as Wreq

-------------------------------------------------------------------------------
-- Core API

-- | Make an introspection query to the remote graphql server for the data we
-- need to present and stitch the remote schema. This powers add_remote_schema,
-- and also is called by schema cache rebuilding code in "Hasura.RQL.DDL.Schema.Cache".
fetchRemoteSchema ::
  forall m.
  (MonadIO m, MonadError QErr m, Tracing.MonadTrace m, ProvidesNetwork m) =>
  Env.Environment ->
  ValidatedRemoteSchemaDef ->
  m (IntrospectionResult, BL.ByteString, RemoteSchemaInfo)
fetchRemoteSchema :: forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m, ProvidesNetwork m) =>
Environment
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, ByteString, RemoteSchemaInfo)
fetchRemoteSchema Environment
env ValidatedRemoteSchemaDef
rsDef = do
  (DiffTime
_, [Header]
_, ByteString
rawIntrospectionResult) <-
    Environment
-> UserInfo
-> [Header]
-> ValidatedRemoteSchemaDef
-> GQLReqOutgoing
-> m (DiffTime, [Header], ByteString)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m, ProvidesNetwork m) =>
Environment
-> UserInfo
-> [Header]
-> ValidatedRemoteSchemaDef
-> GQLReqOutgoing
-> m (DiffTime, [Header], ByteString)
execRemoteGQ Environment
env UserInfo
adminUserInfo [] ValidatedRemoteSchemaDef
rsDef GQLReqOutgoing
introspectionQuery
  (IntrospectionResult
ir, RemoteSchemaInfo
rsi) <- ByteString
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, RemoteSchemaInfo)
forall (m :: * -> *).
(MonadIO m, MonadError QErr m) =>
ByteString
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, RemoteSchemaInfo)
stitchRemoteSchema ByteString
rawIntrospectionResult ValidatedRemoteSchemaDef
rsDef
  -- The 'rawIntrospectionResult' contains the 'Bytestring' response of
  -- the introspection result of the remote server. We store this in the
  -- 'RemoteSchemaCtx' because we can use this when the 'introspect_remote_schema'
  -- is called by simple encoding the result to JSON.
  (IntrospectionResult, ByteString, RemoteSchemaInfo)
-> m (IntrospectionResult, ByteString, RemoteSchemaInfo)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IntrospectionResult
ir, ByteString
rawIntrospectionResult, RemoteSchemaInfo
rsi)

-- | Parses the remote schema introspection result, and check whether it looks
-- like it's a valid GraphQL endpoint even under the configured customization.
stitchRemoteSchema ::
  (MonadIO m, MonadError QErr m) =>
  BL.ByteString ->
  ValidatedRemoteSchemaDef ->
  m (IntrospectionResult, RemoteSchemaInfo)
stitchRemoteSchema :: forall (m :: * -> *).
(MonadIO m, MonadError QErr m) =>
ByteString
-> ValidatedRemoteSchemaDef
-> m (IntrospectionResult, RemoteSchemaInfo)
stitchRemoteSchema ByteString
rawIntrospectionResult rsDef :: ValidatedRemoteSchemaDef
rsDef@ValidatedRemoteSchemaDef {Bool
Int
[HeaderConf]
Maybe RemoteSchemaCustomization
EnvRecord URI
_vrsdUrl :: EnvRecord URI
_vrsdHeaders :: [HeaderConf]
_vrsdFwdClientHeaders :: Bool
_vrsdTimeoutSeconds :: Int
_vrsdCustomization :: Maybe RemoteSchemaCustomization
_vrsdUrl :: ValidatedRemoteSchemaDef -> EnvRecord URI
_vrsdHeaders :: ValidatedRemoteSchemaDef -> [HeaderConf]
_vrsdFwdClientHeaders :: ValidatedRemoteSchemaDef -> Bool
_vrsdTimeoutSeconds :: ValidatedRemoteSchemaDef -> Int
_vrsdCustomization :: ValidatedRemoteSchemaDef -> Maybe RemoteSchemaCustomization
..} = do
  -- Parse the JSON into flat GraphQL type AST.
  FromIntrospection IntrospectionResult
_rscIntroOriginal <-
    ByteString -> Either String (FromIntrospection IntrospectionResult)
forall a. FromJSON a => ByteString -> Either String a
J.eitherDecode ByteString
rawIntrospectionResult Either String (FromIntrospection IntrospectionResult)
-> (String -> m (FromIntrospection IntrospectionResult))
-> m (FromIntrospection IntrospectionResult)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
`onLeft` (Text -> m (FromIntrospection IntrospectionResult)
forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema (Text -> m (FromIntrospection IntrospectionResult))
-> (String -> Text)
-> String
-> m (FromIntrospection IntrospectionResult)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack)

  -- Possibly transform type names from the remote schema, per the user's 'RemoteSchemaDef'.
  let rsCustomizer :: RemoteSchemaCustomizer
rsCustomizer = IntrospectionResult
-> Maybe RemoteSchemaCustomization -> RemoteSchemaCustomizer
getCustomizer (IntrospectionResult -> IntrospectionResult
addDefaultRoots IntrospectionResult
_rscIntroOriginal) Maybe RemoteSchemaCustomization
_vrsdCustomization
  RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
validateSchemaCustomizations RemoteSchemaCustomizer
rsCustomizer (IntrospectionResult -> RemoteSchemaIntrospection
irDoc IntrospectionResult
_rscIntroOriginal)

  let remoteSchemaInfo :: RemoteSchemaInfo
remoteSchemaInfo = RemoteSchemaInfo {RemoteSchemaCustomizer
ValidatedRemoteSchemaDef
rsDef :: ValidatedRemoteSchemaDef
rsCustomizer :: RemoteSchemaCustomizer
rsDef :: ValidatedRemoteSchemaDef
rsCustomizer :: RemoteSchemaCustomizer
..}

  -- Check that the parsed GraphQL type info is valid by running the schema
  -- generation. The result is discarded, as the local schema will be built
  -- properly for each role at schema generation time, but this allows us to
  -- quickly reject an invalid schema.
  m (RemoteSchemaParser Parse) -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
    (m (RemoteSchemaParser Parse) -> m ())
-> m (RemoteSchemaParser Parse) -> m ()
forall a b. (a -> b) -> a -> b
$ MemoizeT m (RemoteSchemaParser Parse)
-> m (RemoteSchemaParser Parse)
forall (m :: * -> *) a. Monad m => MemoizeT m a -> m a
runMemoizeT
    (MemoizeT m (RemoteSchemaParser Parse)
 -> m (RemoteSchemaParser Parse))
-> MemoizeT m (RemoteSchemaParser Parse)
-> m (RemoteSchemaParser Parse)
forall a b. (a -> b) -> a -> b
$ SchemaContext
-> SchemaT
     (SchemaContext, MkTypename, CustomizeRemoteFieldName)
     (MemoizeT m)
     (RemoteSchemaParser Parse)
-> MemoizeT m (RemoteSchemaParser Parse)
forall (m :: * -> *) a.
SchemaContext
-> SchemaT
     (SchemaContext, MkTypename, CustomizeRemoteFieldName) m a
-> m a
runRemoteSchema SchemaContext
minimumValidContext
    (SchemaT
   (SchemaContext, MkTypename, CustomizeRemoteFieldName)
   (MemoizeT m)
   (RemoteSchemaParser Parse)
 -> MemoizeT m (RemoteSchemaParser Parse))
-> SchemaT
     (SchemaContext, MkTypename, CustomizeRemoteFieldName)
     (MemoizeT m)
     (RemoteSchemaParser Parse)
-> MemoizeT m (RemoteSchemaParser Parse)
forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) (n :: * -> *).
MonadBuildRemoteSchema r m n =>
IntrospectionResult
-> RemoteSchemaRelationships
-> RemoteSchemaInfo
-> SchemaT r m (RemoteSchemaParser n)
buildRemoteParser @_ @_ @Parse
      IntrospectionResult
_rscIntroOriginal
      RemoteSchemaRelationships
forall a. Monoid a => a
mempty -- remote relationships
      RemoteSchemaInfo
remoteSchemaInfo
  (IntrospectionResult, RemoteSchemaInfo)
-> m (IntrospectionResult, RemoteSchemaInfo)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntrospectionResult
_rscIntroOriginal, RemoteSchemaInfo
remoteSchemaInfo)
  where
    -- If there is no explicit mutation or subscription root type we need to check for
    -- objects type definitions with the default names "Mutation" and "Subscription".
    -- If found, we add the default roots explicitly to the IntrospectionResult.
    -- This simplifies the customization code.
    addDefaultRoots :: IntrospectionResult -> IntrospectionResult
    addDefaultRoots :: IntrospectionResult -> IntrospectionResult
addDefaultRoots IntrospectionResult {Maybe Name
Name
RemoteSchemaIntrospection
irDoc :: IntrospectionResult -> RemoteSchemaIntrospection
irDoc :: RemoteSchemaIntrospection
irQueryRoot :: Name
irMutationRoot :: Maybe Name
irSubscriptionRoot :: Maybe Name
irQueryRoot :: IntrospectionResult -> Name
irMutationRoot :: IntrospectionResult -> Maybe Name
irSubscriptionRoot :: IntrospectionResult -> Maybe Name
..} =
      IntrospectionResult
        { irMutationRoot :: Maybe Name
irMutationRoot = Name -> Maybe Name -> Maybe Name
getRootTypeName Name
GName._Mutation Maybe Name
irMutationRoot,
          irSubscriptionRoot :: Maybe Name
irSubscriptionRoot = Name -> Maybe Name -> Maybe Name
getRootTypeName Name
GName._Subscription Maybe Name
irSubscriptionRoot,
          Name
RemoteSchemaIntrospection
irDoc :: RemoteSchemaIntrospection
irDoc :: RemoteSchemaIntrospection
irQueryRoot :: Name
irQueryRoot :: Name
..
        }
      where
        getRootTypeName :: Name -> Maybe Name -> Maybe Name
getRootTypeName Name
defaultName Maybe Name
providedName =
          Maybe Name
providedName Maybe Name -> Maybe Name -> Maybe Name
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Name
defaultName Name
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
-> Maybe Name
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ RemoteSchemaIntrospection
-> Name
-> Maybe (ObjectTypeDefinition RemoteSchemaInputValueDefinition)
lookupObject RemoteSchemaIntrospection
irDoc Name
defaultName)

    -- Minimum valid information required to run schema generation for
    -- the remote schema.
    minimumValidContext :: SchemaContext
minimumValidContext =
      SchemaKind
-> RemoteRelationshipParserBuilder -> RoleName -> SchemaContext
SchemaContext
        SchemaKind
HasuraSchema
        RemoteRelationshipParserBuilder
ignoreRemoteRelationship
        RoleName
adminRoleName

-- | Sends a GraphQL query to the given server.
execRemoteGQ ::
  ( MonadIO m,
    MonadError QErr m,
    Tracing.MonadTrace m,
    ProvidesNetwork m
  ) =>
  Env.Environment ->
  UserInfo ->
  [HTTP.Header] ->
  ValidatedRemoteSchemaDef ->
  GQLReqOutgoing ->
  -- | Returns the response body and headers, along with the time taken for the
  -- HTTP request to complete
  m (DiffTime, [HTTP.Header], BL.ByteString)
execRemoteGQ :: forall (m :: * -> *).
(MonadIO m, MonadError QErr m, MonadTrace m, ProvidesNetwork m) =>
Environment
-> UserInfo
-> [Header]
-> ValidatedRemoteSchemaDef
-> GQLReqOutgoing
-> m (DiffTime, [Header], ByteString)
execRemoteGQ Environment
env UserInfo
userInfo [Header]
reqHdrs ValidatedRemoteSchemaDef
rsdef gqlReq :: GQLReqOutgoing
gqlReq@GQLReq {Maybe VariableValues
Maybe OperationName
SingleOperation
_grOperationName :: Maybe OperationName
_grQuery :: SingleOperation
_grVariables :: Maybe VariableValues
_grOperationName :: forall a. GQLReq a -> Maybe OperationName
_grQuery :: forall a. GQLReq a -> a
_grVariables :: forall a. GQLReq a -> Maybe VariableValues
..} = do
  let gqlReqUnparsed :: GQLReqUnparsed
gqlReqUnparsed = GQLReqOutgoing -> GQLReqUnparsed
renderGQLReqOutgoing GQLReqOutgoing
gqlReq

  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (SingleOperation -> OperationType
forall (frag :: * -> *) var.
TypedOperationDefinition frag var -> OperationType
G._todType SingleOperation
_grQuery OperationType -> OperationType -> Bool
forall a. Eq a => a -> a -> Bool
== OperationType
G.OperationTypeSubscription)
    (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema Text
"subscription to remote server is not supported"
  [Header]
confHdrs <- Environment -> [HeaderConf] -> m [Header]
forall (m :: * -> *).
MonadError QErr m =>
Environment -> [HeaderConf] -> m [Header]
makeHeadersFromConf Environment
env [HeaderConf]
hdrConf
  let clientHdrs :: [Header]
clientHdrs = [Header] -> [Header] -> Bool -> [Header]
forall a. a -> a -> Bool -> a
bool [] ([Header] -> [Header]
mkClientHeadersForward [Header]
reqHdrs) Bool
fwdClientHdrs
      -- filter out duplicate headers
      -- priority: conf headers > resolved userinfo vars > client headers
      hdrMaps :: [HashMap HeaderName ByteString]
hdrMaps =
        [ [Header] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [Header]
confHdrs,
          [Header] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [Header]
userInfoToHdrs,
          [Header] -> HashMap HeaderName ByteString
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList [Header]
clientHdrs
        ]
      headers :: [Header]
headers = HashMap HeaderName ByteString -> [Header]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList (HashMap HeaderName ByteString -> [Header])
-> HashMap HeaderName ByteString -> [Header]
forall a b. (a -> b) -> a -> b
$ (HashMap HeaderName ByteString
 -> HashMap HeaderName ByteString -> HashMap HeaderName ByteString)
-> HashMap HeaderName ByteString
-> [HashMap HeaderName ByteString]
-> HashMap HeaderName ByteString
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr HashMap HeaderName ByteString
-> HashMap HeaderName ByteString -> HashMap HeaderName ByteString
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
HashMap.union HashMap HeaderName ByteString
forall k v. HashMap k v
HashMap.empty [HashMap HeaderName ByteString]
hdrMaps
      finalHeaders :: [Header]
finalHeaders = [Header] -> [Header]
addDefaultHeaders [Header]
headers
  Request
initReq <- Either HttpException Request
-> (HttpException -> m Request) -> m Request
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft (Text -> Either HttpException Request
HTTP.mkRequestEither (Text -> Either HttpException Request)
-> Text -> Either HttpException Request
forall a b. (a -> b) -> a -> b
$ URI -> Text
forall a. Show a => a -> Text
tshow URI
url) (EnvRecord URI -> HttpException -> m Request
forall (m :: * -> *) a.
QErrM m =>
EnvRecord URI -> HttpException -> m a
throwRemoteSchemaHttp EnvRecord URI
webhookEnvRecord)
  let req :: Request
req =
        Request
initReq
          Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ByteString ByteString
-> ByteString -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ByteString ByteString
Lens' Request ByteString
HTTP.method ByteString
"POST"
          Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request [Header] [Header]
-> [Header] -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request [Header] [Header]
Lens' Request [Header]
HTTP.headers [Header]
finalHeaders
          Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request RequestBody RequestBody
-> RequestBody -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request RequestBody RequestBody
Lens' Request RequestBody
HTTP.body (ByteString -> RequestBody
HTTP.RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ GQLReqUnparsed -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode GQLReqUnparsed
gqlReqUnparsed)
          Request -> (Request -> Request) -> Request
forall a b. a -> (a -> b) -> b
& ASetter Request Request ResponseTimeout ResponseTimeout
-> ResponseTimeout -> Request -> Request
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Request Request ResponseTimeout ResponseTimeout
Lens' Request ResponseTimeout
HTTP.timeout (Int -> ResponseTimeout
HTTP.responseTimeoutMicro (Int
timeout Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000))

  Manager
manager <- m Manager
forall (m :: * -> *). ProvidesNetwork m => m Manager
askHTTPManager
  Request
-> (Request -> m (DiffTime, [Header], ByteString))
-> m (DiffTime, [Header], ByteString)
forall (m :: * -> *) a.
(MonadIO m, MonadTrace m) =>
Request -> (Request -> m a) -> m a
Tracing.traceHTTPRequest Request
req \Request
req' -> do
    (DiffTime
time, Either HttpException (Response ByteString)
res) <- m (Either HttpException (Response ByteString))
-> m (DiffTime, Either HttpException (Response ByteString))
forall (m :: * -> *) a. MonadIO m => m a -> m (DiffTime, a)
withElapsedTime (m (Either HttpException (Response ByteString))
 -> m (DiffTime, Either HttpException (Response ByteString)))
-> m (Either HttpException (Response ByteString))
-> m (DiffTime, Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Either HttpException (Response ByteString))
-> m (Either HttpException (Response ByteString))
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either HttpException (Response ByteString))
 -> m (Either HttpException (Response ByteString)))
-> IO (Either HttpException (Response ByteString))
-> m (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either HttpException (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either HttpException (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req' Manager
manager
    Response ByteString
resp <- Either HttpException (Response ByteString)
-> (HttpException -> m (Response ByteString))
-> m (Response ByteString)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft Either HttpException (Response ByteString)
res (EnvRecord URI -> HttpException -> m (Response ByteString)
forall (m :: * -> *) a.
QErrM m =>
EnvRecord URI -> HttpException -> m a
throwRemoteSchemaHttp EnvRecord URI
webhookEnvRecord)
    (DiffTime, [Header], ByteString)
-> m (DiffTime, [Header], ByteString)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DiffTime
time, Response ByteString -> [Header]
forall a. Response a -> [Header]
mkSetCookieHeaders Response ByteString
resp, Response ByteString
resp Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
Wreq.responseBody)
  where
    ValidatedRemoteSchemaDef EnvRecord URI
webhookEnvRecord [HeaderConf]
hdrConf Bool
fwdClientHdrs Int
timeout Maybe RemoteSchemaCustomization
_mPrefix = ValidatedRemoteSchemaDef
rsdef
    url :: URI
url = EnvRecord URI -> URI
forall a. EnvRecord a -> a
_envVarValue EnvRecord URI
webhookEnvRecord
    userInfoToHdrs :: [Header]
userInfoToHdrs = SessionVariables -> [Header]
sessionVariablesToHeaders (SessionVariables -> [Header]) -> SessionVariables -> [Header]
forall a b. (a -> b) -> a -> b
$ UserInfo -> SessionVariables
_uiSession UserInfo
userInfo

-------------------------------------------------------------------------------
-- Validation

validateSchemaCustomizations ::
  forall m.
  (MonadError QErr m) =>
  RemoteSchemaCustomizer ->
  RemoteSchemaIntrospection ->
  m ()
validateSchemaCustomizations :: forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
validateSchemaCustomizations RemoteSchemaCustomizer
remoteSchemaCustomizer RemoteSchemaIntrospection
remoteSchemaIntrospection = do
  RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
validateSchemaCustomizationsConsistent RemoteSchemaCustomizer
remoteSchemaCustomizer RemoteSchemaIntrospection
remoteSchemaIntrospection
  RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
validateSchemaCustomizationsDistinct RemoteSchemaCustomizer
remoteSchemaCustomizer RemoteSchemaIntrospection
remoteSchemaIntrospection

validateSchemaCustomizationsConsistent ::
  forall m.
  (MonadError QErr m) =>
  RemoteSchemaCustomizer ->
  RemoteSchemaIntrospection ->
  m ()
validateSchemaCustomizationsConsistent :: forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
validateSchemaCustomizationsConsistent RemoteSchemaCustomizer
remoteSchemaCustomizer (RemoteSchemaIntrospection HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions) = do
  (TypeDefinition [Name] RemoteSchemaInputValueDefinition -> m ())
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TypeDefinition [Name] RemoteSchemaInputValueDefinition -> m ()
forall a. TypeDefinition [Name] a -> m ()
validateInterfaceFields HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions
  where
    customizeFieldName :: CustomizeRemoteFieldName
customizeFieldName = RemoteSchemaCustomizer -> CustomizeRemoteFieldName
remoteSchemaCustomizeFieldName RemoteSchemaCustomizer
remoteSchemaCustomizer

    validateInterfaceFields :: G.TypeDefinition [G.Name] a -> m ()
    validateInterfaceFields :: forall a. TypeDefinition [Name] a -> m ()
validateInterfaceFields = \case
      G.TypeDefinitionInterface G.InterfaceTypeDefinition {[Name]
[FieldDefinition a]
[Directive Void]
Maybe Description
Name
_itdDescription :: Maybe Description
_itdName :: Name
_itdDirectives :: [Directive Void]
_itdFieldsDefinition :: [FieldDefinition a]
_itdPossibleTypes :: [Name]
_itdDescription :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> Maybe Description
_itdName :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
_itdDirectives :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> [Directive Void]
_itdFieldsDefinition :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> [FieldDefinition inputType]
_itdPossibleTypes :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> possibleTypes
..} ->
        [Name] -> (Name -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Name]
_itdPossibleTypes ((Name -> m ()) -> m ()) -> (Name -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Name
typeName ->
          [FieldDefinition a] -> (FieldDefinition a -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [FieldDefinition a]
_itdFieldsDefinition ((FieldDefinition a -> m ()) -> m ())
-> (FieldDefinition a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \G.FieldDefinition {ArgumentsDefinition a
[Directive Void]
Maybe Description
Name
GType
_fldDescription :: Maybe Description
_fldName :: Name
_fldArgumentsDefinition :: ArgumentsDefinition a
_fldType :: GType
_fldDirectives :: [Directive Void]
_fldDescription :: forall inputType. FieldDefinition inputType -> Maybe Description
_fldName :: forall inputType. FieldDefinition inputType -> Name
_fldArgumentsDefinition :: forall inputType.
FieldDefinition inputType -> ArgumentsDefinition inputType
_fldType :: forall inputType. FieldDefinition inputType -> GType
_fldDirectives :: forall inputType. FieldDefinition inputType -> [Directive Void]
..} -> do
            let interfaceCustomizedFieldName :: Name
interfaceCustomizedFieldName = CustomizeRemoteFieldName -> Name -> Name -> Name
runCustomizeRemoteFieldName CustomizeRemoteFieldName
customizeFieldName Name
_itdName Name
_fldName
                typeCustomizedFieldName :: Name
typeCustomizedFieldName = CustomizeRemoteFieldName -> Name -> Name -> Name
runCustomizeRemoteFieldName CustomizeRemoteFieldName
customizeFieldName Name
typeName Name
_fldName
            Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
interfaceCustomizedFieldName Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
typeCustomizedFieldName)
              (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema
              (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Remote schema customization inconsistency: field name mapping for field "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
_fldName
              Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" of interface "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
_itdName
              Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" is inconsistent with mapping for type "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeName
              Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
". Interface field name maps to "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
interfaceCustomizedFieldName
              Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
". Type field name maps to "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
typeCustomizedFieldName
              Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
"."
      TypeDefinition [Name] a
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

validateSchemaCustomizationsDistinct ::
  forall m.
  (MonadError QErr m) =>
  RemoteSchemaCustomizer ->
  RemoteSchemaIntrospection ->
  m ()
validateSchemaCustomizationsDistinct :: forall (m :: * -> *).
MonadError QErr m =>
RemoteSchemaCustomizer -> RemoteSchemaIntrospection -> m ()
validateSchemaCustomizationsDistinct RemoteSchemaCustomizer
remoteSchemaCustomizer (RemoteSchemaIntrospection HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions) = do
  m ()
validateTypeMappingsAreDistinct
  (TypeDefinition [Name] RemoteSchemaInputValueDefinition -> m ())
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ TypeDefinition [Name] RemoteSchemaInputValueDefinition -> m ()
forall a b. TypeDefinition a b -> m ()
validateFieldMappingsAreDistinct HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions
  where
    customizeTypeName :: MkTypename
customizeTypeName = RemoteSchemaCustomizer -> MkTypename
remoteSchemaCustomizeTypeName RemoteSchemaCustomizer
remoteSchemaCustomizer
    customizeFieldName :: Name -> Name -> Name
customizeFieldName = CustomizeRemoteFieldName -> Name -> Name -> Name
runCustomizeRemoteFieldName (RemoteSchemaCustomizer -> CustomizeRemoteFieldName
remoteSchemaCustomizeFieldName RemoteSchemaCustomizer
remoteSchemaCustomizer)

    validateTypeMappingsAreDistinct :: m ()
    validateTypeMappingsAreDistinct :: m ()
validateTypeMappingsAreDistinct = do
      let dups :: HashSet Name
dups = [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ MkTypename -> Name -> Name
runMkTypename MkTypename
customizeTypeName (Name -> Name) -> [Name] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions
      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HashSet Name -> Bool
forall a. HashSet a -> Bool
Set.null HashSet Name
dups)
        (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema
        (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Type name mappings are not distinct; the following types appear more than once: "
        Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashSet Name -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
dquoteList HashSet Name
dups

    validateFieldMappingsAreDistinct :: G.TypeDefinition a b -> m ()
    validateFieldMappingsAreDistinct :: forall a b. TypeDefinition a b -> m ()
validateFieldMappingsAreDistinct = \case
      G.TypeDefinitionInterface G.InterfaceTypeDefinition {a
[FieldDefinition b]
[Directive Void]
Maybe Description
Name
_itdDescription :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> Maybe Description
_itdName :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
_itdDirectives :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> [Directive Void]
_itdFieldsDefinition :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> [FieldDefinition inputType]
_itdPossibleTypes :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> possibleTypes
_itdDescription :: Maybe Description
_itdName :: Name
_itdDirectives :: [Directive Void]
_itdFieldsDefinition :: [FieldDefinition b]
_itdPossibleTypes :: a
..} -> do
        let dups :: HashSet Name
dups = [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Name
customizeFieldName Name
_itdName (Name -> Name)
-> (FieldDefinition b -> Name) -> FieldDefinition b -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDefinition b -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName (FieldDefinition b -> Name) -> [FieldDefinition b] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldDefinition b]
_itdFieldsDefinition
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HashSet Name -> Bool
forall a. HashSet a -> Bool
Set.null HashSet Name
dups)
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Field name mappings for interface type "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
_itdName
          Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" are not distinct; the following fields appear more than once: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashSet Name -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
dquoteList HashSet Name
dups
      G.TypeDefinitionObject G.ObjectTypeDefinition {[Name]
[FieldDefinition b]
[Directive Void]
Maybe Description
Name
_otdDescription :: Maybe Description
_otdName :: Name
_otdImplementsInterfaces :: [Name]
_otdDirectives :: [Directive Void]
_otdFieldsDefinition :: [FieldDefinition b]
_otdDescription :: forall inputType.
ObjectTypeDefinition inputType -> Maybe Description
_otdName :: forall inputType. ObjectTypeDefinition inputType -> Name
_otdImplementsInterfaces :: forall inputType. ObjectTypeDefinition inputType -> [Name]
_otdDirectives :: forall inputType.
ObjectTypeDefinition inputType -> [Directive Void]
_otdFieldsDefinition :: forall inputType.
ObjectTypeDefinition inputType -> [FieldDefinition inputType]
..} -> do
        let dups :: HashSet Name
dups = [Name] -> HashSet Name
forall a. Hashable a => [a] -> HashSet a
duplicates ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Name
customizeFieldName Name
_otdName (Name -> Name)
-> (FieldDefinition b -> Name) -> FieldDefinition b -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldDefinition b -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName (FieldDefinition b -> Name) -> [FieldDefinition b] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldDefinition b]
_otdFieldsDefinition
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (HashSet Name -> Bool
forall a. HashSet a -> Bool
Set.null HashSet Name
dups)
          (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema
          (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Field name mappings for object type "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name
_otdName
          Name -> Text -> Text
forall t. ToTxt t => t -> Text -> Text
<<> Text
" are not distinct; the following fields appear more than once: "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> HashSet Name -> Text
forall t (f :: * -> *). (ToTxt t, Foldable f) => f t -> Text
dquoteList HashSet Name
dups
      TypeDefinition a b
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-------------------------------------------------------------------------------
-- Introspection

introspectionQuery :: GQLReqOutgoing
introspectionQuery :: GQLReqOutgoing
introspectionQuery =
  $( do
       fp <- makeRelativeToProject "src-rsr/introspection.json"
       TH.qAddDependentFile fp
       eitherResult <- TH.runIO $ J.eitherDecodeFileStrict fp
       either fail TH.lift $ do
         r@GQLReq {..} <- eitherResult
         op <- left (T.unpack . showQErr) $ getSingleOperation r
         pure GQLReq {_grQuery = op, ..}
   )

-- | Parsing the introspection query result.  We use this newtype wrapper to
-- avoid orphan instances and parse JSON in the way that we need for GraphQL
-- introspection results.
newtype FromIntrospection a = FromIntrospection {forall a. FromIntrospection a -> a
fromIntrospection :: a}
  deriving (Int -> FromIntrospection a -> ShowS
[FromIntrospection a] -> ShowS
FromIntrospection a -> String
(Int -> FromIntrospection a -> ShowS)
-> (FromIntrospection a -> String)
-> ([FromIntrospection a] -> ShowS)
-> Show (FromIntrospection a)
forall a. Show a => Int -> FromIntrospection a -> ShowS
forall a. Show a => [FromIntrospection a] -> ShowS
forall a. Show a => FromIntrospection a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> FromIntrospection a -> ShowS
showsPrec :: Int -> FromIntrospection a -> ShowS
$cshow :: forall a. Show a => FromIntrospection a -> String
show :: FromIntrospection a -> String
$cshowList :: forall a. Show a => [FromIntrospection a] -> ShowS
showList :: [FromIntrospection a] -> ShowS
Show, FromIntrospection a -> FromIntrospection a -> Bool
(FromIntrospection a -> FromIntrospection a -> Bool)
-> (FromIntrospection a -> FromIntrospection a -> Bool)
-> Eq (FromIntrospection a)
forall a.
Eq a =>
FromIntrospection a -> FromIntrospection a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a.
Eq a =>
FromIntrospection a -> FromIntrospection a -> Bool
== :: FromIntrospection a -> FromIntrospection a -> Bool
$c/= :: forall a.
Eq a =>
FromIntrospection a -> FromIntrospection a -> Bool
/= :: FromIntrospection a -> FromIntrospection a -> Bool
Eq, (forall x. FromIntrospection a -> Rep (FromIntrospection a) x)
-> (forall x. Rep (FromIntrospection a) x -> FromIntrospection a)
-> Generic (FromIntrospection a)
forall x. Rep (FromIntrospection a) x -> FromIntrospection a
forall x. FromIntrospection a -> Rep (FromIntrospection a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (FromIntrospection a) x -> FromIntrospection a
forall a x. FromIntrospection a -> Rep (FromIntrospection a) x
$cfrom :: forall a x. FromIntrospection a -> Rep (FromIntrospection a) x
from :: forall x. FromIntrospection a -> Rep (FromIntrospection a) x
$cto :: forall a x. Rep (FromIntrospection a) x -> FromIntrospection a
to :: forall x. Rep (FromIntrospection a) x -> FromIntrospection a
Generic, (forall a b.
 (a -> b) -> FromIntrospection a -> FromIntrospection b)
-> (forall a b. a -> FromIntrospection b -> FromIntrospection a)
-> Functor FromIntrospection
forall a b. a -> FromIntrospection b -> FromIntrospection a
forall a b. (a -> b) -> FromIntrospection a -> FromIntrospection b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> FromIntrospection a -> FromIntrospection b
fmap :: forall a b. (a -> b) -> FromIntrospection a -> FromIntrospection b
$c<$ :: forall a b. a -> FromIntrospection b -> FromIntrospection a
<$ :: forall a b. a -> FromIntrospection b -> FromIntrospection a
Functor)

instance J.FromJSON (FromIntrospection G.Description) where
  parseJSON :: Value -> Parser (FromIntrospection Description)
parseJSON = (Text -> FromIntrospection Description)
-> Parser Text -> Parser (FromIntrospection Description)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Description -> FromIntrospection Description
forall a. a -> FromIntrospection a
FromIntrospection (Description -> FromIntrospection Description)
-> (Text -> Description) -> Text -> FromIntrospection Description
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Description
G.Description) (Parser Text -> Parser (FromIntrospection Description))
-> (Value -> Parser Text)
-> Value
-> Parser (FromIntrospection Description)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Parser Text
forall a. FromJSON a => Value -> Parser a
J.parseJSON

instance (J.FromJSON (FromIntrospection a)) => J.FromJSON (FromIntrospection (G.FieldDefinition a)) where
  parseJSON :: Value -> Parser (FromIntrospection (FieldDefinition a))
parseJSON = String
-> (Object -> Parser (FromIntrospection (FieldDefinition a)))
-> Value
-> Parser (FromIntrospection (FieldDefinition a))
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"FieldDefinition" ((Object -> Parser (FromIntrospection (FieldDefinition a)))
 -> Value -> Parser (FromIntrospection (FieldDefinition a)))
-> (Object -> Parser (FromIntrospection (FieldDefinition a)))
-> Value
-> Parser (FromIntrospection (FieldDefinition a))
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Name
name <- Object
o Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
    Maybe Description
desc <- (FromIntrospection Description -> Description)
-> Maybe (FromIntrospection Description) -> Maybe Description
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection Description -> Description
forall a. FromIntrospection a -> a
fromIntrospection (Maybe (FromIntrospection Description) -> Maybe Description)
-> Parser (Maybe (FromIntrospection Description))
-> Parser (Maybe Description)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (FromIntrospection Description))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
    [a]
args <- (FromIntrospection a -> a) -> [FromIntrospection a] -> [a]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection a -> a
forall a. FromIntrospection a -> a
fromIntrospection ([FromIntrospection a] -> [a])
-> Parser [FromIntrospection a] -> Parser [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [FromIntrospection a]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"args"
    GType
type' <- FromIntrospection GType -> GType
forall a. FromIntrospection a -> a
fromIntrospection (FromIntrospection GType -> GType)
-> Parser (FromIntrospection GType) -> Parser GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (FromIntrospection GType)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    let r :: FieldDefinition a
r =
          Maybe Description
-> Name -> [a] -> GType -> [Directive Void] -> FieldDefinition a
forall inputType.
Maybe Description
-> Name
-> ArgumentsDefinition inputType
-> GType
-> [Directive Void]
-> FieldDefinition inputType
G.FieldDefinition
            Maybe Description
desc
            Name
name
            [a]
args
            GType
type'
            []
    FromIntrospection (FieldDefinition a)
-> Parser (FromIntrospection (FieldDefinition a))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (FromIntrospection (FieldDefinition a)
 -> Parser (FromIntrospection (FieldDefinition a)))
-> FromIntrospection (FieldDefinition a)
-> Parser (FromIntrospection (FieldDefinition a))
forall a b. (a -> b) -> a -> b
$ FieldDefinition a -> FromIntrospection (FieldDefinition a)
forall a. a -> FromIntrospection a
FromIntrospection FieldDefinition a
r

instance J.FromJSON (FromIntrospection G.GType) where
  parseJSON :: Value -> Parser (FromIntrospection GType)
parseJSON = String
-> (Object -> Parser (FromIntrospection GType))
-> Value
-> Parser (FromIntrospection GType)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"GType" ((Object -> Parser (FromIntrospection GType))
 -> Value -> Parser (FromIntrospection GType))
-> (Object -> Parser (FromIntrospection GType))
-> Value
-> Parser (FromIntrospection GType)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
kind <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"kind"
    Maybe Name
mName <- Object
o Object -> Key -> Parser (Maybe Name)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"name"
    Maybe (FromIntrospection GType)
mType <- Object
o Object -> Key -> Parser (Maybe (FromIntrospection GType))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"ofType"
    GType
r <- case (Text
kind, Maybe Name
mName, Maybe (FromIntrospection GType)
mType) of
      (Text
"NON_NULL", Maybe Name
_, Just FromIntrospection GType
typ) -> GType -> Parser GType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (GType -> Parser GType) -> GType -> Parser GType
forall a b. (a -> b) -> a -> b
$ GType -> GType
mkNotNull (FromIntrospection GType -> GType
forall a. FromIntrospection a -> a
fromIntrospection FromIntrospection GType
typ)
      (Text
"NON_NULL", Maybe Name
_, Maybe (FromIntrospection GType)
Nothing) -> Text -> Parser GType
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr Text
"NON_NULL should have `ofType`"
      (Text
"LIST", Maybe Name
_, Just FromIntrospection GType
typ) ->
        GType -> Parser GType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (GType -> Parser GType) -> GType -> Parser GType
forall a b. (a -> b) -> a -> b
$ Nullability -> GType -> GType
G.TypeList (Bool -> Nullability
G.Nullability Bool
True) (FromIntrospection GType -> GType
forall a. FromIntrospection a -> a
fromIntrospection FromIntrospection GType
typ)
      (Text
"LIST", Maybe Name
_, Maybe (FromIntrospection GType)
Nothing) -> Text -> Parser GType
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr Text
"LIST should have `ofType`"
      (Text
_, Just Name
name, Maybe (FromIntrospection GType)
_) -> GType -> Parser GType
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (GType -> Parser GType) -> GType -> Parser GType
forall a b. (a -> b) -> a -> b
$ Nullability -> Name -> GType
G.TypeNamed (Bool -> Nullability
G.Nullability Bool
True) Name
name
      (Text, Maybe Name, Maybe (FromIntrospection GType))
_ -> Text -> Parser GType
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr (Text -> Parser GType) -> Text -> Parser GType
forall a b. (a -> b) -> a -> b
$ Text
"kind: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
kind Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" should have name"
    FromIntrospection GType -> Parser (FromIntrospection GType)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (FromIntrospection GType -> Parser (FromIntrospection GType))
-> FromIntrospection GType -> Parser (FromIntrospection GType)
forall a b. (a -> b) -> a -> b
$ GType -> FromIntrospection GType
forall a. a -> FromIntrospection a
FromIntrospection GType
r
    where
      mkNotNull :: GType -> GType
mkNotNull GType
typ = case GType
typ of
        G.TypeList Nullability
_ GType
ty -> Nullability -> GType -> GType
G.TypeList (Bool -> Nullability
G.Nullability Bool
False) GType
ty
        G.TypeNamed Nullability
_ Name
n -> Nullability -> Name -> GType
G.TypeNamed (Bool -> Nullability
G.Nullability Bool
False) Name
n

instance J.FromJSON (FromIntrospection G.InputValueDefinition) where
  parseJSON :: Value -> Parser (FromIntrospection InputValueDefinition)
parseJSON = String
-> (Object -> Parser (FromIntrospection InputValueDefinition))
-> Value
-> Parser (FromIntrospection InputValueDefinition)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"InputValueDefinition" ((Object -> Parser (FromIntrospection InputValueDefinition))
 -> Value -> Parser (FromIntrospection InputValueDefinition))
-> (Object -> Parser (FromIntrospection InputValueDefinition))
-> Value
-> Parser (FromIntrospection InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Name
name <- Object
o Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
    Maybe Description
desc <- (FromIntrospection Description -> Description)
-> Maybe (FromIntrospection Description) -> Maybe Description
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection Description -> Description
forall a. FromIntrospection a -> a
fromIntrospection (Maybe (FromIntrospection Description) -> Maybe Description)
-> Parser (Maybe (FromIntrospection Description))
-> Parser (Maybe Description)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (FromIntrospection Description))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
    GType
type' <- FromIntrospection GType -> GType
forall a. FromIntrospection a -> a
fromIntrospection (FromIntrospection GType -> GType)
-> Parser (FromIntrospection GType) -> Parser GType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (FromIntrospection GType)
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"type"
    Maybe (Value Void)
defVal <- (FromIntrospection (Value Void) -> Value Void)
-> Maybe (FromIntrospection (Value Void)) -> Maybe (Value Void)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection (Value Void) -> Value Void
forall a. FromIntrospection a -> a
fromIntrospection (Maybe (FromIntrospection (Value Void)) -> Maybe (Value Void))
-> Parser (Maybe (FromIntrospection (Value Void)))
-> Parser (Maybe (Value Void))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (FromIntrospection (Value Void)))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"defaultValue"
    FromIntrospection InputValueDefinition
-> Parser (FromIntrospection InputValueDefinition)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (FromIntrospection InputValueDefinition
 -> Parser (FromIntrospection InputValueDefinition))
-> FromIntrospection InputValueDefinition
-> Parser (FromIntrospection InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ InputValueDefinition -> FromIntrospection InputValueDefinition
forall a. a -> FromIntrospection a
FromIntrospection (InputValueDefinition -> FromIntrospection InputValueDefinition)
-> InputValueDefinition -> FromIntrospection InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name
-> GType
-> Maybe (Value Void)
-> [Directive Void]
-> InputValueDefinition
G.InputValueDefinition Maybe Description
desc Name
name GType
type' Maybe (Value Void)
defVal []

instance J.FromJSON (FromIntrospection (G.Value Void)) where
  parseJSON :: Value -> Parser (FromIntrospection (Value Void))
parseJSON = String
-> (Text -> Parser (FromIntrospection (Value Void)))
-> Value
-> Parser (FromIntrospection (Value Void))
forall a. String -> (Text -> Parser a) -> Value -> Parser a
J.withText String
"Value Void" ((Text -> Parser (FromIntrospection (Value Void)))
 -> Value -> Parser (FromIntrospection (Value Void)))
-> (Text -> Parser (FromIntrospection (Value Void)))
-> Value
-> Parser (FromIntrospection (Value Void))
forall a b. (a -> b) -> a -> b
$ \Text
t ->
    let parseValueConst :: Text -> Either Text (Value Void)
parseValueConst = Parser (Value Void) -> Text -> Either Text (Value Void)
forall a. Parser a -> Text -> Either Text a
G.runParser Parser (Value Void)
forall var. Variable var => Parser (Value var)
G.value
     in Value Void -> FromIntrospection (Value Void)
forall a. a -> FromIntrospection a
FromIntrospection (Value Void -> FromIntrospection (Value Void))
-> Parser (Value Void) -> Parser (FromIntrospection (Value Void))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Text (Value Void)
-> (Text -> Parser (Value Void)) -> Parser (Value Void)
forall (m :: * -> *) e a.
Applicative m =>
Either e a -> (e -> m a) -> m a
onLeft (Text -> Either Text (Value Void)
parseValueConst Text
t) (String -> Parser (Value Void)
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser (Value Void))
-> (Text -> String) -> Text -> Parser (Value Void)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack)

instance J.FromJSON (FromIntrospection G.EnumValueDefinition) where
  parseJSON :: Value -> Parser (FromIntrospection EnumValueDefinition)
parseJSON = String
-> (Object -> Parser (FromIntrospection EnumValueDefinition))
-> Value
-> Parser (FromIntrospection EnumValueDefinition)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"EnumValueDefinition" ((Object -> Parser (FromIntrospection EnumValueDefinition))
 -> Value -> Parser (FromIntrospection EnumValueDefinition))
-> (Object -> Parser (FromIntrospection EnumValueDefinition))
-> Value
-> Parser (FromIntrospection EnumValueDefinition)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    EnumValue
name <- Object
o Object -> Key -> Parser EnumValue
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
    Maybe Description
desc <- (FromIntrospection Description -> Description)
-> Maybe (FromIntrospection Description) -> Maybe Description
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection Description -> Description
forall a. FromIntrospection a -> a
fromIntrospection (Maybe (FromIntrospection Description) -> Maybe Description)
-> Parser (Maybe (FromIntrospection Description))
-> Parser (Maybe Description)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (FromIntrospection Description))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
    FromIntrospection EnumValueDefinition
-> Parser (FromIntrospection EnumValueDefinition)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (FromIntrospection EnumValueDefinition
 -> Parser (FromIntrospection EnumValueDefinition))
-> FromIntrospection EnumValueDefinition
-> Parser (FromIntrospection EnumValueDefinition)
forall a b. (a -> b) -> a -> b
$ EnumValueDefinition -> FromIntrospection EnumValueDefinition
forall a. a -> FromIntrospection a
FromIntrospection (EnumValueDefinition -> FromIntrospection EnumValueDefinition)
-> EnumValueDefinition -> FromIntrospection EnumValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> EnumValue -> [Directive Void] -> EnumValueDefinition
G.EnumValueDefinition Maybe Description
desc EnumValue
name []

instance J.FromJSON (FromIntrospection (G.TypeDefinition [G.Name] G.InputValueDefinition)) where
  parseJSON :: Value
-> Parser
     (FromIntrospection (TypeDefinition [Name] InputValueDefinition))
parseJSON = String
-> (Object
    -> Parser
         (FromIntrospection (TypeDefinition [Name] InputValueDefinition)))
-> Value
-> Parser
     (FromIntrospection (TypeDefinition [Name] InputValueDefinition))
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"TypeDefinition" ((Object
  -> Parser
       (FromIntrospection (TypeDefinition [Name] InputValueDefinition)))
 -> Value
 -> Parser
      (FromIntrospection (TypeDefinition [Name] InputValueDefinition)))
-> (Object
    -> Parser
         (FromIntrospection (TypeDefinition [Name] InputValueDefinition)))
-> Value
-> Parser
     (FromIntrospection (TypeDefinition [Name] InputValueDefinition))
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
kind :: Text <- Object
o Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"kind"
    Name
name <- Object
o Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
    Maybe Description
desc <- (FromIntrospection Description -> Description)
-> Maybe (FromIntrospection Description) -> Maybe Description
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection Description -> Description
forall a. FromIntrospection a -> a
fromIntrospection (Maybe (FromIntrospection Description) -> Maybe Description)
-> Parser (Maybe (FromIntrospection Description))
-> Parser (Maybe Description)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser (Maybe (FromIntrospection Description))
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"description"
    TypeDefinition [Name] InputValueDefinition
r <- case Text
kind of
      Text
"SCALAR" ->
        TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] InputValueDefinition
 -> Parser (TypeDefinition [Name] InputValueDefinition))
-> TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ ScalarTypeDefinition -> TypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
ScalarTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionScalar (ScalarTypeDefinition
 -> TypeDefinition [Name] InputValueDefinition)
-> ScalarTypeDefinition
-> TypeDefinition [Name] InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name -> [Directive Void] -> ScalarTypeDefinition
G.ScalarTypeDefinition Maybe Description
desc Name
name []
      Text
"OBJECT" -> do
        Maybe [FromIntrospection (FieldDefinition InputValueDefinition)]
fields <- Object
o Object
-> Key
-> Parser
     (Maybe [FromIntrospection (FieldDefinition InputValueDefinition)])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"fields"
        Maybe
  [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
interfaces :: Maybe [FromIntrospection (G.TypeDefinition [G.Name] G.InputValueDefinition)] <- Object
o Object
-> Key
-> Parser
     (Maybe
        [FromIntrospection (TypeDefinition [Name] InputValueDefinition)])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"interfaces"
        [Name]
implIfaces <- [TypeDefinition [Name] InputValueDefinition]
-> (TypeDefinition [Name] InputValueDefinition -> Parser Name)
-> Parser [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (([FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
 -> [TypeDefinition [Name] InputValueDefinition])
-> Maybe
     [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [TypeDefinition [Name] InputValueDefinition]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((FromIntrospection (TypeDefinition [Name] InputValueDefinition)
 -> TypeDefinition [Name] InputValueDefinition)
-> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [TypeDefinition [Name] InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> TypeDefinition [Name] InputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection) Maybe
  [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
interfaces) \case
          G.TypeDefinitionInterface (G.InterfaceTypeDefinition {[Name]
[FieldDefinition InputValueDefinition]
[Directive Void]
Maybe Description
Name
_itdDescription :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> Maybe Description
_itdName :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
_itdDirectives :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> [Directive Void]
_itdFieldsDefinition :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> [FieldDefinition inputType]
_itdPossibleTypes :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> possibleTypes
_itdDescription :: Maybe Description
_itdName :: Name
_itdDirectives :: [Directive Void]
_itdFieldsDefinition :: [FieldDefinition InputValueDefinition]
_itdPossibleTypes :: [Name]
..}) -> Name -> Parser Name
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
_itdName
          TypeDefinition [Name] InputValueDefinition
_ -> Text -> Parser Name
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr (Text -> Parser Name) -> Text -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text
"Error: object type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" can only implement interfaces"
        let flds :: [FieldDefinition InputValueDefinition]
flds = ([FromIntrospection (FieldDefinition InputValueDefinition)]
 -> [FieldDefinition InputValueDefinition])
-> Maybe [FromIntrospection (FieldDefinition InputValueDefinition)]
-> [FieldDefinition InputValueDefinition]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((FromIntrospection (FieldDefinition InputValueDefinition)
 -> FieldDefinition InputValueDefinition)
-> [FromIntrospection (FieldDefinition InputValueDefinition)]
-> [FieldDefinition InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection (FieldDefinition InputValueDefinition)
-> FieldDefinition InputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection) Maybe [FromIntrospection (FieldDefinition InputValueDefinition)]
fields
        TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] InputValueDefinition
 -> Parser (TypeDefinition [Name] InputValueDefinition))
-> TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ ObjectTypeDefinition InputValueDefinition
-> TypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
ObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionObject (ObjectTypeDefinition InputValueDefinition
 -> TypeDefinition [Name] InputValueDefinition)
-> ObjectTypeDefinition InputValueDefinition
-> TypeDefinition [Name] InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name
-> [Name]
-> [Directive Void]
-> [FieldDefinition InputValueDefinition]
-> ObjectTypeDefinition InputValueDefinition
forall inputType.
Maybe Description
-> Name
-> [Name]
-> [Directive Void]
-> [FieldDefinition inputType]
-> ObjectTypeDefinition inputType
G.ObjectTypeDefinition Maybe Description
desc Name
name [Name]
implIfaces [] [FieldDefinition InputValueDefinition]
flds
      Text
"INTERFACE" -> do
        Maybe [FromIntrospection (FieldDefinition InputValueDefinition)]
fields <- Object
o Object
-> Key
-> Parser
     (Maybe [FromIntrospection (FieldDefinition InputValueDefinition)])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"fields"
        Maybe
  [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
possibleTypes :: Maybe [FromIntrospection (G.TypeDefinition [G.Name] G.InputValueDefinition)] <- Object
o Object
-> Key
-> Parser
     (Maybe
        [FromIntrospection (TypeDefinition [Name] InputValueDefinition)])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"possibleTypes"
        let flds :: [FieldDefinition InputValueDefinition]
flds = [FieldDefinition InputValueDefinition]
-> ([FromIntrospection (FieldDefinition InputValueDefinition)]
    -> [FieldDefinition InputValueDefinition])
-> Maybe [FromIntrospection (FieldDefinition InputValueDefinition)]
-> [FieldDefinition InputValueDefinition]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ((FromIntrospection (FieldDefinition InputValueDefinition)
 -> FieldDefinition InputValueDefinition)
-> [FromIntrospection (FieldDefinition InputValueDefinition)]
-> [FieldDefinition InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection (FieldDefinition InputValueDefinition)
-> FieldDefinition InputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection) Maybe [FromIntrospection (FieldDefinition InputValueDefinition)]
fields
        -- TODO (non PDV) track which interfaces implement which other interfaces, after a
        -- GraphQL spec > Jun 2018 is released.
        [Name]
possTps <- [TypeDefinition [Name] InputValueDefinition]
-> (TypeDefinition [Name] InputValueDefinition -> Parser Name)
-> Parser [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (([FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
 -> [TypeDefinition [Name] InputValueDefinition])
-> Maybe
     [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [TypeDefinition [Name] InputValueDefinition]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((FromIntrospection (TypeDefinition [Name] InputValueDefinition)
 -> TypeDefinition [Name] InputValueDefinition)
-> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [TypeDefinition [Name] InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> TypeDefinition [Name] InputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection) Maybe
  [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
possibleTypes) \case
          G.TypeDefinitionObject (G.ObjectTypeDefinition {[Name]
[FieldDefinition InputValueDefinition]
[Directive Void]
Maybe Description
Name
_otdDescription :: forall inputType.
ObjectTypeDefinition inputType -> Maybe Description
_otdName :: forall inputType. ObjectTypeDefinition inputType -> Name
_otdImplementsInterfaces :: forall inputType. ObjectTypeDefinition inputType -> [Name]
_otdDirectives :: forall inputType.
ObjectTypeDefinition inputType -> [Directive Void]
_otdFieldsDefinition :: forall inputType.
ObjectTypeDefinition inputType -> [FieldDefinition inputType]
_otdDescription :: Maybe Description
_otdName :: Name
_otdImplementsInterfaces :: [Name]
_otdDirectives :: [Directive Void]
_otdFieldsDefinition :: [FieldDefinition InputValueDefinition]
..}) -> Name -> Parser Name
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
_otdName
          TypeDefinition [Name] InputValueDefinition
_ -> Text -> Parser Name
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr (Text -> Parser Name) -> Text -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text
"Error: interface type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" can only be implemented by objects"
        TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] InputValueDefinition
 -> Parser (TypeDefinition [Name] InputValueDefinition))
-> TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ InterfaceTypeDefinition [Name] InputValueDefinition
-> TypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInterface (InterfaceTypeDefinition [Name] InputValueDefinition
 -> TypeDefinition [Name] InputValueDefinition)
-> InterfaceTypeDefinition [Name] InputValueDefinition
-> TypeDefinition [Name] InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name
-> [Directive Void]
-> [FieldDefinition InputValueDefinition]
-> [Name]
-> InterfaceTypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
Maybe Description
-> Name
-> [Directive Void]
-> [FieldDefinition inputType]
-> possibleTypes
-> InterfaceTypeDefinition possibleTypes inputType
G.InterfaceTypeDefinition Maybe Description
desc Name
name [] [FieldDefinition InputValueDefinition]
flds [Name]
possTps
      Text
"UNION" -> do
        [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
possibleTypes :: [FromIntrospection (G.TypeDefinition [G.Name] G.InputValueDefinition)] <- Object
o Object
-> Key
-> Parser
     [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"possibleTypes"
        [Name]
possibleTypes' <- [TypeDefinition [Name] InputValueDefinition]
-> (TypeDefinition [Name] InputValueDefinition -> Parser Name)
-> Parser [Name]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for (FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> TypeDefinition [Name] InputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection (FromIntrospection (TypeDefinition [Name] InputValueDefinition)
 -> TypeDefinition [Name] InputValueDefinition)
-> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [TypeDefinition [Name] InputValueDefinition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
possibleTypes) \case
          G.TypeDefinitionObject (G.ObjectTypeDefinition {[Name]
[FieldDefinition InputValueDefinition]
[Directive Void]
Maybe Description
Name
_otdDescription :: forall inputType.
ObjectTypeDefinition inputType -> Maybe Description
_otdName :: forall inputType. ObjectTypeDefinition inputType -> Name
_otdImplementsInterfaces :: forall inputType. ObjectTypeDefinition inputType -> [Name]
_otdDirectives :: forall inputType.
ObjectTypeDefinition inputType -> [Directive Void]
_otdFieldsDefinition :: forall inputType.
ObjectTypeDefinition inputType -> [FieldDefinition inputType]
_otdDescription :: Maybe Description
_otdName :: Name
_otdImplementsInterfaces :: [Name]
_otdDirectives :: [Directive Void]
_otdFieldsDefinition :: [FieldDefinition InputValueDefinition]
..}) -> Name -> Parser Name
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Name
_otdName
          TypeDefinition [Name] InputValueDefinition
_ -> Text -> Parser Name
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr (Text -> Parser Name) -> Text -> Parser Name
forall a b. (a -> b) -> a -> b
$ Text
"Error: union type " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" can only be implemented by objects"
        TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] InputValueDefinition
 -> Parser (TypeDefinition [Name] InputValueDefinition))
-> TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ UnionTypeDefinition -> TypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
UnionTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionUnion (UnionTypeDefinition -> TypeDefinition [Name] InputValueDefinition)
-> UnionTypeDefinition
-> TypeDefinition [Name] InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name -> [Directive Void] -> [Name] -> UnionTypeDefinition
G.UnionTypeDefinition Maybe Description
desc Name
name [] [Name]
possibleTypes'
      Text
"ENUM" -> do
        [EnumValueDefinition]
vals <- (FromIntrospection EnumValueDefinition -> EnumValueDefinition)
-> [FromIntrospection EnumValueDefinition] -> [EnumValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection EnumValueDefinition -> EnumValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection ([FromIntrospection EnumValueDefinition] -> [EnumValueDefinition])
-> Parser [FromIntrospection EnumValueDefinition]
-> Parser [EnumValueDefinition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object -> Key -> Parser [FromIntrospection EnumValueDefinition]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"enumValues"
        TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] InputValueDefinition
 -> Parser (TypeDefinition [Name] InputValueDefinition))
-> TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ EnumTypeDefinition -> TypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
EnumTypeDefinition -> TypeDefinition possibleTypes inputType
G.TypeDefinitionEnum (EnumTypeDefinition -> TypeDefinition [Name] InputValueDefinition)
-> EnumTypeDefinition -> TypeDefinition [Name] InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name
-> [Directive Void]
-> [EnumValueDefinition]
-> EnumTypeDefinition
G.EnumTypeDefinition Maybe Description
desc Name
name [] [EnumValueDefinition]
vals
      Text
"INPUT_OBJECT" -> do
        [InputValueDefinition]
inputFields <- ([FromIntrospection InputValueDefinition]
 -> [InputValueDefinition])
-> Maybe [FromIntrospection InputValueDefinition]
-> [InputValueDefinition]
forall m a. Monoid m => (a -> m) -> Maybe a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ((FromIntrospection InputValueDefinition -> InputValueDefinition)
-> [FromIntrospection InputValueDefinition]
-> [InputValueDefinition]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FromIntrospection InputValueDefinition -> InputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection) (Maybe [FromIntrospection InputValueDefinition]
 -> [InputValueDefinition])
-> Parser (Maybe [FromIntrospection InputValueDefinition])
-> Parser [InputValueDefinition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o Object
-> Key -> Parser (Maybe [FromIntrospection InputValueDefinition])
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"inputFields"
        TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeDefinition [Name] InputValueDefinition
 -> Parser (TypeDefinition [Name] InputValueDefinition))
-> TypeDefinition [Name] InputValueDefinition
-> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ InputObjectTypeDefinition InputValueDefinition
-> TypeDefinition [Name] InputValueDefinition
forall possibleTypes inputType.
InputObjectTypeDefinition inputType
-> TypeDefinition possibleTypes inputType
G.TypeDefinitionInputObject (InputObjectTypeDefinition InputValueDefinition
 -> TypeDefinition [Name] InputValueDefinition)
-> InputObjectTypeDefinition InputValueDefinition
-> TypeDefinition [Name] InputValueDefinition
forall a b. (a -> b) -> a -> b
$ Maybe Description
-> Name
-> [Directive Void]
-> [InputValueDefinition]
-> InputObjectTypeDefinition InputValueDefinition
forall inputType.
Maybe Description
-> Name
-> [Directive Void]
-> [inputType]
-> InputObjectTypeDefinition inputType
G.InputObjectTypeDefinition Maybe Description
desc Name
name [] [InputValueDefinition]
inputFields
      Text
_ -> Text -> Parser (TypeDefinition [Name] InputValueDefinition)
forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr (Text -> Parser (TypeDefinition [Name] InputValueDefinition))
-> Text -> Parser (TypeDefinition [Name] InputValueDefinition)
forall a b. (a -> b) -> a -> b
$ Text
"unknown kind: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
kind
    FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> Parser
     (FromIntrospection (TypeDefinition [Name] InputValueDefinition))
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (FromIntrospection (TypeDefinition [Name] InputValueDefinition)
 -> Parser
      (FromIntrospection (TypeDefinition [Name] InputValueDefinition)))
-> FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> Parser
     (FromIntrospection (TypeDefinition [Name] InputValueDefinition))
forall a b. (a -> b) -> a -> b
$ TypeDefinition [Name] InputValueDefinition
-> FromIntrospection (TypeDefinition [Name] InputValueDefinition)
forall a. a -> FromIntrospection a
FromIntrospection TypeDefinition [Name] InputValueDefinition
r

instance J.FromJSON (FromIntrospection IntrospectionResult) where
  parseJSON :: Value -> Parser (FromIntrospection IntrospectionResult)
parseJSON = String
-> (Object -> Parser (FromIntrospection IntrospectionResult))
-> Value
-> Parser (FromIntrospection IntrospectionResult)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"SchemaDocument" ((Object -> Parser (FromIntrospection IntrospectionResult))
 -> Value -> Parser (FromIntrospection IntrospectionResult))
-> (Object -> Parser (FromIntrospection IntrospectionResult))
-> Value
-> Parser (FromIntrospection IntrospectionResult)
forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Object
data' <- Object
o Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"data"
    Object
schema <- Object
data' Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"__schema"
    -- the list of types
    [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
types <- Object
schema Object
-> Key
-> Parser
     [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"types"
    -- query root
    Object
queryType <- Object
schema Object -> Key -> Parser Object
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"queryType"
    Name
queryRoot <- Object
queryType Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name"
    -- mutation root
    Maybe Object
mMutationType <- Object
schema Object -> Key -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"mutationType"
    Maybe Name
mutationRoot <- Maybe Object -> (Object -> Parser Name) -> Parser (Maybe Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Object
mMutationType (Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name")
    -- subscription root
    Maybe Object
mSubsType <- Object
schema Object -> Key -> Parser (Maybe Object)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
.:? Key
"subscriptionType"
    Maybe Name
subsRoot <- Maybe Object -> (Object -> Parser Name) -> Parser (Maybe Name)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe Object
mSubsType (Object -> Key -> Parser Name
forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"name")
    let types' :: [FromIntrospection
   (TypeDefinition [Name] RemoteSchemaInputValueDefinition)]
types' =
          ((FromIntrospection (TypeDefinition [Name] InputValueDefinition)
 -> FromIntrospection
      (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
-> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [FromIntrospection
      (TypeDefinition [Name] RemoteSchemaInputValueDefinition)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FromIntrospection (TypeDefinition [Name] InputValueDefinition)
  -> FromIntrospection
       (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
 -> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
 -> [FromIntrospection
       (TypeDefinition [Name] RemoteSchemaInputValueDefinition)])
-> ((InputValueDefinition -> RemoteSchemaInputValueDefinition)
    -> FromIntrospection (TypeDefinition [Name] InputValueDefinition)
    -> FromIntrospection
         (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
-> (InputValueDefinition -> RemoteSchemaInputValueDefinition)
-> [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
-> [FromIntrospection
      (TypeDefinition [Name] RemoteSchemaInputValueDefinition)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinition [Name] InputValueDefinition
 -> TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> FromIntrospection
     (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> FromIntrospection a -> FromIntrospection b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((TypeDefinition [Name] InputValueDefinition
  -> TypeDefinition [Name] RemoteSchemaInputValueDefinition)
 -> FromIntrospection (TypeDefinition [Name] InputValueDefinition)
 -> FromIntrospection
      (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
-> ((InputValueDefinition -> RemoteSchemaInputValueDefinition)
    -> TypeDefinition [Name] InputValueDefinition
    -> TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> (InputValueDefinition -> RemoteSchemaInputValueDefinition)
-> FromIntrospection (TypeDefinition [Name] InputValueDefinition)
-> FromIntrospection
     (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InputValueDefinition -> RemoteSchemaInputValueDefinition)
-> TypeDefinition [Name] InputValueDefinition
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall a b.
(a -> b) -> TypeDefinition [Name] a -> TypeDefinition [Name] b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
            -- presets are only defined for non-admin roles,
            -- an admin will not have any presets
            -- defined and the admin will be the one,
            -- who'll be adding the remote schema,
            -- hence presets are set to `Nothing`
            (InputValueDefinition
-> Maybe (Value RemoteSchemaVariable)
-> RemoteSchemaInputValueDefinition
`RemoteSchemaInputValueDefinition` Maybe (Value RemoteSchemaVariable)
forall a. Maybe a
Nothing)
            [FromIntrospection (TypeDefinition [Name] InputValueDefinition)]
types
        r :: IntrospectionResult
r =
          RemoteSchemaIntrospection
-> Name -> Maybe Name -> Maybe Name -> IntrospectionResult
IntrospectionResult
            (HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> RemoteSchemaIntrospection
RemoteSchemaIntrospection (HashMap
   Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
 -> RemoteSchemaIntrospection)
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> RemoteSchemaIntrospection
forall a b. (a -> b) -> a -> b
$ (TypeDefinition [Name] RemoteSchemaInputValueDefinition -> Name)
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall k v. Hashable k => (v -> k) -> [v] -> HashMap k v
HashMap.fromListOn TypeDefinition [Name] RemoteSchemaInputValueDefinition -> Name
forall possibleTypes inputType.
TypeDefinition possibleTypes inputType -> Name
getTypeName ([TypeDefinition [Name] RemoteSchemaInputValueDefinition]
 -> HashMap
      Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition))
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
forall a b. (a -> b) -> a -> b
$ FromIntrospection
  (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> TypeDefinition [Name] RemoteSchemaInputValueDefinition
forall a. FromIntrospection a -> a
fromIntrospection (FromIntrospection
   (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
 -> TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> [FromIntrospection
      (TypeDefinition [Name] RemoteSchemaInputValueDefinition)]
-> [TypeDefinition [Name] RemoteSchemaInputValueDefinition]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FromIntrospection
   (TypeDefinition [Name] RemoteSchemaInputValueDefinition)]
types')
            Name
queryRoot
            Maybe Name
mutationRoot
            Maybe Name
subsRoot
    FromIntrospection IntrospectionResult
-> Parser (FromIntrospection IntrospectionResult)
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return (FromIntrospection IntrospectionResult
 -> Parser (FromIntrospection IntrospectionResult))
-> FromIntrospection IntrospectionResult
-> Parser (FromIntrospection IntrospectionResult)
forall a b. (a -> b) -> a -> b
$ IntrospectionResult -> FromIntrospection IntrospectionResult
forall a. a -> FromIntrospection a
FromIntrospection IntrospectionResult
r

-------------------------------------------------------------------------------
-- Customization

getCustomizer :: IntrospectionResult -> Maybe RemoteSchemaCustomization -> RemoteSchemaCustomizer
getCustomizer :: IntrospectionResult
-> Maybe RemoteSchemaCustomization -> RemoteSchemaCustomizer
getCustomizer IntrospectionResult
_ Maybe RemoteSchemaCustomization
Nothing = RemoteSchemaCustomizer
identityCustomizer
getCustomizer IntrospectionResult {Maybe Name
Name
RemoteSchemaIntrospection
irDoc :: IntrospectionResult -> RemoteSchemaIntrospection
irQueryRoot :: IntrospectionResult -> Name
irMutationRoot :: IntrospectionResult -> Maybe Name
irSubscriptionRoot :: IntrospectionResult -> Maybe Name
irDoc :: RemoteSchemaIntrospection
irQueryRoot :: Name
irMutationRoot :: Maybe Name
irSubscriptionRoot :: Maybe Name
..} (Just RemoteSchemaCustomization {Maybe [RemoteFieldCustomization]
Maybe Name
Maybe RemoteTypeCustomization
_rscRootFieldsNamespace :: Maybe Name
_rscTypeNames :: Maybe RemoteTypeCustomization
_rscFieldNames :: Maybe [RemoteFieldCustomization]
_rscRootFieldsNamespace :: RemoteSchemaCustomization -> Maybe Name
_rscTypeNames :: RemoteSchemaCustomization -> Maybe RemoteTypeCustomization
_rscFieldNames :: RemoteSchemaCustomization -> Maybe [RemoteFieldCustomization]
..}) = RemoteSchemaCustomizer {Maybe Name
HashMap Name (HashMap Name Name)
HashMap Name Name
_rscNamespaceFieldName :: Maybe Name
_rscCustomizeTypeName :: HashMap Name Name
_rscCustomizeFieldName :: HashMap Name (HashMap Name Name)
_rscNamespaceFieldName :: Maybe Name
_rscCustomizeTypeName :: HashMap Name Name
_rscCustomizeFieldName :: HashMap Name (HashMap Name Name)
..}
  where
    rootTypeNames :: HashSet Name
rootTypeNames =
      if Maybe Name -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Name
_rscRootFieldsNamespace
        then [Name] -> HashSet Name
forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList ([Name] -> HashSet Name) -> [Name] -> HashSet Name
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes [Name -> Maybe Name
forall a. a -> Maybe a
Just Name
irQueryRoot, Maybe Name
irMutationRoot, Maybe Name
irSubscriptionRoot]
        else HashSet Name
forall a. Monoid a => a
mempty
    -- root type names should not be prefixed or suffixed unless
    -- there is a custom root namespace field
    protectedTypeNames :: HashSet Name
protectedTypeNames = HashSet Name
GName.builtInScalars HashSet Name -> HashSet Name -> HashSet Name
forall a. Semigroup a => a -> a -> a
<> HashSet Name
rootTypeNames
    nameFilter :: Name -> Bool
nameFilter Name
name = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Text
"__" Text -> Text -> Bool
`T.isPrefixOf` Name -> Text
G.unName Name
name Bool -> Bool -> Bool
|| Name
name Name -> HashSet Name -> Bool
forall a. (Eq a, Hashable a) => a -> HashSet a -> Bool
`Set.member` HashSet Name
protectedTypeNames

    mkPrefixSuffixMap :: Maybe G.Name -> Maybe G.Name -> [G.Name] -> HashMap G.Name G.Name
    mkPrefixSuffixMap :: Maybe Name -> Maybe Name -> [Name] -> HashMap Name Name
mkPrefixSuffixMap Maybe Name
mPrefix Maybe Name
mSuffix [Name]
names = [(Name, Name)] -> HashMap Name Name
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Name, Name)] -> HashMap Name Name)
-> [(Name, Name)] -> HashMap Name Name
forall a b. (a -> b) -> a -> b
$ case (Maybe Name
mPrefix, Maybe Name
mSuffix) of
      (Maybe Name
Nothing, Maybe Name
Nothing) -> []
      (Just Name
prefix, Maybe Name
Nothing) -> (Name -> (Name, Name)) -> [Name] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
name -> (Name
name, Name
prefix Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
name)) [Name]
names
      (Maybe Name
Nothing, Just Name
suffix) -> (Name -> (Name, Name)) -> [Name] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
name -> (Name
name, Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
suffix)) [Name]
names
      (Just Name
prefix, Just Name
suffix) -> (Name -> (Name, Name)) -> [Name] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\Name
name -> (Name
name, Name
prefix Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
name Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> Name
suffix)) [Name]
names

    RemoteSchemaIntrospection HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions = RemoteSchemaIntrospection
irDoc
    typesToRename :: [Name]
typesToRename = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
nameFilter ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> [Name]
forall k v. HashMap k v -> [k]
HashMap.keys HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions

    -- NOTE: We are creating a root type name mapping, this will be used to
    -- prefix the root field names with the root field namespace. We are doing
    -- this inorder to reduce typename conflicts while adding the root field
    -- namespace. Please note that this will have lower precedence order than
    -- the _rtcMapping. This means that a user can still change the root type
    -- name.
    rootTypeNameMap :: HashMap Name Name
rootTypeNameMap =
      Maybe Name -> Maybe Name -> [Name] -> HashMap Name Name
mkPrefixSuffixMap Maybe Name
_rscRootFieldsNamespace Maybe Name
forall a. Maybe a
Nothing
        ([Name] -> HashMap Name Name) -> [Name] -> HashMap Name Name
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
forall (f :: * -> *) a. Filterable f => f (Maybe a) -> f a
catMaybes [Name -> Maybe Name
forall a. a -> Maybe a
Just Name
irQueryRoot, Maybe Name
irMutationRoot, Maybe Name
irSubscriptionRoot]

    typeRenameMap :: HashMap Name Name
typeRenameMap =
      case Maybe RemoteTypeCustomization
_rscTypeNames of
        Maybe RemoteTypeCustomization
Nothing -> HashMap Name Name
rootTypeNameMap
        Just RemoteTypeCustomization {Maybe Name
HashMap Name Name
_rtcPrefix :: Maybe Name
_rtcSuffix :: Maybe Name
_rtcMapping :: HashMap Name Name
_rtcPrefix :: RemoteTypeCustomization -> Maybe Name
_rtcSuffix :: RemoteTypeCustomization -> Maybe Name
_rtcMapping :: RemoteTypeCustomization -> HashMap Name Name
..} ->
          HashMap Name Name
_rtcMapping HashMap Name Name -> HashMap Name Name -> HashMap Name Name
forall a. Semigroup a => a -> a -> a
<> HashMap Name Name
rootTypeNameMap HashMap Name Name -> HashMap Name Name -> HashMap Name Name
forall a. Semigroup a => a -> a -> a
<> Maybe Name -> Maybe Name -> [Name] -> HashMap Name Name
mkPrefixSuffixMap Maybe Name
_rtcPrefix Maybe Name
_rtcSuffix [Name]
typesToRename

    typeFieldMap :: HashMap G.Name [G.Name] -- typeName -> fieldNames
    typeFieldMap :: HashMap Name [Name]
typeFieldMap =
      (TypeDefinition [Name] RemoteSchemaInputValueDefinition
 -> Maybe [Name])
-> HashMap
     Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
-> HashMap Name [Name]
forall a b. (a -> Maybe b) -> HashMap Name a -> HashMap Name b
forall (f :: * -> *) a b.
Filterable f =>
(a -> Maybe b) -> f a -> f b
mapMaybe TypeDefinition [Name] RemoteSchemaInputValueDefinition
-> Maybe [Name]
forall {possibleTypes} {inputType}.
TypeDefinition possibleTypes inputType -> Maybe [Name]
getFieldsNames HashMap
  Name (TypeDefinition [Name] RemoteSchemaInputValueDefinition)
typeDefinitions
      where
        getFieldsNames :: TypeDefinition possibleTypes inputType -> Maybe [Name]
getFieldsNames = \case
          G.TypeDefinitionObject G.ObjectTypeDefinition {[Name]
[FieldDefinition inputType]
[Directive Void]
Maybe Description
Name
_otdDescription :: forall inputType.
ObjectTypeDefinition inputType -> Maybe Description
_otdName :: forall inputType. ObjectTypeDefinition inputType -> Name
_otdImplementsInterfaces :: forall inputType. ObjectTypeDefinition inputType -> [Name]
_otdDirectives :: forall inputType.
ObjectTypeDefinition inputType -> [Directive Void]
_otdFieldsDefinition :: forall inputType.
ObjectTypeDefinition inputType -> [FieldDefinition inputType]
_otdDescription :: Maybe Description
_otdName :: Name
_otdImplementsInterfaces :: [Name]
_otdDirectives :: [Directive Void]
_otdFieldsDefinition :: [FieldDefinition inputType]
..} -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name]) -> [Name] -> Maybe [Name]
forall a b. (a -> b) -> a -> b
$ FieldDefinition inputType -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName (FieldDefinition inputType -> Name)
-> [FieldDefinition inputType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldDefinition inputType]
_otdFieldsDefinition
          G.TypeDefinitionInterface G.InterfaceTypeDefinition {possibleTypes
[FieldDefinition inputType]
[Directive Void]
Maybe Description
Name
_itdDescription :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> Maybe Description
_itdName :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> Name
_itdDirectives :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> [Directive Void]
_itdFieldsDefinition :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType
-> [FieldDefinition inputType]
_itdPossibleTypes :: forall possibleTypes inputType.
InterfaceTypeDefinition possibleTypes inputType -> possibleTypes
_itdDescription :: Maybe Description
_itdName :: Name
_itdDirectives :: [Directive Void]
_itdFieldsDefinition :: [FieldDefinition inputType]
_itdPossibleTypes :: possibleTypes
..} -> [Name] -> Maybe [Name]
forall a. a -> Maybe a
Just ([Name] -> Maybe [Name]) -> [Name] -> Maybe [Name]
forall a b. (a -> b) -> a -> b
$ FieldDefinition inputType -> Name
forall inputType. FieldDefinition inputType -> Name
G._fldName (FieldDefinition inputType -> Name)
-> [FieldDefinition inputType] -> [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldDefinition inputType]
_itdFieldsDefinition
          TypeDefinition possibleTypes inputType
_ -> Maybe [Name]
forall a. Maybe a
Nothing

    mkFieldRenameMap :: RemoteFieldCustomization -> [Name] -> HashMap Name Name
mkFieldRenameMap RemoteFieldCustomization {Maybe Name
HashMap Name Name
Name
_rfcParentType :: Name
_rfcPrefix :: Maybe Name
_rfcSuffix :: Maybe Name
_rfcMapping :: HashMap Name Name
_rfcParentType :: RemoteFieldCustomization -> Name
_rfcPrefix :: RemoteFieldCustomization -> Maybe Name
_rfcSuffix :: RemoteFieldCustomization -> Maybe Name
_rfcMapping :: RemoteFieldCustomization -> HashMap Name Name
..} [Name]
fieldNames =
      HashMap Name Name
_rfcMapping HashMap Name Name -> HashMap Name Name -> HashMap Name Name
forall a. Semigroup a => a -> a -> a
<> Maybe Name -> Maybe Name -> [Name] -> HashMap Name Name
mkPrefixSuffixMap Maybe Name
_rfcPrefix Maybe Name
_rfcSuffix [Name]
fieldNames

    fieldRenameMap :: HashMap Name (HashMap Name Name)
fieldRenameMap =
      case Maybe [RemoteFieldCustomization]
_rscFieldNames of
        Maybe [RemoteFieldCustomization]
Nothing -> HashMap Name (HashMap Name Name)
forall k v. HashMap k v
HashMap.empty
        Just [RemoteFieldCustomization]
fieldNameCustomizations ->
          let customizationMap :: HashMap Name RemoteFieldCustomization
customizationMap = [(Name, RemoteFieldCustomization)]
-> HashMap Name RemoteFieldCustomization
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([(Name, RemoteFieldCustomization)]
 -> HashMap Name RemoteFieldCustomization)
-> [(Name, RemoteFieldCustomization)]
-> HashMap Name RemoteFieldCustomization
forall a b. (a -> b) -> a -> b
$ (RemoteFieldCustomization -> (Name, RemoteFieldCustomization))
-> [RemoteFieldCustomization] -> [(Name, RemoteFieldCustomization)]
forall a b. (a -> b) -> [a] -> [b]
map (\RemoteFieldCustomization
rfc -> (RemoteFieldCustomization -> Name
_rfcParentType RemoteFieldCustomization
rfc, RemoteFieldCustomization
rfc)) [RemoteFieldCustomization]
fieldNameCustomizations
           in (RemoteFieldCustomization -> [Name] -> HashMap Name Name)
-> HashMap Name RemoteFieldCustomization
-> HashMap Name [Name]
-> HashMap Name (HashMap Name Name)
forall k v1 v2 v3.
(Eq k, Hashable k) =>
(v1 -> v2 -> v3) -> HashMap k v1 -> HashMap k v2 -> HashMap k v3
HashMap.intersectionWith RemoteFieldCustomization -> [Name] -> HashMap Name Name
mkFieldRenameMap HashMap Name RemoteFieldCustomization
customizationMap HashMap Name [Name]
typeFieldMap

    _rscNamespaceFieldName :: Maybe Name
_rscNamespaceFieldName = Maybe Name
_rscRootFieldsNamespace
    _rscCustomizeTypeName :: HashMap Name Name
_rscCustomizeTypeName = HashMap Name Name
typeRenameMap
    _rscCustomizeFieldName :: HashMap Name (HashMap Name Name)
_rscCustomizeFieldName = HashMap Name (HashMap Name Name)
fieldRenameMap

------------------------------------------------------------------------------
-- Local error handling

pErr :: (MonadFail m) => Text -> m a
pErr :: forall (m :: * -> *) a. MonadFail m => Text -> m a
pErr = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m a) -> (Text -> String) -> Text -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

throwRemoteSchema :: (QErrM m) => Text -> m a
throwRemoteSchema :: forall (m :: * -> *) a. QErrM m => Text -> m a
throwRemoteSchema = Code -> Text -> m a
forall (m :: * -> *) a. QErrM m => Code -> Text -> m a
throw400 Code
RemoteSchemaError

throwRemoteSchemaHttp ::
  (QErrM m) =>
  EnvRecord URI ->
  HTTP.HttpException ->
  m a
throwRemoteSchemaHttp :: forall (m :: * -> *) a.
QErrM m =>
EnvRecord URI -> HttpException -> m a
throwRemoteSchemaHttp EnvRecord URI
urlEnvRecord HttpException
exception =
  QErr -> m a
forall a. QErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
    (QErr -> m a) -> QErr -> m a
forall a b. (a -> b) -> a -> b
$ (EnvRecord URI -> QErr
forall {a}. EnvRecord a -> QErr
baseError EnvRecord URI
urlEnvRecord)
      { qeInternal :: Maybe QErrExtra
qeInternal = QErrExtra -> Maybe QErrExtra
forall a. a -> Maybe a
Just (QErrExtra -> Maybe QErrExtra) -> QErrExtra -> Maybe QErrExtra
forall a b. (a -> b) -> a -> b
$ Value -> QErrExtra
ExtraInternal (Value -> QErrExtra) -> Value -> QErrExtra
forall a b. (a -> b) -> a -> b
$ ShowErrorInfo -> HttpException -> Value
getHttpExceptionJson (Bool -> ShowErrorInfo
ShowErrorInfo Bool
True) (HttpException -> Value) -> HttpException -> Value
forall a b. (a -> b) -> a -> b
$ HttpException -> HttpException
HttpException HttpException
exception
      }
  where
    baseError :: EnvRecord a -> QErr
baseError EnvRecord a
val = Code -> Text -> QErr
err400 Code
RemoteSchemaError (EnvRecord a -> Text
forall {a}. EnvRecord a -> Text
httpExceptMsg EnvRecord a
val)
    httpExceptMsg :: EnvRecord a -> Text
httpExceptMsg EnvRecord a
val = Text
"HTTP exception occurred while sending the request to " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall a. Show a => a -> Text
tshow (EnvRecord a -> Text
forall {a}. EnvRecord a -> Text
_envVarName EnvRecord a
val)