{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | This module provides the functions to parse and execute @GraphQL@ queries.
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)

-- | If the text parses correctly as a @GraphQL@ query the query is
-- executed using the given 'Schema'.
graphql :: MonadCatch m
    => Schema m -- ^ Resolvers.
    -> Text -- ^ Text representing a @GraphQL@ request document.
    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
graphql :: Schema m -> Text -> m (Either (ResponseEventStream m Value) Object)
graphql schema :: 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

-- | If the text parses correctly as a @GraphQL@ query the substitution is
-- applied to the query and the query is then executed using to the given
-- 'Schema'.
graphqlSubs :: MonadCatch m
    => Schema m -- ^ Resolvers.
    -> Maybe Text -- ^ Operation name.
    -> Aeson.Object -- ^ Variable substitution function.
    -> Text -- ^ Text representing a @GraphQL@ request document.
    -> m (Either (ResponseEventStream m Aeson.Value) Aeson.Object) -- ^ Response.
graphqlSubs :: Schema m
-> Maybe Text
-> Object
-> Text
-> m (Either (ResponseEventStream m Value) Object)
graphqlSubs schema :: Schema m
schema operationName :: Maybe Text
operationName variableValues :: Object
variableValues document' :: 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 "" Text
document' of
        Left errorBundle :: 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 parsed :: Document
parsed ->
            case Document -> Seq Error
validate Document
parsed of
                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
                errors :: 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 "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 data'' :: Value
data'' Seq.Empty) = k -> Value -> HashMap k Value
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton "data" Value
data''
    formatResponse (Response data'' :: Value
data'' errors' :: Seq Error
errors') = [(k, Value)] -> HashMap k Value
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList
        [ ("data", Value
data'')
        , ("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{..} = [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 ("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 "locations" [Location]
locations
        , (Path -> Value) -> Text -> [Path] -> Maybe Pair
forall a a. (a -> Value) -> a -> [a] -> Maybe (a, Value)
toMaybe Path -> Value
fromPath "path" [Path]
path
        ]
    fromValidationError :: Error -> Value
fromValidationError Validate.Error{..} = [Pair] -> Value
Aeson.object
        [ ("message", String -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON String
message)
        , ("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 _ _ [] = Maybe (a, Value)
forall a. Maybe a
Nothing
    toMaybe f :: a -> Value
f key :: a
key xs :: [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 segment :: Text
segment) = Text -> Value
Aeson.String Text
segment
    fromPath (Index index :: Int
index) = Int -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Int
index
    fromLocation :: Location -> Value
fromLocation Location{..} = [Pair] -> Value
Aeson.object
        [ ("line", Word -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Word
line)
        , ("column", Word -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON Word
column)
        ]