231 lines
10 KiB
Haskell
231 lines
10 KiB
Haskell
{-# 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
|