{- 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 OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}

-- | JSON serialization.
module Language.GraphQL.JSON
    ( JSON(..)
    , graphql
    ) where

import Control.Monad.Catch (MonadCatch)
import qualified Data.Aeson.Types as Aeson
import Data.Maybe (catMaybes)
import qualified Data.Sequence as Seq
import Data.Vector (Vector)
import qualified Data.Vector as Vector
import qualified Language.GraphQL as GraphQL
import Language.GraphQL.AST (Location(..), Name)
import Language.GraphQL.Error
import Language.GraphQL.Type.Schema (Schema)
import Data.Bifunctor (Bifunctor(..))
import qualified Conduit
import qualified Data.Aeson.Key as Aeson.Key
import qualified Data.Aeson.KeyMap as KeyMap
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Scientific (toBoundedInteger, toRealFloat)
import Data.Text (Text)
import Language.GraphQL.Execute.Coerce
import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
import qualified Language.GraphQL.Type.In as In
import qualified Language.GraphQL.Type.Out as Out
import qualified Language.GraphQL.Type as Type

-- | Wraps an aeson value.
newtype JSON = JSON Aeson.Value

instance Aeson.ToJSON JSON where
    toJSON :: JSON -> Value
toJSON (JSON Value
value) = Value
value

instance Aeson.FromJSON JSON where
    parseJSON :: Value -> Parser JSON
parseJSON = JSON -> Parser JSON
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSON -> Parser JSON) -> (Value -> JSON) -> Value -> Parser JSON
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> JSON
JSON

instance Serialize JSON where
    serialize :: forall (m :: * -> *). Type m -> Output JSON -> Maybe JSON
serialize (Out.ScalarBaseType ScalarType
scalarType) Output JSON
value
        | Type.ScalarType Name
"Int" Maybe Name
_ <- ScalarType
scalarType
        , Int Int32
int <- Output JSON
value = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Aeson.Number (Scientific -> Value) -> Scientific -> Value
forall a b. (a -> b) -> a -> b
$ Int32 -> Scientific
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
int
        | Type.ScalarType Name
"Float" Maybe Name
_ <- ScalarType
scalarType
        , Float Double
float <- Output JSON
value = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ Double -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Double
float
        | Type.ScalarType Name
"String" Maybe Name
_ <- ScalarType
scalarType
        , String Name
string <- Output JSON
value = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ Name -> Value
Aeson.String Name
string
        | Type.ScalarType Name
"ID" Maybe Name
_ <- ScalarType
scalarType
        , String Name
string <- Output JSON
value = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ Name -> Value
Aeson.String Name
string
        | Type.ScalarType Name
"Boolean" Maybe Name
_ <- ScalarType
scalarType
        , Boolean Bool
boolean <- Output JSON
value = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Aeson.Bool Bool
boolean
    serialize Type m
_ (Enum Name
enum) = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ Name -> Value
Aeson.String Name
enum
    serialize Type m
_ (List [JSON]
list) = JSON -> Maybe JSON
forall a. a -> Maybe a
Just (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ [JSON] -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON [JSON]
list
    serialize Type m
_ (Object OrderedMap JSON
object) = JSON -> Maybe JSON
forall a. a -> Maybe a
Just
        (JSON -> Maybe JSON) -> JSON -> Maybe JSON
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON
        (Value -> JSON) -> Value -> JSON
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object
        ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ (Name, JSON) -> Pair
forall {a}. ToJSON a => (Name, a) -> Pair
toJSONKeyValue ((Name, JSON) -> Pair) -> [(Name, JSON)] -> [Pair]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OrderedMap JSON -> [(Name, JSON)]
forall v. OrderedMap v -> [(Name, v)]
OrderedMap.toList OrderedMap JSON
object
      where
        toJSONKeyValue :: (Name, a) -> Pair
toJSONKeyValue (Name
key, a
value) = (Name -> Key
Aeson.Key.fromText Name
key, a -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON a
value)
    serialize Type m
_ Output JSON
_ = Maybe JSON
forall a. Maybe a
Nothing
    null :: JSON
null = Value -> JSON
JSON Value
Aeson.Null

instance VariableValue JSON where
    coerceVariableValue :: Type -> JSON -> Maybe Value
coerceVariableValue Type
_ (JSON Value
Aeson.Null) = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
Type.Null
    coerceVariableValue (In.ScalarBaseType ScalarType
scalarType) (JSON Value
value)
        | (Aeson.String Name
stringValue) <- Value
value = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.String Name
stringValue
        | (Aeson.Bool Bool
booleanValue) <- Value
value = Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Bool -> Value
Type.Boolean Bool
booleanValue
        | (Aeson.Number Scientific
numberValue) <- Value
value
        , (Type.ScalarType Name
"Float" Maybe Name
_) <- ScalarType
scalarType =
            Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Double -> Value
Type.Float (Double -> Value) -> Double -> Value
forall a b. (a -> b) -> a -> b
$ Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
numberValue
        | (Aeson.Number Scientific
numberValue) <- Value
value = -- ID or Int
            Int32 -> Value
Type.Int (Int32 -> Value) -> Maybe Int32 -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Scientific -> Maybe Int32
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
numberValue
    coerceVariableValue (In.EnumBaseType EnumType
_) (JSON (Aeson.String Name
stringValue)) =
        Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.Enum Name
stringValue
    coerceVariableValue (In.InputObjectBaseType InputObjectType
objectType) (JSON Value
value)
        | (Aeson.Object Object
objectValue) <- Value
value = do
            let (In.InputObjectType Name
_ Maybe Name
_ HashMap Name InputField
inputFields) = InputObjectType
objectType
            (Object
newObjectValue, HashMap Name Value
resultMap) <- Object
-> HashMap Name InputField -> Maybe (Object, HashMap Name Value)
foldWithKey Object
objectValue HashMap Name InputField
inputFields
            if Object -> Bool
forall v. KeyMap v -> Bool
KeyMap.null Object
newObjectValue
                then Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Value -> Maybe Value
forall a b. (a -> b) -> a -> b
$ HashMap Name Value -> Value
Type.Object HashMap Name Value
resultMap
                else Maybe Value
forall a. Maybe a
Nothing
      where
        foldWithKey :: Aeson.Object
            -> HashMap Name In.InputField
            -> Maybe (Aeson.Object, HashMap Name Type.Value)
        foldWithKey :: Object
-> HashMap Name InputField -> Maybe (Object, HashMap Name Value)
foldWithKey Object
objectValue = (Name
 -> InputField
 -> Maybe (Object, HashMap Name Value)
 -> Maybe (Object, HashMap Name Value))
-> Maybe (Object, HashMap Name Value)
-> HashMap Name InputField
-> Maybe (Object, HashMap Name Value)
forall k v a. (k -> v -> a -> a) -> a -> HashMap k v -> a
HashMap.foldrWithKey Name
-> InputField
-> Maybe (Object, HashMap Name Value)
-> Maybe (Object, HashMap Name Value)
matchFieldValues'
            (Maybe (Object, HashMap Name Value)
 -> HashMap Name InputField -> Maybe (Object, HashMap Name Value))
-> Maybe (Object, HashMap Name Value)
-> HashMap Name InputField
-> Maybe (Object, HashMap Name Value)
forall a b. (a -> b) -> a -> b
$ (Object, HashMap Name Value) -> Maybe (Object, HashMap Name Value)
forall a. a -> Maybe a
Just (Object
objectValue, HashMap Name Value
forall k v. HashMap k v
HashMap.empty)
        matchFieldValues' :: Text
            -> In.InputField
            -> Maybe (Aeson.Object, HashMap Name Type.Value)
            -> Maybe (Aeson.Object, HashMap Name Type.Value)
        matchFieldValues' :: Name
-> InputField
-> Maybe (Object, HashMap Name Value)
-> Maybe (Object, HashMap Name Value)
matchFieldValues' Name
_ InputField
_ Maybe (Object, HashMap Name Value)
Nothing = Maybe (Object, HashMap Name Value)
forall a. Maybe a
Nothing
        matchFieldValues' Name
fieldName InputField
inputField (Just (Object
objectValue, HashMap Name Value
resultMap)) =
            let fieldKey :: Key
fieldKey = Name -> Key
Aeson.Key.fromText Name
fieldName
                In.InputField Maybe Name
_ Type
fieldType Maybe Value
_ = InputField
inputField
                insert :: Value -> HashMap Name Value
insert = (Value -> HashMap Name Value -> HashMap Name Value)
-> HashMap Name Value -> Value -> HashMap Name Value
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Name -> Value -> HashMap Name Value -> HashMap Name Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HashMap.insert Name
fieldName) HashMap Name Value
resultMap
                newObjectValue :: Object
newObjectValue = Key -> Object -> Object
forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
fieldKey Object
objectValue
             in case Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
fieldKey Object
objectValue of
                    Just Value
variableValue -> do
                        Value
coerced <- Type -> JSON -> Maybe Value
forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
fieldType
                            (JSON -> Maybe Value) -> JSON -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON Value
variableValue
                        (Object, HashMap Name Value) -> Maybe (Object, HashMap Name Value)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object
newObjectValue, Value -> HashMap Name Value
insert Value
coerced)
                    Maybe Value
Nothing -> (Object, HashMap Name Value) -> Maybe (Object, HashMap Name Value)
forall a. a -> Maybe a
Just (Object
objectValue, HashMap Name Value
resultMap)
    coerceVariableValue (In.ListBaseType Type
listType) (JSON Value
value)
        | (Aeson.Array Array
arrayValue) <- Value
value =
            [Value] -> Value
Type.List ([Value] -> Value) -> Maybe [Value] -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Value -> Maybe [Value] -> Maybe [Value])
-> Maybe [Value] -> Array -> Maybe [Value]
forall a b. (a -> b -> b) -> b -> Vector a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Value -> Maybe [Value] -> Maybe [Value]
foldVector ([Value] -> Maybe [Value]
forall a. a -> Maybe a
Just []) Array
arrayValue
        | Bool
otherwise = Type -> JSON -> Maybe Value
forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
listType (JSON -> Maybe Value) -> JSON -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON Value
value
      where
        foldVector :: Value -> Maybe [Value] -> Maybe [Value]
foldVector Value
_ Maybe [Value]
Nothing = Maybe [Value]
forall a. Maybe a
Nothing
        foldVector Value
variableValue (Just [Value]
list) = do
            Value
coerced <- Type -> JSON -> Maybe Value
forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
listType (JSON -> Maybe Value) -> JSON -> Maybe Value
forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON Value
variableValue
            [Value] -> Maybe [Value]
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Value] -> Maybe [Value]) -> [Value] -> Maybe [Value]
forall a b. (a -> b) -> a -> b
$ Value
coerced Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
list
    coerceVariableValue Type
_ JSON
_ = Maybe Value
forall a. Maybe a
Nothing

-- | If the text parses correctly as a @GraphQL@ query the query is
-- executed using the given 'Schema'.
graphql :: MonadCatch m
    => Schema m -- ^ Resolvers.
    -> Maybe Text -- ^ Operation name.
    -> Aeson.Object -- ^ Variables.
    -> Text -- ^ Text representing a @GraphQL@ request document.
    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
graphql :: forall (m :: * -> *).
MonadCatch m =>
Schema m
-> Maybe Name
-> Object
-> Name
-> m (Either (ResponseEventStream m Value) Object)
graphql Schema m
schema Maybe Name
operationName Object
variableValues = (Either (ConduitT () (Response JSON) m ()) (Response JSON)
 -> Either (ResponseEventStream m Value) Object)
-> m (Either (ConduitT () (Response JSON) m ()) (Response JSON))
-> m (Either (ResponseEventStream m Value) Object)
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ConduitT () (Response JSON) m () -> ResponseEventStream m Value)
-> (Response JSON -> Object)
-> Either (ConduitT () (Response JSON) m ()) (Response JSON)
-> Either (ResponseEventStream m Value) Object
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap ConduitT () (Response JSON) m () -> ResponseEventStream m Value
forall {i} {r}.
ConduitT i (Response JSON) m r -> ConduitT i (Response Value) m r
stream Response JSON -> Object
formatResponse)
    (m (Either (ConduitT () (Response JSON) m ()) (Response JSON))
 -> m (Either (ResponseEventStream m Value) Object))
-> (Name
    -> m (Either (ConduitT () (Response JSON) m ()) (Response JSON)))
-> Name
-> m (Either (ResponseEventStream m Value) Object)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema m
-> Maybe Name
-> HashMap Name JSON
-> Name
-> m (Either (ConduitT () (Response JSON) m ()) (Response JSON))
forall (m :: * -> *) a b.
(MonadCatch m, VariableValue a, Serialize b) =>
Schema m
-> Maybe Name
-> HashMap Name a
-> Name
-> m (Either (ResponseEventStream m b) (Response b))
GraphQL.graphql Schema m
schema Maybe Name
operationName HashMap Name JSON
jsonVariables
  where
    jsonVariables :: HashMap Name JSON
jsonVariables = Value -> JSON
JSON (Value -> JSON) -> HashMap Name Value -> HashMap Name JSON
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object -> HashMap Name Value
forall v. KeyMap v -> HashMap Name v
KeyMap.toHashMapText Object
variableValues
    -- stream :: ResponseEventStream m JSON -> ResponseEventStream m Aeson.Value
    stream :: ConduitT i (Response JSON) m r -> ConduitT i (Response Value) m r
stream = (Response JSON -> Response Value)
-> ConduitT i (Response JSON) m r
-> ConduitT i (Response Value) m r
forall (m :: * -> *) o1 o2 i r.
Monad m =>
(o1 -> o2) -> ConduitT i o1 m r -> ConduitT i o2 m r
Conduit.mapOutput Response JSON -> Response Value
mapResponse
    mapResponse :: Response JSON -> Response Value
mapResponse response :: Response JSON
response@Response{ $sel:data':Response :: forall a. Response a -> a
data' = JSON Value
json } =
        Response JSON
response{ data' = json }
    formatResponse :: Response JSON -> Aeson.Object
    formatResponse :: Response JSON -> Object
formatResponse Response{ Seq Error
errors :: Seq Error
$sel:errors:Response :: forall a. Response a -> Seq Error
errors, $sel:data':Response :: forall a. Response a -> a
data' = JSON Value
json } =
        let dataResponse :: Object
dataResponse = Key -> Value -> Object
forall v. Key -> v -> KeyMap v
KeyMap.singleton Key
"data" Value
json
         in case Seq Error
errors of
              Seq Error
Seq.Empty -> Object
dataResponse
              Seq Error
_ -> (Value -> Object -> Object) -> Object -> Value -> Object
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"errors") Object
dataResponse
                  (Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ Array -> Value
Aeson.Array (Array -> Value) -> Array -> Value
forall a b. (a -> b) -> a -> b
$ (Error -> Array -> Array) -> Array -> Seq Error -> Array
forall a b. (a -> b -> b) -> b -> Seq a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Error -> Array -> Array
fromError Array
forall a. Monoid a => a
mempty Seq Error
errors
    fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value
    fromError :: Error -> Array -> Array
fromError Error{[Location]
[Path]
Name
message :: Name
locations :: [Location]
path :: [Path]
$sel:message:Error :: Error -> Name
$sel:locations:Error :: Error -> [Location]
$sel:path:Error :: Error -> [Path]
..} = Value -> Array -> Array
forall a. a -> Vector a -> Vector a
Vector.cons (Value -> Array -> Array) -> Value -> Array -> Array
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
        [ Pair -> Maybe Pair
forall a. a -> Maybe a
Just (Key
"message", Name -> Value
Aeson.String Name
message)
        , (Location -> Value) -> Key -> [Location] -> Maybe Pair
forall {a} {a}. (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe Location -> Value
fromLocation Key
"locations" [Location]
locations
        , (Path -> Value) -> Key -> [Path] -> Maybe Pair
forall {a} {a}. (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe Path -> Value
fromPath Key
"path" [Path]
path
        ]
    fromPath :: Path -> Value
fromPath (Segment Name
segment) = Name -> Value
Aeson.String Name
segment
    fromPath (Index Int
index) = Int -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Int
index
    fromLocation :: Location -> Value
fromLocation Location{Word
line :: Word
column :: Word
$sel:line:Location :: Location -> Word
$sel:column:Location :: Location -> Word
..} = [Pair] -> Value
Aeson.object
        [ (Key
"line", Word -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Word
line)
        , (Key
"column", Word -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Word
column)
        ]
    toMaybe :: (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe a -> Value
_ a
_ [] = Maybe (a, Value)
forall a. Maybe a
Nothing
    toMaybe a -> Value
f a
key [a]
xs = (a, Value) -> Maybe (a, Value)
forall a. a -> Maybe a
Just (a
key, (a -> Value) -> [a] -> Value
forall a. (a -> Value) -> [a] -> Value
Aeson.listValue a -> Value
f [a]
xs)