diff --git a/CHANGELOG.md b/CHANGELOG.md index 7cfe229..efcc224 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -12,6 +12,7 @@ and this project adheres to - `Execute` reexports `Execute.Coerce`. - `Error.Error` is an error representation with a message and source location. - `Error.Response` represents a result of running a GraphQL query. +- `Type.Schema` exports `Type` which lists all types possible in the schema. ## Changed - `Trans.ActionT` has become to `Type.Out.ResolverT`. Since `Type.Out.Resolver` diff --git a/graphql.cabal b/graphql.cabal index 7c8737c..e7ac249 100644 --- a/graphql.cabal +++ b/graphql.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 7101732e7932f4605d0c6ecaf88fd11c1fb6cb8045e6e0f419858cad027f383a +-- hash: c06170c5fd3d1c3e42fb8c8fde8afd88bf3dd142f6cee1f83128e8d00d443f2d name: graphql version: 0.8.0.0 @@ -50,12 +50,12 @@ library Language.GraphQL.Type Language.GraphQL.Type.In Language.GraphQL.Type.Out + Language.GraphQL.Type.Schema other-modules: Language.GraphQL.Execute.Execution Language.GraphQL.Execute.Transform Language.GraphQL.Type.Definition - Language.GraphQL.Type.Directive - Language.GraphQL.Type.Schema + Language.GraphQL.Type.Internal hs-source-dirs: src build-depends: diff --git a/package.yaml b/package.yaml index af29c48..88b238c 100644 --- a/package.yaml +++ b/package.yaml @@ -43,8 +43,7 @@ library: - Language.GraphQL.Execute.Execution - Language.GraphQL.Execute.Transform - Language.GraphQL.Type.Definition - - Language.GraphQL.Type.Directive - - Language.GraphQL.Type.Schema + - Language.GraphQL.Type.Internal tests: tasty: diff --git a/src/Language/GraphQL/Error.hs b/src/Language/GraphQL/Error.hs index 4c37f6a..b36be9c 100644 --- a/src/Language/GraphQL/Error.hs +++ b/src/Language/GraphQL/Error.hs @@ -79,8 +79,8 @@ singleError :: Serialize a => Text -> Response a singleError message = Response null $ Seq.singleton $ makeErrorMessage message -- | Convenience function for just wrapping an error message. -addErrMsg :: Monad m => Text -> CollectErrsT m () -addErrMsg = addErr . makeErrorMessage +addErrMsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a +addErrMsg errorMessage = (addErr . makeErrorMessage) errorMessage >> pure null -- | @GraphQL@ error. data Error = Error diff --git a/src/Language/GraphQL/Execute/Execution.hs b/src/Language/GraphQL/Execute/Execution.hs index 2b12c43..e9ba4a7 100644 --- a/src/Language/GraphQL/Execute/Execution.hs +++ b/src/Language/GraphQL/Execute/Execution.hs @@ -25,6 +25,7 @@ import qualified Language.GraphQL.Execute.Transform as Transform import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Internal import Language.GraphQL.Type.Schema import Prelude hiding (null) @@ -108,12 +109,12 @@ executeField fieldDefinition prev fields = do let Out.Field _ fieldType argumentDefinitions resolver = fieldDefinition let (Transform.Field _ _ arguments' _ :| []) = fields case coerceArgumentValues argumentDefinitions arguments' of - Nothing -> errmsg "Argument coercing failed." + 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 -> errmsg errorMessage + Left errorMessage -> addErrMsg errorMessage completeValue :: (Monad m, Serialize a) => Out.Type m @@ -136,7 +137,7 @@ completeValue outputType@(Out.EnumBaseType enumType) _ (Type.Enum enum) = let Type.EnumType _ _ enumMembers = enumType in if HashMap.member enum enumMembers then coerceResult outputType $ Enum enum - else errmsg "Value completion failed." + else addErrMsg "Value completion failed." completeValue (Out.ObjectBaseType objectType) fields result = executeSelectionSet result objectType $ mergeSelectionSets fields completeValue (Out.InterfaceBaseType interfaceType) fields result @@ -146,7 +147,7 @@ completeValue (Out.InterfaceBaseType interfaceType) fields result case concreteType of Just objectType -> executeSelectionSet result objectType $ mergeSelectionSets fields - Nothing -> errmsg "Value completion failed." + Nothing -> addErrMsg "Value completion failed." completeValue (Out.UnionBaseType unionType) fields result | Type.Object objectMap <- result = do let abstractType = AbstractUnionType unionType @@ -154,8 +155,8 @@ completeValue (Out.UnionBaseType unionType) fields result case concreteType of Just objectType -> executeSelectionSet result objectType $ mergeSelectionSets fields - Nothing -> errmsg "Value completion failed." -completeValue _ _ _ = errmsg "Value completion failed." + Nothing -> addErrMsg "Value completion failed." +completeValue _ _ _ = addErrMsg "Value completion failed." mergeSelectionSets :: Monad m => NonEmpty (Transform.Field m) -> Seq (Transform.Selection m) mergeSelectionSets = foldr forEach mempty @@ -163,16 +164,13 @@ mergeSelectionSets = foldr forEach mempty forEach (Transform.Field _ _ _ fieldSelectionSet) selectionSet = selectionSet <> fieldSelectionSet -errmsg :: (Monad m, Serialize a) => Text -> CollectErrsT m a -errmsg errorMessage = addErrMsg errorMessage >> pure null - coerceResult :: (Monad m, Serialize a) => Out.Type m -> Output a -> CollectErrsT m a coerceResult outputType result | Just serialized <- serialize outputType result = pure serialized - | otherwise = errmsg "Result coercion failed." + | otherwise = addErrMsg "Result coercion failed." -- | Takes an 'Out.ObjectType' and a list of 'Transform.Selection's and applies -- each field to each 'Transform.Selection'. Resolves into a value containing diff --git a/src/Language/GraphQL/Execute/Transform.hs b/src/Language/GraphQL/Execute/Transform.hs index 79ee855..30d5130 100644 --- a/src/Language/GraphQL/Execute/Transform.hs +++ b/src/Language/GraphQL/Execute/Transform.hs @@ -45,10 +45,10 @@ import qualified Data.Text as Text import qualified Language.GraphQL.AST as Full import Language.GraphQL.AST (Name) import qualified Language.GraphQL.Execute.Coerce as Coerce -import Language.GraphQL.Type.Directive (Directive(..)) -import qualified Language.GraphQL.Type.Directive as Directive +import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type as Type import qualified Language.GraphQL.Type.In as In +import Language.GraphQL.Type.Internal import qualified Language.GraphQL.Type.Out as Out import Language.GraphQL.Type.Schema @@ -285,7 +285,7 @@ selection (Full.Field alias name arguments' directives' selections) = maybe (Left mempty) (Right . SelectionField) <$> do fieldArguments <- foldM go HashMap.empty arguments' fieldSelections <- appendSelection selections - fieldDirectives <- Directive.selection <$> directives directives' + fieldDirectives <- Definition.selection <$> directives directives' let field' = Field alias name fieldArguments fieldSelections pure $ field' <$ fieldDirectives where @@ -294,7 +294,7 @@ selection (Full.Field alias name arguments' directives' selections) = selection (Full.FragmentSpread name directives') = maybe (Left mempty) (Right . SelectionFragment) <$> do - spreadDirectives <- Directive.selection <$> directives directives' + spreadDirectives <- Definition.selection <$> directives directives' fragments' <- gets fragments fragmentDefinitions' <- gets fragmentDefinitions @@ -308,7 +308,7 @@ selection (Full.FragmentSpread name directives') = _ -> lift $ pure Nothing | otherwise -> lift $ pure Nothing selection (Full.InlineFragment type' directives' selections) = do - fragmentDirectives <- Directive.selection <$> directives directives' + fragmentDirectives <- Definition.selection <$> directives directives' case fragmentDirectives of Nothing -> pure $ Left mempty _ -> do @@ -336,11 +336,11 @@ appendSelection = foldM go mempty append acc (Left list) = list >< acc append acc (Right one) = one <| acc -directives :: [Full.Directive] -> State (Replacement m) [Directive] +directives :: [Full.Directive] -> State (Replacement m) [Definition.Directive] directives = traverse directive where directive (Full.Directive directiveName directiveArguments) - = Directive directiveName . Type.Arguments + = Definition.Directive directiveName . Type.Arguments <$> foldM go HashMap.empty directiveArguments go arguments (Full.Argument name value') = do substitutedValue <- value value' diff --git a/src/Language/GraphQL/Type/Definition.hs b/src/Language/GraphQL/Type/Definition.hs index 40055e7..476fb3a 100644 --- a/src/Language/GraphQL/Type/Definition.hs +++ b/src/Language/GraphQL/Type/Definition.hs @@ -3,6 +3,7 @@ -- | Types that can be used as both input and output types. module Language.GraphQL.Type.Definition ( Arguments(..) + , Directive(..) , EnumType(..) , EnumValue(..) , ScalarType(..) @@ -12,14 +13,16 @@ module Language.GraphQL.Type.Definition , float , id , int + , selection , string ) where import Data.Int (Int32) import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap import Data.String (IsString(..)) import Data.Text (Text) -import Language.GraphQL.AST.Document (Name) +import Language.GraphQL.AST (Name) import Prelude hiding (id) -- | Represents accordingly typed GraphQL values. @@ -124,3 +127,49 @@ id = ScalarType "ID" (Just description) \JSON response as a String; however, it is not intended to be \ \human-readable. When expected as an input type, any string (such as \ \`\"4\"`) or integer (such as `4`) input value will be accepted as an ID." + +-- | Directive. +data Directive = Directive Name Arguments + deriving (Eq, Show) + +-- | Directive processing status. +data Status + = Skip -- ^ Skip the selection and stop directive processing + | Include Directive -- ^ The directive was processed, try other handlers + | Continue Directive -- ^ Directive handler mismatch, try other handlers + +-- | Takes a list of directives, handles supported directives and excludes them +-- from the result. If the selection should be skipped, returns 'Nothing'. +selection :: [Directive] -> Maybe [Directive] +selection = foldr go (Just []) + where + go directive' directives' = + case (skip . include) (Continue directive') of + (Include _) -> directives' + Skip -> Nothing + (Continue x) -> (x :) <$> directives' + +handle :: (Directive -> Status) -> Status -> Status +handle _ Skip = Skip +handle handler (Continue directive) = handler directive +handle handler (Include directive) = handler directive + +-- * Directive implementations + +skip :: Status -> Status +skip = handle skip' + where + skip' directive'@(Directive "skip" (Arguments arguments)) = + case HashMap.lookup "if" arguments of + (Just (Boolean True)) -> Skip + _ -> Include directive' + skip' directive' = Continue directive' + +include :: Status -> Status +include = handle include' + where + include' directive'@(Directive "include" (Arguments arguments)) = + case HashMap.lookup "if" arguments of + (Just (Boolean True)) -> Include directive' + _ -> Skip + include' directive' = Continue directive' diff --git a/src/Language/GraphQL/Type/Directive.hs b/src/Language/GraphQL/Type/Directive.hs deleted file mode 100644 index 6ff73d4..0000000 --- a/src/Language/GraphQL/Type/Directive.hs +++ /dev/null @@ -1,56 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Language.GraphQL.Type.Directive - ( Directive(..) - , selection - ) where - -import qualified Data.HashMap.Strict as HashMap -import Language.GraphQL.AST (Name) -import Language.GraphQL.Type.Definition - --- | Directive. -data Directive = Directive Name Arguments - deriving (Eq, Show) - --- | Directive processing status. -data Status - = Skip -- ^ Skip the selection and stop directive processing - | Include Directive -- ^ The directive was processed, try other handlers - | Continue Directive -- ^ Directive handler mismatch, try other handlers - --- | Takes a list of directives, handles supported directives and excludes them --- from the result. If the selection should be skipped, returns 'Nothing'. -selection :: [Directive] -> Maybe [Directive] -selection = foldr go (Just []) - where - go directive' directives' = - case (skip . include) (Continue directive') of - (Include _) -> directives' - Skip -> Nothing - (Continue x) -> (x :) <$> directives' - -handle :: (Directive -> Status) -> Status -> Status -handle _ Skip = Skip -handle handler (Continue directive) = handler directive -handle handler (Include directive) = handler directive - --- * Directive implementations - -skip :: Status -> Status -skip = handle skip' - where - skip' directive'@(Directive "skip" (Arguments arguments)) = - case HashMap.lookup "if" arguments of - (Just (Boolean True)) -> Skip - _ -> Include directive' - skip' directive' = Continue directive' - -include :: Status -> Status -include = handle include' - where - include' directive'@(Directive "include" (Arguments arguments)) = - case HashMap.lookup "if" arguments of - (Just (Boolean True)) -> Include directive' - _ -> Skip - include' directive' = Continue directive' diff --git a/src/Language/GraphQL/Type/Internal.hs b/src/Language/GraphQL/Type/Internal.hs new file mode 100644 index 0000000..07dabe6 --- /dev/null +++ b/src/Language/GraphQL/Type/Internal.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ExplicitForAll #-} + +module Language.GraphQL.Type.Internal + ( AbstractType(..) + , CompositeType(..) + , collectReferencedTypes + ) where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HashMap +import Language.GraphQL.AST (Name) +import qualified Language.GraphQL.Type.Definition as Definition +import qualified Language.GraphQL.Type.In as In +import qualified Language.GraphQL.Type.Out as Out +import Language.GraphQL.Type.Schema + +-- | These types may describe the parent context of a selection set. +data CompositeType m + = CompositeUnionType (Out.UnionType m) + | CompositeObjectType (Out.ObjectType m) + | CompositeInterfaceType (Out.InterfaceType m) + deriving Eq + +-- | These types may describe the parent context of a selection set. +data AbstractType m + = AbstractUnionType (Out.UnionType m) + | AbstractInterfaceType (Out.InterfaceType m) + deriving Eq + +-- | Traverses the schema and finds all referenced types. +collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m) +collectReferencedTypes schema = + let queryTypes = traverseObjectType (query schema) HashMap.empty + in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema + where + collect traverser typeName element foundTypes + | HashMap.member typeName foundTypes = foundTypes + | otherwise = traverser $ HashMap.insert typeName element foundTypes + visitFields (Out.Field _ outputType arguments _) foundTypes + = traverseOutputType outputType + $ foldr visitArguments foundTypes arguments + visitArguments (In.Argument _ inputType _) = traverseInputType inputType + visitInputFields (In.InputField _ inputType _) = traverseInputType inputType + traverseInputType (In.InputObjectBaseType objectType) = + let (In.InputObjectType typeName _ inputFields) = objectType + element = InputObjectType objectType + traverser = flip (foldr visitInputFields) inputFields + in collect traverser typeName element + traverseInputType (In.ListBaseType listType) = + traverseInputType listType + traverseInputType (In.ScalarBaseType scalarType) = + let (Definition.ScalarType typeName _) = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseInputType (In.EnumBaseType enumType) = + let (Definition.EnumType typeName _ _) = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseOutputType (Out.ObjectBaseType objectType) = + traverseObjectType objectType + traverseOutputType (Out.InterfaceBaseType interfaceType) = + traverseInterfaceType interfaceType + traverseOutputType (Out.UnionBaseType unionType) = + let (Out.UnionType typeName _ types) = unionType + traverser = flip (foldr traverseObjectType) types + in collect traverser typeName (UnionType unionType) + traverseOutputType (Out.ListBaseType listType) = + traverseOutputType listType + traverseOutputType (Out.ScalarBaseType scalarType) = + let (Definition.ScalarType typeName _) = scalarType + in collect Prelude.id typeName (ScalarType scalarType) + traverseOutputType (Out.EnumBaseType enumType) = + let (Definition.EnumType typeName _ _) = enumType + in collect Prelude.id typeName (EnumType enumType) + traverseObjectType objectType foundTypes = + let (Out.ObjectType typeName _ interfaces fields) = objectType + element = ObjectType objectType + traverser = polymorphicTraverser interfaces fields + in collect traverser typeName element foundTypes + traverseInterfaceType interfaceType foundTypes = + let (Out.InterfaceType typeName _ interfaces fields) = interfaceType + element = InterfaceType interfaceType + traverser = polymorphicTraverser interfaces fields + in collect traverser typeName element foundTypes + polymorphicTraverser interfaces fields + = flip (foldr visitFields) fields + . flip (foldr traverseInterfaceType) interfaces diff --git a/src/Language/GraphQL/Type/Schema.hs b/src/Language/GraphQL/Type/Schema.hs index 4420cbb..8cf0383 100644 --- a/src/Language/GraphQL/Type/Schema.hs +++ b/src/Language/GraphQL/Type/Schema.hs @@ -1,18 +1,10 @@ -{-# LANGUAGE ExplicitForAll #-} - -- | This module provides a representation of a @GraphQL@ Schema in addition to -- functions for defining and manipulating schemas. module Language.GraphQL.Type.Schema - ( AbstractType(..) - , CompositeType(..) - , Schema(..) + ( Schema(..) , Type(..) - , collectReferencedTypes ) where -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Language.GraphQL.AST.Document (Name) import qualified Language.GraphQL.Type.Definition as Definition import qualified Language.GraphQL.Type.In as In import qualified Language.GraphQL.Type.Out as Out @@ -27,19 +19,6 @@ data Type m | UnionType (Out.UnionType m) deriving Eq --- | These types may describe the parent context of a selection set. -data CompositeType m - = CompositeUnionType (Out.UnionType m) - | CompositeObjectType (Out.ObjectType m) - | CompositeInterfaceType (Out.InterfaceType m) - deriving Eq - --- | These types may describe the parent context of a selection set. -data AbstractType m - = AbstractUnionType (Out.UnionType m) - | AbstractInterfaceType (Out.InterfaceType m) - deriving Eq - -- | A Schema is created by supplying the root types of each type of operation, -- query and mutation (optional). A schema definition is then supplied to the -- validator and executor. @@ -51,60 +30,3 @@ data Schema m = Schema { query :: Out.ObjectType m , mutation :: Maybe (Out.ObjectType m) } - --- | Traverses the schema and finds all referenced types. -collectReferencedTypes :: forall m. Schema m -> HashMap Name (Type m) -collectReferencedTypes schema = - let queryTypes = traverseObjectType (query schema) HashMap.empty - in maybe queryTypes (`traverseObjectType` queryTypes) $ mutation schema - where - collect traverser typeName element foundTypes - | HashMap.member typeName foundTypes = foundTypes - | otherwise = traverser $ HashMap.insert typeName element foundTypes - visitFields (Out.Field _ outputType arguments _) foundTypes - = traverseOutputType outputType - $ foldr visitArguments foundTypes arguments - visitArguments (In.Argument _ inputType _) = traverseInputType inputType - visitInputFields (In.InputField _ inputType _) = traverseInputType inputType - traverseInputType (In.InputObjectBaseType objectType) = - let (In.InputObjectType typeName _ inputFields) = objectType - element = InputObjectType objectType - traverser = flip (foldr visitInputFields) inputFields - in collect traverser typeName element - traverseInputType (In.ListBaseType listType) = - traverseInputType listType - traverseInputType (In.ScalarBaseType scalarType) = - let (Definition.ScalarType typeName _) = scalarType - in collect Prelude.id typeName (ScalarType scalarType) - traverseInputType (In.EnumBaseType enumType) = - let (Definition.EnumType typeName _ _) = enumType - in collect Prelude.id typeName (EnumType enumType) - traverseOutputType (Out.ObjectBaseType objectType) = - traverseObjectType objectType - traverseOutputType (Out.InterfaceBaseType interfaceType) = - traverseInterfaceType interfaceType - traverseOutputType (Out.UnionBaseType unionType) = - let (Out.UnionType typeName _ types) = unionType - traverser = flip (foldr traverseObjectType) types - in collect traverser typeName (UnionType unionType) - traverseOutputType (Out.ListBaseType listType) = - traverseOutputType listType - traverseOutputType (Out.ScalarBaseType scalarType) = - let (Definition.ScalarType typeName _) = scalarType - in collect Prelude.id typeName (ScalarType scalarType) - traverseOutputType (Out.EnumBaseType enumType) = - let (Definition.EnumType typeName _ _) = enumType - in collect Prelude.id typeName (EnumType enumType) - traverseObjectType objectType foundTypes = - let (Out.ObjectType typeName _ interfaces fields) = objectType - element = ObjectType objectType - traverser = polymorphicTraverser interfaces fields - in collect traverser typeName element foundTypes - traverseInterfaceType interfaceType foundTypes = - let (Out.InterfaceType typeName _ interfaces fields) = interfaceType - element = InterfaceType interfaceType - traverser = polymorphicTraverser interfaces fields - in collect traverser typeName element foundTypes - polymorphicTraverser interfaces fields - = flip (foldr visitFields) fields - . flip (foldr traverseInterfaceType) interfaces diff --git a/stack.yaml b/stack.yaml index 6e55f3d..65e78cc 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.3 +resolver: lts-16.4 packages: - .