{- 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON forall a b. (a -> b) -> a -> b
$ Scientific -> Value
Aeson.Number forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
Aeson.toJSON Double
float
        | Type.ScalarType Name
"String" Maybe Name
_ <- ScalarType
scalarType
        , String Name
string <- Output JSON
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON forall a b. (a -> b) -> a -> b
$ Bool -> Value
Aeson.Bool Bool
boolean
    serialize Type m
_ (Enum Name
enum) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON forall a b. (a -> b) -> a -> b
$ Name -> Value
Aeson.String Name
enum
    serialize Type m
_ (List [JSON]
list) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON forall a b. (a -> b) -> a -> b
$ forall a. ToJSON a => a -> Value
Aeson.toJSON [JSON]
list
    serialize Type m
_ (Object OrderedMap JSON
object) = forall a. a -> Maybe a
Just
        forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON
        forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object
        forall a b. (a -> b) -> a -> b
$ forall {a}. ToJSON a => (Name, a) -> Pair
toJSONKeyValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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, forall a. ToJSON a => a -> Value
Aeson.toJSON a
value)
    serialize Type m
_ Output 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) = forall a. a -> Maybe a
Just Value
Type.Null
    coerceVariableValue (In.ScalarBaseType ScalarType
scalarType) (JSON Value
value)
        | (Aeson.String Name
stringValue) <- Value
value = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name -> Value
Type.String Name
stringValue
        | (Aeson.Bool Bool
booleanValue) <- Value
value = forall a. a -> Maybe a
Just 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 =
            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. RealFloat a => Scientific -> a
toRealFloat Scientific
numberValue
        | (Aeson.Number Scientific
numberValue) <- Value
value = -- ID or Int
            Int32 -> Value
Type.Int forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
numberValue
    coerceVariableValue (In.EnumBaseType EnumType
_) (JSON (Aeson.String 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) (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 forall v. KeyMap v -> Bool
KeyMap.null Object
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 :: 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 = 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'
            forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Object
objectValue, 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 = 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 = 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 Name
fieldName) HashMap Name Value
resultMap
                newObjectValue :: Object
newObjectValue = forall v. Key -> KeyMap v -> KeyMap v
KeyMap.delete Key
fieldKey Object
objectValue
             in case forall v. Key -> KeyMap v -> Maybe v
KeyMap.lookup Key
fieldKey Object
objectValue of
                    Just Value
variableValue -> do
                        Value
coerced <- forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
fieldType
                            forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON Value
variableValue
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object
newObjectValue, Value -> HashMap Name Value
insert Value
coerced)
                    Maybe Value
Nothing -> 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Value -> Maybe [Value] -> Maybe [Value]
foldVector (forall a. a -> Maybe a
Just []) Array
arrayValue
        | Bool
otherwise = forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
listType forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON Value
value
      where
        foldVector :: Value -> Maybe [Value] -> Maybe [Value]
foldVector Value
_ Maybe [Value]
Nothing = forall a. Maybe a
Nothing
        foldVector Value
variableValue (Just [Value]
list) = do
            Value
coerced <- forall a. VariableValue a => Type -> a -> Maybe Value
coerceVariableValue Type
listType forall a b. (a -> b) -> a -> b
$ Value -> JSON
JSON Value
variableValue
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Value
coerced forall a. a -> [a] -> [a]
: [Value]
list
    coerceVariableValue Type
_ JSON
_ = 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall {i} {r}.
ConduitT i (Response JSON) m r -> ConduitT i (Response Value) m r
stream Response JSON -> Object
formatResponse)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = 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{ $sel:data':Response :: Value
data' = Value
json }
    formatResponse :: Response JSON -> Aeson.Object
    formatResponse :: Response JSON -> Object
formatResponse Response{ Seq Error
$sel:errors:Response :: forall a. Response a -> Seq Error
errors :: Seq Error
errors, $sel:data':Response :: forall a. Response a -> a
data' = JSON Value
json } =
        let dataResponse :: Object
dataResponse = 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
_ -> forall a b c. (a -> b -> c) -> b -> a -> c
flip (forall v. Key -> v -> KeyMap v -> KeyMap v
KeyMap.insert Key
"errors") Object
dataResponse
                  forall a b. (a -> b) -> a -> b
$ Array -> Value
Aeson.Array forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Error -> Array -> Array
fromError forall a. Monoid a => a
mempty Seq Error
errors
    fromError :: Error -> Vector Aeson.Value -> Vector Aeson.Value
    fromError :: Error -> Array -> Array
fromError Error{[Path]
[Location]
Name
$sel:message:Error :: Error -> Name
$sel:locations:Error :: Error -> [Location]
$sel:path:Error :: Error -> [Path]
path :: [Path]
locations :: [Location]
message :: Name
..} = forall a. a -> Vector a -> Vector a
Vector.cons forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
Aeson.object forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
        [ forall a. a -> Maybe a
Just (Key
"message", Name -> Value
Aeson.String Name
message)
        , forall {a} {a}. (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe Location -> Value
fromLocation Key
"locations" [Location]
locations
        , 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) = forall a. ToJSON a => a -> Value
Aeson.toJSON Int
index
    fromLocation :: Location -> Value
fromLocation Location{Word
$sel:line:Location :: Location -> Word
$sel:column:Location :: Location -> Word
column :: Word
line :: Word
..} = [Pair] -> Value
Aeson.object
        [ (Key
"line", forall a. ToJSON a => a -> Value
Aeson.toJSON Word
line)
        , (Key
"column", forall a. ToJSON a => a -> Value
Aeson.toJSON Word
column)
        ]
    toMaybe :: (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe a -> Value
_ a
_ [] = forall a. Maybe a
Nothing
    toMaybe a -> Value
f a
key [a]
xs = forall a. a -> Maybe a
Just (a
key, forall a. (a -> Value) -> [a] -> Value
Aeson.listValue a -> Value
f [a]
xs)