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 import Data.GraphQL.Schema
graphql :: (Alternative m, Monad m) => Schema m -> Text -> m Aeson.Value 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 . Attoparsec.parseOnly document

View File

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

View File

@ -4,10 +4,11 @@ module Data.GraphQL.Schema where
#if !MIN_VERSION_base(4,8,0) #if !MIN_VERSION_base(4,8,0)
import Control.Applicative ((<$>)) import Control.Applicative ((<$>))
#endif #endif
import Data.String (IsString(fromString))
import Data.Aeson (ToJSON(toJSON)) import Data.Aeson (ToJSON(toJSON))
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap)
import Data.Text (Text) import Data.Text (Text, pack)
data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot) data Schema f = Schema (QueryRoot f) -- (Maybe MutationRoot)
@ -25,6 +26,8 @@ data Output = OutputObject (HashMap Text Output)
type Argument = (Text, Scalar) type Argument = (Text, Scalar)
type Subs = Text -> Maybe Scalar
data Input = InputField Text [Argument] [Input] data Input = InputField Text [Argument] [Input]
deriving (Show) deriving (Show)
@ -36,6 +39,9 @@ data Scalar = ScalarInt Int
| ScalarID Text | ScalarID Text
deriving (Show) deriving (Show)
instance IsString Scalar where
fromString = ScalarString . pack
instance ToJSON Scalar where instance ToJSON Scalar where
toJSON (ScalarInt x) = toJSON x toJSON (ScalarInt x) = toJSON x
toJSON (ScalarFloat 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 Test.Tasty.HUnit (Assertion, testCase, (@?=))
import Data.GraphQL import Data.GraphQL
import Data.GraphQL.Schema (Subs)
import Test.StarWars.Schema import Test.StarWars.Schema
@ -20,6 +21,9 @@ import Test.StarWars.Schema
testQuery :: Text -> Aeson.Value -> Assertion testQuery :: Text -> Aeson.Value -> Assertion
testQuery q expected = graphql schema q @?= Just expected 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 :: TestTree
test = testGroup "Star Wars Query Tests" test = testGroup "Star Wars Query Tests"
[ testGroup "Basic Queries" [ 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)]
]
] ]