diff options
| -rw-r--r-- | Data/GraphQL/Execute.hs | 79 | ||||
| -rw-r--r-- | Data/GraphQL/Schema.hs | 76 | ||||
| -rw-r--r-- | tests/Test/StarWars/Data.hs | 10 | ||||
| -rw-r--r-- | tests/Test/StarWars/QueryTests.hs | 75 | ||||
| -rw-r--r-- | tests/Test/StarWars/Schema.hs | 92 |
5 files changed, 191 insertions, 141 deletions
diff --git a/Data/GraphQL/Execute.hs b/Data/GraphQL/Execute.hs index 1abda00..ba1eded 100644 --- a/Data/GraphQL/Execute.hs +++ b/Data/GraphQL/Execute.hs @@ -2,64 +2,41 @@ module Data.GraphQL.Execute (execute) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), pure) -import Data.Traversable (traverse) +import Control.Applicative ((<$>)) #endif -import Control.Applicative (Alternative, empty) -import Data.Foldable (fold) +import Control.Applicative (Alternative) import Data.Maybe (catMaybes) import qualified Data.Aeson as Aeson -import qualified Data.HashMap.Strict as HashMap -import qualified Data.Text as T import Data.GraphQL.AST -import Data.GraphQL.Schema (Resolver, Schema(..)) +import Data.GraphQL.Schema (Schema(..)) import qualified Data.GraphQL.Schema as Schema execute - :: (Alternative m, Monad m) + :: Alternative 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 _varDefs _ _ sels))]) = pure sels -query _ = empty - -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 - => Schema.Subs -> Resolver f -> Selection -> f Aeson.Object -selection f resolv (SelectionField field@(Field alias name _ _ _)) = - fmap (HashMap.singleton aliasOrName) - $ Aeson.toJSON - <$> resolv (fieldToInput f field) - where - aliasOrName = if T.null alias then name else alias -selection _ _ _ = empty - --- * AST/Schema conversions - -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 :: Schema.Subs -> Field -> Schema.Input -fieldToInput f (Field _ n as _ sels) = - -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error - Schema.InputField n (catMaybes $ argument f <$> as) - (fieldToInput f . selectionToField <$> sels) - -selectionToField :: Selection -> Field -selectionToField (SelectionField x) = x -selectionToField _ = error "selectionField: not implemented yet" +execute (Schema resolvm) subs = + fmap Aeson.toJSON . Schema.withFields resolvm . rootFields subs + +rootFields :: Schema.Subs -> Document -> [Field] +rootFields subs (Document [DefinitionOperation (Query (Node _varDefs _ _ sels))]) = + Schema.fields $ substitute subs <$> sels +rootFields _ _ = [] + +substitute :: Schema.Subs -> Selection -> Selection +substitute subs (SelectionField (Field alias name args directives sels)) = + SelectionField $ Field + alias + name + -- TODO: Get rid of `catMaybes`, invalid arguments should raise an error + (catMaybes $ subsArg subs <$> args) + directives + (substitute subs <$> sels) +substitute _ sel = sel + +-- TODO: Support different value types +subsArg :: Schema.Subs -> Argument -> Maybe Argument +subsArg subs (Argument n (ValueVariable (Variable v))) = + Argument n . ValueString . StringValue <$> subs v +subsArg _ arg = Just arg diff --git a/Data/GraphQL/Schema.hs b/Data/GraphQL/Schema.hs index 4ec3748..510741b 100644 --- a/Data/GraphQL/Schema.hs +++ b/Data/GraphQL/Schema.hs @@ -1,20 +1,46 @@ {-# LANGUAGE CPP #-} -module Data.GraphQL.Schema where +module Data.GraphQL.Schema + ( Schema(..) + , QueryRoot + , ResolverO + , ResolverM + , Output(..) + , Subs + , Scalar(..) + , withField + , withFieldFinal + , withFields + , withArgument + , outputTraverse + , fields + -- * Reexports + , Field + , Argument + ) where #if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>)) +import Data.Traversable (traverse) #endif +import Control.Applicative +import Data.Maybe (catMaybes) +import Data.Foldable (fold) import Data.String (IsString(fromString)) import Data.Aeson (ToJSON(toJSON)) import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.Text (Text, pack) +import qualified Data.Text as T (null) + +import Data.GraphQL.AST data Schema f = Schema (QueryRoot f) -type QueryRoot f = Resolver f +type QueryRoot f = ResolverM f -type Resolver f = Input -> f Output +-- TODO: Come up with a unique data type or better renaming +type ResolverM f = Field -> f (HashMap Text Output) +type ResolverO f = [Field] -> f Output data Output = OutputObject (HashMap Text Output) | OutputList [Output] @@ -22,12 +48,7 @@ data Output = OutputObject (HashMap Text Output) | OutputEnum Text deriving (Show) -type Argument = (Text, Scalar) - -type Subs = Text -> Maybe Scalar - -data Input = InputField Text [Argument] [Input] - deriving (Show) +type Subs = Text -> Maybe Text -- TODO: GraphQL spec for Integer Scalar is 32bits data Scalar = ScalarInt Int @@ -53,3 +74,38 @@ instance ToJSON Output where toJSON (OutputScalar x) = toJSON x toJSON (OutputEnum x) = toJSON x +-- * Helpers + +withField :: Alternative f => Text -> ([Argument] -> ResolverO f) -> ResolverM f +withField n f (Field alias name' args _ sels) = + if n == name' + then HashMap.singleton aliasOrName <$> f args (fields sels) + else empty + where + aliasOrName = if T.null alias then name' else alias + +withFieldFinal :: Alternative f => Text -> Output -> ResolverM f +withFieldFinal n o fld@(Field _ _ [] _ []) = withField n (\_ _ -> pure o) fld +withFieldFinal _ _ _ = empty + +withFields :: Alternative f => ResolverM f -> ResolverO f +withFields f = fmap (OutputObject . fold) . traverse f + +outputTraverse :: Applicative f => (a -> f Output) -> [a] -> f Output +outputTraverse f = fmap OutputList . traverse f + +withArgument :: Text -> [Argument] -> Maybe Scalar +withArgument x [Argument n s] = if x == n then scalarValue s else Nothing +withArgument _ _ = Nothing + +scalarValue :: Value -> Maybe Scalar +scalarValue (ValueInt x) = Just . ScalarInt $ fromIntegral x +scalarValue (ValueString (StringValue x)) = Just $ ScalarString x +scalarValue _ = Nothing + +fields :: SelectionSet -> [Field] +fields = catMaybes . fmap field + +field :: Selection -> Maybe Field +field (SelectionField x) = Just x +field _ = Nothing diff --git a/tests/Test/StarWars/Data.hs b/tests/Test/StarWars/Data.hs index 2c1b323..a898cea 100644 --- a/tests/Test/StarWars/Data.hs +++ b/tests/Test/StarWars/Data.hs @@ -38,7 +38,7 @@ data Droid = Droid type Character = Either Droid Human --- I don't think this is cumbersome enough to make it worth using lens. +-- I still don't think this is cumbersome enough to bring lens id_ :: Character -> ID id_ (Left x) = _id_ . _droidChar $ x @@ -128,7 +128,6 @@ threepio = Droid artoo :: Character artoo = Left artoo' - artoo' :: Droid artoo' = Droid { _droidChar = CharCommon @@ -149,7 +148,6 @@ getHero _ = artoo getHeroIO :: Int -> IO Character getHeroIO = pure . getHero - getHuman :: Alternative f => ID -> f Character getHuman = fmap Right . getHuman' @@ -171,3 +169,9 @@ getDroid' _ = empty getFriends :: Character -> [Character] getFriends char = catMaybes $ liftA2 (<|>) getDroid getHuman <$> friends char + +getEpisode :: Alternative f => Int -> f Text +getEpisode 4 = pure "NEWHOPE" +getEpisode 5 = pure "EMPIRE" +getEpisode 6 = pure "JEDI" +getEpisode _ = empty diff --git a/tests/Test/StarWars/QueryTests.hs b/tests/Test/StarWars/QueryTests.hs index 5ffb4b0..ccaf481 100644 --- a/tests/Test/StarWars/QueryTests.hs +++ b/tests/Test/StarWars/QueryTests.hs @@ -18,12 +18,6 @@ import Test.StarWars.Schema -- * Test -- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsQueryTests.js -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" @@ -148,24 +142,23 @@ test = testGroup "Star Wars Query Tests" $ object [ "human" .= object ["name" .= ("Han Solo" :: Text)] ] - -- TODO: This test is directly ported from `graphql-js`, however do we want - -- to mimic the same behavior? Is this part of the spec? Once proper - -- exceptions are implemented this test might no longer be meaningful. - -- If the same behavior needs to be replicated, should it be implemented - -- when defining the `Schema` or when executing? - -- - -- , testCase "Invalid ID" . testQueryParams - -- (\v -> if v == "id" - -- then Just "Not a valid ID" - -- else Nothing) - -- [r| query humanQuery($id: String!) { - -- human(id: $id) { - -- name - -- } - -- } - -- |] - -- $ object ["human" .= Aeson.Null] - , testCase "Luke with alias" . testQuery + , testCase "Invalid ID" $ testFailParams + (\v -> if v == "id" + then Just "Not a valid ID" + else Nothing) + [r| query humanQuery($id: String!) { + human(id: $id) { + name + } + } + |] + -- TODO: This test is directly ported from `graphql-js`, however do we want + -- to mimic the same behavior? Is this part of the spec? Once proper + -- exceptions are implemented this test might no longer be meaningful. + -- If the same behavior needs to be replicated, should it be implemented + -- when defining the `Schema` or when executing? + -- $ object ["human" .= Aeson.Null] + , testCase "Luke aliased" . testQuery [r| query FetchLukeAliased { luke: human(id: "1000") { name @@ -177,6 +170,28 @@ test = testGroup "Star Wars Query Tests" "name" .= ("Luke Skywalker" :: Text) ] ] + , testCase "R2-D2 ID and friends aliased" . testQuery + [r| query HeroNameAndFriendsQuery { + hero { + id + name + friends { + friendName: name + } + } + } + |] + $ object [ + "hero" .= object [ + "id" .= ("2001" :: Text) + , "name" .= ("R2-D2" :: Text) + , "friends" .= [ + object ["friendName" .= ("Luke Skywalker" :: Text)] + , object ["friendName" .= ("Han Solo" :: Text)] + , object ["friendName" .= ("Leia Organa" :: Text)] + ] + ] + ] , testCase "Luke and Leia aliased" . testQuery [r| query FetchLukeAndLeiaAliased { luke: human(id: "1000") { @@ -196,3 +211,15 @@ test = testGroup "Star Wars Query Tests" ] ] ] + +testQuery :: Text -> Aeson.Value -> Assertion +testQuery q expected = graphql schema q @?= Just expected + +-- testFail :: Text -> Assertion +-- testFail q = graphql schema q @?= Nothing + +testQueryParams :: Subs -> Text -> Aeson.Value -> Assertion +testQueryParams f q expected = graphqlSubs schema f q @?= Just expected + +testFailParams :: Subs -> Text -> Assertion +testFailParams f q = graphqlSubs schema f q @?= Nothing diff --git a/tests/Test/StarWars/Schema.hs b/tests/Test/StarWars/Schema.hs index 57c1b24..1cd8f42 100644 --- a/tests/Test/StarWars/Schema.hs +++ b/tests/Test/StarWars/Schema.hs @@ -1,17 +1,7 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Test.StarWars.Schema where -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure) -import Data.Traversable (traverse) -#endif -import Control.Applicative (Alternative, empty) -import Data.Foldable (fold) - -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Text (Text) +import Control.Applicative ((<|>), Alternative, empty) import Data.GraphQL.Schema @@ -23,47 +13,43 @@ import Test.StarWars.Data schema :: (Alternative m, Monad m) => Schema m schema = Schema query -query :: (Alternative m, Monad m) => QueryRoot m -query (InputField "hero" args ins) = hero args ins -query (InputField "human" args ins) = human args ins -query (InputField "droid" args ins) = droid args ins -query _ = empty +query :: (Alternative m, Monad m) => ResolverM m +query fld = + withField "hero" hero fld + <|> withField "human" human fld + <|> withField "droid" droid fld -hero :: Alternative f => [Argument] -> [Input] -> f Output +hero :: Alternative f => [Argument] -> ResolverO f hero [] = characterFields artoo -hero [("episode", ScalarInt n)] = characterFields $ getHero n -hero _ = const empty - -human :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output -human [("id", ScalarString i)] ins = flip characterFields ins =<< getHuman i -human _ _ = empty - -droid :: (Alternative m, Monad m) => [Argument] -> [Input] -> m Output -droid [("id", ScalarString i)] ins = flip characterFields ins =<< getDroid i -droid _ _ = empty - -episode :: Alternative f => Int -> f Output -episode 4 = pure $ OutputEnum "NEWHOPE" -episode 5 = pure $ OutputEnum "EMPIRE" -episode 6 = pure $ OutputEnum "JEDI" -episode _ = empty - -characterField :: Alternative f => Character -> Input -> f (HashMap Text Output) -characterField char (InputField "id" [] []) = - pure . HashMap.singleton "id" . OutputScalar . ScalarString . id_ $ char -characterField char (InputField "name" [] []) = - pure . HashMap.singleton "name" . OutputScalar . ScalarString . name $ char -characterField char (InputField "friends" [] ins) = - fmap (HashMap.singleton "friends" . OutputList) - . traverse (`characterFields` ins) - . getFriends - $ char -characterField char (InputField "appearsIn" [] []) = - fmap (HashMap.singleton "appearsIn" . OutputList) - . traverse episode - . appearsIn - $ char -characterField _ _ = empty - -characterFields :: Alternative f => Character -> [Input] -> f Output -characterFields char = fmap (OutputObject . fold) . traverse (characterField char) +hero args = + case withArgument "episode" args of + Just (ScalarInt n) -> characterFields $ getHero n + _ -> const empty + +human :: (Alternative m, Monad m) => [Argument] -> ResolverO m +human args flds = + case withArgument "id" args of + Just (ScalarString i) -> flip characterFields flds =<< getHuman i + _ -> empty + +droid :: (Alternative m, Monad m) => [Argument] -> ResolverO m +droid args flds = + case withArgument "id" args of + Just (ScalarString i) -> flip characterFields flds =<< getDroid i + _ -> empty + +characterField :: Alternative f => Character -> ResolverM f +characterField char fld = + withFieldFinal "id" (OutputScalar . ScalarString . id_ $ char) fld + <|> withFieldFinal "name" (OutputScalar . ScalarString . name $ char) fld + <|> withField "friends" friends' fld + <|> withField "appearsIn" appears' fld + where + friends' [] flds = outputTraverse (`characterFields` flds) $ getFriends char + friends' _ _ = empty + + appears' [] [] = outputTraverse (fmap OutputEnum . getEpisode) $ appearsIn char + appears' _ _ = empty + +characterFields :: Alternative f => Character -> ResolverO f +characterFields = withFields . characterField |