{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Language.GraphQL
( graphql
, graphqlSubs
) where
import Control.Monad.Catch (MonadCatch)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.HashMap.Strict as HashMap
import Data.Maybe (catMaybes)
import qualified Data.Sequence as Seq
import Data.Text (Text)
import Language.GraphQL.AST
import Language.GraphQL.Error
import Language.GraphQL.Execute
import qualified Language.GraphQL.Validate as Validate
import Language.GraphQL.Type.Schema (Schema)
import Text.Megaparsec (parse)
graphql :: MonadCatch m
=> Schema m
-> Text
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object)
graphql :: Schema m -> Text -> m (Either (ResponseEventStream m Value) Object)
graphql Schema m
schema = Schema m
-> Maybe Text
-> Object
-> Text
-> m (Either (ResponseEventStream m Value) Object)
forall (m :: * -> *).
MonadCatch m =>
Schema m
-> Maybe Text
-> Object
-> Text
-> m (Either (ResponseEventStream m Value) Object)
graphqlSubs Schema m
schema Maybe Text
forall a. Monoid a => a
mempty Object
forall a. Monoid a => a
mempty
graphqlSubs :: MonadCatch m
=> Schema m
-> Maybe Text
-> Aeson.Object
-> Text
-> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object)
graphqlSubs :: Schema m
-> Maybe Text
-> Object
-> Text
-> m (Either (ResponseEventStream m Value) Object)
graphqlSubs Schema m
schema Maybe Text
operationName Object
variableValues Text
document' =
case Parsec Void Text Document
-> String -> Text -> Either (ParseErrorBundle Text Void) Document
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse Parsec Void Text Document
document String
"" Text
document' of
Left ParseErrorBundle Text Void
errorBundle -> Object -> Either (ResponseEventStream m Value) Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Object -> Either (ResponseEventStream m Value) Object)
-> (Response Value -> Object)
-> Response Value
-> Either (ResponseEventStream m Value) Object
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Response Value -> Object
forall k.
(Hashable k, IsString k, Eq k) =>
Response Value -> HashMap k Value
formatResponse (Response Value -> Either (ResponseEventStream m Value) Object)
-> m (Response Value)
-> m (Either (ResponseEventStream m Value) Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ParseErrorBundle Text Void -> m (Response Value)
forall (f :: * -> *) a.
(Applicative f, Serialize a) =>
ParseErrorBundle Text Void -> f (Response a)
parseError ParseErrorBundle Text Void
errorBundle
Right Document
parsed ->
case Document -> Seq Error
validate Document
parsed of
Seq Error
Seq.Empty -> (Response Value -> Object)
-> Either (ResponseEventStream m Value) (Response Value)
-> Either (ResponseEventStream m Value) Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Response Value -> Object
forall k.
(Hashable k, IsString k, Eq k) =>
Response Value -> HashMap k Value
formatResponse
(Either (ResponseEventStream m Value) (Response Value)
-> Either (ResponseEventStream m Value) Object)
-> m (Either (ResponseEventStream m Value) (Response Value))
-> m (Either (ResponseEventStream m Value) Object)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Schema m
-> Maybe Text
-> Object
-> Document
-> m (Either (ResponseEventStream m Value) (Response Value))
forall (m :: * -> *) a b.
(MonadCatch m, VariableValue a, Serialize b) =>
Schema m
-> Maybe Text
-> HashMap Text a
-> Document
-> m (Either (ResponseEventStream m b) (Response b))
execute Schema m
schema Maybe Text
operationName Object
variableValues Document
parsed
Seq Error
errors -> Either (ResponseEventStream m Value) Object
-> m (Either (ResponseEventStream m Value) Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either (ResponseEventStream m Value) Object
-> m (Either (ResponseEventStream m Value) Object))
-> Either (ResponseEventStream m Value) Object
-> m (Either (ResponseEventStream m Value) Object)
forall a b. (a -> b) -> a -> b
$ Object -> Either (ResponseEventStream m Value) Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure
(Object -> Either (ResponseEventStream m Value) Object)
-> Object -> Either (ResponseEventStream m Value) Object
forall a b. (a -> b) -> a -> b
$ Text -> Value -> Object
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton Text
"errors"
(Value -> Object) -> Value -> Object
forall a b. (a -> b) -> a -> b
$ Seq Value -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON
(Seq Value -> Value) -> Seq Value -> Value
forall a b. (a -> b) -> a -> b
$ Error -> Value
fromValidationError (Error -> Value) -> Seq Error -> Seq Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Error
errors
where
validate :: Document -> Seq Error
validate = Schema m -> [Rule m] -> Document -> Seq Error
forall (m :: * -> *). Schema m -> [Rule m] -> Document -> Seq Error
Validate.document Schema m
schema [Rule m]
forall (m :: * -> *). [Rule m]
Validate.specifiedRules
formatResponse :: Response Value -> HashMap k Value
formatResponse (Response Value
data'' Seq Error
Seq.Empty) = k -> Value -> HashMap k Value
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton k
"data" Value
data''
formatResponse (Response Value
data'' Seq Error
errors') = [(k, Value)] -> HashMap k Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
[ (k
"data", Value
data'')
, (k
"errors", Seq Value -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON (Seq Value -> Value) -> Seq Value -> Value
forall a b. (a -> b) -> a -> b
$ Error -> Value
fromError (Error -> Value) -> Seq Error -> Seq Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Seq Error
errors')
]
fromError :: Error -> Value
fromError Error{[Location]
[Path]
Text
$sel:path:Error :: Error -> [Path]
$sel:locations:Error :: Error -> [Location]
$sel:message:Error :: Error -> Text
path :: [Path]
locations :: [Location]
message :: Text
..} = [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 (Text
"message", Text -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Text
message)
, (Location -> Value) -> Text -> [Location] -> Maybe Pair
forall a a. (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe Location -> Value
fromLocation Text
"locations" [Location]
locations
, (Path -> Value) -> Text -> [Path] -> Maybe Pair
forall a a. (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe Path -> Value
fromPath Text
"path" [Path]
path
]
fromValidationError :: Error -> Value
fromValidationError Validate.Error{String
[Location]
locations :: Error -> [Location]
message :: Error -> String
locations :: [Location]
message :: String
..} = [Pair] -> Value
Aeson.object
[ (Text
"message", String -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON String
message)
, (Text
"locations", (Location -> Value) -> [Location] -> Value
forall a. (a -> Value) -> [a] -> Value
Aeson.listValue Location -> Value
fromLocation [Location]
locations)
]
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)
fromPath :: Path -> Value
fromPath (Segment Text
segment) = Text -> Value
Aeson.String Text
segment
fromPath (Index Int
index) = Int -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Int
index
fromLocation :: Location -> Value
fromLocation Location{Word
$sel:column:Location :: Location -> Word
$sel:line:Location :: Location -> Word
column :: Word
line :: Word
..} = [Pair] -> Value
Aeson.object
[ (Text
"line", Word -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Word
line)
, (Text
"column", Word -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Word
column)
]