aboutsummaryrefslogtreecommitdiff
path: root/src/Language/GraphQL
diff options
context:
space:
mode:
Diffstat (limited to 'src/Language/GraphQL')
-rw-r--r--src/Language/GraphQL/Execute/Coerce.hs97
-rw-r--r--src/Language/GraphQL/Type/Schema.hs4
-rw-r--r--src/Language/GraphQL/Validate/Rules.hs12
3 files changed, 84 insertions, 29 deletions
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs
index f5ee204..9bc6b10 100644
--- a/src/Language/GraphQL/Execute/Coerce.hs
+++ b/src/Language/GraphQL/Execute/Coerce.hs
@@ -5,6 +5,7 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP #-}
-- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce
@@ -15,7 +16,10 @@ module Language.GraphQL.Execute.Coerce
, matchFieldValues
) where
+#ifdef WITH_JSON
import qualified Data.Aeson as Aeson
+import Data.Scientific (toBoundedInteger, toRealFloat)
+#endif
import Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
@@ -24,7 +28,6 @@ import Data.Text (Text)
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Data.Text.Lazy.Builder.Int as Text.Builder
-import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name)
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
@@ -61,20 +64,13 @@ class VariableValue a where
-> a -- ^ Variable value being coerced.
-> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
-instance VariableValue Aeson.Value where
- coerceVariableValue _ Aeson.Null = Just Type.Null
- coerceVariableValue (In.ScalarBaseType scalarType) value
- | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
- | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
- | (Aeson.Number numberValue) <- value
- , (Type.ScalarType "Float" _) <- scalarType =
- Just $ Type.Float $ toRealFloat numberValue
- | (Aeson.Number numberValue) <- value = -- ID or Int
- Type.Int <$> toBoundedInteger numberValue
- coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
+instance VariableValue Type.Value where
+ coerceVariableValue _ Type.Null = Just Type.Null
+ coerceVariableValue (In.ScalarBaseType _) value = Just value
+ coerceVariableValue (In.EnumBaseType _) (Type.Enum stringValue) =
Just $ Type.Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) value
- | (Aeson.Object objectValue) <- value = do
+ | (Type.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue
@@ -94,14 +90,9 @@ instance VariableValue Aeson.Value where
pure (newObjectValue, insert coerced)
Nothing -> Just (objectValue, resultMap)
coerceVariableValue (In.ListBaseType listType) value
- | (Aeson.Array arrayValue) <- value =
- Type.List <$> foldr foldVector (Just []) arrayValue
+ | (Type.List arrayValue) <- value =
+ Type.List <$> traverse (coerceVariableValue listType) arrayValue
| otherwise = coerceVariableValue listType value
- where
- foldVector _ Nothing = Nothing
- foldVector variableValue (Just list) = do
- coerced <- coerceVariableValue listType variableValue
- pure $ coerced : list
coerceVariableValue _ _ = Nothing
-- | Looks up a value by name in the given map, coerces it and inserts into the
@@ -216,6 +207,28 @@ data Output a
instance forall a. IsString (Output a) where
fromString = String . fromString
+instance Serialize Type.Value where
+ null = Type.Null
+ serialize (Out.ScalarBaseType scalarType) value
+ | Type.ScalarType "Int" _ <- scalarType
+ , Int int <- value = Just $ Type.Int int
+ | Type.ScalarType "Float" _ <- scalarType
+ , Float float <- value = Just $ Type.Float float
+ | Type.ScalarType "String" _ <- scalarType
+ , String string <- value = Just $ Type.String string
+ | Type.ScalarType "ID" _ <- scalarType
+ , String string <- value = Just $ Type.String string
+ | Type.ScalarType "Boolean" _ <- scalarType
+ , Boolean boolean <- value = Just $ Type.Boolean boolean
+ serialize _ (Enum enum) = Just $ Type.Enum enum
+ serialize _ (List list) = Just $ Type.List list
+ serialize _ (Object object) = Just
+ $ Type.Object
+ $ HashMap.fromList
+ $ OrderedMap.toList object
+ serialize _ _ = Nothing
+
+#ifdef WITH_JSON
instance Serialize Aeson.Value where
serialize (Out.ScalarBaseType scalarType) value
| Type.ScalarType "Int" _ <- scalarType
@@ -236,3 +249,47 @@ instance Serialize Aeson.Value where
$ Aeson.toJSON <$> object
serialize _ _ = Nothing
null = Aeson.Null
+
+instance VariableValue Aeson.Value where
+ coerceVariableValue _ Aeson.Null = Just Type.Null
+ coerceVariableValue (In.ScalarBaseType scalarType) value
+ | (Aeson.String stringValue) <- value = Just $ Type.String stringValue
+ | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
+ | (Aeson.Number numberValue) <- value
+ , (Type.ScalarType "Float" _) <- scalarType =
+ Just $ Type.Float $ toRealFloat numberValue
+ | (Aeson.Number numberValue) <- value = -- ID or Int
+ Type.Int <$> toBoundedInteger numberValue
+ coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
+ Just $ Type.Enum stringValue
+ coerceVariableValue (In.InputObjectBaseType objectType) value
+ | (Aeson.Object objectValue) <- value = do
+ let (In.InputObjectType _ _ inputFields) = objectType
+ (newObjectValue, resultMap) <- foldWithKey objectValue inputFields
+ if HashMap.null newObjectValue
+ then Just $ Type.Object resultMap
+ else Nothing
+ where
+ foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
+ $ Just (objectValue, HashMap.empty)
+ matchFieldValues' _ _ Nothing = Nothing
+ matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
+ let (In.InputField _ fieldType _) = inputField
+ insert = flip (HashMap.insert fieldName) resultMap
+ newObjectValue = HashMap.delete fieldName objectValue
+ in case HashMap.lookup fieldName objectValue of
+ Just variableValue -> do
+ coerced <- coerceVariableValue fieldType variableValue
+ pure (newObjectValue, insert coerced)
+ Nothing -> Just (objectValue, resultMap)
+ coerceVariableValue (In.ListBaseType listType) value
+ | (Aeson.Array arrayValue) <- value =
+ Type.List <$> foldr foldVector (Just []) arrayValue
+ | otherwise = coerceVariableValue listType value
+ where
+ foldVector _ Nothing = Nothing
+ foldVector variableValue (Just list) = do
+ coerced <- coerceVariableValue listType variableValue
+ pure $ coerced : list
+ coerceVariableValue _ _ = Nothing
+#endif
diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs
index ddddb4a..c8ac77a 100644
--- a/src/Language/GraphQL/Type/Schema.hs
+++ b/src/Language/GraphQL/Type/Schema.hs
@@ -205,5 +205,5 @@ collectImplementations = HashMap.foldr go HashMap.empty
let Out.ObjectType _ _ interfaces _ = objectType
in foldr (add implementation) accumulator interfaces
go _ accumulator = accumulator
- add implementation (Out.InterfaceType typeName _ _ _) accumulator =
- HashMap.insertWith (++) typeName [implementation] accumulator
+ add implementation (Out.InterfaceType typeName _ _ _) =
+ HashMap.insertWith (++) typeName [implementation]
diff --git a/src/Language/GraphQL/Validate/Rules.hs b/src/Language/GraphQL/Validate/Rules.hs
index 46a14b7..d7cc395 100644
--- a/src/Language/GraphQL/Validate/Rules.hs
+++ b/src/Language/GraphQL/Validate/Rules.hs
@@ -152,7 +152,7 @@ singleFieldSubscriptionsRule = OperationDefinitionRule $ \case
where
errorMessage =
"Anonymous Subscription must select only one top level field."
- collectFields selectionSet = foldM forEach HashSet.empty selectionSet
+ collectFields = foldM forEach HashSet.empty
forEach accumulator = \case
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
Full.FragmentSpreadSelection fragmentSelection ->
@@ -472,7 +472,7 @@ noFragmentCyclesRule = FragmentDefinitionRule $ \case
collectCycles :: Traversable t
=> t Full.Selection
-> StateT (Int, Full.Name) (ReaderT (Validation m) Seq) (HashMap Full.Name Int)
- collectCycles selectionSet = foldM forEach HashMap.empty selectionSet
+ collectCycles = foldM forEach HashMap.empty
forEach accumulator = \case
Full.FieldSelection fieldSelection -> forField accumulator fieldSelection
Full.InlineFragmentSelection fragmentSelection ->
@@ -702,8 +702,7 @@ uniqueInputFieldNamesRule =
where
go (Full.Node (Full.Object fields) _) = filterFieldDuplicates fields
go _ = mempty
- filterFieldDuplicates fields =
- filterDuplicates getFieldName "input field" fields
+ filterFieldDuplicates = filterDuplicates getFieldName "input field"
getFieldName (Full.ObjectField fieldName _ location') = (fieldName, location')
constGo (Full.Node (Full.ConstObject fields) _) = filterFieldDuplicates fields
constGo _ = mempty
@@ -1331,8 +1330,8 @@ variablesInAllowedPositionRule = OperationDefinitionRule $ \case
-> Type.CompositeType m
-> t Full.Selection
-> ValidationState m (Seq Error)
- visitSelectionSet variables selectionType selections =
- foldM (evaluateSelection variables selectionType) mempty selections
+ visitSelectionSet variables selectionType =
+ foldM (evaluateSelection variables selectionType) mempty
evaluateFieldSelection variables selections accumulator = \case
Just newParentType -> do
let folder = evaluateSelection variables newParentType
@@ -1617,4 +1616,3 @@ valuesOfCorrectTypeRule = ValueRule go constGo
}
| otherwise -> mempty
_ -> checkResult
-
generated by cgit v1.2.3 (git 2.26.2) at 2026-10-02 09:35:40 +0000