{- 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 #-}
{-# 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 Data.Int (Int32)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
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 Language.GraphQL.AST (Name)
import Language.GraphQL.Execute.OrderedMap (OrderedMap)
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
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 Type.Value where
    coerceVariableValue :: Type -> Value -> Maybe Value
coerceVariableValue Type
_ Value
Type.Null = forall a. a -> Maybe a
Just Value
Type.Null
    coerceVariableValue (In.ScalarBaseType ScalarType
_) Value
value = forall a. a -> Maybe a
Just Value
value
    coerceVariableValue (In.EnumBaseType EnumType
_) (Type.Enum Name
stringValue) =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.Enum Name
stringValue
    coerceVariableValue (In.InputObjectBaseType InputObjectType
objectType) Value
value
        | (Type.Object HashMap Name Value
objectValue) <- Value
value = do
            let (In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
inputFields) = InputObjectType
objectType
            (HashMap Name Value
newObjectValue, HashMap Name Value
resultMap) <- forall {a} {k}.
(VariableValue a, Hashable k) =>
HashMap k a
-> HashMap k InputField -> Maybe (HashMap k a, HashMap k Value)
foldWithKey HashMap Name Value
objectValue HashMap Name InputField
inputFields
            if forall k v. HashMap k v -> Bool
HashMap.null HashMap Name Value
newObjectValue
                then forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HashMap Name Value -> Value
Type.Object HashMap Name Value
resultMap
                else forall a. Maybe a
Nothing
      where
        foldWithKey :: HashMap k a
-> HashMap k InputField -> Maybe (HashMap k a, HashMap k Value)
foldWithKey HashMap k a
objectValue = forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey forall {k} {a}.
(VariableValue a, Hashable k) =>
k
-> InputField
-> Maybe (HashMap k a, HashMap k Value)
-> Maybe (HashMap k a, HashMap k Value)
matchFieldValues'
            forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (HashMap k a
objectValue, forall k v. HashMap k v
HashMap.empty)
        matchFieldValues' :: k
-> InputField
-> Maybe (HashMap k a, HashMap k Value)
-> Maybe (HashMap k a, HashMap k Value)
matchFieldValues' k
_ InputField
_ Maybe (HashMap k a, HashMap k Value)
Nothing = forall a. Maybe a
Nothing
        matchFieldValues' k
fieldName InputField
inputField (Just (HashMap k a
objectValue, HashMap k Value
resultMap)) =
            let (In.InputField Maybe Name
_ Type
fieldType Maybe Value
_) = InputField
inputField
                insert :: Value -> HashMap k Value
insert = forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert k
fieldName) HashMap k Value
resultMap
                newObjectValue :: HashMap k a
newObjectValue = forall k v. (Eq k, Hashable k) => k -> HashMap k v -> HashMap k v
HashMap.delete k
fieldName HashMap k a
objectValue
             in case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup k
fieldName HashMap k a
objectValue of
                    Just a
variableValue -> do
                        Value
coerced <- forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
fieldType a
variableValue
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (HashMap k a
newObjectValue, Value -> HashMap k Value
insert Value
coerced)
                    Maybe a
Nothing -> forall a. a -> Maybe a
Just (HashMap k a
objectValue, HashMap k Value
resultMap)
    coerceVariableValue (In.ListBaseType Type
listType) Value
value
        | (Type.List [Value]
arrayValue) <- Value
value =
            [Value] -> Value
Type.List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
listType) [Value]
arrayValue
        | Bool
otherwise = forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
listType Value
value
    coerceVariableValue Type
_ Value
_ = forall a. Maybe a
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 :: forall a.
(Type -> a -> Maybe Value)
-> HashMap Name a
-> Name
-> Type
-> Maybe Value
-> Maybe (HashMap Name Value)
-> Maybe (HashMap Name Value)
matchFieldValues Type -> a -> Maybe Value
coerce HashMap Name a
values' Name
fieldName Type
type' Maybe Value
defaultValue Maybe (HashMap Name Value)
resultMap =
    case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Name
fieldName HashMap Name a
values' of
        Just a
variableValue -> Maybe Value -> Maybe (HashMap Name Value)
coerceRuntimeValue forall a b. (a -> b) -> a -> b
$ Type -> a -> Maybe Value
coerce Type
type' a
variableValue
        Maybe a
Nothing
            | Just Value
value <- Maybe Value
defaultValue ->
                forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Name
fieldName Value
value forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (HashMap Name Value)
resultMap
            | Maybe Value
Nothing <- Maybe Value
defaultValue
            , Type -> Bool
In.isNonNullType Type
type' -> forall a. Maybe a
Nothing
            | Bool
otherwise -> Maybe (HashMap Name Value)
resultMap
  where
    coerceRuntimeValue :: Maybe Value -> Maybe (HashMap Name Value)
coerceRuntimeValue (Just Value
Type.Null)
        | Type -> Bool
In.isNonNullType Type
type' = forall a. Maybe a
Nothing
    coerceRuntimeValue Maybe Value
coercedValue =
        forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Name
fieldName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Value
coercedValue forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (HashMap Name Value)
resultMap

-- | Coerces operation arguments according to the input coercion rules for the
-- corresponding types.
coerceInputLiteral :: In.Type -> Type.Value -> Maybe Type.Value
coerceInputLiteral :: Type -> Value -> Maybe Value
coerceInputLiteral (Type -> Bool
In.isNonNullType -> Bool
False) Value
Type.Null = forall a. a -> Maybe a
Just Value
Type.Null
coerceInputLiteral (In.ScalarBaseType ScalarType
type') Value
value
    | (Type.String Name
stringValue) <- Value
value
    , (Type.ScalarType Name
"String" Maybe Name
_) <- ScalarType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.String Name
stringValue
    | (Type.Boolean Bool
booleanValue) <- Value
value
    , (Type.ScalarType Name
"Boolean" Maybe Name
_) <- ScalarType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> Value
Type.Boolean Bool
booleanValue
    | (Type.Int Int32
intValue) <- Value
value
    , (Type.ScalarType Name
"Int" Maybe Name
_) <- ScalarType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int32 -> Value
Type.Int Int32
intValue
    | (Type.Float Double
floatValue) <- Value
value
    , (Type.ScalarType Name
"Float" Maybe Name
_) <- ScalarType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Value
Type.Float Double
floatValue
    | (Type.Int Int32
intValue) <- Value
value
    , (Type.ScalarType Name
"Float" Maybe Name
_) <- ScalarType
type' =
        forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Value
Type.Float forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
intValue
    | (Type.String Name
stringValue) <- Value
value
    , (Type.ScalarType Name
"ID" Maybe Name
_) <- ScalarType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.String Name
stringValue
    | (Type.Int Int32
intValue) <- Value
value
    , (Type.ScalarType Name
"ID" Maybe Name
_) <- ScalarType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int32 -> Value
decimal Int32
intValue
  where
    decimal :: Int32 -> Value
decimal = Name -> Value
Type.String
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Name
Text.Lazy.toStrict
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Text.Builder.toLazyText
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Builder
Text.Builder.decimal
coerceInputLiteral (In.EnumBaseType EnumType
type') (Type.Enum Name
enumValue)
    | Name -> EnumType -> Bool
member Name
enumValue EnumType
type' = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.Enum Name
enumValue
  where
    member :: Name -> EnumType -> Bool
member Name
value (Type.EnumType Name
_ Maybe Name
_ HashMap Name EnumValue
members) = forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Name
value HashMap Name EnumValue
members
coerceInputLiteral (In.InputObjectBaseType InputObjectType
type') (Type.Object HashMap Name Value
values) = 
    let (In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
inputFields) = InputObjectType
type'
     in HashMap Name Value -> Value
Type.Object
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey (HashMap Name Value
-> Name
-> InputField
-> Maybe (HashMap Name Value)
-> Maybe (HashMap Name Value)
matchFieldValues' HashMap Name Value
values) (forall a. a -> Maybe a
Just forall k v. HashMap k v
HashMap.empty) HashMap Name InputField
inputFields
  where
    matchFieldValues' :: HashMap Name Value
-> Name
-> InputField
-> Maybe (HashMap Name Value)
-> Maybe (HashMap Name Value)
matchFieldValues' HashMap Name Value
values' Name
fieldName (In.InputField Maybe Name
_ Type
inputFieldType Maybe Value
defaultValue) =
        forall a.
(Type -> a -> Maybe Value)
-> HashMap Name a
-> Name
-> Type
-> Maybe Value
-> Maybe (HashMap Name Value)
-> Maybe (HashMap Name Value)
matchFieldValues Type -> Value -> Maybe Value
coerceInputLiteral HashMap Name Value
values' Name
fieldName Type
inputFieldType Maybe Value
defaultValue
coerceInputLiteral (In.ListBaseType Type
listType) (Type.List [Value]
list) =
    [Value] -> Value
Type.List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Type -> Value -> Maybe Value
coerceInputLiteral Type
listType) [Value]
list
coerceInputLiteral (In.ListBaseType Type
listType) Value
singleton =
    Type -> Value -> Maybe Value
wrapSingleton Type
listType Value
singleton
  where
      wrapSingleton :: Type -> Value -> Maybe Value
wrapSingleton (In.ListBaseType Type
listType') Value
singleton' =
          [Value] -> Value
Type.List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type -> Value -> Maybe Value
wrapSingleton Type
listType' Value
singleton']
      wrapSingleton Type
listType' Value
singleton' =
          [Value] -> Value
Type.List forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Type -> Value -> Maybe Value
coerceInputLiteral Type
listType' Value
singleton']
coerceInputLiteral Type
_ Value
_ = forall a. Maybe a
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 (OrderedMap a)
    deriving (Output a -> Output a -> Bool
forall a. Eq a => Output a -> Output a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Output a -> Output a -> Bool
$c/= :: forall a. Eq a => Output a -> Output a -> Bool
== :: Output a -> Output a -> Bool
$c== :: forall a. Eq a => Output a -> Output a -> Bool
Eq, Int -> Output a -> ShowS
forall a. Show a => Int -> Output a -> ShowS
forall a. Show a => [Output a] -> ShowS
forall a. Show a => Output a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Output a] -> ShowS
$cshowList :: forall a. Show a => [Output a] -> ShowS
show :: Output a -> String
$cshow :: forall a. Show a => Output a -> String
showsPrec :: Int -> Output a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Output a -> ShowS
Show)

instance forall a. IsString (Output a) where
    fromString :: String -> Output a
fromString = forall a. Name -> Output a
String forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsString a => String -> a
fromString

instance Serialize Type.Value where
    null :: Value
null = Value
Type.Null
    serialize :: forall (m :: * -> *). Type m -> Output Value -> Maybe Value
serialize (Out.ScalarBaseType ScalarType
scalarType) Output Value
value
        | Type.ScalarType Name
"Int" Maybe Name
_ <- ScalarType
scalarType
        , Int Int32
int <- Output Value
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int32 -> Value
Type.Int Int32
int
        | Type.ScalarType Name
"Float" Maybe Name
_ <- ScalarType
scalarType
        , Float Double
float <- Output Value
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Double -> Value
Type.Float Double
float
        | Type.ScalarType Name
"String" Maybe Name
_ <- ScalarType
scalarType
        , String Name
string <- Output Value
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.String Name
string
        | Type.ScalarType Name
"ID" Maybe Name
_ <- ScalarType
scalarType
        , String Name
string <- Output Value
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.String Name
string
        | Type.ScalarType Name
"Boolean" Maybe Name
_ <- ScalarType
scalarType
        , Boolean Bool
boolean <- Output Value
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bool -> Value
Type.Boolean Bool
boolean
    serialize Type m
_ (Enum Name
enum) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.Enum Name
enum
    serialize Type m
_ (List [Value]
list) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ [Value] -> Value
Type.List [Value]
list
    serialize Type m
_ (Object OrderedMap Value
object) = forall a. a -> Maybe a
Just
        forall a b. (a -> b) -> a -> b
$ HashMap Name Value -> Value
Type.Object
        forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
        forall a b. (a -> b) -> a -> b
$ forall v. OrderedMap v -> [(Name, v)]
OrderedMap.toList OrderedMap Value
object
    serialize Type m
_ Output Value
_ = forall a. Maybe a
Nothing