From 882276a845c33c06b235d9604cbfd5b55d784c7d Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Sat, 13 Jun 2020 07:20:19 +0200 Subject: Coerce result Fixes #45. --- src/Language/GraphQL/Execute/Coerce.hs | 142 +++++++++++++++++++++++---------- 1 file changed, 102 insertions(+), 40 deletions(-) (limited to 'src/Language/GraphQL/Execute/Coerce.hs') diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs index b550bea..88ab412 100644 --- a/src/Language/GraphQL/Execute/Coerce.hs +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -3,21 +3,28 @@ -- | Types and functions used for input and result coercion. module Language.GraphQL.Execute.Coerce - ( VariableValue(..) + ( Output(..) + , Serialize(..) + , VariableValue(..) , coerceInputLiteral , matchFieldValues ) where import qualified Data.Aeson as Aeson +import Data.Int (Int32) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap +import Data.Map.Strict (Map) +import Data.String (IsString(..)) +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 qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In -import Language.GraphQL.Type.Definition +import qualified Language.GraphQL.Type.Out as Out -- | Since variables are passed separately from the query, in an independent -- format, they should be first coerced to the internal representation used by @@ -46,26 +53,26 @@ class VariableValue a where coerceVariableValue :: In.Type -- ^ Expected type (variable type given in the query). -> a -- ^ Variable value being coerced. - -> Maybe Value -- ^ Coerced value on success, 'Nothing' otherwise. + -> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise. instance VariableValue Aeson.Value where - coerceVariableValue _ Aeson.Null = Just Null + coerceVariableValue _ Aeson.Null = Just Type.Null coerceVariableValue (In.ScalarBaseType scalarType) value - | (Aeson.String stringValue) <- value = Just $ String stringValue - | (Aeson.Bool booleanValue) <- value = Just $ Boolean booleanValue + | (Aeson.String stringValue) <- value = Just $ Type.String stringValue + | (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue | (Aeson.Number numberValue) <- value - , (ScalarType "Float" _) <- scalarType = - Just $ Float $ toRealFloat numberValue + , (Type.ScalarType "Float" _) <- scalarType = + Just $ Type.Float $ toRealFloat numberValue | (Aeson.Number numberValue) <- value = -- ID or Int - Int <$> toBoundedInteger numberValue + Type.Int <$> toBoundedInteger numberValue coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) = - Just $ Enum 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 $ Object resultMap + then Just $ Type.Object resultMap else Nothing where foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues' @@ -81,8 +88,8 @@ instance VariableValue Aeson.Value where pure (newObjectValue, insert coerced) Nothing -> Just (objectValue, resultMap) coerceVariableValue (In.ListBaseType listType) value - | (Aeson.Array arrayValue) <- value = List - <$> foldr foldVector (Just []) arrayValue + | (Aeson.Array arrayValue) <- value = + Type.List <$> foldr foldVector (Just []) arrayValue | otherwise = coerceVariableValue listType value where foldVector _ Nothing = Nothing @@ -97,13 +104,13 @@ instance VariableValue Aeson.Value where -- result map. Otherwise it fails with 'Nothing' if the Input Type is a -- Non-Nullable type, or returns the unchanged, original map. matchFieldValues :: forall a - . (In.Type -> a -> Maybe Value) + . (In.Type -> a -> Maybe Type.Value) -> HashMap Name a -> Name -> In.Type - -> Maybe Value - -> Maybe (HashMap Name Value) - -> Maybe (HashMap Name Value) + -> Maybe Type.Value + -> Maybe (HashMap Name Type.Value) + -> Maybe (HashMap Name Type.Value) matchFieldValues coerce values' fieldName type' defaultValue resultMap = case HashMap.lookup fieldName values' of Just variableValue -> coerceRuntimeValue $ coerce type' variableValue @@ -114,44 +121,99 @@ matchFieldValues coerce values' fieldName type' defaultValue resultMap = , In.isNonNullType type' -> Nothing | otherwise -> resultMap where - coerceRuntimeValue (Just Null) + coerceRuntimeValue (Just Type.Null) | In.isNonNullType type' = Nothing coerceRuntimeValue coercedValue = HashMap.insert fieldName <$> coercedValue <*> resultMap -- | Coerces operation arguments according to the input coercion rules for the -- corresponding types. -coerceInputLiteral :: In.Type -> Value -> Maybe Value +coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value coerceInputLiteral (In.ScalarBaseType type') value - | (String stringValue) <- value - , (ScalarType "String" _) <- type' = Just $ String stringValue - | (Boolean booleanValue) <- value - , (ScalarType "Boolean" _) <- type' = Just $ Boolean booleanValue - | (Int intValue) <- value - , (ScalarType "Int" _) <- type' = Just $ Int intValue - | (Float floatValue) <- value - , (ScalarType "Float" _) <- type' = Just $ Float floatValue - | (Int intValue) <- value - , (ScalarType "Float" _) <- type' = - Just $ Float $ fromIntegral intValue - | (String stringValue) <- value - , (ScalarType "ID" _) <- type' = Just $ String stringValue - | (Int intValue) <- value - , (ScalarType "ID" _) <- type' = Just $ decimal intValue + | (Type.String stringValue) <- value + , (Type.ScalarType "String" _) <- type' = Just $ Type.String stringValue + | (Type.Boolean booleanValue) <- value + , (Type.ScalarType "Boolean" _) <- type' = Just $ Type.Boolean booleanValue + | (Type.Int intValue) <- value + , (Type.ScalarType "Int" _) <- type' = Just $ Type.Int intValue + | (Type.Float floatValue) <- value + , (Type.ScalarType "Float" _) <- type' = Just $ Type.Float floatValue + | (Type.Int intValue) <- value + , (Type.ScalarType "Float" _) <- type' = + Just $ Type.Float $ fromIntegral intValue + | (Type.String stringValue) <- value + , (Type.ScalarType "ID" _) <- type' = Just $ Type.String stringValue + | (Type.Int intValue) <- value + , (Type.ScalarType "ID" _) <- type' = Just $ decimal intValue where - decimal = String + decimal = Type.String . Text.Lazy.toStrict . Text.Builder.toLazyText . Text.Builder.decimal -coerceInputLiteral (In.EnumBaseType type') (Enum enumValue) - | member enumValue type' = Just $ Enum enumValue +coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue) + | member enumValue type' = Just $ Type.Enum enumValue where - member value (EnumType _ _ members) = HashMap.member value members -coerceInputLiteral (In.InputObjectBaseType type') (Object values) = + member value (Type.EnumType _ _ members) = HashMap.member value members +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = let (In.InputObjectType _ _ inputFields) = type' - in Object + in Type.Object <$> HashMap.foldrWithKey (matchFieldValues' values) (Just HashMap.empty) inputFields where matchFieldValues' values' fieldName (In.InputField _ inputFieldType defaultValue) = matchFieldValues coerceInputLiteral values' fieldName inputFieldType defaultValue coerceInputLiteral _ _ = Nothing + +-- | 'Serialize' describes how a @GraphQL@ value should be serialized. +class Serialize a where + -- | Serializes a @GraphQL@ value according to the given serialization + -- format. + -- + -- Type infomration is given as a hint, e.g. if you need to know what type + -- is being serialized to serialize it properly. Don't do any validation for + -- @GraphQL@ built-in types here. + -- + -- If the value cannot be serialized without losing information, return + -- 'Nothing' — it will cause a field error. + serialize :: forall m + . Out.Type m -- ^ Expected output type. + -> Output a -- ^ The value to be serialized. + -> Maybe a -- ^ Serialized value on success or 'Nothing'. + -- | __null__ representation in the given serialization format. + null :: a + +-- | Intermediate type used to serialize a @GraphQL@ value. +-- +-- The serialization is done during the execution, and 'Output' contains +-- already serialized data (in 'List' and 'Object') as well as the new layer +-- that has to be serialized in the current step. So 'Output' is parameterized +-- by the serialization format. +data Output a + = Int Int32 + | Float Double + | String Text + | Boolean Bool + | Enum Name + | List [a] + | Object (Map Name a) + deriving (Eq, Show) + +instance forall a. IsString (Output a) where + fromString = String . fromString + +instance Serialize Aeson.Value where + serialize (Out.ScalarBaseType scalarType) value + | Type.ScalarType "Int" _ <- scalarType + , Int int <- value = Just $ Aeson.toJSON int + | Type.ScalarType "Float" _ <- scalarType + , Float float <- value = Just $ Aeson.toJSON float + | Type.ScalarType "String" _ <- scalarType + , String string <- value = Just $ Aeson.String string + | Type.ScalarType "ID" _ <- scalarType + , String string <- value = Just $ Aeson.String string + | Type.ScalarType "Boolean" _ <- scalarType + , Boolean boolean <- value = Just $ Aeson.Bool boolean + serialize _ (Enum enum) = Just $ Aeson.String enum + serialize _ (List list) = Just $ Aeson.toJSON list + serialize _ (Object object) = Just $ Aeson.toJSON object + serialize _ _ = Nothing + null = Aeson.Null -- cgit v1.2.3