morpheus-graphql-app 0.27.2 → 0.27.3
raw patch · 4 files changed
+204/−298 lines, 4 filesdep ~transformersdep ~vectorPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: transformers, vector
API changes (from Hackage documentation)
Files
- morpheus-graphql-app.cabal +5/−5
- src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs +8/−8
- src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs +21/−54
- src/Data/Morpheus/App/RenderIntrospection.hs +170/−231
morpheus-graphql-app.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morpheus-graphql-app-version: 0.27.2+version: 0.27.3 synopsis: Morpheus GraphQL App description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -165,9 +165,9 @@ , template-haskell >=2.0.0 && <3.0.0 , text >=1.2.3 && <3.0.0 , th-lift-instances >=0.1.1 && <0.3.0- , transformers >=0.3.0 && <0.6.0+ , transformers >=0.3.0 && <0.7.0 , unordered-containers >=0.2.8 && <0.3.0- , vector >=0.12.0.1 && <0.13.0+ , vector >=0.12.0.1 && <0.15.0 default-language: Haskell2010 test-suite morpheus-graphql-app-test@@ -201,7 +201,7 @@ , template-haskell >=2.0.0 && <3.0.0 , text >=1.2.3 && <3.0.0 , th-lift-instances >=0.1.1 && <0.3.0- , transformers >=0.3.0 && <0.6.0+ , transformers >=0.3.0 && <0.7.0 , unordered-containers >=0.2.8 && <0.3.0- , vector >=0.12.0.1 && <0.13.0+ , vector >=0.12.0.1 && <0.15.0 default-language: Haskell2010
src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs view
@@ -88,11 +88,11 @@ subscriptionResolver, channelMap }- ctx@ResolverContext {operation = Operation {..}, ..} =+ ctx@ResolverContext {operation = Operation {..}} = selectByOperation operationType where selectByOperation OPERATION_QUERY =- runResolver channelMap (rootResolver (withIntroFields schema <$> queryResolver) operationSelection) ctx+ runResolver channelMap (rootResolver (withIntroFields <$> queryResolver) operationSelection) ctx selectByOperation OPERATION_MUTATION = runResolver channelMap (rootResolver mutationResolver operationSelection) ctx selectByOperation OPERATION_SUBSCRIPTION =@@ -106,16 +106,16 @@ where queryResolver = do name <- asks (typeName . query . schema)- resolveNamedRoot name (withNamedIntroFields name ctx queryResolverMap) operationSelection+ resolveNamedRoot name (withNamedIntroFields name queryResolverMap) operationSelection selectByOperation _ = throwError "mutation and subscription is not supported for namedResolvers" -withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverContext -> ResolverMap m -> ResolverMap m-withNamedIntroFields queryName ResolverContext {..} = adjust updateNamed queryName+withNamedIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => TypeName -> ResolverMap m -> ResolverMap m+withNamedIntroFields = adjust updateNamed where updateNamed NamedResolver {..} = NamedResolver {resolverFun = const (updateResult <$> resolverFun ["ROOT"]), ..} where- updateResult [NamedObjectResolver obj] = [NamedObjectResolver (withIntroFields schema obj)]+ updateResult [NamedObjectResolver obj] = [NamedObjectResolver (withIntroFields obj)] updateResult value = value -withIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => Schema VALID -> ObjectTypeResolver m -> ObjectTypeResolver m-withIntroFields schema (ObjectTypeResolver fields) = ObjectTypeResolver (fields <> objectFields (schemaAPI schema))+withIntroFields :: (MonadResolver m, MonadOperation m ~ QUERY) => ObjectTypeResolver m -> ObjectTypeResolver m+withIntroFields (ObjectTypeResolver fields) = ObjectTypeResolver (fields <> objectFields schemaAPI)
src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs view
@@ -1,7 +1,7 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -12,91 +12,58 @@ import Data.Morpheus.App.Internal.Resolving.MonadResolver ( MonadResolver (..),- withArguments,+ ResolverContext (..),+ getArgument, ) import Data.Morpheus.App.Internal.Resolving.Types ( ObjectTypeResolver (..), ResolverValue,- mkList, mkNull, mkObject, ) import Data.Morpheus.App.RenderIntrospection- ( createObjectType,- render,+ ( renderI, ) import Data.Morpheus.Internal.Utils- ( empty,- selectOr,+ ( IsMap (..), ) import Data.Morpheus.Types.Internal.AST- ( Argument (..),- DirectiveDefinition (..),- FieldName,- OBJECT,+ ( DirectiveDefinition (..), QUERY, ScalarValue (..), Schema (..),- TypeDefinition (..),- TypeName, VALID, Value (..), packName, typeDefinitions, ) import Relude hiding (empty)-import qualified Relude as HM -resolveTypes :: MonadResolver m => Schema VALID -> m (ResolverValue m)-resolveTypes schema = mkList <$> traverse render (toList $ typeDefinitions schema)--renderOperation ::- MonadResolver m =>- Maybe (TypeDefinition OBJECT VALID) ->- m (ResolverValue m)-renderOperation (Just TypeDefinition {typeName}) = pure $ createObjectType typeName Nothing [] empty-renderOperation Nothing = pure mkNull--findType ::- MonadResolver m =>- TypeName ->- Schema VALID ->- m (ResolverValue m)-findType name = selectOr (pure mkNull) render name . typeDefinitions--schemaResolver ::- MonadResolver m =>- Schema VALID ->- m (ResolverValue m)-schemaResolver schema@Schema {query, mutation, subscription, directiveDefinitions} =+resolveSchema :: MonadResolver m => Schema VALID -> m (ResolverValue m)+resolveSchema schema@Schema {..} = pure $ mkObject "__Schema"- [ ("types", resolveTypes schema),- ("queryType", renderOperation (Just query)),- ("mutationType", renderOperation mutation),- ("subscriptionType", renderOperation subscription),- ("directives", render $ sortWith directiveDefinitionName $ toList directiveDefinitions)+ [ ("types", renderI $ toList $ typeDefinitions schema),+ ("queryType", renderI (Just query)),+ ("mutationType", renderI mutation),+ ("subscriptionType", renderI subscription),+ ("directives", renderI $ sortWith directiveDefinitionName $ toList directiveDefinitions) ] +resolveType :: (MonadResolver m) => Value VALID -> m (ResolverValue m)+resolveType (Scalar (String typename)) = asks (typeDefinitions . schema) >>= renderI . lookup (packName typename)+resolveType _ = pure mkNull+ schemaAPI :: ( MonadOperation m ~ QUERY, MonadResolver m ) =>- Schema VALID -> ObjectTypeResolver m-schemaAPI schema =+schemaAPI = ObjectTypeResolver- ( HM.fromList- [ ("__type", withArguments typeResolver),- ("__schema", schemaResolver schema)+ ( fromList+ [ ("__type", getArgument "name" >>= resolveType),+ ("__schema", asks schema >>= resolveSchema) ] )- where- typeResolver = selectOr (pure mkNull) handleArg ("name" :: FieldName)- where- handleArg- Argument- { argumentValue = (Scalar (String typename))- } = findType (packName typename) schema- handleArg _ = pure mkNull
src/Data/Morpheus/App/RenderIntrospection.hs view
@@ -9,8 +9,7 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.RenderIntrospection- ( render,- createObjectType,+ ( renderI, ) where @@ -27,7 +26,7 @@ mkObject, mkString, )-import qualified Data.Morpheus.Core as GQL+import Data.Morpheus.Core (render) import Data.Morpheus.Internal.Utils ( fromLBS, selectBy,@@ -45,8 +44,10 @@ FieldDefinition (..), FieldName, FieldsDefinition,+ GQLError, IN, Msg (msg),+ Name, OUT, TRUE, TypeContent (..),@@ -72,273 +73,211 @@ import Data.Text (pack) import Relude -selectType :: MonadResolver m => TypeName -> m (TypeDefinition ANY VALID)-selectType name =+iError :: GQLError -> GQLError+iError x = internal ("INTROSPECTION" <> x)++getType :: MonadResolver m => TypeName -> m TypeDef+getType name = asks schema- >>= selectBy (internal $ "INTROSPECTION Type not Found: \"" <> msg name <> "\"") name+ >>= selectBy (iError $ "type \"" <> msg name <> "\" not found!") name . typeDefinitions -class RenderIntrospection a where- render :: (MonadResolver m) => a -> m (ResolverValue m)+assertINTERFACE :: MonadResolver m => TypeDef -> m TypeDef+assertINTERFACE t@TypeDefinition {typeContent = DataInterface {}} = pure t+assertINTERFACE t = throwError $ iError $ "Type " <> msg (typeName t) <> " must be an Interface!" -instance RenderIntrospection TypeName where- render = pure . mkString . unpackName+type TypeDef = TypeDefinition ANY VALID -instance RenderIntrospection FieldName where- render = pure . mkString . unpackName+type IValue m = m (ResolverValue m) -instance RenderIntrospection Description where- render = pure . mkString+type IField m = (FieldName, IValue m) -instance RenderIntrospection a => RenderIntrospection [a] where- render ls = mkList <$> traverse render ls+class RenderI a where+ renderI :: MonadResolver m => a -> IValue m -instance RenderIntrospection a => RenderIntrospection (Maybe a) where- render (Just value) = render value- render Nothing = pure mkNull+instance RenderI (Name t) where+ renderI = pure . mkString . unpackName -instance RenderIntrospection Bool where- render = pure . mkBoolean+instance RenderI Description where+ renderI = pure . mkString -instance RenderIntrospection TypeKind where- render = pure . mkString . fromLBS . GQL.render+instance RenderI a => RenderI [a] where+ renderI ls = mkList <$> traverse renderI ls -instance RenderIntrospection (DirectiveDefinition VALID) where- render- DirectiveDefinition- { directiveDefinitionName,- directiveDefinitionDescription,- directiveDefinitionLocations,- directiveDefinitionArgs- } =- pure $- mkObject- "__Directive"- [ renderName directiveDefinitionName,- description directiveDefinitionDescription,- ("locations", render directiveDefinitionLocations),- ("args", render directiveDefinitionArgs)- ]+instance RenderI a => RenderI (Maybe a) where+ renderI (Just value) = renderI value+ renderI Nothing = pure mkNull -instance RenderIntrospection DirectiveLocation where- render locations = pure $ mkString (pack $ show locations)+instance RenderI Bool where+ renderI = pure . mkBoolean -instance RenderIntrospection (TypeDefinition cat VALID) where- render- TypeDefinition- { typeName,- typeDescription,- typeContent- } = pure $ renderContent typeContent- where- __type ::- MonadResolver m =>- TypeKind ->- [(FieldName, m (ResolverValue m))] ->- ResolverValue m- __type kind = mkType kind typeName typeDescription- renderContent :: MonadResolver m => TypeContent bool a VALID -> ResolverValue m- renderContent DataScalar {} = __type KIND_SCALAR []- renderContent (DataEnum enums) = __type KIND_ENUM [("enumValues", render enums)]- renderContent (DataInputObject inputFields) =- __type- KIND_INPUT_OBJECT- [("inputFields", render inputFields)]- renderContent DataObject {objectImplements, objectFields} =- createObjectType typeName typeDescription objectImplements objectFields- renderContent (DataUnion union) =- __type- KIND_UNION- [("possibleTypes", render $ toList union)]- renderContent (DataInputUnion members) =- mkType- KIND_INPUT_OBJECT- typeName- ( Just- ( "Note! This input is an exclusive object,\n"- <> "i.e., the customer can provide a value for only one field."- )- <> typeDescription- )- [ ( "inputFields",- render (mkInputUnionFields members)+instance RenderI TypeKind where+ renderI = pure . mkString . fromLBS . render++instance RenderI (DirectiveDefinition VALID) where+ renderI DirectiveDefinition {..} =+ object+ "__Directive"+ [ fName directiveDefinitionName,+ fDescription directiveDefinitionDescription,+ ("locations", renderI directiveDefinitionLocations),+ ("args", renderI directiveDefinitionArgs)+ ]++instance RenderI DirectiveLocation where+ renderI locations = pure $ mkString (pack $ show locations)++instance RenderI (TypeDefinition c VALID) where+ renderI TypeDefinition {..} = renderContent typeContent+ where+ __type :: MonadResolver m => TypeKind -> [IField m] -> IValue m+ __type kind = __Type kind typeName typeDescription+ renderContent :: MonadResolver m => TypeContent bool a VALID -> IValue m+ renderContent DataScalar {} = __type KIND_SCALAR []+ renderContent (DataEnum enums) = __type KIND_ENUM [("enumValues", renderI enums)]+ renderContent (DataInputObject inputFields) =+ __type+ KIND_INPUT_OBJECT+ [("inputFields", renderI inputFields)]+ renderContent DataObject {objectImplements, objectFields} =+ __Type+ (KIND_OBJECT Nothing)+ typeName+ typeDescription+ [ ("fields", renderI objectFields),+ ("interfaces", traverse (getType >=> assertINTERFACE) objectImplements >>= renderI)+ ]+ renderContent (DataUnion union) =+ __type+ KIND_UNION+ [("possibleTypes", renderI $ toList union)]+ renderContent (DataInputUnion members) =+ __Type+ KIND_INPUT_OBJECT+ typeName+ ( Just+ ( "Note! This input is an exclusive object,\n"+ <> "i.e., the customer can provide a value for only one field." )- ]- renderContent (DataInterface fields) =- __type- KIND_INTERFACE- [ ("fields", render fields),- ("possibleTypes", renderPossibleTypes typeName)- ]+ <> typeDescription+ )+ [ ( "inputFields",+ renderI (mkInputUnionFields members)+ )+ ]+ renderContent (DataInterface fields) =+ __type+ KIND_INTERFACE+ [ ("fields", renderI fields),+ ("possibleTypes", asks schema >>= renderI . possibleInterfaceTypes typeName)+ ] -instance RenderIntrospection (UnionMember OUT s) where- render UnionMember {memberName} = selectType memberName >>= render+instance RenderI (UnionMember OUT s) where+ renderI UnionMember {memberName} = getType memberName >>= renderI -instance- RenderIntrospection (FieldDefinition cat s) =>- RenderIntrospection (FieldsDefinition cat s)- where- render = render . filter fieldVisibility . toList+instance RenderI (FieldDefinition cat s) => RenderI (FieldsDefinition cat s) where+ renderI = renderI . filter fieldVisibility . toList -instance RenderIntrospection (FieldContent TRUE IN VALID) where- render = render . defaultInputValue+instance RenderI (FieldContent TRUE IN VALID) where+ renderI = renderI . defaultInputValue -instance RenderIntrospection (Value VALID) where- render Null = pure mkNull- render x = pure $ mkString $ fromLBS $ GQL.render x+instance RenderI (Value VALID) where+ renderI Null = pure mkNull+ renderI x = pure $ mkString $ fromLBS $ render x -instance RenderIntrospection (FieldDefinition OUT VALID) where- render FieldDefinition {..} =- pure $- mkObject "__Field" $- [ renderName fieldName,- description fieldDescription,- type' fieldType,- ("args", maybe (pure $ mkList []) render fieldContent)- ]- <> renderDeprecated fieldDirectives+instance RenderI (FieldDefinition OUT VALID) where+ renderI FieldDefinition {..} =+ object "__Field" $+ [ fName fieldName,+ fDescription fieldDescription,+ fType fieldType,+ ("args", maybe (pure $ mkList []) renderI fieldContent)+ ]+ <> fDeprecated fieldDirectives -instance RenderIntrospection (FieldContent TRUE OUT VALID) where- render (FieldArgs args) = render args+instance RenderI (FieldContent TRUE OUT VALID) where+ renderI (FieldArgs args) = renderI args -instance RenderIntrospection (ArgumentsDefinition VALID) where- render = fmap mkList . traverse (render . argument) . toList+instance RenderI (ArgumentsDefinition VALID) where+ renderI = fmap mkList . traverse (renderI . argument) . toList -instance RenderIntrospection (FieldDefinition IN VALID) where- render FieldDefinition {..} =- pure $- mkObject- "__InputValue"- [ renderName fieldName,- description fieldDescription,- type' fieldType,- defaultValue fieldContent- ]+instance RenderI (FieldDefinition IN VALID) where+ renderI FieldDefinition {..} =+ object+ "__InputValue"+ [ fName fieldName,+ fDescription fieldDescription,+ fType fieldType,+ fDefaultValue fieldContent+ ] -instance RenderIntrospection (DataEnumValue VALID) where- render DataEnumValue {enumName, enumDescription, enumDirectives} =- pure $- mkObject "__Field" $- [ renderName enumName,- description enumDescription- ]- <> renderDeprecated enumDirectives+instance RenderI (DataEnumValue VALID) where+ renderI DataEnumValue {..} =+ object "__EnumValue" $+ [ fName enumName,+ fDescription enumDescription+ ]+ <> fDeprecated enumDirectives -instance RenderIntrospection TypeRef where- render TypeRef {typeConName, typeWrappers} = renderWrapper typeWrappers+instance RenderI TypeRef where+ renderI TypeRef {..} = renderWrapper typeWrappers where- renderWrapper :: (Monad m, MonadResolver m) => TypeWrapper -> m (ResolverValue m) renderWrapper (TypeList nextWrapper isNonNull) =- pure $- withNonNull isNonNull $- mkObject- "__Type"- [ renderKind KIND_LIST,- ("ofType", renderWrapper nextWrapper)- ]+ withNonNull isNonNull $ wrapper KIND_LIST (renderWrapper nextWrapper) renderWrapper (BaseType isNonNull) =- withNonNull isNonNull <$> do- kind <- kindOf <$> selectType typeConName- pure $ mkType kind typeConName Nothing []--withNonNull ::- MonadResolver m =>- Bool ->- ResolverValue m ->- ResolverValue m-withNonNull True contentType =- mkObject- "__Type"- [ renderKind KIND_NON_NULL,- ("ofType", pure contentType)- ]-withNonNull False contentType = contentType--renderPossibleTypes ::- MonadResolver m =>- TypeName ->- m (ResolverValue m)-renderPossibleTypes name = mkList <$> (asks schema >>= traverse render . possibleInterfaceTypes name)+ withNonNull isNonNull $ do+ kind <- kindOf <$> getType typeConName+ __Type kind typeConName Nothing [] -renderDeprecated ::- MonadResolver m =>- Directives s ->- [(FieldName, m (ResolverValue m))]-renderDeprecated dirs =- [ ("isDeprecated", render (isJust $ lookupDeprecated dirs)),- ("deprecationReason", render (lookupDeprecated dirs >>= lookupDeprecatedReason))- ]+withNonNull :: MonadResolver m => Bool -> IValue m -> IValue m+withNonNull True = wrapper KIND_NON_NULL+withNonNull False = id -description ::+__Type :: MonadResolver m =>- Maybe Description ->- (FieldName, m (ResolverValue m))-description = ("description",) . render--mkType ::- ( RenderIntrospection name,- MonadResolver m- ) => TypeKind ->- name ->+ Name t -> Maybe Description ->- [(FieldName, m (ResolverValue m))] ->- ResolverValue m-mkType kind name desc etc =- mkObject+ [IField m] ->+ IValue m+__Type kind name desc etc =+ object "__Type"- ( [ renderKind kind,- renderName name,- description desc+ ( [ fKind kind,+ fName name,+ fDescription desc ] <> etc ) -createObjectType ::- (MonadResolver m) =>- TypeName ->- Maybe Description ->- [TypeName] ->- FieldsDefinition OUT VALID ->- ResolverValue m-createObjectType name desc interfaces fields =- mkType (KIND_OBJECT Nothing) name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]+wrapper :: MonadResolver m => TypeKind -> IValue m -> IValue m+wrapper k t =+ object+ "__Type"+ [ fKind k,+ ("ofType", t)+ ] -implementedInterface ::- (MonadResolver m) =>- TypeName ->- m (ResolverValue m)-implementedInterface name =- selectType name- >>= renderContent- where- renderContent typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef- renderContent _ = throwError $ internal $ "Type " <> msg name <> " must be an Interface"+object :: Monad m => TypeName -> [IField m] -> IValue m+object name = pure . mkObject name -renderName ::- ( RenderIntrospection name,- MonadResolver m- ) =>- name ->- (FieldName, m (ResolverValue m))-renderName = ("name",) . render+fDeprecated :: MonadResolver m => Directives s -> [IField m]+fDeprecated dirs =+ [ ("isDeprecated", renderI (isJust $ lookupDeprecated dirs)),+ ("deprecationReason", renderI (lookupDeprecated dirs >>= lookupDeprecatedReason))+ ] -renderKind ::- MonadResolver m =>- TypeKind ->- (FieldName, m (ResolverValue m))-renderKind = ("kind",) . render+fDescription :: MonadResolver m => Maybe Description -> IField m+fDescription = ("description",) . renderI -type' ::- MonadResolver m =>- TypeRef ->- (FieldName, m (ResolverValue m))-type' = ("type",) . render+fName :: MonadResolver m => Name t -> IField m+fName = ("name",) . renderI -defaultValue ::- MonadResolver m =>- Maybe (FieldContent TRUE IN VALID) ->- ( FieldName,- m (ResolverValue m)- )-defaultValue = ("defaultValue",) . render+fKind :: MonadResolver m => TypeKind -> IField m+fKind = ("kind",) . renderI++fType :: MonadResolver m => TypeRef -> IField m+fType = ("type",) . renderI++fDefaultValue :: MonadResolver m => Maybe (FieldContent TRUE IN VALID) -> IField m+fDefaultValue = ("defaultValue",) . renderI