{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
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
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 =
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
graphql :: MonadCatch m
=> Schema m
-> Maybe Text
-> Aeson.Object
-> Text
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object)
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 :: 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)