Skip to content

Commit 207a2ff

Browse files
jmljml
authored
Merge pull request #86 from jml/more-tests
More tests (fix aliases)
2 parents 1c6cac8 + 2b64b65 commit 207a2ff

File tree

6 files changed

+174
-17
lines changed

6 files changed

+174
-17
lines changed

‎src/GraphQL/API/Enum.hs

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -100,7 +100,11 @@ instance forall conName p b sa sb f.
100100

101101
-- | For each enum type we need 1) a list of all possible values 2) a
102102
-- way to serialise and 3) deserialise.
103+
--
104+
-- TODO: Update this comment to explain what a GraphQLEnum is, why you might
105+
-- want an instance, and any laws that apply to method relations.
103106
class GraphQLEnum a where
107+
-- TODO: Document each of these methods.
104108
enumValues :: [Either NameError Name]
105109
default enumValues :: (Generic a, GenericEnumValues (Rep a)) => [Either NameError Name]
106110
enumValues = genericEnumValues @(Rep a)

‎src/GraphQL/Internal/Validation.hs

Lines changed: 10 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -56,6 +56,7 @@ module GraphQL.Internal.Validation
5656
, getFields
5757
, Field
5858
, getFieldSelectionSet
59+
, getResponseKey
5960
, FragmentSpread
6061
, lookupArgument
6162
, VariableValue
@@ -267,6 +268,15 @@ data Field' spread value
267268
= Field' (Maybe Alias) Name (Arguments value) (Directives value) [Selection' spread value]
268269
deriving (Eq, Show)
269270

271+
-- | Get the response key of a field.
272+
--
273+
-- \"A field’s response key is its alias if an alias is provided, and it is
274+
-- otherwise the field’s name.\"
275+
--
276+
-- <https://facebook.github.io/graphql/#sec-Field-Alias>
277+
getResponseKey :: Field' spread value -> Name
278+
getResponseKey (Field' alias name _ _ _) = fromMaybe name alias
279+
270280
instance HasName (Field' spread value) where
271281
getName (Field' _ name _ _ _) = name
272282

‎src/GraphQL/Resolver.hs

Lines changed: 9 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -60,6 +60,7 @@ import GraphQL.Internal.Validation
6060
, Field
6161
, getFields
6262
, getFieldSelectionSet
63+
, getResponseKey
6364
, lookupArgument
6465
)
6566

@@ -254,19 +255,17 @@ resolveField :: forall dispatchType (m :: Type -> Type).
254255
resolveField handler nextHandler field =
255256
-- check name before
256257
case nameFromSymbol @(FieldName dispatchType) of
257-
Left err -> pure (Result [SchemaError err] (Just (GValue.ObjectField queryFieldName GValue.ValueNull)))
258-
Right name' -> runResolver name'
259-
where
260-
runResolver :: Name -> m ResolveFieldResult
261-
runResolver name'
262-
| queryFieldName == name' =
258+
Left err -> pure (Result [SchemaError err] (Just (GValue.ObjectField responseKey GValue.ValueNull)))
259+
Right name'
260+
| getName field == name' ->
263261
case buildFieldResolver @m @dispatchType handler field of
264-
Left err -> pure (Result [err] (Just (GValue.ObjectField queryFieldName GValue.ValueNull)))
262+
Left err -> pure (Result [err] (Just (GValue.ObjectField responseKey GValue.ValueNull)))
265263
Right resolver -> do
266264
Result errs value <- resolver
267-
pure (Result errs (Just (GValue.ObjectField queryFieldName value)))
268-
| otherwise = nextHandler
269-
queryFieldName = getName field
265+
pure (Result errs (Just (GValue.ObjectField responseKey value)))
266+
| otherwise -> nextHandler
267+
where
268+
responseKey = getResponseKey field
270269

271270
-- We're using our usual trick of rewriting a type in a closed type
272271
-- family to emulate a closed typeclass. The following are the

‎src/GraphQL/Value.hs

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -32,6 +32,7 @@ module GraphQL.Value
3232
-- * Names
3333
, Name(..)
3434
, NameError(..)
35+
, makeName
3536
-- * Objects
3637
, Object
3738
, Object'(..)
@@ -54,7 +55,7 @@ import qualified Data.Map as Map
5455
import Test.QuickCheck (Arbitrary(..), Gen, oneof, listOf, sized)
5556

5657
import GraphQL.Internal.Arbitrary (arbitraryText)
57-
import GraphQL.Internal.Name (Name(..), NameError(..))
58+
import GraphQL.Internal.Name (Name(..), NameError(..), makeName)
5859
import GraphQL.Internal.Syntax.AST (Variable)
5960
import qualified GraphQL.Internal.Syntax.AST as AST
6061
import GraphQL.Internal.OrderedMap (OrderedMap)

‎tests/EndToEndTests.hs

Lines changed: 140 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -8,10 +8,13 @@ module EndToEndTests (tests) where
88

99
import Protolude
1010

11-
import Data.Aeson (toJSON, object, (.=))
12-
import GraphQL (interpretAnonymousQuery)
11+
import Data.Aeson (Value(Null), toJSON, object, (.=))
12+
import qualified Data.Map as Map
13+
import GraphQL (compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery)
1314
import GraphQL.API (Object, Field)
15+
import GraphQL.Internal.Syntax.AST (Variable(..))
1416
import GraphQL.Resolver ((:<>)(..), Handler)
17+
import GraphQL.Value (makeName)
1518
import GraphQL.Value.ToValue (ToValue(..))
1619
import Test.Tasty (TestTree)
1720
import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)
@@ -128,7 +131,7 @@ tests = testSpec "End-to-end tests" $ do
128131
]
129132
]
130133
toJSON (toValue response) `shouldBe` expected
131-
it "TODO: Handles nested queries" $ do
134+
it "Handles nested queries" $ do
132135
let root = pure (viewServerDog mortgage)
133136
let query = [r|{
134137
dog {
@@ -152,3 +155,137 @@ tests = testSpec "End-to-end tests" $ do
152155
]
153156
]
154157
toJSON (toValue response) `shouldBe` expected
158+
it "It aliases fields" $ do
159+
let root = pure (viewServerDog mortgage)
160+
let query = [r|{
161+
dog {
162+
name
163+
boss: owner {
164+
name
165+
}
166+
}
167+
}
168+
|]
169+
response <- interpretAnonymousQuery @QueryRoot root query
170+
let expected =
171+
object
172+
[ "data" .= object
173+
[ "dog" .= object
174+
[ "name" .= ("Mortgage" :: Text)
175+
, "boss" .= object
176+
[ "name" .= ("jml" :: Text)
177+
]
178+
]
179+
]
180+
]
181+
toJSON (toValue response) `shouldBe` expected
182+
it "Passes arguments to functions" $ do
183+
let root = pure (viewServerDog mortgage)
184+
let query = [r|{
185+
dog {
186+
name
187+
doesKnowCommand(dogCommand: Sit)
188+
}
189+
}
190+
|]
191+
response <- interpretAnonymousQuery @QueryRoot root query
192+
let expected =
193+
object
194+
[ "data" .= object
195+
[ "dog" .= object
196+
[ "name" .= ("Mortgage" :: Text)
197+
, "doesKnowCommand" .= False
198+
]
199+
]
200+
]
201+
toJSON (toValue response) `shouldBe` expected
202+
describe "interpretQuery" $ do
203+
it "Handles the simplest named query" $ do
204+
let root = pure (viewServerDog mortgage)
205+
let query = [r|query myQuery {
206+
dog {
207+
name
208+
}
209+
}
210+
|]
211+
response <- interpretQuery @QueryRoot root query Nothing mempty
212+
let expected =
213+
object
214+
[ "data" .= object
215+
[ "dog" .= object
216+
[ "name" .= ("Mortgage" :: Text)
217+
]
218+
]
219+
]
220+
toJSON (toValue response) `shouldBe` expected
221+
it "Allows calling query by name" $ do
222+
let root = pure (viewServerDog mortgage)
223+
let query = [r|query myQuery {
224+
dog {
225+
name
226+
}
227+
}
228+
|]
229+
let Right name = makeName "myQuery"
230+
response <- interpretQuery @QueryRoot root query (Just name) mempty
231+
let expected =
232+
object
233+
[ "data" .= object
234+
[ "dog" .= object
235+
[ "name" .= ("Mortgage" :: Text)
236+
]
237+
]
238+
]
239+
toJSON (toValue response) `shouldBe` expected
240+
describe "Handles variables" $ do
241+
let root = pure (viewServerDog mortgage)
242+
let Right query =
243+
compileQuery [r|query myQuery($whichCommand: DogCommand) {
244+
dog {
245+
name
246+
doesKnowCommand(dogCommand: $whichCommand)
247+
}
248+
}
249+
|]
250+
it "Errors when no variables provided" $ do
251+
response <- executeQuery @QueryRoot root query Nothing mempty
252+
let expected =
253+
object
254+
[ "data" .= object
255+
[ "dog" .= object
256+
[ "name" .= ("Mortgage" :: Text)
257+
, "doesKnowCommand" .= Null
258+
]
259+
]
260+
, "errors" .=
261+
[
262+
object
263+
-- TODO: This error message is pretty bad. We should define
264+
-- a typeclass for client-friendly "Show" (separate from
265+
-- actual Show which remains extremely useful for debugging)
266+
-- and use that when including values in error messages.
267+
[ "message" .= ("Could not coerce Name {unName = \"dogCommand\"} to valid value: ValueScalar' ConstNull not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text)
268+
]
269+
]
270+
]
271+
toJSON (toValue response) `shouldBe` expected
272+
it "Substitutes variables when they are provided" $ do
273+
-- TODO: This is a crummy way to make a variable map. jml doesn't want
274+
-- to come up with a new API in this PR, but probably we should have a
275+
-- very simple function to turn a JSON value / object into the
276+
-- variable map that we desire. Alternatively, we should have APIs
277+
-- like Aeson does.
278+
let Right varName = makeName "whichCommand"
279+
let vars = Map.singleton (Variable varName) (toValue Sit)
280+
response <- executeQuery @QueryRoot root query Nothing vars
281+
let expected =
282+
object
283+
[ "data" .= object
284+
[ "dog" .= object
285+
[ "name" .= ("Mortgage" :: Text)
286+
, "doesKnowCommand" .= False
287+
]
288+
]
289+
]
290+
toJSON (toValue response) `shouldBe` expected
291+

‎tests/ExampleSchema.hs

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE DataKinds #-}
22
{-# LANGUAGE DeriveGeneric #-}
3+
{-# LANGUAGE PatternSynonyms #-}
34
{-# LANGUAGE TypeOperators #-}
45
{-# LANGUAGE ViewPatterns #-}
56

@@ -60,13 +61,13 @@
6061
-- Haskell as we go.
6162

6263
module ExampleSchema
63-
( DogCommand
64+
( DogCommand(..)
6465
, Dog
6566
, Sentient
6667
, Pet
6768
, Alien
6869
, Human
69-
, CatCommand
70+
, CatCommand(..)
7071
, Cat
7172
, CatOrDog
7273
, DogOrHuman
@@ -88,7 +89,8 @@ import GraphQL.API
8889
-- XXX: This really shouldn't be part of Resolver, since whether or not a
8990
-- thing has a default is part of the API / Schema definition.
9091
import GraphQL.Resolver (Defaultable(..))
91-
import GraphQL.Value (unName)
92+
import GraphQL.Value (pattern ValueEnum, unName)
93+
import GraphQL.Value.ToValue (ToValue(..))
9294

9395
-- | A command that can be given to a 'Dog'.
9496
--
@@ -107,6 +109,10 @@ data DogCommand = Sit | Down | Heel deriving (Show, Eq, Ord, Generic)
107109

108110
instance GraphQLEnum DogCommand
109111

112+
-- TODO: Probably shouldn't have to do this for enums.
113+
instance ToValue DogCommand where
114+
toValue = ValueEnum . enumToValue
115+
110116
-- | A dog.
111117
--
112118
-- This is an example of a GraphQL \"object\".

0 commit comments

Comments
 (0)