66 lines
2.2 KiB
Haskell
66 lines
2.2 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
module Data.GraphQL.Execute (execute) where
|
|
|
|
#if !MIN_VERSION_base(4,8,0)
|
|
import Control.Applicative ((<$>), pure)
|
|
import Data.Traversable (traverse)
|
|
#endif
|
|
import Control.Applicative (Alternative, empty)
|
|
import Data.Foldable (fold)
|
|
import Data.Maybe (catMaybes)
|
|
|
|
import qualified Data.Aeson as Aeson
|
|
import qualified Data.HashMap.Strict as HashMap
|
|
import qualified Data.Text as T
|
|
|
|
import Data.GraphQL.AST
|
|
import Data.GraphQL.Schema (Resolver, Schema(..))
|
|
import qualified Data.GraphQL.Schema as Schema
|
|
|
|
execute
|
|
:: (Alternative m, Monad m)
|
|
=> Schema m -> Schema.Subs -> Document -> m Aeson.Value
|
|
execute (Schema resolv) f doc = selectionSet f resolv =<< query doc
|
|
|
|
query :: Alternative f => Document -> f SelectionSet
|
|
query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = pure sels
|
|
query _ = empty
|
|
|
|
selectionSet
|
|
:: Alternative f
|
|
=> Schema.Subs -> Resolver f -> SelectionSet -> f Aeson.Value
|
|
selectionSet f resolv = fmap (Aeson.Object . fold)
|
|
. traverse (selection f resolv)
|
|
|
|
selection
|
|
:: Alternative f
|
|
=> Schema.Subs -> Resolver f -> Selection -> f Aeson.Object
|
|
selection f resolv (SelectionField field@(Field alias name _ _ _)) =
|
|
fmap (HashMap.singleton aliasOrName)
|
|
$ Aeson.toJSON
|
|
<$> resolv (fieldToInput f field)
|
|
where
|
|
aliasOrName = if T.null alias then name else alias
|
|
selection _ _ _ = empty
|
|
|
|
-- * AST/Schema conversions
|
|
|
|
argument :: Schema.Subs -> Argument -> Maybe Schema.Argument
|
|
argument f (Argument n (ValueVariable (Variable v))) =
|
|
maybe Nothing (\v' -> Just (n, v')) $ f v
|
|
argument _ (Argument n (ValueInt v)) =
|
|
Just (n, Schema.ScalarInt $ fromIntegral v)
|
|
argument _ (Argument n (ValueString (StringValue v))) =
|
|
Just (n, Schema.ScalarString v)
|
|
argument _ _ = error "argument: not implemented yet"
|
|
|
|
fieldToInput :: Schema.Subs -> Field -> Schema.Input
|
|
fieldToInput f (Field _ n as _ sels) =
|
|
-- TODO: Get rid of `catMaybes`, invalid arguments should raise an error
|
|
Schema.InputField n (catMaybes $ argument f <$> as)
|
|
(fieldToInput f . selectionToField <$> sels)
|
|
|
|
selectionToField :: Selection -> Field
|
|
selectionToField (SelectionField x) = x
|
|
selectionToField _ = error "selectionField: not implemented yet"
|