Constrain base monad to MonadCatch
Let's try MonadThrow/MonadCatch. It looks nice at a first glance. The monad transformer stack contains only the ReaderT, less lifts are required. Exception subtyping is easier, the user can (and should) define custom error types and throw them. And it is still possible to use pure error handling, if someone doesn't like runtime exceptions or need to run a query in a pure environment. Fixes #42.
This commit is contained in:
parent
e24386402b
commit
09135c581a
|
|
@ -24,12 +24,16 @@ and this project adheres to
|
|||
- Parsing subscriptions (the execution always fails yet).
|
||||
- `Error.ResponseEventStream`, `Type.Out.Resolve`, `Type.Out.Subscribe` and
|
||||
`Type.Out.SourceEventStream` define subscription resolvers.
|
||||
- `Error.ResolverException` is an exception that can be thrown by (field value
|
||||
and event stream) resolvers to signalize an error. Other exceptions will
|
||||
escape.
|
||||
|
||||
## Changed
|
||||
- `Type.Out.Resolver`: Interface fields don't have resolvers, object fields
|
||||
have value resolvers, root subscription type resolvers need an additional
|
||||
resolver that creates an event stream. `Resolver` represents these differences
|
||||
now and pairs a field with the function(s).
|
||||
now and pairs a field with the function(s). Resolvers don't have `ExceptT`,
|
||||
errors are handled with `MonadThrow`/`MonadCatch`.
|
||||
- All code from `Trans` is moved to `Type.Out` and exported by `Type` and
|
||||
`Type.Out`.
|
||||
- `AST.Core` contained only `Arguments` which was moved to `Type.Definition`.
|
||||
|
|
@ -43,6 +47,8 @@ and this project adheres to
|
|||
variable names is changed back to JSON since it is a common format and it
|
||||
saves additional conversions. Custom format still can be used with the
|
||||
underlying functions (in the `Execute` module).
|
||||
- The constraint of the base monad was changed to `MonadCatch` (and it implies
|
||||
`MonadThrow`).
|
||||
|
||||
## Removed
|
||||
- `Trans.ActionT` is an unneeded layer of complexity. `Type.Out.Resolver`
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ cabal-version: 1.12
|
|||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
--
|
||||
-- hash: 38e16611476c6163a049a4ddbaef34cf3fdef8f85d25f7bcaed839372c9fdf75
|
||||
-- hash: f3469205f704a81ee0f55655758cf588a9e9eb52303dadd58def32a2eb207696
|
||||
|
||||
name: graphql
|
||||
version: 0.8.0.0
|
||||
|
|
@ -64,6 +64,7 @@ library
|
|||
, base >=4.7 && <5
|
||||
, conduit
|
||||
, containers
|
||||
, exceptions
|
||||
, megaparsec
|
||||
, parser-combinators
|
||||
, scientific
|
||||
|
|
@ -100,6 +101,7 @@ test-suite tasty
|
|||
, base >=4.7 && <5
|
||||
, conduit
|
||||
, containers
|
||||
, exceptions
|
||||
, graphql
|
||||
, hspec
|
||||
, hspec-expectations
|
||||
|
|
|
|||
|
|
@ -30,6 +30,7 @@ dependencies:
|
|||
- base >= 4.7 && < 5
|
||||
- conduit
|
||||
- containers
|
||||
- exceptions
|
||||
- megaparsec
|
||||
- parser-combinators
|
||||
- scientific
|
||||
|
|
|
|||
|
|
@ -7,6 +7,7 @@ module Language.GraphQL
|
|||
, graphqlSubs
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Data.Aeson.Types as Aeson
|
||||
import Data.Either (fromRight)
|
||||
|
|
@ -20,7 +21,7 @@ import Text.Megaparsec (parse)
|
|||
|
||||
-- | If the text parses correctly as a @GraphQL@ query the query is
|
||||
-- executed using the given 'Schema'.
|
||||
graphql :: Monad m
|
||||
graphql :: MonadCatch m
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Text -- ^ Text representing a @GraphQL@ request document.
|
||||
-> m Aeson.Value -- ^ Response.
|
||||
|
|
@ -29,7 +30,7 @@ graphql schema = graphqlSubs schema mempty mempty
|
|||
-- | If the text parses correctly as a @GraphQL@ query the substitution is
|
||||
-- applied to the query and the query is then executed using to the given
|
||||
-- 'Schema'.
|
||||
graphqlSubs :: Monad m
|
||||
graphqlSubs :: MonadCatch m
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> Aeson.Object -- ^ Variable substitution function.
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE ExistentialQuantification #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
|
|
@ -8,6 +9,7 @@ module Language.GraphQL.Error
|
|||
, CollectErrsT
|
||||
, Error(..)
|
||||
, Resolution(..)
|
||||
, ResolverException(..)
|
||||
, Response(..)
|
||||
, ResponseEventStream
|
||||
, addErr
|
||||
|
|
@ -17,6 +19,7 @@ module Language.GraphQL.Error
|
|||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Exception (Exception(..))
|
||||
import Control.Monad.Trans.State (StateT, modify, runStateT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..), (|>))
|
||||
|
|
@ -102,6 +105,15 @@ data Response a = Response
|
|||
-- Stream.
|
||||
type ResponseEventStream m a = ConduitT () (Response a) m ()
|
||||
|
||||
-- | Only exceptions that inherit from 'ResolverException' a cought by the
|
||||
-- executor.
|
||||
data ResolverException = forall e. Exception e => ResolverException e
|
||||
|
||||
instance Show ResolverException where
|
||||
show (ResolverException e) = show e
|
||||
|
||||
instance Exception ResolverException
|
||||
|
||||
-- | Runs the given query computation, but collects the errors into an error
|
||||
-- list, which is then sent back with the data.
|
||||
runCollectErrs :: (Monad m, Serialize a)
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@ module Language.GraphQL.Execute
|
|||
, module Language.GraphQL.Execute.Coerce
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadCatch)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
|
|
@ -25,7 +26,7 @@ import Language.GraphQL.Type.Schema
|
|||
--
|
||||
-- Returns the result of the query against the schema wrapped in a /data/
|
||||
-- field, or errors wrapped in an /errors/ field.
|
||||
execute :: (Monad m, VariableValue a, Serialize b)
|
||||
execute :: (MonadCatch m, VariableValue a, Serialize b)
|
||||
=> Schema m -- ^ Resolvers.
|
||||
-> Maybe Text -- ^ Operation name.
|
||||
-> HashMap Name a -- ^ Variable substitution function.
|
||||
|
|
@ -39,7 +40,7 @@ execute schema operationName subs document =
|
|||
$ Transform.queryError queryError
|
||||
Right transformed -> executeRequest transformed
|
||||
|
||||
executeRequest :: (Monad m, Serialize a)
|
||||
executeRequest :: (MonadCatch m, Serialize a)
|
||||
=> Transform.Document m
|
||||
-> m (Either (ResponseEventStream m a) (Response a))
|
||||
executeRequest (Transform.Document types' rootObjectType operation)
|
||||
|
|
@ -53,7 +54,7 @@ executeRequest (Transform.Document types' rootObjectType operation)
|
|||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
executeOperation :: (Monad m, Serialize a)
|
||||
executeOperation :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ module Language.GraphQL.Execute.Execution
|
|||
, executeSelectionSet
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (Exception(..), MonadCatch(..))
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Control.Monad.Trans.Except (runExceptT)
|
||||
import Control.Monad.Trans.Reader (runReaderT)
|
||||
import Control.Monad.Trans.State (gets)
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
|
|
@ -19,7 +19,7 @@ import qualified Data.HashMap.Strict as HashMap
|
|||
import qualified Data.Map.Strict as Map
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
|
|
@ -31,14 +31,19 @@ import Language.GraphQL.Type.Internal
|
|||
import Language.GraphQL.Type.Schema
|
||||
import Prelude hiding (null)
|
||||
|
||||
resolveFieldValue :: Monad m
|
||||
resolveFieldValue :: MonadCatch m
|
||||
=> Type.Value
|
||||
-> Type.Subs
|
||||
-> Type.Resolve m
|
||||
-> m (Either Text Type.Value)
|
||||
-> CollectErrsT m Type.Value
|
||||
resolveFieldValue result args resolver =
|
||||
flip runReaderT context $ runExceptT resolver
|
||||
catch (lift $ runReaderT resolver context) handleFieldError
|
||||
where
|
||||
handleFieldError :: MonadCatch m
|
||||
=> ResolverException
|
||||
-> CollectErrsT m Type.Value
|
||||
handleFieldError e =
|
||||
addErr (Error (Text.pack $ displayException e) []) >> pure Type.Null
|
||||
context = Type.Context
|
||||
{ Type.arguments = Type.Arguments args
|
||||
, Type.values = result
|
||||
|
|
@ -102,7 +107,7 @@ instanceOf objectType (AbstractUnionType unionType) =
|
|||
where
|
||||
go unionMemberType acc = acc || objectType == unionMemberType
|
||||
|
||||
executeField :: (Monad m, Serialize a)
|
||||
executeField :: (MonadCatch m, Serialize a)
|
||||
=> Out.Resolver m
|
||||
-> Type.Value
|
||||
-> NonEmpty (Transform.Field m)
|
||||
|
|
@ -119,12 +124,10 @@ executeField fieldResolver prev fields
|
|||
case coerceArgumentValues argumentDefinitions arguments' of
|
||||
Nothing -> addErrMsg "Argument coercing failed."
|
||||
Just argumentValues -> do
|
||||
answer <- lift $ resolveFieldValue prev argumentValues resolver
|
||||
case answer of
|
||||
Right result -> completeValue fieldType fields result
|
||||
Left errorMessage -> addErrMsg errorMessage
|
||||
answer <- resolveFieldValue prev argumentValues resolver
|
||||
completeValue fieldType fields answer
|
||||
|
||||
completeValue :: (Monad m, Serialize a)
|
||||
completeValue :: (MonadCatch m, Serialize a)
|
||||
=> Out.Type m
|
||||
-> NonEmpty (Transform.Field m)
|
||||
-> Type.Value
|
||||
|
|
@ -166,13 +169,15 @@ completeValue (Out.UnionBaseType unionType) fields result
|
|||
Nothing -> addErrMsg "Value completion failed."
|
||||
completeValue _ _ _ = addErrMsg "Value completion failed."
|
||||
|
||||
mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m)
|
||||
mergeSelectionSets :: MonadCatch m
|
||||
=> NonEmpty (Transform.Field m)
|
||||
-> Seq (Transform.Selection m)
|
||||
mergeSelectionSets = foldr forEach mempty
|
||||
where
|
||||
forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet =
|
||||
selectionSet <> fieldSelectionSet
|
||||
|
||||
coerceResult :: (Monad m, Serialize a)
|
||||
coerceResult :: (MonadCatch m, Serialize a)
|
||||
=> Out.Type m
|
||||
-> Output a
|
||||
-> CollectErrsT m a
|
||||
|
|
@ -183,7 +188,7 @@ coerceResult outputType result
|
|||
-- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies
|
||||
-- each field to each 'Transform.Selection'. Resolves into a value containing
|
||||
-- the resolved 'Transform.Selection', or a null value and error information.
|
||||
executeSelectionSet :: (Monad m, Serialize a)
|
||||
executeSelectionSet :: (MonadCatch m, Serialize a)
|
||||
=> Type.Value
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ module Language.GraphQL.Execute.Subscribe
|
|||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Monad.Trans.Except (ExceptT(..), runExceptT)
|
||||
import Control.Monad.Catch (Exception(..), MonadCatch(..))
|
||||
import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
|
@ -17,6 +17,7 @@ import qualified Data.Map.Strict as Map
|
|||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Data.Sequence (Seq(..))
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Language.GraphQL.AST (Name)
|
||||
import Language.GraphQL.Execute.Coerce
|
||||
import Language.GraphQL.Execute.Execution
|
||||
|
|
@ -29,7 +30,7 @@ import Language.GraphQL.Type.Schema
|
|||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
subscribe :: (Monad m, Serialize a)
|
||||
subscribe :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
|
|
@ -38,7 +39,7 @@ subscribe types' objectType fields = do
|
|||
sourceStream <- createSourceEventStream types' objectType fields
|
||||
traverse (mapSourceToResponseEvent types' objectType fields) sourceStream
|
||||
|
||||
mapSourceToResponseEvent :: (Monad m, Serialize a)
|
||||
mapSourceToResponseEvent :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
|
|
@ -48,7 +49,7 @@ mapSourceToResponseEvent types' subscriptionType fields sourceStream = pure
|
|||
$ sourceStream
|
||||
.| mapMC (executeSubscriptionEvent types' subscriptionType fields)
|
||||
|
||||
createSourceEventStream :: Monad m
|
||||
createSourceEventStream :: MonadCatch m
|
||||
=> HashMap Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
|
|
@ -67,14 +68,18 @@ createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes
|
|||
where
|
||||
groupedFieldSet = collectFields subscriptionType fields
|
||||
|
||||
resolveFieldEventStream :: Monad m
|
||||
resolveFieldEventStream :: MonadCatch m
|
||||
=> Type.Value
|
||||
-> Type.Subs
|
||||
-> ExceptT Text (ReaderT Out.Context m) (Out.SourceEventStream m)
|
||||
-> Out.Subscribe m
|
||||
-> m (Either Text (Out.SourceEventStream m))
|
||||
resolveFieldEventStream result args resolver =
|
||||
flip runReaderT context $ runExceptT resolver
|
||||
catch (Right <$> runReaderT resolver context) handleEventStreamError
|
||||
where
|
||||
handleEventStreamError :: MonadCatch m
|
||||
=> ResolverException
|
||||
-> m (Either Text (Out.SourceEventStream m))
|
||||
handleEventStreamError = pure . Left . Text.pack . displayException
|
||||
context = Type.Context
|
||||
{ Type.arguments = Type.Arguments args
|
||||
, Type.values = result
|
||||
|
|
@ -82,7 +87,7 @@ resolveFieldEventStream result args resolver =
|
|||
|
||||
-- This is actually executeMutation, but we don't distinguish between queries
|
||||
-- and mutations yet.
|
||||
executeSubscriptionEvent :: (Monad m, Serialize a)
|
||||
executeSubscriptionEvent :: (MonadCatch m, Serialize a)
|
||||
=> HashMap Name (Type m)
|
||||
-> Out.ObjectType m
|
||||
-> Seq (Transform.Selection m)
|
||||
|
|
|
|||
|
|
@ -33,7 +33,6 @@ module Language.GraphQL.Type.Out
|
|||
) where
|
||||
|
||||
import Conduit
|
||||
import Control.Monad.Trans.Except (ExceptT)
|
||||
import Control.Monad.Trans.Reader (ReaderT, asks)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
|
@ -180,11 +179,11 @@ data Context = Context
|
|||
|
||||
-- | Monad transformer stack used by the resolvers for determining the resolved
|
||||
-- value of a field.
|
||||
type Resolve m = ExceptT Text (ReaderT Context m) Value
|
||||
type Resolve m = ReaderT Context m Value
|
||||
|
||||
-- | Monad transformer stack used by the resolvers for determining the resolved
|
||||
-- event stream of a subscription field.
|
||||
type Subscribe m = ExceptT Text (ReaderT Context m) (SourceEventStream m)
|
||||
type Subscribe m = ReaderT Context m (SourceEventStream m)
|
||||
|
||||
-- | A source stream represents the sequence of events, each of which will
|
||||
-- trigger a GraphQL execution corresponding to that event.
|
||||
|
|
@ -206,7 +205,7 @@ data Resolver m
|
|||
-- be optional then).
|
||||
argument :: Monad m => Name -> Resolve m
|
||||
argument argumentName = do
|
||||
argumentValue <- lift $ asks $ lookupArgument . arguments
|
||||
argumentValue <- asks $ lookupArgument . arguments
|
||||
pure $ fromMaybe Null argumentValue
|
||||
where
|
||||
lookupArgument (Arguments argumentMap) =
|
||||
|
|
|
|||
|
|
@ -7,11 +7,10 @@ module Language.GraphQL.ExecuteSpec
|
|||
( spec
|
||||
) where
|
||||
|
||||
import Control.Exception (SomeException)
|
||||
import Data.Aeson ((.=))
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Conduit
|
||||
import Data.Either (fromRight)
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Language.GraphQL.AST (Name)
|
||||
|
|
@ -23,14 +22,14 @@ import Language.GraphQL.Type.Out as Out
|
|||
import Test.Hspec (Spec, context, describe, it, shouldBe)
|
||||
import Text.Megaparsec (parse)
|
||||
|
||||
schema :: Schema Identity
|
||||
schema :: Schema (Either SomeException)
|
||||
schema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
, subscription = Just subscriptionType
|
||||
}
|
||||
|
||||
queryType :: Out.ObjectType Identity
|
||||
queryType :: Out.ObjectType (Either SomeException)
|
||||
queryType = Out.ObjectType "Query" Nothing []
|
||||
$ HashMap.singleton "philosopher"
|
||||
$ ValueResolver philosopherField
|
||||
|
|
@ -39,7 +38,7 @@ queryType = Out.ObjectType "Query" Nothing []
|
|||
philosopherField =
|
||||
Out.Field Nothing (Out.NonNullObjectType philosopherType) HashMap.empty
|
||||
|
||||
philosopherType :: Out.ObjectType Identity
|
||||
philosopherType :: Out.ObjectType (Either SomeException)
|
||||
philosopherType = Out.ObjectType "Philosopher" Nothing []
|
||||
$ HashMap.fromList resolvers
|
||||
where
|
||||
|
|
@ -54,7 +53,7 @@ philosopherType = Out.ObjectType "Philosopher" Nothing []
|
|||
= Out.Field Nothing (Out.NonNullScalarType string) HashMap.empty
|
||||
lastNameResolver = pure $ Type.String "Nietzsche"
|
||||
|
||||
subscriptionType :: Out.ObjectType Identity
|
||||
subscriptionType :: Out.ObjectType (Either SomeException)
|
||||
subscriptionType = Out.ObjectType "Subscription" Nothing []
|
||||
$ HashMap.singleton "newQuote"
|
||||
$ EventStreamResolver quoteField (pure $ Type.Object mempty)
|
||||
|
|
@ -63,7 +62,7 @@ subscriptionType = Out.ObjectType "Subscription" Nothing []
|
|||
quoteField =
|
||||
Out.Field Nothing (Out.NonNullObjectType quoteType) HashMap.empty
|
||||
|
||||
quoteType :: Out.ObjectType Identity
|
||||
quoteType :: Out.ObjectType (Either SomeException)
|
||||
quoteType = Out.ObjectType "Quote" Nothing []
|
||||
$ HashMap.singleton "quote"
|
||||
$ ValueResolver quoteField
|
||||
|
|
@ -84,9 +83,7 @@ spec =
|
|||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
actual = fromRight (singleError "")
|
||||
$ runIdentity
|
||||
$ either (pure . parseError) execute'
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName surname } }"
|
||||
in actual `shouldBe` expected
|
||||
it "merges selections" $
|
||||
|
|
@ -98,9 +95,7 @@ spec =
|
|||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
actual = fromRight (singleError "")
|
||||
$ runIdentity
|
||||
$ either (pure . parseError) execute'
|
||||
Right (Right actual) = either (pure . parseError) execute'
|
||||
$ parse document "" "{ philosopher { firstName } philosopher { lastName } }"
|
||||
in actual `shouldBe` expected
|
||||
context "Subscription" $
|
||||
|
|
@ -112,8 +107,7 @@ spec =
|
|||
]
|
||||
expected = Response data'' mempty
|
||||
execute' = execute schema Nothing (mempty :: HashMap Name Aeson.Value)
|
||||
Left stream = runIdentity
|
||||
$ either (pure . parseError) execute'
|
||||
Right (Left stream) = either (pure . parseError) execute'
|
||||
$ parse document "" "subscription { newQuote { quote } }"
|
||||
Just actual = runConduitPure $ stream .| await
|
||||
Right (Just actual) = runConduit $ stream .| await
|
||||
in actual `shouldBe` expected
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Test.StarWars.Data
|
||||
( Character
|
||||
, StarWarsException(..)
|
||||
, appearsIn
|
||||
, artoo
|
||||
, getDroid
|
||||
|
|
@ -16,11 +17,12 @@ module Test.StarWars.Data
|
|||
, typeName
|
||||
) where
|
||||
|
||||
import Data.Functor.Identity (Identity)
|
||||
import Control.Monad.Catch (Exception(..), MonadThrow(..), SomeException)
|
||||
import Control.Applicative (Alternative(..), liftA2)
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
import Data.Typeable (cast)
|
||||
import Language.GraphQL.Error
|
||||
import Language.GraphQL.Type
|
||||
|
||||
-- * Data
|
||||
|
|
@ -66,8 +68,20 @@ appearsIn :: Character -> [Int]
|
|||
appearsIn (Left x) = _appearsIn . _droidChar $ x
|
||||
appearsIn (Right x) = _appearsIn . _humanChar $ x
|
||||
|
||||
secretBackstory :: Resolve Identity
|
||||
secretBackstory = throwE "secretBackstory is secret."
|
||||
data StarWarsException = SecretBackstory | InvalidArguments
|
||||
|
||||
instance Show StarWarsException where
|
||||
show SecretBackstory = "secretBackstory is secret."
|
||||
show InvalidArguments = "Invalid arguments."
|
||||
|
||||
instance Exception StarWarsException where
|
||||
toException = toException . ResolverException
|
||||
fromException e = do
|
||||
ResolverException resolverException <- fromException e
|
||||
cast resolverException
|
||||
|
||||
secretBackstory :: Resolve (Either SomeException)
|
||||
secretBackstory = throwM SecretBackstory
|
||||
|
||||
typeName :: Character -> Text
|
||||
typeName = either (const "Droid") (const "Human")
|
||||
|
|
|
|||
|
|
@ -6,7 +6,6 @@ module Test.StarWars.QuerySpec
|
|||
|
||||
import qualified Data.Aeson as Aeson
|
||||
import Data.Aeson ((.=))
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Text (Text)
|
||||
import Language.GraphQL
|
||||
|
|
@ -357,8 +356,11 @@ spec = describe "Star Wars Query Tests" $ do
|
|||
alderaan = "homePlanet" .= ("Alderaan" :: Text)
|
||||
|
||||
testQuery :: Text -> Aeson.Value -> Expectation
|
||||
testQuery q expected = runIdentity (graphql schema q) `shouldBe` expected
|
||||
testQuery q expected =
|
||||
let Right actual = graphql schema q
|
||||
in actual `shouldBe` expected
|
||||
|
||||
testQueryParams :: Aeson.Object -> Text -> Aeson.Value -> Expectation
|
||||
testQueryParams f q expected =
|
||||
runIdentity (graphqlSubs schema Nothing f q) `shouldBe` expected
|
||||
let Right actual = graphqlSubs schema Nothing f q
|
||||
in actual `shouldBe` expected
|
||||
|
|
|
|||
|
|
@ -4,10 +4,8 @@ module Test.StarWars.Schema
|
|||
( schema
|
||||
) where
|
||||
|
||||
import Control.Monad.Catch (MonadThrow(..), SomeException)
|
||||
import Control.Monad.Trans.Reader (asks)
|
||||
import Control.Monad.Trans.Except (throwE)
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Functor.Identity (Identity)
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Data.Maybe (catMaybes)
|
||||
import Data.Text (Text)
|
||||
|
|
@ -19,7 +17,7 @@ import Prelude hiding (id)
|
|||
|
||||
-- See https://github.com/graphql/graphql-js/blob/master/src/__tests__/starWarsSchema.js
|
||||
|
||||
schema :: Schema Identity
|
||||
schema :: Schema (Either SomeException)
|
||||
schema = Schema
|
||||
{ query = queryType
|
||||
, mutation = Nothing
|
||||
|
|
@ -42,7 +40,7 @@ schema = Schema
|
|||
droidField = Out.Field Nothing (Out.NamedObjectType droidObject) mempty
|
||||
droidFieldResolver = ValueResolver droidField droid
|
||||
|
||||
heroObject :: Out.ObjectType Identity
|
||||
heroObject :: Out.ObjectType (Either SomeException)
|
||||
heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
||||
[ ("id", idFieldType)
|
||||
, ("name", nameFieldType)
|
||||
|
|
@ -57,7 +55,7 @@ heroObject = Out.ObjectType "Human" Nothing [] $ HashMap.fromList
|
|||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "homePlanet"
|
||||
|
||||
droidObject :: Out.ObjectType Identity
|
||||
droidObject :: Out.ObjectType (Either SomeException)
|
||||
droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
||||
[ ("id", idFieldType)
|
||||
, ("name", nameFieldType)
|
||||
|
|
@ -72,29 +70,29 @@ droidObject = Out.ObjectType "Droid" Nothing [] $ HashMap.fromList
|
|||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "primaryFunction"
|
||||
|
||||
typenameFieldType :: Resolver Identity
|
||||
typenameFieldType :: Resolver (Either SomeException)
|
||||
typenameFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "__typename"
|
||||
|
||||
idFieldType :: Resolver Identity
|
||||
idFieldType :: Resolver (Either SomeException)
|
||||
idFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType id) mempty)
|
||||
$ idField "id"
|
||||
|
||||
nameFieldType :: Resolver Identity
|
||||
nameFieldType :: Resolver (Either SomeException)
|
||||
nameFieldType
|
||||
= ValueResolver (Out.Field Nothing (Out.NamedScalarType string) mempty)
|
||||
$ idField "name"
|
||||
|
||||
friendsFieldType :: Resolver Identity
|
||||
friendsFieldType :: Resolver (Either SomeException)
|
||||
friendsFieldType
|
||||
= ValueResolver (Out.Field Nothing fieldType mempty)
|
||||
$ idField "friends"
|
||||
where
|
||||
fieldType = Out.ListType $ Out.NamedObjectType droidObject
|
||||
|
||||
appearsInField :: Resolver Identity
|
||||
appearsInField :: Resolver (Either SomeException)
|
||||
appearsInField
|
||||
= ValueResolver (Out.Field (Just description) fieldType mempty)
|
||||
$ idField "appearsIn"
|
||||
|
|
@ -102,14 +100,14 @@ appearsInField
|
|||
fieldType = Out.ListType $ Out.NamedEnumType episodeEnum
|
||||
description = "Which movies they appear in."
|
||||
|
||||
secretBackstoryFieldType :: Resolver Identity
|
||||
secretBackstoryFieldType :: Resolver (Either SomeException)
|
||||
secretBackstoryFieldType = ValueResolver field secretBackstory
|
||||
where
|
||||
field = Out.Field Nothing (Out.NamedScalarType string) mempty
|
||||
|
||||
idField :: Text -> Resolve Identity
|
||||
idField :: Text -> Resolve (Either SomeException)
|
||||
idField f = do
|
||||
v <- lift $ asks values
|
||||
v <- asks values
|
||||
let (Object v') = v
|
||||
pure $ v' HashMap.! f
|
||||
|
||||
|
|
@ -122,7 +120,7 @@ episodeEnum = EnumType "Episode" (Just description)
|
|||
empire = ("EMPIRE", EnumValue $ Just "Released in 1980.")
|
||||
jedi = ("JEDI", EnumValue $ Just "Released in 1983.")
|
||||
|
||||
hero :: Resolve Identity
|
||||
hero :: Resolve (Either SomeException)
|
||||
hero = do
|
||||
episode <- argument "episode"
|
||||
pure $ character $ case episode of
|
||||
|
|
@ -131,19 +129,19 @@ hero = do
|
|||
Enum "JEDI" -> getHero 6
|
||||
_ -> artoo
|
||||
|
||||
human :: Resolve Identity
|
||||
human :: Resolve (Either SomeException)
|
||||
human = do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
String i -> pure $ maybe Null character $ getHuman i >>= Just
|
||||
_ -> throwE "Invalid arguments."
|
||||
_ -> throwM InvalidArguments
|
||||
|
||||
droid :: Resolve Identity
|
||||
droid :: Resolve (Either SomeException)
|
||||
droid = do
|
||||
id' <- argument "id"
|
||||
case id' of
|
||||
String i -> pure $ maybe Null character $ getDroid i >>= Just
|
||||
_ -> throwE "Invalid arguments."
|
||||
_ -> throwM InvalidArguments
|
||||
|
||||
character :: Character -> Value
|
||||
character char = Object $ HashMap.fromList
|
||||
|
|
|
|||
Loading…
Reference in New Issue