1
0
mirror of https://github.com/hasura/graphql-engine.git synced 2024-12-27 17:36:15 +03:00
graphql-engine/server/src-lib/Hasura/GraphQL/Parser/Internal/Parser.hs
Robert 11a454c2d6 server, pro: actually reformat the code-base using ormolu
This commit applies ormolu to the whole Haskell code base by running `make format`.

For in-flight branches, simply merging changes from `main` will result in merge conflicts.
To avoid this, update your branch using the following instructions. Replace `<format-commit>`
by the hash of *this* commit.

$ git checkout my-feature-branch
$ git merge <format-commit>^    # and resolve conflicts normally
$ make format
$ git commit -a -m "reformat with ormolu"
$ git merge -s ours post-ormolu

https://github.com/hasura/graphql-engine-mono/pull/2404

GitOrigin-RevId: 75049f5c12f430c615eafb4c6b8e83e371e01c8e
2021-09-23 22:57:37 +00:00

378 lines
15 KiB
Haskell
Raw Blame History

This file contains ambiguous Unicode characters

This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{-# OPTIONS_HADDOCK not-home #-}
-- | Defines the 'Parser' type and its primitive combinators.
module Hasura.GraphQL.Parser.Internal.Parser
( module Hasura.GraphQL.Parser.Internal.Parser,
module Hasura.GraphQL.Parser.Internal.Input,
Parser (..),
parserType,
runParser,
ParserInput,
)
where
import Data.Aeson qualified as A
import Data.HashMap.Strict.Extended qualified as M
import Data.HashMap.Strict.InsOrd qualified as OMap
import Data.HashSet qualified as S
import Data.List.Extended qualified as LE
import Data.Parser.JSONPath
import Data.Text.Extended
import Data.Type.Equality
import Hasura.Base.Error
import Hasura.GraphQL.Parser.Class.Parse
import Hasura.GraphQL.Parser.Collect
import Hasura.GraphQL.Parser.Directives
import Hasura.GraphQL.Parser.Internal.Input
import Hasura.GraphQL.Parser.Internal.TypeChecking
import Hasura.GraphQL.Parser.Internal.Types
import Hasura.GraphQL.Parser.Schema
import Hasura.Prelude
import Language.GraphQL.Draft.Syntax hiding (Definition)
import Language.GraphQL.Draft.Syntax qualified as G
infixl 1 `bind`
bind :: Monad m => Parser k m a -> (a -> m b) -> Parser k m b
bind p f = p {pParser = pParser p >=> f}
infixl 1 `bindFields`
bindFields :: Monad m => InputFieldsParser m a -> (a -> m b) -> InputFieldsParser m b
bindFields p f = p {ifParser = ifParser p >=> f}
-- | A parser for a single field in a selection set. Build a 'FieldParser'
-- with 'selection' or 'subselection', and combine them together with
-- 'selectionSet' to obtain a 'Parser'.
data FieldParser m a = FieldParser
{ fDefinition :: Definition FieldInfo,
fParser :: Field NoFragments Variable -> m a
}
deriving (Functor)
instance HasDefinition (FieldParser m a) FieldInfo where
definitionLens f parser = definitionLens f (fDefinition parser) <&> \fDefinition -> parser {fDefinition}
infixl 1 `bindField`
bindField :: Monad m => FieldParser m a -> (a -> m b) -> FieldParser m b
bindField p f = p {fParser = fParser p >=> f}
-- | A single parsed field in a selection set.
data ParsedSelection a
= -- | An ordinary field.
SelectField a
| -- | The magical @__typename@ field, implicitly available on all objects
-- <as part of GraphQL introspection http://spec.graphql.org/June2018/#sec-Type-Name-Introspection>.
SelectTypename Name
deriving (Functor)
handleTypename :: (Name -> a) -> ParsedSelection a -> a
handleTypename _ (SelectField value) = value
handleTypename f (SelectTypename name) = f name
nullable :: forall k m a. (MonadParse m, 'Input <: k) => Parser k m a -> Parser k m (Maybe a)
nullable parser =
gcastWith
(inputParserInput @k)
Parser
{ pType = schemaType,
pParser =
peelVariable (toGraphQLType schemaType) >=> \case
JSONValue A.Null -> pure Nothing
GraphQLValue VNull -> pure Nothing
value -> Just <$> pParser parser value
}
where
schemaType = nullableType $ pType parser
-- | Decorate a schema field as NON_NULL
nonNullableField :: forall m a. FieldParser m a -> FieldParser m a
nonNullableField (FieldParser (Definition n u d (FieldInfo as t)) p) =
FieldParser (Definition n u d (FieldInfo as (nonNullableType t))) p
-- | Decorate a schema field as NULL
nullableField :: forall m a. FieldParser m a -> FieldParser m a
nullableField (FieldParser (Definition n u d (FieldInfo as t)) p) =
FieldParser (Definition n u d (FieldInfo as (nullableType t))) p
multipleField :: forall m a. FieldParser m a -> FieldParser m a
multipleField (FieldParser (Definition n u d (FieldInfo as t)) p) =
FieldParser (Definition n u d (FieldInfo as (Nullable (TList t)))) p
-- | Decorate a schema field with reference to given @'G.GType'
wrapFieldParser :: forall m a. G.GType -> FieldParser m a -> FieldParser m a
wrapFieldParser = \case
G.TypeNamed (G.Nullability True) _ -> nullableField
G.TypeNamed (G.Nullability False) _ -> nonNullableField
G.TypeList (G.Nullability True) t -> nullableField . multipleField . wrapFieldParser t
G.TypeList (G.Nullability False) t -> nonNullableField . multipleField . wrapFieldParser t
-- | Decorate a schema output type as NON_NULL
nonNullableParser :: forall m a. Parser 'Output m a -> Parser 'Output m a
nonNullableParser parser = parser {pType = nonNullableType (pType parser)}
-- | Make a schema output as nullable
nullableParser :: forall m a. Parser 'Output m a -> Parser 'Output m a
nullableParser parser = parser {pType = nullableType (pType parser)}
multiple :: forall m a. Parser 'Output m a -> Parser 'Output m a
multiple parser = parser {pType = Nullable $ TList $ pType parser}
-- | A variant of 'selectionSetObject' which doesn't implement any interfaces
selectionSet ::
MonadParse m =>
Name ->
Maybe Description ->
[FieldParser m a] ->
Parser 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a))
selectionSet name desc fields = selectionSetObject name desc fields []
safeSelectionSet ::
(MonadError QErr n, MonadParse m) =>
Name ->
Maybe Description ->
[FieldParser m a] ->
n (Parser 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a)))
safeSelectionSet name desc fields
| S.null duplicates = pure $ selectionSetObject name desc fields []
| otherwise = throw500 $ case desc of
Nothing -> "found duplicate fields in selection set: " <> duplicatesList
Just d -> "found duplicate fields in selection set for " <> unDescription d <> ": " <> duplicatesList
where
duplicates = LE.duplicates $ getName . fDefinition <$> fields
duplicatesList = commaSeparated $ unName <$> toList duplicates
-- Should this rather take a non-empty `FieldParser` list?
-- See also Note [Selectability of tables].
selectionSetObject ::
MonadParse m =>
Name ->
Maybe Description ->
-- | Fields of this object, including any fields that are required from the
-- interfaces that it implements. Note that we can't derive those fields from
-- the list of interfaces (next argument), because the types of the fields of
-- the object are only required to be *subtypes* of the types of the fields of
-- the interfaces it implements.
[FieldParser m a] ->
-- | Interfaces implemented by this object;
-- see Note [The interfaces story] in Hasura.GraphQL.Parser.Schema.
[Parser 'Output m b] ->
Parser 'Output m (OMap.InsOrdHashMap Name (ParsedSelection a))
selectionSetObject name description parsers implementsInterfaces =
Parser
{ pType =
Nullable $
TNamed $
mkDefinition name description $
TIObject $ ObjectInfo (map fDefinition parsers) interfaces,
pParser = \input -> withPath (++ [Key "selectionSet"]) do
-- Not all fields have a selection set, but if they have one, it
-- must contain at least one field. The GraphQL parser returns a
-- list to represent this: an empty list indicates there was no
-- selection set, as an empty set is rejected outright.
-- Arguably, this would be better represented by a `Maybe
-- (NonEmpty a)`.
-- The parser can't know whether a given field needs a selection
-- set or not; but if we're in this function, it means that yes:
-- this field needs a selection set, and if none was provided,
-- we must fail.
when (null input) $
parseError $ "missing selection set for " <>> name
-- TODO(PDV) This probably accepts invalid queries, namely queries that use
-- type names that do not exist.
fields <- collectFields (name : parsedInterfaceNames) input
for fields \selectionField@Field {_fName, _fAlias, _fDirectives} -> do
parsedValue <-
if
| _fName == $$(litName "__typename") ->
pure $ SelectTypename name
| Just parser <- M.lookup _fName parserMap ->
withPath (++ [Key (unName _fName)]) $
SelectField <$> parser selectionField
| otherwise ->
withPath (++ [Key (unName _fName)]) $
parseError $ "field " <> _fName <<> " not found in type: " <> squote name
_dirMap <- parseDirectives customDirectives (DLExecutable EDLFIELD) _fDirectives
-- insert processing of custom directives here
pure parsedValue
}
where
parserMap =
parsers
& map (\FieldParser {fDefinition, fParser} -> (getName fDefinition, fParser))
& M.fromList
interfaces = mapMaybe (getInterfaceInfo . pType) implementsInterfaces
parsedInterfaceNames = fmap getName interfaces
selectionSetInterface ::
(MonadParse n, Traversable t) =>
Name ->
Maybe Description ->
-- | Fields defined in this interface
[FieldParser n a] ->
-- | Parsers for the object types that implement this interface; see
-- Note [The interfaces story] in Hasura.GraphQL.Parser.Schema for details.
t (Parser 'Output n b) ->
Parser 'Output n (t b)
selectionSetInterface name description fields objectImplementations =
Parser
{ pType =
Nullable $
TNamed $
mkDefinition name description $
TIInterface $ InterfaceInfo (map fDefinition fields) objects,
pParser = \input -> for objectImplementations (($ input) . pParser)
-- Note: This is somewhat suboptimal, since it parses a query against every
-- possible object implementing this interface, possibly duplicating work for
-- fields defined on the interface itself.
--
-- Furthermore, in our intended use case (Relay), based on a field argument,
-- we can decide which object we are about to retrieve, so in theory we could
-- save some work by only parsing against that object type. But its still
-- useful to parse against all of them, since it checks the validity of any
-- fragments on the other types.
}
where
objects = catMaybes $ toList $ fmap (getObjectInfo . pType) objectImplementations
selectionSetUnion ::
(MonadParse n, Traversable t) =>
Name ->
Maybe Description ->
-- | The member object types.
t (Parser 'Output n b) ->
Parser 'Output n (t b)
selectionSetUnion name description objectImplementations =
Parser
{ pType =
Nullable $
TNamed $
mkDefinition name description $
TIUnion $ UnionInfo objects,
pParser = \input -> for objectImplementations (($ input) . pParser)
}
where
objects = catMaybes $ toList $ fmap (getObjectInfo . pType) objectImplementations
-- | Builds a 'FieldParser' for a field that does not take a subselection set,
-- i.e. a field that returns a scalar or enum. The fields type is taken from
-- the provided 'Parser', but the 'Parser' is not otherwise used.
--
-- See also Note [The delicate balance of GraphQL kinds] in "Hasura.GraphQL.Parser.Schema".
selection ::
forall m a b.
MonadParse m =>
Name ->
Maybe Description ->
-- | parser for the input arguments
InputFieldsParser m a ->
-- | type of the result
Parser 'Both m b ->
FieldParser m a
selection name description argumentsParser resultParser =
rawSelection name description argumentsParser resultParser
<&> \(_alias, _args, a) -> a
rawSelection ::
forall m a b.
MonadParse m =>
Name ->
Maybe Description ->
-- | parser for the input arguments
InputFieldsParser m a ->
-- | type of the result
Parser 'Both m b ->
-- | alias provided (if any), and the arguments
FieldParser m (Maybe Name, HashMap Name (Value Variable), a)
rawSelection name description argumentsParser resultParser =
FieldParser
{ fDefinition =
mkDefinition name description $
FieldInfo (ifDefinitions argumentsParser) (pType resultParser),
fParser = \Field {_fAlias, _fArguments, _fSelectionSet} -> do
unless (null _fSelectionSet) $
parseError "unexpected subselection set for non-object field"
-- check for extraneous arguments here, since the InputFieldsParser just
-- handles parsing the fields it cares about
for_ (M.keys _fArguments) \argumentName ->
unless (argumentName `S.member` argumentNames) $
parseError $ name <<> " has no argument named " <>> argumentName
fmap (_fAlias,_fArguments,) $ withPath (++ [Key "args"]) $ ifParser argumentsParser $ GraphQLValue <$> _fArguments
}
where
-- If `ifDefinitions` is empty, then not forcing this will lead to
-- a thunk which is usually never forced because the definition is only used
-- inside the loop which checks arguments have the correct name.
-- Forcing it will lead to the statically allocated empty set.
-- If it's non-empty then it will be forced the first time the parser
-- is used so might as well force it when constructing the parser.
!argumentNames = S.fromList (dName <$> ifDefinitions argumentsParser)
-- | Builds a 'FieldParser' for a field that takes a subselection set, i.e. a
-- field that returns an object.
--
-- See also Note [The delicate balance of GraphQL kinds] in "Hasura.GraphQL.Parser.Schema".
subselection ::
forall m a b.
MonadParse m =>
Name ->
Maybe Description ->
-- | parser for the input arguments
InputFieldsParser m a ->
-- | parser for the subselection set
Parser 'Output m b ->
FieldParser m (a, b)
subselection name description argumentsParser bodyParser =
rawSubselection name description argumentsParser bodyParser
<&> \(_alias, _args, a, b) -> (a, b)
rawSubselection ::
forall m a b.
MonadParse m =>
Name ->
Maybe Description ->
-- | parser for the input arguments
InputFieldsParser m a ->
-- | parser for the subselection set
Parser 'Output m b ->
FieldParser m (Maybe Name, HashMap Name (Value Variable), a, b)
rawSubselection name description argumentsParser bodyParser =
FieldParser
{ fDefinition =
mkDefinition name description $
FieldInfo (ifDefinitions argumentsParser) (pType bodyParser),
fParser = \Field {_fAlias, _fArguments, _fSelectionSet} -> do
-- check for extraneous arguments here, since the InputFieldsParser just
-- handles parsing the fields it cares about
for_ (M.keys _fArguments) \argumentName ->
unless (argumentName `S.member` argumentNames) $
parseError $ name <<> " has no argument named " <>> argumentName
(_fAlias,_fArguments,,) <$> withPath (++ [Key "args"]) (ifParser argumentsParser $ GraphQLValue <$> _fArguments)
<*> pParser bodyParser _fSelectionSet
}
where
argumentNames = S.fromList (dName <$> ifDefinitions argumentsParser)
-- | A shorthand for a 'selection' that takes no arguments.
selection_ ::
MonadParse m =>
Name ->
Maybe Description ->
-- | type of the result
Parser 'Both m a ->
FieldParser m ()
selection_ name description = selection name description (pure ())
-- | A shorthand for a 'subselection' that takes no arguments.
subselection_ ::
MonadParse m =>
Name ->
Maybe Description ->
-- | parser for the subselection set
Parser 'Output m a ->
FieldParser m a
subselection_ name description bodyParser =
snd <$> subselection name description (pure ()) bodyParser