diff --git a/Data/GraphQL.hs b/Data/GraphQL.hs index d18ff2f..2da8a46 100644 --- a/Data/GraphQL.hs +++ b/Data/GraphQL.hs @@ -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) - . Attoparsec.parseOnly document +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 diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 01fc118..9d20e5c 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -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 _ = empty +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 diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 8ceb11f..8d63696 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -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 diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs index 994f7bc..6f59ec2 100644 --- a/tests/Test/StarWars/QueryTests.hs +++ b/tests/Test/StarWars/QueryTests.hs @@ -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)] + ] ]