graphql/src/Language/GraphQL/Execute/Coerce.hs

235 lines
11 KiB
Haskell
Raw Normal View History

{- This Source Code Form is subject to the terms of the Mozilla Public License,
v. 2.0. If a copy of the MPL was not distributed with this file, You can
obtain one at https://mozilla.org/MPL/2.0/. -}
{-# LANGUAGE ExplicitForAll #-}
2020-05-21 10:20:59 +02:00
{-# LANGUAGE OverloadedStrings #-}
2020-06-19 10:53:41 +02:00
{-# LANGUAGE ViewPatterns #-}
2020-05-21 10:20:59 +02:00
-- | Types and functions used for input and result coercion.
module Language.GraphQL.Execute.Coerce
2020-06-13 07:20:19 +02:00
( Output(..)
, Serialize(..)
, VariableValue(..)
, coerceInputLiteral
, matchFieldValues
2020-05-21 10:20:59 +02:00
) where
import qualified Data.Aeson as Aeson
2020-06-13 07:20:19 +02:00
import Data.Int (Int32)
2020-05-22 10:11:48 +02:00
import Data.HashMap.Strict (HashMap)
2020-05-21 10:20:59 +02:00
import qualified Data.HashMap.Strict as HashMap
2020-06-13 07:20:19 +02:00
import Data.Map.Strict (Map)
import Data.String (IsString(..))
import Data.Text (Text)
2020-05-22 10:11:48 +02:00
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
2020-05-21 10:20:59 +02:00
import Data.Scientific (toBoundedInteger, toRealFloat)
import Language.GraphQL.AST (Name)
2020-06-13 07:20:19 +02:00
import qualified Language.GraphQL.Type as Type
2020-05-24 13:51:00 +02:00
import qualified Language.GraphQL.Type.In as In
2020-06-13 07:20:19 +02:00
import qualified Language.GraphQL.Type.Out as Out
2020-05-21 10:20:59 +02:00
-- | 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).
2020-05-21 10:20:59 +02:00
-> a -- ^ Variable value being coerced.
2020-06-13 07:20:19 +02:00
-> Maybe Type.Value -- ^ Coerced value on success, 'Nothing' otherwise.
2020-05-21 10:20:59 +02:00
instance VariableValue Aeson.Value where
2020-06-13 07:20:19 +02:00
coerceVariableValue _ Aeson.Null = Just Type.Null
coerceVariableValue (In.ScalarBaseType scalarType) value
2020-06-13 07:20:19 +02:00
| (Aeson.String stringValue) <- value = Just $ Type.String stringValue
| (Aeson.Bool booleanValue) <- value = Just $ Type.Boolean booleanValue
2020-05-21 10:20:59 +02:00
| (Aeson.Number numberValue) <- value
2020-06-13 07:20:19 +02:00
, (Type.ScalarType "Float" _) <- scalarType =
Just $ Type.Float $ toRealFloat numberValue
2020-05-21 10:20:59 +02:00
| (Aeson.Number numberValue) <- value = -- ID or Int
2020-06-13 07:20:19 +02:00
Type.Int <$> toBoundedInteger numberValue
coerceVariableValue (In.EnumBaseType _) (Aeson.String stringValue) =
2020-06-13 07:20:19 +02:00
Just $ Type.Enum stringValue
coerceVariableValue (In.InputObjectBaseType objectType) value
2020-05-21 10:20:59 +02:00
| (Aeson.Object objectValue) <- value = do
let (In.InputObjectType _ _ inputFields) = objectType
2020-05-21 10:20:59 +02:00
(newObjectValue, resultMap) <- foldWithKey objectValue inputFields
if HashMap.null newObjectValue
2020-06-13 07:20:19 +02:00
then Just $ Type.Object resultMap
2020-05-21 10:20:59 +02:00
else Nothing
where
foldWithKey objectValue = HashMap.foldrWithKey matchFieldValues'
2020-05-21 10:20:59 +02:00
$ Just (objectValue, HashMap.empty)
matchFieldValues' _ _ Nothing = Nothing
matchFieldValues' fieldName inputField (Just (objectValue, resultMap)) =
let (In.InputField _ fieldType _) = inputField
2020-05-21 10:20:59 +02:00
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
2020-06-13 07:20:19 +02:00
| (Aeson.Array arrayValue) <- value =
Type.List <$> foldr foldVector (Just []) arrayValue
2020-05-21 10:20:59 +02:00
| otherwise = coerceVariableValue listType value
where
foldVector _ Nothing = Nothing
foldVector variableValue (Just list) = do
coerced <- coerceVariableValue listType variableValue
pure $ coerced : list
coerceVariableValue _ _ = Nothing
2020-05-22 10:11:48 +02:00
-- | 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
2020-06-13 07:20:19 +02:00
. (In.Type -> a -> Maybe Type.Value)
-> HashMap Name a
-> Name
-> In.Type
2020-06-13 07:20:19 +02:00
-> 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
2020-06-13 07:20:19 +02:00
coerceRuntimeValue (Just Type.Null)
| In.isNonNullType type' = Nothing
coerceRuntimeValue coercedValue =
HashMap.insert fieldName <$> coercedValue <*> resultMap
2020-05-22 10:11:48 +02:00
-- | Coerces operation arguments according to the input coercion rules for the
-- corresponding types.
2020-06-13 07:20:19 +02:00
coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
2020-06-19 10:53:41 +02:00
coerceInputLiteral (In.isNonNullType -> False) Type.Null = Just Type.Null
coerceInputLiteral (In.ScalarBaseType type') value
2020-06-13 07:20:19 +02:00
| (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
2020-05-22 10:11:48 +02:00
where
2020-06-13 07:20:19 +02:00
decimal = Type.String
2020-05-22 10:11:48 +02:00
. Text.Lazy.toStrict
. Text.Builder.toLazyText
. Text.Builder.decimal
2020-06-13 07:20:19 +02:00
coerceInputLiteral (In.EnumBaseType type') (Type.Enum enumValue)
| member enumValue type' = Just $ Type.Enum enumValue
where
2020-06-13 07:20:19 +02:00
member value (Type.EnumType _ _ members) = HashMap.member value members
coerceInputLiteral (In.InputObjectBaseType type') (Type.Object values) =
let (In.InputObjectType _ _ inputFields) = type'
2020-06-19 10:53:41 +02:00
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
2020-06-19 10:53:41 +02:00
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
2020-06-13 07:20:19 +02:00
-- | '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