graphql-api-0.4.0: tests/EndToEndSpec.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeOperators #-}
-- | 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 EndToEndSpec (spec) 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, List, Argument, (:>), Defaultable(..), HasAnnotatedInputType(..))
import GraphQL.Internal.Syntax.AST (Variable(..))
import GraphQL.Resolver ((:<>)(..), Handler, unionValue, returns)
import GraphQL.Value (ToValue(..), FromValue(..), makeName)
import Test.Hspec
import Text.RawString.QQ (r)
import ExampleSchema
-- | Example query root.
--
-- @
-- type QueryRoot {
-- dog: Dog
-- describeDog(dog: DEFAULT): String
-- }
-- @
--
-- Drawn from <https://facebook.github.io/graphql/#sec-Validation>.
type QueryRoot = Object "QueryRoot" '[]
'[ Field "dog" Dog
, Argument "dog" DogStuff :> Field "describeDog" Text
, Field "catOrDog" CatOrDog
, Field "catOrDogList" (List CatOrDog)
]
-- | An object that is passed as an argument. i.e. an input object.
--
-- TODO: Ideally this would be Dog itself, or ServerDog at worst.
-- Unfortunately, jml cannot figure out how to do that.
data DogStuff = DogStuff { toy :: Text, likesTreats :: Bool } deriving (Show, Generic)
instance FromValue DogStuff
instance HasAnnotatedInputType DogStuff
instance Defaultable DogStuff where
defaultFor "dog" = pure DogStuff { toy = "shoe", likesTreats = False }
defaultFor _ = empty
catOrDog :: Handler IO CatOrDog
catOrDog = do
name <- pure "MonadicFelix" -- we can do monadic actions
unionValue @Cat (catHandler name Nothing 15)
catOrDogList :: Handler IO (List CatOrDog)
catOrDogList =
returns [ unionValue @Cat (catHandler "Felix the Cat" (Just "felix") 42)
, unionValue @Cat (catHandler "Henry" Nothing 10)
, unionValue @Dog (viewServerDog mortgage)
]
catHandler :: Text -> Maybe Text -> Int32 -> Handler IO Cat
catHandler name nickName meowVolume = pure $
returns name :<>
returns (returns <$> nickName) :<>
returns . const False :<> -- doesn't know any commands
returns meowVolume
-- | 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 $
returns name :<>
returns (fmap returns nickname) :<>
returns barkVolume :<>
returns . doesKnowCommand dog :<>
returns . isHouseTrained dog :<>
viewServerHuman owner
describeDog :: DogStuff -> Handler IO Text
describeDog (DogStuff toy likesTreats)
| likesTreats = returns $ "likes treats and their favorite toy is a " <> toy
| otherwise = returns $ "their favorite toy is a " <> toy
rootHandler :: ServerDog -> Handler IO QueryRoot
rootHandler dog = pure $ viewServerDog dog :<> describeDog :<> catOrDog :<> catOrDogList
-- | 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'.
newtype ServerHuman = ServerHuman Text deriving (Eq, Ord, Show, Generic)
-- | Present a 'ServerHuman' as a GraphQL 'Human'.
viewServerHuman :: ServerHuman -> Handler IO Human
viewServerHuman (ServerHuman name) = pure (returns name)
-- | It me.
jml :: ServerHuman
jml = ServerHuman "jml"
spec :: Spec
spec = describe "End-to-end tests" $ do
describe "interpretAnonymousQuery" $ do
it "Handles the simplest possible valid query" $ do
let query = [r|{
dog {
name
}
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Handles more than one field" $ do
let query = [r|{
dog {
name
barkVolume
}
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) 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 query = [r|{
dog {
name
owner {
name
}
}
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) 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 query = [r|{
dog {
name
boss: owner {
name
}
}
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) 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 query = [r|{
dog {
name
doesKnowCommand(dogCommand: Sit)
}
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= False
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Passes arguments that are objects to functions" $ do
let query = [r|{
describeDog(dog: {toy: "bone", likesTreats: true})
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "describeDog" .= ("likes treats and their favorite toy is a bone" :: Text) ]
]
toJSON (toValue response) `shouldBe` expected
it "Passes default arguments that are objects to functions" $ do
let query = [r|{
describeDog
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "describeDog" .= ("their favorite toy is a shoe" :: Text) ]
]
toJSON (toValue response) `shouldBe` expected
it "Handles fairly complex queries" $ do
let query = [r|{
dog {
callsign: name
... on Dog {
callsign: name
me: owner {
... on Sentient {
name
}
... on Human {
name
}
name
}
}
}
}
|]
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "callsign" .= ("Mortgage" :: Text)
, "me" .= object
[ "name" .= ("jml" :: Text)
]
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Lets you query union types" $ do
let query = "{ catOrDog { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }"
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "catOrDog" .= object
[ "name" .= ("MonadicFelix" :: Text)
, "meowVolume" .= (15 :: Float)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Lets you query lists of union types" $ do
let query = "{ catOrDogList { ... on Cat { name meowVolume } ... on Dog { barkVolume } } }"
response <- interpretAnonymousQuery @QueryRoot (rootHandler mortgage) query
let expected =
object
[ "data" .= object
[ "catOrDogList" .=
[ object
[ "name" .= ("Felix the Cat" :: Text)
, "meowVolume" .= (42 :: Float)
]
, object
[ "name" .= ("Henry" :: Text)
, "meowVolume" .= (10 :: Float)
]
, object
[ "barkVolume" .= (0 :: Float)
]
]
]
]
toJSON (toValue response) `shouldBe` expected
describe "interpretQuery" $ do
it "Handles the simplest named query" $ do
let query = [r|query myQuery {
dog {
name
}
}
|]
response <- interpretQuery @QueryRoot (rootHandler mortgage) 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 query = [r|query myQuery {
dog {
name
}
}
|]
let Right name = makeName "myQuery"
response <- interpretQuery @QueryRoot (rootHandler mortgage) query (Just name) mempty
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected
describe "Handles variables" $ do
let Right schema = makeSchema @Dog
let Right query =
compileQuery schema
[r|query myQuery($whichCommand: DogCommand) {
dog {
name
doesKnowCommand(dogCommand: $whichCommand)
}
}
|]
let Right annotatedQuery =
compileQuery schema
[r|query myQuery($whichCommand: DogCommand!) {
dog {
name
doesKnowCommand(dogCommand: $whichCommand)
}
}
|]
let Right badQuery =
compileQuery schema
[r|query myQuery($whichCommand: String!) {
dog {
name
doesKnowCommand(dogCommand: $whichCommand)
}
}
|]
it "Errors when variable and argument types are in conflict" $ do
let vars = Map.singleton (Variable "whichCommand") $ toValue @Text "cow"
response <- executeQuery @QueryRoot (rootHandler mortgage) badQuery Nothing vars
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' (ConstString (String \"cow\")) not an enum: [Right (Name {unName = \"Sit\"}),Right (Name {unName = \"Down\"}),Right (Name {unName = \"Heel\"})]" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Errors when no variables provided" $ do
response <- executeQuery @QueryRoot (rootHandler mortgage) query Nothing mempty
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= Null
]
]
, "errors" .=
[
object
[ "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 (rootHandler mortgage) query Nothing vars
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= False
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Substitutes annotated variables when they are provided" $ do
let Right varName = makeName "whichCommand"
let vars = Map.singleton (Variable varName) (toValue Sit)
response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing vars
let expected =
object
[ "data" .= object
[ "dog" .= object
[ "name" .= ("Mortgage" :: Text)
, "doesKnowCommand" .= False
]
]
]
toJSON (toValue response) `shouldBe` expected
it "Errors when non-null variable is not provided" $ do
response <- executeQuery @QueryRoot (rootHandler mortgage) annotatedQuery Nothing mempty
let expected =
object
[ "data" .= Null
, "errors" .=
[
object
[ "message" .= ("Execution error: MissingValue (Variable (Name {unName = \"whichCommand\"}))" :: Text)
]
]
]
toJSON (toValue response) `shouldBe` expected