graphql-api-0.2.0: tests/EndToEndTests.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
-- | Tests that span the entire system.
--
-- These tests function both as examples of how to use the API, as well as
-- sanity checks on our reasoning.
module EndToEndTests (tests) where
import Protolude
import Data.Aeson (Value(Null), toJSON, object, (.=))
import qualified Data.Map as Map
import GraphQL (makeSchema, compileQuery, executeQuery, interpretAnonymousQuery, interpretQuery)
import GraphQL.API (Object, Field)
import GraphQL.Internal.Syntax.AST (Variable(..))
import GraphQL.Resolver ((:<>)(..), Handler)
import GraphQL.Value (makeName)
import GraphQL.Value.ToValue (ToValue(..))
import Test.Tasty (TestTree)
import Test.Tasty.Hspec (testSpec, describe, it, shouldBe)
import Text.RawString.QQ (r)
import ExampleSchema
-- | Example query root.
--
-- @
-- type QueryRoot {
-- dog: Dog
-- }
-- @
--
-- Drawn from <https://facebook.github.io/graphql/#sec-Validation>.
type QueryRoot = Object "QueryRoot" '[]
'[ Field "dog" Dog
]
-- | Our server's internal representation of a 'Dog'.
data ServerDog
= ServerDog
{ name :: Text
, nickname :: Maybe Text
, barkVolume :: Int32
, knownCommands :: Set DogCommand
, houseTrainedAtHome :: Bool
, houseTrainedElsewhere :: Bool
, owner :: ServerHuman
}
-- | Whether 'ServerDog' knows the given command.
doesKnowCommand :: ServerDog -> DogCommand -> Bool
doesKnowCommand dog command = command `elem` knownCommands dog
-- | Whether 'ServerDog' is house-trained.
isHouseTrained :: ServerDog -> Maybe Bool -> Bool
isHouseTrained dog Nothing = houseTrainedAtHome dog || houseTrainedElsewhere dog
isHouseTrained dog (Just False) = houseTrainedAtHome dog
isHouseTrained dog (Just True) = houseTrainedElsewhere dog
-- | Present 'ServerDog' for GraphQL.
viewServerDog :: ServerDog -> Handler IO Dog
viewServerDog dog@(ServerDog{..}) = pure $
pure name :<>
pure (fmap pure nickname) :<>
pure barkVolume :<>
pure . doesKnowCommand dog :<>
pure . isHouseTrained dog :<>
viewServerHuman owner
-- | jml has a stuffed black dog called "Mortgage".
mortgage :: ServerDog
mortgage = ServerDog
{ name = "Mortgage"
, nickname = Just "Mort"
, barkVolume = 0 -- He's stuffed
, knownCommands = mempty -- He's stuffed
, houseTrainedAtHome = True -- Never been a problem
, houseTrainedElsewhere = True -- Untested in the field
, owner = jml
}
-- | Our server's internal representation of a 'Human'.
data ServerHuman = ServerHuman Text deriving (Eq, Ord, Show)
-- | Present a 'ServerHuman' as a GraphQL 'Human'.
viewServerHuman :: ServerHuman -> Handler IO Human
viewServerHuman (ServerHuman name) = pure (pure name)
-- | It me.
jml :: ServerHuman
jml = ServerHuman "jml"
tests :: IO TestTree
tests = testSpec "End-to-end tests" $ do
describe "interpretAnonymousQuery" $ do
it "Handles the simplest possible valid query" $ do
let root = pure (viewServerDog mortgage)
let query = [r|{
dog {
name
}
}
|]
response <- interpretAnonymousQuery @QueryRoot root query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Handles more than one field" $ do
let root = pure (viewServerDog mortgage)
let query = [r|{
dog {
name
barkVolume
}
}
|]
response <- interpretAnonymousQuery @QueryRoot root query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "barkVolume" .= (0 :: Int32)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Handles nested queries" $ do
let root = pure (viewServerDog mortgage)
let query = [r|{
dog {
name
owner {
name
}
}
}
|]
response <- interpretAnonymousQuery @QueryRoot root query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "owner" .= object
[ "name" .= ("jml" :: Text)
]
]
]
]
toJSON (toValue response) `shouldBe` expected
it "It aliases fields" $ do
let root = pure (viewServerDog mortgage)
let query = [r|{
dog {
name
boss: owner {
name
}
}
}
|]
response <- interpretAnonymousQuery @QueryRoot root query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "boss" .= object
[ "name" .= ("jml" :: Text)
]
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Passes arguments to functions" $ do
let root = pure (viewServerDog mortgage)
let query = [r|{
dog {
name
doesKnowCommand(dogCommand: Sit)
}
}
|]
response <- interpretAnonymousQuery @QueryRoot root query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= False
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Handles fairly complex queries" $ do
let root = pure (viewServerDog mortgage)
-- TODO: jml would like to put some union checks in here, but we don't
-- have any unions reachable from Dog!
let query = [r|{
dog {
callsign: name
... on Dog {
callsign: name
me: owner {
... on Sentient {
name
}
... on Human {
name
}
name
}
}
}
}
|]
response <- interpretAnonymousQuery @QueryRoot root query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "callsign" .= ("Mortgage" :: Text)
, "me" .= object
[ "name" .= ("jml" :: Text)
]
]
]
]
toJSON (toValue response) `shouldBe` expected
describe "interpretQuery" $ do
it "Handles the simplest named query" $ do
let root = pure (viewServerDog mortgage)
let query = [r|query myQuery {
dog {
name
}
}
|]
response <- interpretQuery @QueryRoot root query Nothing mempty
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Allows calling query by name" $ do
let root = pure (viewServerDog mortgage)
let query = [r|query myQuery {
dog {
name
}
}
|]
let Right name = makeName "myQuery"
response <- interpretQuery @QueryRoot root query (Just name) mempty
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected
describe "Handles variables" $ do
let root = pure (viewServerDog mortgage)
let Right schema = makeSchema @Dog
let Right query =
compileQuery schema
[r|query myQuery($whichCommand: DogCommand) {
dog {
name
doesKnowCommand(dogCommand: $whichCommand)
}
}
|]
it "Errors when no variables provided" $ do
response <- executeQuery @QueryRoot root query Nothing mempty
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= Null
]
]
, "errors" .=
[
object
-- TODO: This error message is pretty bad. We should define
-- a typeclass for client-friendly "Show" (separate from
-- actual Show which remains extremely useful for debugging)
-- and use that when including values in error messages.
[ "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)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Substitutes variables when they are provided" $ do
-- TODO: This is a crummy way to make a variable map. jml doesn't want
-- to come up with a new API in this PR, but probably we should have a
-- very simple function to turn a JSON value / object into the
-- variable map that we desire. Alternatively, we should have APIs
-- like Aeson does.
-- <https://github.com/jml/graphql-api/issues/96>
let Right varName = makeName "whichCommand"
let vars = Map.singleton (Variable varName) (toValue Sit)
response <- executeQuery @QueryRoot root query Nothing vars
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= False
]
]
]
toJSON (toValue response) `shouldBe` expected