diff options
Diffstat (limited to 'src/Language/GraphQL/Execute/Coerce.hs')
| -rw-r--r-- | src/Language/GraphQL/Execute/Coerce.hs | 230 |
1 files changed, 230 insertions, 0 deletions
diff --git a/src/Language/GraphQL/Execute/Coerce.hs b/src/Language/GraphQL/Execute/Coerce.hs new file mode 100644 index 0000000..60fb71d --- /dev/null +++ b/src/Language/GraphQL/Execute/Coerce.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | Types and functions used for input and result coercion. +module Language.GraphQL.Execute.Coerce + ( 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 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 +-- this implementation. +class VariableValue a where + -- | Only a basic, format-specific, coercion must be done here. Type + -- correctness or nullability shouldn't be validated here, they will be + -- validated later. The type information is provided only as a hint. + -- + -- For example @GraphQL@ prohibits the coercion from a 't:Float' to an + -- 't:Int', but @JSON@ doesn't have integers, so whole numbers should be + -- coerced to 't:Int` when receiving variables as a JSON object. The same + -- holds for 't:Enum'. There are formats that support enumerations, @JSON@ + -- doesn't, so the type information is given and 'coerceVariableValue' can + -- check that an 't:Enum' is expected and treat the given value + -- appropriately. Even checking whether this value is a proper member of the + -- corresponding 't:Enum' type isn't required here, since this can be + -- checked independently. + -- + -- Another example is an @ID@. @GraphQL@ explicitly allows to coerce + -- integers and strings to @ID@s, so if an @ID@ is received as an integer, + -- it can be left as is and will be coerced later. + -- + -- If a value cannot be coerced without losing information, 'Nothing' should + -- be returned, the coercion will fail then and the query won't be executed. + coerceVariableValue + :: In.Type -- ^ Expected type (variable type given in the query). + -> 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) = + 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 + +-- | Looks up a value by name in the given map, coerces it and inserts into the +-- result map. If the coercion fails, returns 'Nothing'. If the value isn't +-- given, but a default value is known, inserts the default value into the +-- 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 Type.Value) + -> HashMap Name a + -> Name + -> In.Type + -> 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 + Nothing + | Just value <- defaultValue -> + HashMap.insert fieldName value <$> resultMap + | Nothing <- defaultValue + , In.isNonNullType type' -> Nothing + | otherwise -> resultMap + where + 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 -> Type.Value -> Maybe Type.Value +coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null +coerceInputLiteral (In.ScalarBaseType type') value + | (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 = Type.String + . Text.Lazy.toStrict + . Text.Builder.toLazyText + . Text.Builder.decimal +coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue) + | member enumValue type' = Just $ Type.Enum enumValue + where + member value (Type.EnumType _ _ members) = HashMap.member value members +coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) = + let (In.InputObjectType _ _ inputFields) = type' + 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 (In.ListBaseType listType) (Type.List list) = + Type.List <$> traverse (coerceInputLiteral listType) list +coerceInputLiteral (In.ListBaseType listType) singleton = + wrapSingleton listType singleton + where + wrapSingleton (In.ListBaseType listType') singleton' = + Type.List <$> sequence [wrapSingleton listType' singleton'] + wrapSingleton listType' singleton' = + Type.List <$> sequence [coerceInputLiteral listType' singleton'] +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 |