Initial support for variable substitution

The correspondent end-to-end test has been ported. The variable
definition still needs to be checked.
This commit is contained in:
Danny Navarro 2016-02-15 14:25:15 +01:00
parent 119f94b38e
commit 98d2d41cda
4 changed files with 54 additions and 21 deletions

View File

@ -12,5 +12,9 @@ import Data.GraphQL.Parser
import Data.GraphQL.Schema
graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value
graphql schema = either (const empty) (execute schema)
graphql = flip graphqlSubs $ const Nothing
graphqlSubs :: (Alternative m, Monad m) => Schema m -> Subs -> Text -> m Aeson.Value
graphqlSubs schema f =
either (const empty) (execute schema f)
. Attoparsec.parseOnly document

View File

@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module Data.GraphQL.Execute where
#if !MIN_VERSION_base(4,8,0)
@ -8,6 +7,7 @@ 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
@ -16,31 +16,37 @@ import Data.GraphQL.AST
import Data.GraphQL.Schema (Resolver, Schema(..))
import qualified Data.GraphQL.Schema as Schema
execute :: (Alternative m, Monad m) => Schema m -> Document -> m Aeson.Value
execute (Schema resolv) doc = selectionSet resolv =<< query doc
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 _ _ _ sels))]) = pure sels
query (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) =
pure sels
query _ = empty
selectionSet :: Alternative f => Resolver f -> SelectionSet -> f Aeson.Value
selectionSet resolv = fmap (Aeson.Object . fold) . traverse (selection resolv)
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 => Resolver f -> Selection -> f Aeson.Object
selection resolv (SelectionField field@(Field _ name _ _ _)) =
fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput field)
selection _ _ = empty
selection :: Alternative f => Schema.Subs -> Resolver f -> Selection -> f Aeson.Object
selection f resolv (SelectionField field@(Field _ name _ _ _)) =
fmap (HashMap.singleton name) $ Aeson.toJSON <$> resolv (fieldToInput f field)
selection _ _ _ = empty
-- * AST/Schema conversions
argument :: Argument -> Schema.Argument
argument (Argument n (ValueInt v)) = (n, Schema.ScalarInt $ fromIntegral v)
argument (Argument n (ValueString (StringValue v))) = (n, Schema.ScalarString v)
argument _ = error "argument: not implemented yet"
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 :: Field -> Schema.Input
fieldToInput (Field _ n as _ sels) =
Schema.InputField n (argument <$> as) (fieldToInput . selectionToField <$> sels)
fieldToInput :: Schema.Subs -> Field -> Schema.Input
fieldToInput f (Field _ n as _ sels) =
Schema.InputField n (catMaybes $ argument f <$> as)
(fieldToInput f . selectionToField <$> sels)
selectionToField :: Selection -> Field
selectionToField (SelectionField x) = x

View File

@ -4,10 +4,11 @@ module Data.GraphQL.Schema where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>))
#endif
import Data.String (IsString(fromString))
import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap)
import Data.Text (Text)
import Data.Text (Text, pack)
data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot)
@ -25,6 +26,8 @@ data Output = OutputObject (HashMap Text Output)
type Argument = (Text, Scalar)
type Subs = Text -> Maybe Scalar
data Input = InputField Text [Argument] [Input]
deriving (Show)
@ -36,6 +39,9 @@ data Scalar = ScalarInt Int
| ScalarID Text
deriving (Show)
instance IsString Scalar where
fromString = ScalarString . pack
instance ToJSON Scalar where
toJSON (ScalarInt x) = toJSON x
toJSON (ScalarFloat x) = toJSON x

View File

@ -11,6 +11,7 @@ import Test.Tasty (TestTree, testGroup)
import Test.Tasty.HUnit (Assertion, testCase, (@?=))
import Data.GraphQL
import Data.GraphQL.Schema (Subs)
import Test.StarWars.Schema
@ -20,6 +21,9 @@ import Test.StarWars.Schema
testQuery :: Text -> Aeson.Value -> Assertion
testQuery q expected = graphql schema q @?= Just expected
testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion
testQueryParams f q expected = graphqlSubs schema f q @?= Just expected
test :: TestTree
test = testGroup "Star Wars Query Tests"
[ testGroup "Basic Queries"
@ -118,4 +122,17 @@ test = testGroup "Star Wars Query Tests"
]
]
]
, testCase "Luke ID with variable" . testQueryParams
(\v -> if v == "someId"
then Just "1000"
else Nothing)
[r| query FetchSomeIDQuery($someId: String!) {
human(id: $someId) {
name
}
}
|]
$ object [
"human" .= object ["name" .= ("Luke Skywalker" :: Text)]
]
]