morpheus-graphql 0.11.0 → 0.12.0
raw patch · 184 files changed
+5740/−12039 lines, 184 filesdep +morpheus-graphql-coredep −th-lift-instancesdep ~mtldep ~template-haskelldep ~unliftio-coresetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: morpheus-graphql-core
Dependencies removed: th-lift-instances
Dependency ranges changed: mtl, template-haskell, unliftio-core, websockets
API changes (from Hackage documentation)
- Data.Morpheus.Client: __fetch :: (Fetch a, Monad m, Show a, ToJSON (Args a), FromJSON a) => String -> Text -> (ByteString -> m ByteString) -> Args a -> m (Either String a)
- Data.Morpheus.Client: class Fetch a where {
- Data.Morpheus.Client: defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec]
- Data.Morpheus.Client: defineByDocumentFile :: String -> (GQLQuery, String) -> Q [Dec]
- Data.Morpheus.Client: defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec]
- Data.Morpheus.Client: defineByIntrospectionFile :: String -> (GQLQuery, String) -> Q [Dec]
- Data.Morpheus.Client: defineQuery :: IO (Eventless Schema) -> (GQLQuery, String) -> Q [Dec]
- Data.Morpheus.Client: fetch :: (Fetch a, Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a)
- Data.Morpheus.Client: gql :: QuasiQuoter
- Data.Morpheus.Client: type family Args a :: *;
- Data.Morpheus.Client: }
- Data.Morpheus.Document: parseDSL :: ByteString -> Either String Schema
- Data.Morpheus.Document: parseFullGQLDocument :: ByteString -> Eventless Schema
- Data.Morpheus.Types.Internal.AST: Argument :: Name -> Value valid -> Position -> Argument
- Data.Morpheus.Types.Internal.AST: ArgumentsDefinition :: Maybe Name -> OrderedMap ArgumentDefinition -> ArgumentsDefinition
- Data.Morpheus.Types.Internal.AST: Boolean :: Bool -> ScalarValue
- Data.Morpheus.Types.Internal.AST: ClientQuery :: String -> [ClientType] -> Maybe TypeD -> ClientQuery
- Data.Morpheus.Types.Internal.AST: ClientType :: TypeD -> DataTypeKind -> ClientType
- Data.Morpheus.Types.Internal.AST: ConsD :: Name -> [FieldDefinition] -> ConsD
- Data.Morpheus.Types.Internal.AST: DataEnum :: DataEnum -> TypeContent
- Data.Morpheus.Types.Internal.AST: DataEnumValue :: Name -> Maybe Meta -> DataEnumValue
- Data.Morpheus.Types.Internal.AST: DataFingerprint :: Name -> [String] -> DataFingerprint
- Data.Morpheus.Types.Internal.AST: DataInputObject :: InputFieldsDefinition -> TypeContent
- Data.Morpheus.Types.Internal.AST: DataInputUnion :: [(Key, Bool)] -> TypeContent
- Data.Morpheus.Types.Internal.AST: DataInterface :: FieldsDefinition -> TypeContent
- Data.Morpheus.Types.Internal.AST: DataObject :: [Name] -> FieldsDefinition -> TypeContent
- Data.Morpheus.Types.Internal.AST: DataScalar :: ScalarDefinition -> TypeContent
- Data.Morpheus.Types.Internal.AST: DataUnion :: DataUnion -> TypeContent
- Data.Morpheus.Types.Internal.AST: Directive :: Name -> OrderedMap (Argument VALID) -> Directive
- Data.Morpheus.Types.Internal.AST: FULL_VALIDATION :: VALIDATION_MODE
- Data.Morpheus.Types.Internal.AST: FieldDefinition :: Key -> ArgumentsDefinition -> TypeRef -> Maybe Meta -> FieldDefinition
- Data.Morpheus.Types.Internal.AST: FieldsDefinition :: OrderedMap FieldDefinition -> FieldsDefinition
- Data.Morpheus.Types.Internal.AST: Float :: Float -> ScalarValue
- Data.Morpheus.Types.Internal.AST: Fragment :: Name -> Name -> Position -> SelectionSet RAW -> Fragment
- Data.Morpheus.Types.Internal.AST: GQLError :: Message -> [Position] -> GQLError
- Data.Morpheus.Types.Internal.AST: GQLQuery :: Fragments -> Operation RAW -> [(Key, ResolvedValue)] -> GQLQuery
- Data.Morpheus.Types.Internal.AST: GQLTypeD :: TypeD -> DataTypeKind -> [TypeD] -> TypeDefinition -> GQLTypeD
- Data.Morpheus.Types.Internal.AST: InputFieldsDefinition :: OrderedMap FieldDefinition -> InputFieldsDefinition
- Data.Morpheus.Types.Internal.AST: Int :: Int -> ScalarValue
- Data.Morpheus.Types.Internal.AST: KindEnum :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindInputObject :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindInputUnion :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindList :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindNonNull :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindObject :: Maybe OperationType -> DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindScalar :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: KindUnion :: DataTypeKind
- Data.Morpheus.Types.Internal.AST: ListType :: DataTypeWrapper
- Data.Morpheus.Types.Internal.AST: Meta :: Maybe Description -> [Directive] -> Meta
- Data.Morpheus.Types.Internal.AST: Mutation :: OperationType
- Data.Morpheus.Types.Internal.AST: NoArguments :: ArgumentsDefinition
- Data.Morpheus.Types.Internal.AST: NonNullType :: DataTypeWrapper
- Data.Morpheus.Types.Internal.AST: ObjectEntry :: Name -> Value s -> ObjectEntry
- Data.Morpheus.Types.Internal.AST: Operation :: Maybe Key -> OperationType -> VariableDefinitions s -> SelectionSet s -> Position -> Operation
- Data.Morpheus.Types.Internal.AST: Position :: Int -> Int -> Position
- Data.Morpheus.Types.Internal.AST: Query :: OperationType
- Data.Morpheus.Types.Internal.AST: Ref :: Key -> Position -> Ref
- Data.Morpheus.Types.Internal.AST: ScalarDefinition :: (ValidValue -> Either Key ValidValue) -> ScalarDefinition
- Data.Morpheus.Types.Internal.AST: Schema :: TypeLib -> TypeDefinition -> Maybe TypeDefinition -> Maybe TypeDefinition -> Schema
- Data.Morpheus.Types.Internal.AST: String :: Text -> ScalarValue
- Data.Morpheus.Types.Internal.AST: Subscription :: OperationType
- Data.Morpheus.Types.Internal.AST: TypeD :: Name -> [Name] -> [ConsD] -> Maybe Meta -> TypeD
- Data.Morpheus.Types.Internal.AST: TypeDefinition :: Key -> DataFingerprint -> Maybe Meta -> TypeContent -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: TypeList :: TypeWrapper
- Data.Morpheus.Types.Internal.AST: TypeMaybe :: TypeWrapper
- Data.Morpheus.Types.Internal.AST: TypeRef :: Name -> Maybe Name -> [TypeWrapper] -> TypeRef
- Data.Morpheus.Types.Internal.AST: UnionTag :: Name -> SelectionSet VALID -> UnionTag
- Data.Morpheus.Types.Internal.AST: Variable :: Name -> TypeRef -> Position -> VariableContent (VAR stage) -> Variable
- Data.Morpheus.Types.Internal.AST: WITHOUT_VARIABLES :: VALIDATION_MODE
- Data.Morpheus.Types.Internal.AST: [$sel:fragments:GQLQuery] :: GQLQuery -> Fragments
- Data.Morpheus.Types.Internal.AST: [$sel:inputVariables:GQLQuery] :: GQLQuery -> [(Key, ResolvedValue)]
- Data.Morpheus.Types.Internal.AST: [$sel:operation:GQLQuery] :: GQLQuery -> Operation RAW
- Data.Morpheus.Types.Internal.AST: [DefaultValue] :: Maybe ResolvedValue -> VariableContent RESOLVED
- Data.Morpheus.Types.Internal.AST: [Enum] :: Name -> Value stage
- Data.Morpheus.Types.Internal.AST: [InlineFragment] :: Fragment -> Selection RAW
- Data.Morpheus.Types.Internal.AST: [List] :: [Value stage] -> Value stage
- Data.Morpheus.Types.Internal.AST: [Null] :: Value stage
- Data.Morpheus.Types.Internal.AST: [Object] :: Object stage -> Value stage
- Data.Morpheus.Types.Internal.AST: [ResolvedVariable] :: Ref -> Variable VALID -> Value RESOLVED
- Data.Morpheus.Types.Internal.AST: [Scalar] :: ScalarValue -> Value stage
- Data.Morpheus.Types.Internal.AST: [SelectionField] :: SelectionContent s
- Data.Morpheus.Types.Internal.AST: [SelectionSet] :: SelectionSet s -> SelectionContent s
- Data.Morpheus.Types.Internal.AST: [Selection] :: {selectionName :: Name, selectionAlias :: Maybe Name, selectionPosition :: Position, selectionArguments :: Arguments s, selectionContent :: SelectionContent s} -> Selection s
- Data.Morpheus.Types.Internal.AST: [Spread] :: Ref -> Selection RAW
- Data.Morpheus.Types.Internal.AST: [UnionSelection] :: UnionSelection -> SelectionContent VALID
- Data.Morpheus.Types.Internal.AST: [ValidVariableValue] :: {validVarContent :: ValidValue} -> VariableContent VALID
- Data.Morpheus.Types.Internal.AST: [VariableValue] :: Ref -> Value RAW
- Data.Morpheus.Types.Internal.AST: [argumentName] :: Argument -> Name
- Data.Morpheus.Types.Internal.AST: [argumentPosition] :: Argument -> Position
- Data.Morpheus.Types.Internal.AST: [argumentValue] :: Argument -> Value valid
- Data.Morpheus.Types.Internal.AST: [argumentsTypename] :: ArgumentsDefinition -> Maybe Name
- Data.Morpheus.Types.Internal.AST: [arguments] :: ArgumentsDefinition -> OrderedMap ArgumentDefinition
- Data.Morpheus.Types.Internal.AST: [cFields] :: ConsD -> [FieldDefinition]
- Data.Morpheus.Types.Internal.AST: [cName] :: ConsD -> Name
- Data.Morpheus.Types.Internal.AST: [clientKind] :: ClientType -> DataTypeKind
- Data.Morpheus.Types.Internal.AST: [clientType] :: ClientType -> TypeD
- Data.Morpheus.Types.Internal.AST: [column] :: Position -> Int
- Data.Morpheus.Types.Internal.AST: [dataScalar] :: TypeContent -> ScalarDefinition
- Data.Morpheus.Types.Internal.AST: [directiveArgs] :: Directive -> OrderedMap (Argument VALID)
- Data.Morpheus.Types.Internal.AST: [directiveName] :: Directive -> Name
- Data.Morpheus.Types.Internal.AST: [entryName] :: ObjectEntry -> Name
- Data.Morpheus.Types.Internal.AST: [entryValue] :: ObjectEntry -> Value s
- Data.Morpheus.Types.Internal.AST: [enumMembers] :: TypeContent -> DataEnum
- Data.Morpheus.Types.Internal.AST: [enumMeta] :: DataEnumValue -> Maybe Meta
- Data.Morpheus.Types.Internal.AST: [enumName] :: DataEnumValue -> Name
- Data.Morpheus.Types.Internal.AST: [fieldArgs] :: FieldDefinition -> ArgumentsDefinition
- Data.Morpheus.Types.Internal.AST: [fieldMeta] :: FieldDefinition -> Maybe Meta
- Data.Morpheus.Types.Internal.AST: [fieldName] :: FieldDefinition -> Key
- Data.Morpheus.Types.Internal.AST: [fieldType] :: FieldDefinition -> TypeRef
- Data.Morpheus.Types.Internal.AST: [fragmentName] :: Fragment -> Name
- Data.Morpheus.Types.Internal.AST: [fragmentPosition] :: Fragment -> Position
- Data.Morpheus.Types.Internal.AST: [fragmentSelection] :: Fragment -> SelectionSet RAW
- Data.Morpheus.Types.Internal.AST: [fragmentType] :: Fragment -> Name
- Data.Morpheus.Types.Internal.AST: [inputObjectFields] :: TypeContent -> InputFieldsDefinition
- Data.Morpheus.Types.Internal.AST: [inputUnionMembers] :: TypeContent -> [(Key, Bool)]
- Data.Morpheus.Types.Internal.AST: [interfaceFields] :: TypeContent -> FieldsDefinition
- Data.Morpheus.Types.Internal.AST: [line] :: Position -> Int
- Data.Morpheus.Types.Internal.AST: [locations] :: GQLError -> [Position]
- Data.Morpheus.Types.Internal.AST: [message] :: GQLError -> Message
- Data.Morpheus.Types.Internal.AST: [metaDescription] :: Meta -> Maybe Description
- Data.Morpheus.Types.Internal.AST: [metaDirectives] :: Meta -> [Directive]
- Data.Morpheus.Types.Internal.AST: [mutation] :: Schema -> Maybe TypeDefinition
- Data.Morpheus.Types.Internal.AST: [objectFields] :: TypeContent -> FieldsDefinition
- Data.Morpheus.Types.Internal.AST: [objectImplements] :: TypeContent -> [Name]
- Data.Morpheus.Types.Internal.AST: [operationArguments] :: Operation -> VariableDefinitions s
- Data.Morpheus.Types.Internal.AST: [operationName] :: Operation -> Maybe Key
- Data.Morpheus.Types.Internal.AST: [operationPosition] :: Operation -> Position
- Data.Morpheus.Types.Internal.AST: [operationSelection] :: Operation -> SelectionSet s
- Data.Morpheus.Types.Internal.AST: [operationType] :: Operation -> OperationType
- Data.Morpheus.Types.Internal.AST: [queryArgsType] :: ClientQuery -> Maybe TypeD
- Data.Morpheus.Types.Internal.AST: [queryText] :: ClientQuery -> String
- Data.Morpheus.Types.Internal.AST: [queryTypes] :: ClientQuery -> [ClientType]
- Data.Morpheus.Types.Internal.AST: [query] :: Schema -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: [refName] :: Ref -> Key
- Data.Morpheus.Types.Internal.AST: [refPosition] :: Ref -> Position
- Data.Morpheus.Types.Internal.AST: [subscription] :: Schema -> Maybe TypeDefinition
- Data.Morpheus.Types.Internal.AST: [tCons] :: TypeD -> [ConsD]
- Data.Morpheus.Types.Internal.AST: [tMeta] :: TypeD -> Maybe Meta
- Data.Morpheus.Types.Internal.AST: [tName] :: TypeD -> Name
- Data.Morpheus.Types.Internal.AST: [tNamespace] :: TypeD -> [Name]
- Data.Morpheus.Types.Internal.AST: [typeArgD] :: GQLTypeD -> [TypeD]
- Data.Morpheus.Types.Internal.AST: [typeArgs] :: TypeRef -> Maybe Name
- Data.Morpheus.Types.Internal.AST: [typeConName] :: TypeRef -> Name
- Data.Morpheus.Types.Internal.AST: [typeContent] :: TypeDefinition -> TypeContent
- Data.Morpheus.Types.Internal.AST: [typeD] :: GQLTypeD -> TypeD
- Data.Morpheus.Types.Internal.AST: [typeFingerprint] :: TypeDefinition -> DataFingerprint
- Data.Morpheus.Types.Internal.AST: [typeKindD] :: GQLTypeD -> DataTypeKind
- Data.Morpheus.Types.Internal.AST: [typeMeta] :: TypeDefinition -> Maybe Meta
- Data.Morpheus.Types.Internal.AST: [typeName] :: TypeDefinition -> Key
- Data.Morpheus.Types.Internal.AST: [typeOriginal] :: GQLTypeD -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: [typeWrappers] :: TypeRef -> [TypeWrapper]
- Data.Morpheus.Types.Internal.AST: [types] :: Schema -> TypeLib
- Data.Morpheus.Types.Internal.AST: [unFieldsDefinition] :: FieldsDefinition -> OrderedMap FieldDefinition
- Data.Morpheus.Types.Internal.AST: [unInputFieldsDefinition] :: InputFieldsDefinition -> OrderedMap FieldDefinition
- Data.Morpheus.Types.Internal.AST: [unionMembers] :: TypeContent -> DataUnion
- Data.Morpheus.Types.Internal.AST: [unionTagName] :: UnionTag -> Name
- Data.Morpheus.Types.Internal.AST: [unionTagSelection] :: UnionTag -> SelectionSet VALID
- Data.Morpheus.Types.Internal.AST: [validateValue] :: ScalarDefinition -> ValidValue -> Either Key ValidValue
- Data.Morpheus.Types.Internal.AST: [variableName] :: Variable -> Name
- Data.Morpheus.Types.Internal.AST: [variablePosition] :: Variable -> Position
- Data.Morpheus.Types.Internal.AST: [variableType] :: Variable -> TypeRef
- Data.Morpheus.Types.Internal.AST: [variableValue] :: Variable -> VariableContent (VAR stage)
- Data.Morpheus.Types.Internal.AST: __inputname :: Name
- Data.Morpheus.Types.Internal.AST: allDataTypes :: Schema -> [TypeDefinition]
- Data.Morpheus.Types.Internal.AST: anonymousRef :: Key -> Ref
- Data.Morpheus.Types.Internal.AST: class GQLValue a
- Data.Morpheus.Types.Internal.AST: convertToHaskellName :: Text -> Text
- Data.Morpheus.Types.Internal.AST: convertToJSONName :: Text -> Text
- Data.Morpheus.Types.Internal.AST: createAlias :: Key -> TypeRef
- Data.Morpheus.Types.Internal.AST: createArgument :: Key -> ([TypeWrapper], Key) -> FieldDefinition
- Data.Morpheus.Types.Internal.AST: createDataTypeLib :: Failure Message m => [TypeDefinition] -> m Schema
- Data.Morpheus.Types.Internal.AST: createEnumType :: Name -> [Key] -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: createEnumValue :: Name -> DataEnumValue
- Data.Morpheus.Types.Internal.AST: createField :: ArgumentsDefinition -> Key -> ([TypeWrapper], Key) -> FieldDefinition
- Data.Morpheus.Types.Internal.AST: createInputUnionFields :: Key -> [Key] -> [FieldDefinition]
- Data.Morpheus.Types.Internal.AST: createScalarType :: Name -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: createType :: Key -> TypeContent -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: createUnionType :: Key -> [Key] -> TypeDefinition
- Data.Morpheus.Types.Internal.AST: data Argument (valid :: Stage)
- Data.Morpheus.Types.Internal.AST: data ArgumentsDefinition
- Data.Morpheus.Types.Internal.AST: data ClientQuery
- Data.Morpheus.Types.Internal.AST: data ClientType
- Data.Morpheus.Types.Internal.AST: data ConsD
- Data.Morpheus.Types.Internal.AST: data DataEnumValue
- Data.Morpheus.Types.Internal.AST: data DataFingerprint
- Data.Morpheus.Types.Internal.AST: data DataTypeKind
- Data.Morpheus.Types.Internal.AST: data DataTypeWrapper
- Data.Morpheus.Types.Internal.AST: data Directive
- Data.Morpheus.Types.Internal.AST: data FieldDefinition
- Data.Morpheus.Types.Internal.AST: data Fragment
- Data.Morpheus.Types.Internal.AST: data GQLError
- Data.Morpheus.Types.Internal.AST: data GQLQuery
- Data.Morpheus.Types.Internal.AST: data GQLTypeD
- Data.Morpheus.Types.Internal.AST: data Meta
- Data.Morpheus.Types.Internal.AST: data ObjectEntry (s :: Stage)
- Data.Morpheus.Types.Internal.AST: data Operation (s :: Stage)
- Data.Morpheus.Types.Internal.AST: data OperationType
- Data.Morpheus.Types.Internal.AST: data OrderedMap a
- Data.Morpheus.Types.Internal.AST: data Position
- Data.Morpheus.Types.Internal.AST: data Ref
- Data.Morpheus.Types.Internal.AST: data ScalarValue
- Data.Morpheus.Types.Internal.AST: data Schema
- Data.Morpheus.Types.Internal.AST: data Selection (s :: Stage)
- Data.Morpheus.Types.Internal.AST: data SelectionContent (s :: Stage)
- Data.Morpheus.Types.Internal.AST: data Stage
- Data.Morpheus.Types.Internal.AST: data TypeContent
- Data.Morpheus.Types.Internal.AST: data TypeD
- Data.Morpheus.Types.Internal.AST: data TypeDefinition
- Data.Morpheus.Types.Internal.AST: data TypeRef
- Data.Morpheus.Types.Internal.AST: data TypeWrapper
- Data.Morpheus.Types.Internal.AST: data UnionTag
- Data.Morpheus.Types.Internal.AST: data VALIDATION_MODE
- Data.Morpheus.Types.Internal.AST: data Value (stage :: Stage)
- Data.Morpheus.Types.Internal.AST: data Variable (stage :: Stage)
- Data.Morpheus.Types.Internal.AST: data VariableContent (stage :: Stage)
- Data.Morpheus.Types.Internal.AST: decodeScientific :: Scientific -> ScalarValue
- Data.Morpheus.Types.Internal.AST: defineType :: TypeDefinition -> Schema -> Schema
- Data.Morpheus.Types.Internal.AST: fieldVisibility :: FieldDefinition -> Bool
- Data.Morpheus.Types.Internal.AST: getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m TypeDefinition
- Data.Morpheus.Types.Internal.AST: getOperationName :: Maybe Key -> Key
- Data.Morpheus.Types.Internal.AST: gqlBoolean :: GQLValue a => Bool -> a
- Data.Morpheus.Types.Internal.AST: gqlList :: GQLValue a => [a] -> a
- Data.Morpheus.Types.Internal.AST: gqlNull :: GQLValue a => a
- Data.Morpheus.Types.Internal.AST: gqlObject :: GQLValue a => [(Name, a)] -> a
- Data.Morpheus.Types.Internal.AST: gqlScalar :: GQLValue a => ScalarValue -> a
- Data.Morpheus.Types.Internal.AST: gqlString :: GQLValue a => Text -> a
- Data.Morpheus.Types.Internal.AST: hasArguments :: ArgumentsDefinition -> Bool
- Data.Morpheus.Types.Internal.AST: hsTypeName :: Key -> Key
- Data.Morpheus.Types.Internal.AST: initTypeLib :: TypeDefinition -> Schema
- Data.Morpheus.Types.Internal.AST: insertType :: TypeDefinition -> TypeUpdater
- Data.Morpheus.Types.Internal.AST: instance GHC.Show.Show Data.Morpheus.Types.Internal.AST.GQLQuery
- Data.Morpheus.Types.Internal.AST: instance Language.Haskell.TH.Syntax.Lift Data.Morpheus.Types.Internal.AST.GQLQuery
- Data.Morpheus.Types.Internal.AST: isDefaultTypeName :: Key -> Bool
- Data.Morpheus.Types.Internal.AST: isEntNode :: TypeContent -> Bool
- Data.Morpheus.Types.Internal.AST: isFieldNullable :: FieldDefinition -> Bool
- Data.Morpheus.Types.Internal.AST: isInput :: DataTypeKind -> Bool
- Data.Morpheus.Types.Internal.AST: isInputDataType :: TypeDefinition -> Bool
- Data.Morpheus.Types.Internal.AST: isNullable :: TypeRef -> Bool
- Data.Morpheus.Types.Internal.AST: isNullableWrapper :: [TypeWrapper] -> Bool
- Data.Morpheus.Types.Internal.AST: isObject :: DataTypeKind -> Bool
- Data.Morpheus.Types.Internal.AST: isOutputObject :: DataTypeKind -> Bool
- Data.Morpheus.Types.Internal.AST: isOutputType :: DataTypeKind -> Bool
- Data.Morpheus.Types.Internal.AST: isPrimitiveTypeName :: Key -> Bool
- Data.Morpheus.Types.Internal.AST: isSchemaTypeName :: Key -> Bool
- Data.Morpheus.Types.Internal.AST: isSubscription :: DataTypeKind -> Bool
- Data.Morpheus.Types.Internal.AST: isTypeDefined :: Key -> Schema -> Maybe DataFingerprint
- Data.Morpheus.Types.Internal.AST: isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool
- Data.Morpheus.Types.Internal.AST: kindOf :: TypeDefinition -> DataTypeKind
- Data.Morpheus.Types.Internal.AST: lookupDataType :: Key -> Schema -> Maybe TypeDefinition
- Data.Morpheus.Types.Internal.AST: lookupDeprecated :: Meta -> Maybe Directive
- Data.Morpheus.Types.Internal.AST: lookupDeprecatedReason :: Directive -> Maybe Key
- Data.Morpheus.Types.Internal.AST: lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a
- Data.Morpheus.Types.Internal.AST: newtype FieldsDefinition
- Data.Morpheus.Types.Internal.AST: newtype InputFieldsDefinition
- Data.Morpheus.Types.Internal.AST: newtype ScalarDefinition
- Data.Morpheus.Types.Internal.AST: removeDuplicates :: Eq a => [a] -> [a]
- Data.Morpheus.Types.Internal.AST: replaceValue :: Value -> Value a
- Data.Morpheus.Types.Internal.AST: splitDuplicates :: Eq a => [a] -> ([a], [a])
- Data.Morpheus.Types.Internal.AST: sysTypes :: [Key]
- Data.Morpheus.Types.Internal.AST: toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper]
- Data.Morpheus.Types.Internal.AST: toHSFieldDefinition :: FieldDefinition -> FieldDefinition
- Data.Morpheus.Types.Internal.AST: toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper]
- Data.Morpheus.Types.Internal.AST: toListField :: FieldDefinition -> FieldDefinition
- Data.Morpheus.Types.Internal.AST: toNullableField :: FieldDefinition -> FieldDefinition
- Data.Morpheus.Types.Internal.AST: type ArgumentDefinition = FieldDefinition
- Data.Morpheus.Types.Internal.AST: type Arguments s = OrderedMap (Argument s)
- Data.Morpheus.Types.Internal.AST: type DataEnum = [DataEnumValue]
- Data.Morpheus.Types.Internal.AST: type DataInputUnion = [(Key, Bool)]
- Data.Morpheus.Types.Internal.AST: type DataUnion = [Key]
- Data.Morpheus.Types.Internal.AST: type DefaultValue = Maybe ResolvedValue
- Data.Morpheus.Types.Internal.AST: type Description = Key
- Data.Morpheus.Types.Internal.AST: type Fragments = OrderedMap Fragment
- Data.Morpheus.Types.Internal.AST: type GQLErrors = [GQLError]
- Data.Morpheus.Types.Internal.AST: type Key = Text
- Data.Morpheus.Types.Internal.AST: type MUTATION = 'Mutation
- Data.Morpheus.Types.Internal.AST: type Message = Text
- Data.Morpheus.Types.Internal.AST: type Name = Key
- Data.Morpheus.Types.Internal.AST: type Named a = (Name, a)
- Data.Morpheus.Types.Internal.AST: type Object a = OrderedMap (ObjectEntry a)
- Data.Morpheus.Types.Internal.AST: type QUERY = 'Query
- Data.Morpheus.Types.Internal.AST: type RAW = 'RAW
- Data.Morpheus.Types.Internal.AST: type RESOLVED = 'RESOLVED
- Data.Morpheus.Types.Internal.AST: type RawObject = Object RAW
- Data.Morpheus.Types.Internal.AST: type RawValue = Value RAW
- Data.Morpheus.Types.Internal.AST: type ResolvedObject = Object RESOLVED
- Data.Morpheus.Types.Internal.AST: type ResolvedValue = Value RESOLVED
- Data.Morpheus.Types.Internal.AST: type SUBSCRIPTION = 'Subscription
- Data.Morpheus.Types.Internal.AST: type SelectionSet s = MergeSet (Selection s)
- Data.Morpheus.Types.Internal.AST: type TypeLib = HashMap Key TypeDefinition
- Data.Morpheus.Types.Internal.AST: type TypeUpdater = LibUpdater Schema
- Data.Morpheus.Types.Internal.AST: type VALID = 'VALID
- Data.Morpheus.Types.Internal.AST: type ValidObject = Object VALID
- Data.Morpheus.Types.Internal.AST: type ValidValue = Value VALID
- Data.Morpheus.Types.Internal.AST: type VariableDefinitions s = OrderedMap (Variable s)
- Data.Morpheus.Types.Internal.AST: type Variables = Map Key ResolvedValue
- Data.Morpheus.Types.Internal.AST: typeFromScalar :: Name -> Name
- Data.Morpheus.Types.Internal.AST: unsafeFromFields :: [FieldDefinition] -> FieldsDefinition
- Data.Morpheus.Types.Internal.AST: unsafeFromInputFields :: [FieldDefinition] -> InputFieldsDefinition
+ Data.Morpheus.Kind: type INTERFACE = 'INTERFACE
+ Data.Morpheus.Server: subscriptionApp :: (MonadUnliftIO m, Eq (StreamChannel e), GQLChannel e) => (Store e m -> (Scope WS e m -> m ()) -> m app) -> (Input WS -> Stream WS e m) -> m (app, e -> m ())
+ Data.Morpheus.Server: type ServerConstraint e m = (MonadIO m, MonadUnliftIO m, Eq (StreamChannel e), GQLChannel e)
+ Data.Morpheus.Types: Context :: Selection VALID -> Schema -> Operation VALID -> TypeName -> Context
+ Data.Morpheus.Types: [currentSelection] :: Context -> Selection VALID
+ Data.Morpheus.Types: [currentTypeName] :: Context -> TypeName
+ Data.Morpheus.Types: [operation] :: Context -> Operation VALID
+ Data.Morpheus.Types: [schema] :: Context -> Schema
+ Data.Morpheus.Types: data Context
+ Data.Morpheus.Types: implements :: GQLType a => Proxy a -> [(TypeName, TypeUpdater)]
+ Data.Morpheus.Types: instance Data.Morpheus.Types.FlexibleResolver f a
+ Data.Morpheus.Types: interface :: (GQLType a, Introspect a) => Proxy a -> (TypeName, TypeUpdater)
+ Data.Morpheus.Types: type ComposedResolver o e m f a = (WithOperation o) => Composed (Resolver o e m) f a
+ Data.Morpheus.Types: type ComposedSubField m f a = (m (f (a (UnSubResolver m))))
+ Data.Morpheus.Types: type ResolverO o e m a = (WithOperation o) => Flexible (Resolver o e m) a
+ Data.Morpheus.Types: type HTTP = 'HTTP
+ Data.Morpheus.Types: type ResolverM e m a = Flexible (Resolver MUTATION e m) a
+ Data.Morpheus.Types: type ResolverQ e m a = Flexible (Resolver QUERY e m) a
+ Data.Morpheus.Types: type ResolverS e m a = Resolver SUBSCRIPTION e m (a (Resolver QUERY e m))
+ Data.Morpheus.Types: type WS = 'WS
+ Data.Morpheus.Types.Internal.Subscription: Store :: m (ClientConnectionStore e m) -> ((ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()) -> Store e m
+ Data.Morpheus.Types.Internal.Subscription: [Init] :: ID -> Input WS
+ Data.Morpheus.Types.Internal.Subscription: [Request] :: GQLRequest -> Input HTTP
+ Data.Morpheus.Types.Internal.Subscription: [ScopeHTTP] :: {httpCallback :: event -> m ()} -> Scope HTTP event m
+ Data.Morpheus.Types.Internal.Subscription: [ScopeWS] :: {listener :: m ByteString, callback :: ByteString -> m (), update :: (ClientConnectionStore event m -> ClientConnectionStore event m) -> m ()} -> Scope WS event m
+ Data.Morpheus.Types.Internal.Subscription: [readStore] :: Store e m -> m (ClientConnectionStore e m)
+ Data.Morpheus.Types.Internal.Subscription: [writeStore] :: Store e m -> (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()
+ Data.Morpheus.Types.Internal.Subscription: acceptApolloRequest :: MonadIO m => PendingConnection -> m Connection
+ Data.Morpheus.Types.Internal.Subscription: class GQLChannel a where {
+ Data.Morpheus.Types.Internal.Subscription: connect :: MonadIO m => m (Input WS)
+ Data.Morpheus.Types.Internal.Subscription: connectionSessionIds :: ClientConnection e m -> [SessionID]
+ Data.Morpheus.Types.Internal.Subscription: connectionThread :: MonadUnliftIO m => (Input WS -> Stream WS e m) -> Scope WS e m -> m ()
+ Data.Morpheus.Types.Internal.Subscription: data ClientConnectionStore e (m :: * -> *)
+ Data.Morpheus.Types.Internal.Subscription: data Input (api :: API)
+ Data.Morpheus.Types.Internal.Subscription: data Scope (api :: API) event (m :: * -> *)
+ Data.Morpheus.Types.Internal.Subscription: data Store e m
+ Data.Morpheus.Types.Internal.Subscription: data Stream (api :: API) e (m :: * -> *)
+ Data.Morpheus.Types.Internal.Subscription: disconnect :: Scope WS e m -> Input WS -> m ()
+ Data.Morpheus.Types.Internal.Subscription: empty :: Collection a coll => coll
+ Data.Morpheus.Types.Internal.Subscription: initDefaultStore :: (MonadIO m, MonadIO m2, Eq (StreamChannel event), GQLChannel event) => m2 (Store event m)
+ Data.Morpheus.Types.Internal.Subscription: publish :: (Eq (StreamChannel event), GQLChannel event, Monad m) => event -> ClientConnectionStore event m -> m ()
+ Data.Morpheus.Types.Internal.Subscription: publishEventWith :: (MonadIO m, Eq (StreamChannel event), GQLChannel event) => Store event m -> event -> m ()
+ Data.Morpheus.Types.Internal.Subscription: runStreamHTTP :: Monad m => Scope HTTP e m -> Stream HTTP e m -> m GQLResponse
+ Data.Morpheus.Types.Internal.Subscription: runStreamWS :: Monad m => Scope WS e m -> Stream WS e m -> m ()
+ Data.Morpheus.Types.Internal.Subscription: streamChannels :: GQLChannel a => a -> [Channel a]
+ Data.Morpheus.Types.Internal.Subscription: toList :: ClientConnectionStore e m -> [(UUID, ClientConnection e m)]
+ Data.Morpheus.Types.Internal.Subscription: toOutStream :: (Monad m, Eq (StreamChannel e), GQLChannel e, Functor m) => (GQLRequest -> ResponseStream e m (Value VALID)) -> Input api -> Stream api e m
+ Data.Morpheus.Types.Internal.Subscription: type HTTP = 'HTTP
+ Data.Morpheus.Types.Internal.Subscription: type SessionID = Text
+ Data.Morpheus.Types.Internal.Subscription: type WS = 'WS
+ Data.Morpheus.Types.Internal.Subscription: type family StreamChannel a :: Type;
+ Data.Morpheus.Types.Internal.Subscription: }
- Data.Morpheus.Types: GQLRequest :: Key -> Maybe Key -> Maybe Value -> GQLRequest
+ Data.Morpheus.Types: GQLRequest :: Token -> Maybe FieldName -> Maybe Value -> GQLRequest
- Data.Morpheus.Types: [operationName] :: GQLRequest -> Maybe Key
+ Data.Morpheus.Types: [operationName] :: GQLRequest -> Maybe FieldName
- Data.Morpheus.Types: [query] :: GQLRequest -> Key
+ Data.Morpheus.Types: [query] :: GQLRequest -> Token
- Data.Morpheus.Types: constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a
+ Data.Morpheus.Types: constMutRes :: Monad m => [e] -> a -> args -> ResolverM e m a
- Data.Morpheus.Types: data Resolver (o :: OperationType) event (m :: * -> *) value
+ Data.Morpheus.Types: data Resolver (o :: OperationType) event (m :: Type -> Type) value
- Data.Morpheus.Types: failRes :: (WithOperation o, Monad m) => String -> Resolver o e m a
+ Data.Morpheus.Types: failRes :: (Monad m, WithOperation o) => String -> Resolver o e m a
- Data.Morpheus.Types: subscribe :: forall e m a. (PushEvents (Channel e) (ResolverState (Channel e) m), Monad m) => [StreamChannel e] -> Resolver QUERY e m (e -> Resolver QUERY e m a) -> Resolver SUBSCRIPTION e m a
+ Data.Morpheus.Types: subscribe :: (PushEvents (Channel e) (ResolverState (Channel e) m), Monad m) => [StreamChannel e] -> Resolver QUERY e m (e -> Resolver QUERY e m a) -> Resolver SUBSCRIPTION e m a
- Data.Morpheus.Types: type MUTATION = 'Mutation
+ Data.Morpheus.Types: type MUTATION = Mutation
- Data.Morpheus.Types: type QUERY = 'Query
+ Data.Morpheus.Types: type QUERY = Query
- Data.Morpheus.Types: type ResolveM e m a = MutRes e m (a (MutRes e m))
+ Data.Morpheus.Types: type ResolveM e m a = ResolverM e m a
- Data.Morpheus.Types: type ResolveQ e m a = Res e m (a (Res e m))
+ Data.Morpheus.Types: type ResolveQ e m a = ResolverQ e m a
- Data.Morpheus.Types: type ResolveS e m a = SubRes e m (a (Res e m))
+ Data.Morpheus.Types: type ResolveS e m a = ResolverS e m a
- Data.Morpheus.Types: type SUBSCRIPTION = 'Subscription
+ Data.Morpheus.Types: type SUBSCRIPTION = Subscription
Files
- README.md +40/−12
- Setup.hs +1/−0
- changelog.md +83/−0
- morpheus-graphql.cabal +71/−91
- src/Data/Morpheus.hs +4/−3
- src/Data/Morpheus/Client.hs +0/−66
- src/Data/Morpheus/Document.hs +37/−73
- src/Data/Morpheus/Error/Client/Client.hs +0/−59
- src/Data/Morpheus/Error/Document/Interface.hs +0/−50
- src/Data/Morpheus/Error/Fragment.hs +0/−60
- src/Data/Morpheus/Error/Input.hs +0/−43
- src/Data/Morpheus/Error/Internal.hs +0/−37
- src/Data/Morpheus/Error/NameCollision.hs +0/−12
- src/Data/Morpheus/Error/Operation.hs +0/−21
- src/Data/Morpheus/Error/Schema.hs +0/−24
- src/Data/Morpheus/Error/Selection.hs +0/−37
- src/Data/Morpheus/Error/Utils.hs +0/−30
- src/Data/Morpheus/Error/Variable.hs +0/−44
- src/Data/Morpheus/Execution/Client/Aeson.hs +0/−171
- src/Data/Morpheus/Execution/Client/Build.hs +0/−98
- src/Data/Morpheus/Execution/Client/Compile.hs +0/−64
- src/Data/Morpheus/Execution/Client/Fetch.hs +0/−72
- src/Data/Morpheus/Execution/Client/Selection.hs +0/−313
- src/Data/Morpheus/Execution/Document/Compile.hs +0/−60
- src/Data/Morpheus/Execution/Document/Convert.hs +0/−182
- src/Data/Morpheus/Execution/Document/Declare.hs +0/−72
- src/Data/Morpheus/Execution/Document/Decode.hs +0/−48
- src/Data/Morpheus/Execution/Document/Encode.hs +0/−123
- src/Data/Morpheus/Execution/Document/GQLType.hs +0/−92
- src/Data/Morpheus/Execution/Document/Introspect.hs +0/−95
- src/Data/Morpheus/Execution/Internal/Declare.hs +0/−117
- src/Data/Morpheus/Execution/Internal/Decode.hs +0/−92
- src/Data/Morpheus/Execution/Internal/Utils.hs +0/−37
- src/Data/Morpheus/Execution/Server/Decode.hs +0/−234
- src/Data/Morpheus/Execution/Server/Encode.hs +0/−311
- src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs +0/−47
- src/Data/Morpheus/Execution/Server/Interpreter.hs +0/−64
- src/Data/Morpheus/Execution/Server/Introspect.hs +0/−496
- src/Data/Morpheus/Execution/Server/Resolve.hs +0/−188
- src/Data/Morpheus/Kind.hs +29/−20
- src/Data/Morpheus/Parsing/Document/TypeSystem.hs +0/−205
- src/Data/Morpheus/Parsing/Internal/Arguments.hs +0/−62
- src/Data/Morpheus/Parsing/Internal/Internal.hs +0/−74
- src/Data/Morpheus/Parsing/Internal/Pattern.hs +0/−152
- src/Data/Morpheus/Parsing/Internal/Terms.hs +0/−282
- src/Data/Morpheus/Parsing/Internal/Value.hs +0/−132
- src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +0/−110
- src/Data/Morpheus/Parsing/JSONSchema/Types.hs +0/−77
- src/Data/Morpheus/Parsing/Request/Operation.hs +0/−103
- src/Data/Morpheus/Parsing/Request/Parser.hs +0/−56
- src/Data/Morpheus/Parsing/Request/Selection.hs +0/−133
- src/Data/Morpheus/Rendering/RenderGQL.hs +0/−116
- src/Data/Morpheus/Rendering/RenderIntrospection.hs +0/−255
- src/Data/Morpheus/Schema/Schema.hs +0/−124
- src/Data/Morpheus/Schema/SchemaAPI.hs +0/−97
- src/Data/Morpheus/Schema/TypeKind.hs +0/−29
- src/Data/Morpheus/Server.hs +114/−78
- src/Data/Morpheus/Server/Deriving/Decode.hs +241/−0
- src/Data/Morpheus/Server/Deriving/Encode.hs +327/−0
- src/Data/Morpheus/Server/Deriving/Interpreter.hs +67/−0
- src/Data/Morpheus/Server/Deriving/Introspect.hs +572/−0
- src/Data/Morpheus/Server/Deriving/Resolve.hs +167/−0
- src/Data/Morpheus/Server/Deriving/Utils.hs +53/−0
- src/Data/Morpheus/Server/Document/Compile.hs +64/−0
- src/Data/Morpheus/Server/Document/Convert.hs +205/−0
- src/Data/Morpheus/Server/Document/Declare.hs +83/−0
- src/Data/Morpheus/Server/Document/Decode.hs +51/−0
- src/Data/Morpheus/Server/Document/Encode.hs +131/−0
- src/Data/Morpheus/Server/Document/GQLType.hs +110/−0
- src/Data/Morpheus/Server/Document/Introspect.hs +135/−0
- src/Data/Morpheus/Server/Internal/TH/Decode.hs +96/−0
- src/Data/Morpheus/Server/Types/GQLScalar.hs +72/−0
- src/Data/Morpheus/Server/Types/GQLType.hs +214/−0
- src/Data/Morpheus/Server/Types/ID.hs +46/−0
- src/Data/Morpheus/Server/Types/Types.hs +45/−0
- src/Data/Morpheus/Types.hs +183/−88
- src/Data/Morpheus/Types/GQLScalar.hs +0/−72
- src/Data/Morpheus/Types/GQLType.hs +0/−190
- src/Data/Morpheus/Types/ID.hs +0/−41
- src/Data/Morpheus/Types/IO.hs +0/−126
- src/Data/Morpheus/Types/Internal/AST.hs +0/−165
- src/Data/Morpheus/Types/Internal/AST/Base.hs +0/−268
- src/Data/Morpheus/Types/Internal/AST/Data.hs +0/−592
- src/Data/Morpheus/Types/Internal/AST/MergeSet.hs +0/−106
- src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs +0/−111
- src/Data/Morpheus/Types/Internal/AST/Selection.hs +0/−247
- src/Data/Morpheus/Types/Internal/AST/Value.hs +0/−297
- src/Data/Morpheus/Types/Internal/Operation.hs +0/−100
- src/Data/Morpheus/Types/Internal/Resolving.hs +0/−39
- src/Data/Morpheus/Types/Internal/Resolving/Core.hs +0/−184
- src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +0/−571
- src/Data/Morpheus/Types/Internal/Subscription.hs +115/−99
- src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs +89/−81
- src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs +135/−119
- src/Data/Morpheus/Types/Internal/Subscription/Stream.hs +198/−191
- src/Data/Morpheus/Types/Internal/TH.hs +0/−54
- src/Data/Morpheus/Types/Internal/Validation.hs +0/−354
- src/Data/Morpheus/Types/Internal/Validation/Error.hs +0/−201
- src/Data/Morpheus/Types/Internal/Validation/Validator.hs +0/−226
- src/Data/Morpheus/Types/Types.hs +0/−46
- src/Data/Morpheus/Validation/Document/Validation.hs +0/−72
- src/Data/Morpheus/Validation/Internal/Value.hs +0/−193
- src/Data/Morpheus/Validation/Query/Arguments.hs +0/−123
- src/Data/Morpheus/Validation/Query/Fragment.hs +0/−139
- src/Data/Morpheus/Validation/Query/Selection.hs +0/−205
- src/Data/Morpheus/Validation/Query/UnionSelection.hs +0/−127
- src/Data/Morpheus/Validation/Query/Validation.hs +0/−74
- src/Data/Morpheus/Validation/Query/Variable.hs +0/−169
- test/Feature/Holistic/API.hs +72/−60
- test/Feature/Holistic/arguments/undefinedArgument/response.json +1/−1
- test/Feature/Holistic/cases.json +60/−0
- test/Feature/Holistic/failure/resolveFailure/response.json +1/−1
- test/Feature/Holistic/fragment/loopingFragment/response.json +17/−67
- test/Feature/Holistic/introspection/directives/default/query.gql +54/−0
- test/Feature/Holistic/introspection/directives/default/response.json +60/−0
- test/Feature/Holistic/introspection/interface/query.gql +82/−0
- test/Feature/Holistic/introspection/interface/response.json +125/−0
- test/Feature/Holistic/parsing/complex/response.json +7/−42
- test/Feature/Holistic/parsing/directive/operation/query.gql +4/−4
- test/Feature/Holistic/parsing/directive/operation/response.json +9/−4
- test/Feature/Holistic/parsing/directive/selection/query.gql +4/−4
- test/Feature/Holistic/parsing/directive/selection/response.json +13/−5
- test/Feature/Holistic/parsing/generousSpaces/response.json +1/−1
- test/Feature/Holistic/parsing/invalidFields/response.json +1/−1
- test/Feature/Holistic/parsing/notNullSpacing/response.json +1/−1
- test/Feature/Holistic/reservedNames/query.gql +18/−0
- test/Feature/Holistic/reservedNames/response.json +16/−0
- test/Feature/Holistic/schema.gql +11/−1
- test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql +6/−0
- test/Feature/Holistic/selection/directives/default/requiredArgument/response.json +12/−0
- test/Feature/Holistic/selection/directives/default/resolve/query.gql +17/−0
- test/Feature/Holistic/selection/directives/default/resolve/response.json +10/−0
- test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql +17/−0
- test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json +10/−0
- test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql +13/−0
- test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json +1/−0
- test/Feature/Holistic/selection/directives/default/withMerge/query.gql +15/−0
- test/Feature/Holistic/selection/directives/default/withMerge/response.json +3/−0
- test/Feature/Holistic/selection/directives/default/withVariable/query.gql +15/−0
- test/Feature/Holistic/selection/directives/default/withVariable/response.json +3/−0
- test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql +12/−0
- test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json +32/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql +15/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json +20/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql +9/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json +8/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql +7/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json +8/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql +5/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json +16/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql +5/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json +16/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/query.gql +5/−0
- test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/response.json +16/−0
- test/Feature/Holistic/selection/hasNoSubFields/response.json +1/−1
- test/Feature/Holistic/selection/mergeConflict/alias/query.gql +3/−5
- test/Feature/Holistic/selection/mergeConflict/alias/response.json +4/−4
- test/Feature/Holistic/selection/mergeConflict/arguments/response.json +4/−4
- test/Feature/Holistic/selection/mergeConflict/union/response.json +4/−9
- test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json +1/−1
- test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json +2/−2
- test/Feature/Input/Enum/API.hs +20/−17
- test/Feature/Input/Object/API.hs +36/−30
- test/Feature/Input/Scalar/API.hs +26/−22
- test/Feature/InputType/API.hs +43/−34
- test/Feature/Schema/A2.hs +9/−7
- test/Feature/Schema/API.hs +24/−21
- test/Feature/TypeInference/API.hs +77/−71
- test/Feature/UnionType/API.hs +44/−36
- test/Feature/UnionType/cannotBeSpreadOnType/response.json +1/−1
- test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json +2/−7
- test/Feature/WrappedTypeName/API.hs +58/−39
- test/Lib.hs +12/−11
- test/Rendering/Schema.hs +30/−23
- test/Rendering/TestSchemaRendering.hs +8/−8
- test/Spec.hs +57/−44
- test/Subscription/API.hs +72/−0
- test/Subscription/Case/ApolloRequest.hs +148/−0
- test/Subscription/Case/Publishing.hs +104/−0
- test/Subscription/Test.hs +14/−0
- test/Subscription/Utils.hs +217/−0
- test/Subscription/schema.gql +25/−0
- test/TestFeature.hs +32/−37
- test/Types.hs +31/−0
README.md view
@@ -29,7 +29,7 @@ resolver: lts-14.8 extra-deps:- - morpheus-graphql-0.11.0+ - morpheus-graphql-0.12.0 ``` As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -76,7 +76,7 @@ import Data.Morpheus (interpreter) import Data.Morpheus.Document (importGQLDocumentWithNamespace)-import Data.Morpheus.Types (GQLRootResolver (..), IORes, Undefined(..))+import Data.Morpheus.Types (GQLRootResolver (..), ResolverQ, Undefined(..)) import Data.Text (Text) importGQLDocumentWithNamespace "schema.gql"@@ -109,7 +109,7 @@ ### with Native Haskell Types To define a GraphQL API with Morpheus we start by defining the API Schema as a native Haskell data type,-which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> IORes b`, representing resolving a set of arguments `a` to a concrete value `b`.+which derives the `Generic` typeclass. Lazily resolvable fields on this `Query` type are defined via `a -> ResolverQ () IO b`, representing resolving a set of arguments `a` to a concrete value `b`. ```haskell data Query m = Query@@ -143,7 +143,7 @@ The field name in the final request will be `type` instead of `type'`. The Morpheus request parser converts each of the reserved identities in Haskell 2010 to their corresponding names internally. This also applies to selections. ```haskell-resolveDeity :: DeityArgs -> IORes e Deity+resolveDeity :: DeityArgs -> ResolverQ e () Deity resolveDeity DeityArgs { name, mythology } = liftEither $ dbDeity name mythology askDB :: Text -> Maybe Text -> IO (Either String Deity)@@ -312,7 +312,6 @@ You will get the following schema: - ```gql # has wrapper types@@ -389,24 +388,24 @@ ## Handling Errors -for errors you can use use either `liftEither` or `failRes`:+for errors you can use use either `liftEither` or `MonadFail`: at the and they have same result. with `liftEither` ```haskell-resolveDeity :: DeityArgs -> IORes e Deity+resolveDeity :: DeityArgs -> ResolverQ e IO Deity resolveDeity DeityArgs {} = liftEither $ dbDeity dbDeity :: IO Either Deity dbDeity = pure $ Left "db error" ``` -with `failRes`+with `MonadFail` ```haskell-resolveDeity :: DeityArgs -> IORes e Deity-resolveDeity DeityArgs { } = failRes "db error"+resolveDeity :: DeityArgs -> ResolverQ e IO Deity+resolveDeity DeityArgs { } = fail "db error" ``` ### Mutations@@ -427,7 +426,7 @@ } where -- Mutation Without Event Triggering- createDeity :: MutArgs -> ResolveM () IO Deity+ createDeity :: MutArgs -> ResolverM () IO Deity createDeity_args = lift setDBAddress gqlApi :: ByteString -> IO ByteString@@ -474,7 +473,7 @@ } where -- Mutation Without Event Triggering- createDeity :: ResolveM EVENT IO Address+ createDeity :: ResolverM EVENT IO Address createDeity = do requireAuthorized publish [Event { channels = [ChannelA], content = ContentA 1 }]@@ -487,6 +486,35 @@ deityByEvent (Event [ChannelA] (ContentB _value)) = fetchDeity -- resolve New State deityByEvent _ = fetchDeity -- Resolve Old State ```++### Interface+ +1. defining interface with Haskell Types (runtime validation):+ + ```hs+ -- interface is just regular type derived as interface+ newtype Person m = Person {name :: m Text}+ deriving (Generic)++ instance GQLType (Person m) where+ type KIND (Person m) = INTERFACE++ -- with GQLType user can links interfaces to implementing object+ instance GQLType Deity where+ implements _ = [interface (Proxy @Person)]+ ```++2. defining with `importGQLDocument` and `DSL` (compile time validation):++ ```gql+ interface Account {+ name: String!+ }++ type User implements Account {+ name: String!+ }+ ``` ## Morpheus `GraphQL Client` with Template haskell QuasiQuotes
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
changelog.md view
@@ -1,5 +1,88 @@ # Changelog +## 0.12.0 - 21.05.2020++### Breaking Changes++Package was extracted as:++- `morpheus-graphql-core`: core components like: parser, validator, executor, utils.+ - Data.Morpheus.Core+ - Data.Morpheus.QuasiQuoter+ - Data.Morpheus.Error+ - Data.Morpheus.Internal.TH+ - Data.Morpheus.Internal.Utils+ - Data.Morpheus.Types.Internal.Resolving+ - Data.Morpheus.Types.Internal.Operation+ - Data.Morpheus.Types.Internal.AST+ - Data.Morpheus.Types.IO++- `morpheus-graphql-client`: lightweight version of morpheus client without server implementation+ - Data.Morpheus.Client++- `morpheus-graphql`: morpheus graphql server+ - Data.Morpheus+ - Data.Morpheus.Kind+ - Data.Morpheus.Types+ - Data.Morpheus.Server+ - Data.Morpheus.Document++deprecated:++- `Res`, `IORes`, `ResolveQ` : use `ResolverQ`+- `MutRes`, `IOMutRes`, `ResolveM` : use `ResolverM`+- `SubRes`, `IOSubRes`, `ResolveS`: use `ResolverS`+- `failRes`: use `MonadFail`++## New Feature++- `Semigroup` support for Resolver+- `MonadFail` Support for Resolver+- flexible resolvers: `ResolverO`, `ResolverQ` , `RwsolverM`, `ResolverS`+ they can handle object and scalar types:++ ```hs+ -- if we have record and regular Int+ data Object m = Object { field :: m Int }++ -- we canwrite+ -- handes kind : (* -> *) -> *+ resolveObject :: ResolverO o EVENT IO Object+ -- is alias to: Resolver o () IO (Object (Resolver o () IO))+ -- or+ -- handes kind : *+ resolveInt :: ResolverO o EVENT IO Int+ -- is alias to: Resolver o () IO Int+ ```++ the resolvers : `ResolverQ` , `RwsolverM`, `ResolverS` , are like+ `ResolverO` but with `QUERY` , `MUTATION` and `SUBSCRIPTION` as argument.++- flexible compsed Resolver Type alias: `ComposedResolver`. extends `ResolverO` with+ parameter `(f :: * -> *)`. so that you can compose Resolvers e.g:+ + ```hs+ resolveList :: ComposedResolver o EVENT IO [] Object+ -- is alias to: Resolver o () IO [Object (Resolver o () IO))]+ + resolveList :: ComposedResolver o EVENT IO Maybe Int+ -- is alias to: Resolver o () IO (Maybe Int)+ ```++- server supports interfaces (see Readme):++ 1. define interface with Haskell Types (runtime validation):+ 2. define interface with `importGQLDocument` and `DSL` (compile time validation):++- support default directives: `@skip` and `@include`++- SelectionTree interface++### minor++- fixed subscription sessions, srarting new session does not affects old ones.+- added tests for subscriptions+ ## 0.11.0 - 01.05.2020 ### Breaking Changes
morpheus-graphql.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2.+-- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack ----- hash: e10665dda7dcb75f84d447086dcbd786a36aea915278bd6bbf4285a01cf9d21a+-- hash: c98d51df8567b3a33a0b9f3dcf93217534d9f3a1d666f1ac2ab69b5ce6cfe0b6 name: morpheus-graphql-version: 0.11.0+version: 0.12.0 synopsis: Morpheus GraphQL description: Build GraphQL APIs with your favourite functional language! category: web, graphql@@ -47,6 +47,8 @@ test/Feature/Holistic/introspection/description/inputObject/query.gql test/Feature/Holistic/introspection/description/object/query.gql test/Feature/Holistic/introspection/description/union/query.gql+ test/Feature/Holistic/introspection/directives/default/query.gql+ test/Feature/Holistic/introspection/interface/query.gql test/Feature/Holistic/introspection/kinds/ENUM/query.gql test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/query.gql test/Feature/Holistic/introspection/kinds/OBJECT/query.gql@@ -78,10 +80,24 @@ test/Feature/Holistic/parsing/notNullSpacing/query.gql test/Feature/Holistic/parsing/numbers/query.gql test/Feature/Holistic/parsing/singleLineComments/query.gql+ test/Feature/Holistic/reservedNames/query.gql test/Feature/Holistic/schema.gql test/Feature/Holistic/selection/__typename/query.gql test/Feature/Holistic/selection/AliasResolve/query.gql test/Feature/Holistic/selection/AliasUnknownField/query.gql+ test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql+ test/Feature/Holistic/selection/directives/default/resolve/query.gql+ test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql+ test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql+ test/Feature/Holistic/selection/directives/default/withMerge/query.gql+ test/Feature/Holistic/selection/directives/default/withVariable/query.gql+ test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql+ test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql+ test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql+ test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql+ test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql+ test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql+ test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/query.gql test/Feature/Holistic/selection/hasNoSubFields/query.gql test/Feature/Holistic/selection/mergeConflict/alias/query.gql test/Feature/Holistic/selection/mergeConflict/arguments/query.gql@@ -157,6 +173,7 @@ test/Feature/WrappedTypeName/ignoreSubscriptionResolver/query.gql test/Feature/WrappedTypeName/validWrappedTypes/query.gql test/Rendering/schema.gql+ test/Subscription/schema.gql test/Feature/Holistic/arguments/nameConflict/response.json test/Feature/Holistic/arguments/undefinedArgument/response.json test/Feature/Holistic/arguments/unknownArguments/response.json@@ -182,6 +199,8 @@ test/Feature/Holistic/introspection/description/inputObject/response.json test/Feature/Holistic/introspection/description/object/response.json test/Feature/Holistic/introspection/description/union/response.json+ test/Feature/Holistic/introspection/directives/default/response.json+ test/Feature/Holistic/introspection/interface/response.json test/Feature/Holistic/introspection/kinds/ENUM/response.json test/Feature/Holistic/introspection/kinds/INPUT_OBJECT/response.json test/Feature/Holistic/introspection/kinds/OBJECT/response.json@@ -215,9 +234,23 @@ test/Feature/Holistic/parsing/notNullSpacing/variables.json test/Feature/Holistic/parsing/numbers/response.json test/Feature/Holistic/parsing/singleLineComments/response.json+ test/Feature/Holistic/reservedNames/response.json test/Feature/Holistic/selection/__typename/response.json test/Feature/Holistic/selection/AliasResolve/response.json test/Feature/Holistic/selection/AliasUnknownField/response.json+ test/Feature/Holistic/selection/directives/default/requiredArgument/response.json+ test/Feature/Holistic/selection/directives/default/resolve/response.json+ test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json+ test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json+ test/Feature/Holistic/selection/directives/default/withMerge/response.json+ test/Feature/Holistic/selection/directives/default/withVariable/response.json+ test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json+ test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json+ test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json+ test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json+ test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json+ test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json+ test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/response.json test/Feature/Holistic/selection/hasNoSubFields/response.json test/Feature/Holistic/selection/mergeConflict/alias/response.json test/Feature/Holistic/selection/mergeConflict/arguments/response.json@@ -327,88 +360,29 @@ Data.Morpheus.Types Data.Morpheus.Server Data.Morpheus.Document- Data.Morpheus.Client- Data.Morpheus.Types.Internal.AST- other-modules:- Data.Morpheus.Error.Client.Client- Data.Morpheus.Error.Document.Interface- Data.Morpheus.Error.Fragment- Data.Morpheus.Error.Input- Data.Morpheus.Error.Internal- Data.Morpheus.Error.NameCollision- Data.Morpheus.Error.Operation- Data.Morpheus.Error.Schema- Data.Morpheus.Error.Selection- Data.Morpheus.Error.Utils- Data.Morpheus.Error.Variable- Data.Morpheus.Execution.Client.Aeson- Data.Morpheus.Execution.Client.Build- Data.Morpheus.Execution.Client.Compile- Data.Morpheus.Execution.Client.Fetch- Data.Morpheus.Execution.Client.Selection- Data.Morpheus.Execution.Document.Compile- Data.Morpheus.Execution.Document.Convert- Data.Morpheus.Execution.Document.Declare- Data.Morpheus.Execution.Document.Decode- Data.Morpheus.Execution.Document.Encode- Data.Morpheus.Execution.Document.GQLType- Data.Morpheus.Execution.Document.Introspect- Data.Morpheus.Execution.Internal.Declare- Data.Morpheus.Execution.Internal.Decode- Data.Morpheus.Execution.Internal.Utils- Data.Morpheus.Execution.Server.Decode- Data.Morpheus.Execution.Server.Encode- Data.Morpheus.Execution.Server.Generics.EnumRep- Data.Morpheus.Execution.Server.Interpreter- Data.Morpheus.Execution.Server.Introspect- Data.Morpheus.Execution.Server.Resolve- Data.Morpheus.Parsing.Document.TypeSystem- Data.Morpheus.Parsing.Internal.Arguments- Data.Morpheus.Parsing.Internal.Internal- Data.Morpheus.Parsing.Internal.Pattern- Data.Morpheus.Parsing.Internal.Terms- Data.Morpheus.Parsing.Internal.Value- Data.Morpheus.Parsing.JSONSchema.Parse- Data.Morpheus.Parsing.JSONSchema.Types- Data.Morpheus.Parsing.Request.Operation- Data.Morpheus.Parsing.Request.Parser- Data.Morpheus.Parsing.Request.Selection- Data.Morpheus.Rendering.RenderGQL- Data.Morpheus.Rendering.RenderIntrospection- Data.Morpheus.Schema.Schema- Data.Morpheus.Schema.SchemaAPI- Data.Morpheus.Schema.TypeKind- Data.Morpheus.Types.GQLScalar- Data.Morpheus.Types.GQLType- Data.Morpheus.Types.ID- Data.Morpheus.Types.Internal.AST.Base- Data.Morpheus.Types.Internal.AST.Data- Data.Morpheus.Types.Internal.AST.MergeSet- Data.Morpheus.Types.Internal.AST.OrderedMap- Data.Morpheus.Types.Internal.AST.Selection- Data.Morpheus.Types.Internal.AST.Value- Data.Morpheus.Types.Internal.Operation- Data.Morpheus.Types.Internal.Resolving- Data.Morpheus.Types.Internal.Resolving.Core- Data.Morpheus.Types.Internal.Resolving.Resolver Data.Morpheus.Types.Internal.Subscription+ other-modules:+ Data.Morpheus.Server.Deriving.Decode+ Data.Morpheus.Server.Deriving.Encode+ Data.Morpheus.Server.Deriving.Interpreter+ Data.Morpheus.Server.Deriving.Introspect+ Data.Morpheus.Server.Deriving.Resolve+ Data.Morpheus.Server.Deriving.Utils+ Data.Morpheus.Server.Document.Compile+ Data.Morpheus.Server.Document.Convert+ Data.Morpheus.Server.Document.Declare+ Data.Morpheus.Server.Document.Decode+ Data.Morpheus.Server.Document.Encode+ Data.Morpheus.Server.Document.GQLType+ Data.Morpheus.Server.Document.Introspect+ Data.Morpheus.Server.Internal.TH.Decode+ Data.Morpheus.Server.Types.GQLScalar+ Data.Morpheus.Server.Types.GQLType+ Data.Morpheus.Server.Types.ID+ Data.Morpheus.Server.Types.Types Data.Morpheus.Types.Internal.Subscription.Apollo Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore Data.Morpheus.Types.Internal.Subscription.Stream- Data.Morpheus.Types.Internal.TH- Data.Morpheus.Types.Internal.Validation- Data.Morpheus.Types.Internal.Validation.Error- Data.Morpheus.Types.Internal.Validation.Validator- Data.Morpheus.Types.IO- Data.Morpheus.Types.Types- Data.Morpheus.Validation.Document.Validation- Data.Morpheus.Validation.Internal.Value- Data.Morpheus.Validation.Query.Arguments- Data.Morpheus.Validation.Query.Fragment- Data.Morpheus.Validation.Query.Selection- Data.Morpheus.Validation.Query.UnionSelection- Data.Morpheus.Validation.Query.Validation- Data.Morpheus.Validation.Query.Variable Paths_morpheus_graphql hs-source-dirs: src@@ -419,17 +393,17 @@ , bytestring >=0.10.4 && <0.11 , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0- , mtl >=2.0 && <=2.3+ , morpheus-graphql-core >=0.12.0+ , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4- , template-haskell >=2.0 && <=2.16+ , template-haskell >=2.0 && <=3.0 , text >=1.2.3.0 && <1.3- , th-lift-instances >=0.1.1 && <=0.2.0 , transformers >=0.3.0.0 && <0.6- , unliftio-core >=0.0.1 && <=0.3+ , unliftio-core >=0.0.1 && <=0.4 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13- , websockets >=0.11.0 && <=0.13+ , websockets >=0.11.0 && <=1.0 default-language: Haskell2010 test-suite morpheus-test@@ -449,7 +423,13 @@ Lib Rendering.Schema Rendering.TestSchemaRendering+ Subscription.API+ Subscription.Case.ApolloRequest+ Subscription.Case.Publishing+ Subscription.Test+ Subscription.Utils TestFeature+ Types Paths_morpheus_graphql hs-source-dirs: test@@ -461,17 +441,17 @@ , containers >=0.4.2.1 && <0.7 , megaparsec >=7.0.0 && <9.0.0 , morpheus-graphql- , mtl >=2.0 && <=2.3+ , morpheus-graphql-core >=0.12.0+ , mtl >=2.0 && <=3.0 , scientific >=0.3.6.2 && <0.4 , tasty , tasty-hunit- , template-haskell >=2.0 && <=2.16+ , template-haskell >=2.0 && <=3.0 , text >=1.2.3.0 && <1.3- , th-lift-instances >=0.1.1 && <=0.2.0 , transformers >=0.3.0.0 && <0.6- , unliftio-core >=0.0.1 && <=0.3+ , unliftio-core >=0.0.1 && <=0.4 , unordered-containers >=0.2.8.0 && <0.3 , uuid >=1.0 && <=1.4 , vector >=0.12.0.1 && <0.13- , websockets >=0.11.0 && <=0.13+ , websockets >=0.11.0 && <=1.0 default-language: Haskell2010
src/Data/Morpheus.hs view
@@ -1,8 +1,9 @@ -- | Build GraphQL APIs with your favourite functional language! module Data.Morpheus- ( Interpreter(..)+ ( Interpreter (..), ) where -import Data.Morpheus.Execution.Server.Interpreter- ( Interpreter(..) )+import Data.Morpheus.Server.Deriving.Interpreter+ ( Interpreter (..),+ )
− src/Data/Morpheus/Client.hs
@@ -1,66 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Client- ( gql- , Fetch(..)- , defineQuery- , defineByDocument- , defineByDocumentFile- , defineByIntrospection- , defineByIntrospectionFile- )-where--import Data.ByteString.Lazy ( ByteString )-import qualified Data.ByteString.Lazy as L- ( readFile )-import Language.Haskell.TH-import Language.Haskell.TH.Quote--import Data.Morpheus.Document ( parseFullGQLDocument )--- MORPHEUS-import Data.Morpheus.Execution.Client.Build- ( defineQuery )-import Data.Morpheus.Execution.Client.Compile- ( compileSyntax )-import Data.Morpheus.Execution.Client.Fetch- ( Fetch(..) )-import Data.Morpheus.Parsing.JSONSchema.Parse- ( decodeIntrospection )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )-import Data.Morpheus.Types.Internal.AST- ( GQLQuery- , Schema- )--gql :: QuasiQuoter-gql = QuasiQuoter { quoteExp = compileSyntax- , quotePat = notHandled "Patterns"- , quoteType = notHandled "Types"- , quoteDec = notHandled "Declarations"- }- where- notHandled things =- error $ things ++ " are not supported by the GraphQL QuasiQuoter"--defineByDocumentFile :: String -> (GQLQuery, String) -> Q [Dec]-defineByDocumentFile = defineByDocument . L.readFile--defineByIntrospectionFile :: String -> (GQLQuery, String) -> Q [Dec]-defineByIntrospectionFile = defineByIntrospection . L.readFile---------- TODO: Define By API--- Validates By Server API----defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec]-defineByDocument doc = defineQuery (schemaByDocument doc)--schemaByDocument :: IO ByteString -> IO (Eventless Schema)-schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL--defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec]-defineByIntrospection json = defineQuery (decodeIntrospection <$> json)
src/Data/Morpheus/Document.hs view
@@ -1,82 +1,37 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE FlexibleContexts #-} module Data.Morpheus.Document- ( toGraphQLDocument- , gqlDocument- , parseFullGQLDocument- , importGQLDocument- , importGQLDocumentWithNamespace- , parseDSL+ ( toGraphQLDocument,+ gqlDocument,+ importGQLDocument,+ importGQLDocumentWithNamespace, ) where -import Control.Monad ( (>=>) )-import Data.ByteString.Lazy.Char8 ( ByteString- , pack- )-import Data.Text ( Text )-import qualified Data.Text.Lazy as LT- ( toStrict )-import Data.Text.Lazy.Encoding ( decodeUtf8 )-import Language.Haskell.TH------- MORPHEUS-import Data.Morpheus.Execution.Document.Compile- ( compileDocument- , gqlDocument- )-import Data.Morpheus.Execution.Server.Resolve- ( RootResCon- , fullSchema- )-import Data.Morpheus.Parsing.Document.TypeSystem- ( parseSchema - )-import Data.Morpheus.Rendering.RenderGQL- ( renderGraphQLDocument - )-import Data.Morpheus.Schema.SchemaAPI ( defaultTypes )-import Data.Morpheus.Types ( GQLRootResolver )-import Data.Morpheus.Types.Internal.AST- ( Schema- , createDataTypeLib- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , Result(..)- )-import Data.Morpheus.Validation.Document.Validation- ( validatePartialDocument )-- -parseDSL :: ByteString -> Either String Schema-parseDSL doc = case parseGraphQLDocument doc of- Failure errors -> Left (show errors)- Success { result } -> Right result---parseDocument :: Text -> Eventless Schema-parseDocument doc =- parseSchema doc >>= validatePartialDocument >>= createDataTypeLib--parseGraphQLDocument :: ByteString -> Eventless Schema-parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x)--parseFullGQLDocument :: ByteString -> Eventless Schema-parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes---- | Generates schema.gql file from 'GQLRootResolver'-toGraphQLDocument- :: RootResCon m event query mut sub- => proxy (GQLRootResolver m event query mut sub)- -> ByteString-toGraphQLDocument x = case fullSchema x of- Failure errors -> pack (show errors)- Success { result = lib } -> renderGraphQLDocument lib--+import Data.ByteString.Lazy.Char8+ ( ByteString,+ pack,+ )+import Data.Morpheus.Core+ ( render,+ )+import Data.Morpheus.Server.Deriving.Resolve+ ( RootResCon,+ fullSchema,+ )+import Data.Morpheus.Server.Document.Compile+ ( compileDocument,+ gqlDocument,+ )+import Data.Morpheus.Types (GQLRootResolver)+import Data.Morpheus.Types.Internal.Resolving+ ( resultOr,+ )+import qualified Data.Text.Lazy as LT+ ( fromStrict,+ )+import Data.Text.Lazy.Encoding (encodeUtf8)+import Language.Haskell.TH importGQLDocument :: String -> Q [Dec] importGQLDocument src = runIO (readFile src) >>= compileDocument False@@ -84,3 +39,12 @@ importGQLDocumentWithNamespace :: String -> Q [Dec] importGQLDocumentWithNamespace src = runIO (readFile src) >>= compileDocument True++-- | Generates schema.gql file from 'GQLRootResolver'+toGraphQLDocument ::+ RootResCon m event query mut sub =>+ proxy (GQLRootResolver m event query mut sub) ->+ ByteString+toGraphQLDocument =+ resultOr (pack . show) (encodeUtf8 . LT.fromStrict . render)+ . fullSchema
− src/Data/Morpheus/Error/Client/Client.hs
@@ -1,59 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Client.Client- ( renderGQLErrors- , deprecatedEnum- , deprecatedField- , gqlWarnings- )-where---import Data.Aeson ( encode )-import Data.ByteString.Lazy.Char8 ( unpack )-import Language.Haskell.TH ( Q- , reportWarning- )-import Data.Semigroup ( (<>) )-import Data.Foldable ( traverse_ )---- MORPHEUS-import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Types.Internal.AST.Base- ( Ref(..)- , Description- , Name- , GQLErrors- )---renderGQLErrors :: GQLErrors -> String-renderGQLErrors = unpack . encode--deprecatedEnum :: Name -> Ref -> Maybe Description -> GQLErrors-deprecatedEnum typeName Ref { refPosition, refName } reason =- errorMessage refPosition- $ "the enum value "- <> typeName- <> "."- <> refName- <> "\" is deprecated."- <> maybe "" (" " <>) reason--deprecatedField :: Name -> Ref -> Maybe Description -> GQLErrors-deprecatedField typeName Ref { refPosition, refName } reason =- errorMessage refPosition- $ "the field \""- <> typeName- <> "."- <> refName- <> "\" is deprecated."- <> maybe "" (" " <>) reason--gqlWarnings :: GQLErrors -> Q ()-gqlWarnings [] = pure ()-gqlWarnings warnings = traverse_ handleWarning warnings- where- handleWarning warning =- reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning)
− src/Data/Morpheus/Error/Document/Interface.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Document.Interface- ( unknownInterface- , partialImplements- , ImplementsError(..)- )-where--import Data.Morpheus.Error.Utils ( globalErrorMessage )-import Data.Morpheus.Types.Internal.AST.Base- ( Key- , GQLError(..)- , GQLErrors- )-import Data.Semigroup ( (<>) )--unknownInterface :: Key -> GQLErrors-unknownInterface name = globalErrorMessage message- where message = "Unknown Interface \"" <> name <> "\"."--data ImplementsError- = UnexpectedType { expectedType :: Key- , foundType :: Key }- | UndefinedField--partialImplements :: Key -> [(Key, Key, ImplementsError)] -> GQLErrors-partialImplements name = map impError- where- impError (interfaceName, key, errorType) = GQLError { message = message- , locations = []- }- where- message =- "type \""- <> name- <> "\" implements Interface \""- <> interfaceName- <> "\" Partially,"- <> detailedMessage errorType- detailedMessage UnexpectedType { expectedType, foundType } =- " on key \""- <> key- <> "\" expected type \""- <> expectedType- <> "\" found \""- <> foundType- <> "\"."- detailedMessage UndefinedField = " key \"" <> key <> "\" not found ."
− src/Data/Morpheus/Error/Fragment.hs
@@ -1,60 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Fragment- ( cannotSpreadWithinItself- , cannotBeSpreadOnType- )-where--import Data.Semigroup ( (<>) )-import Data.Text ( Text- , intercalate- )-import qualified Data.Text as T---- MORPHEUS-import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Types.Internal.AST.Base- ( Ref(..)- , Position- , GQLError(..)- , GQLErrors- )--{-- FRAGMENT:- type Experience {- experience ( lang: LANGUAGE ) : String ,- date: String- }- fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."- fragment H on T1 { ...A} , fragment A on T { ...H } -> "Cannot spread fragment \"H\" within itself via A."- fragment H on D {...} -> "Unknown type \"D\"."- {...H} -> "Unknown fragment \"H\"."--}--cannotSpreadWithinItself :: [Ref] -> GQLErrors-cannotSpreadWithinItself fragments = [GQLError { message = text, locations = map refPosition fragments }]- where- text = "Cannot spread fragment \""- <> refName (head fragments)- <> "\" within itself via "- <> T.intercalate ", " (map refName fragments)- <> "."---- Fragment type mismatch -> "Fragment \"H\" cannot be spread here as objects of type \"Hobby\" can never be of type \"Experience\"."-cannotBeSpreadOnType :: Maybe Text -> Text -> Position -> [Text] -> GQLErrors-cannotBeSpreadOnType key fragmentType position typeMembers = errorMessage- position- msg- where- msg =- "Fragment "- <> getName key- <> "cannot be spread here as objects of type \""- <> intercalate ", " typeMembers- <> "\" can never be of type \""- <> fragmentType- <> "\"."- getName (Just x) = "\"" <> x <> "\" "- getName Nothing = ""
− src/Data/Morpheus/Error/Input.hs
@@ -1,43 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Input- ( typeViolation - )-where--import Data.Semigroup ( (<>) )-import Data.Aeson ( encode )-import Data.ByteString.Lazy.Char8 ( unpack )-import Data.Text ( pack )---- MORPHEUS-import Data.Morpheus.Types.Internal.AST - ( Message- , ResolvedValue- , TypeRef(..) - )-import Data.Morpheus.Rendering.RenderGQL- ( RenderGQL(..) )---typeViolation :: TypeRef -> ResolvedValue -> Message-typeViolation expected found = "Expected type \""- <> render expected- <> "\" found "- <> pack (unpack $ encode found)- <> "."--{-- ARGUMENTS:- type Experience {- experience ( lang: LANGUAGE ) : String ,- date: String- }-- - required field !?- - experience( lang: "bal" ) -> "Expected type LANGUAGE, found \"a\"."- - experience( lang: Bla ) -> "Expected type LANGUAGE, found Bla."- - experience( lang: 1 ) -> "Expected type LANGUAGE, found 1."- - experience( a1 : 1 ) -> "Unknown argument \"a1\" on field \"experience\" of type \"Experience\".",- - date(name: "name") -> "Unknown argument \"name\" on field \"date\" of type \"Experience\"."--}
− src/Data/Morpheus/Error/Internal.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Internal- ( internalTypeMismatch- , internalError- , internalResolvingError- )-where--import Data.Text ( pack )-import Data.Semigroup ( (<>) )---- MORPHEUS-import Data.Morpheus.Error.Utils ( globalErrorMessage )-import Data.Morpheus.Types.Internal.Resolving.Core- ( Eventless- , Failure(..)- )-import Data.Morpheus.Types.Internal.AST.Base- ( GQLErrors - , Message- )-import Data.Morpheus.Types.Internal.AST.Value- ( ValidValue )---- GQL:: if no mutation defined -> "Schema is not configured for mutations."--- all kind internal error in development-internalError :: Message -> Eventless a-internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x--internalResolvingError :: Message -> GQLErrors-internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>)---- if value is already validated but value has different type-internalTypeMismatch :: Message -> ValidValue -> Eventless a-internalTypeMismatch text jsType =- internalError $ "Type mismatch " <> text <> pack (show jsType)
− src/Data/Morpheus/Error/NameCollision.hs
@@ -1,12 +0,0 @@-module Data.Morpheus.Error.NameCollision- ( NameCollision(..)- )-where--import Data.Morpheus.Types.Internal.AST.Base- ( Name - , GQLError(..)- )--class NameCollision a where - nameCollision :: Name -> a -> GQLError
− src/Data/Morpheus/Error/Operation.hs
@@ -1,21 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Operation- ( mutationIsNotDefined- , subscriptionIsNotDefined- )-where--import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Types.Internal.AST.Base- ( Position - , GQLErrors - )--mutationIsNotDefined :: Position -> GQLErrors-mutationIsNotDefined position =- errorMessage position "Schema is not configured for mutations."--subscriptionIsNotDefined :: Position -> GQLErrors-subscriptionIsNotDefined position =- errorMessage position "Schema is not configured for subscriptions."
− src/Data/Morpheus/Error/Schema.hs
@@ -1,24 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Schema- ( nameCollisionError- , schemaValidationError- )-where--import Data.Morpheus.Error.Utils ( globalErrorMessage )-import Data.Morpheus.Types.Internal.AST.Base- ( GQLErrors )-import Data.Semigroup ( (<>) )-import Data.Text ( Text )--schemaValidationError :: Text -> GQLErrors-schemaValidationError error' =- globalErrorMessage $ "Schema Validation Error, " <> error'--nameCollisionError :: Text -> GQLErrors-nameCollisionError name =- schemaValidationError- $ "Name collision: \""- <> name- <> "\" is used for different dataTypes in two separate modules"
− src/Data/Morpheus/Error/Selection.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Error.Selection- ( unknownSelectionField- , subfieldsNotSelected- , hasNoSubfields- )-where--import Data.Semigroup ( (<>) )-import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Types.Internal.AST.Base- ( Position- , GQLErrors- , Ref(..)- , Name- )-import Data.Text ( Text )---- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."-hasNoSubfields :: Ref -> Name -> GQLErrors-hasNoSubfields (Ref selectionName position) typeName = errorMessage position text- where- text = "Field \"" <> selectionName <> "\" must not have a selection since type \"" <> typeName <> "\" has no subfields."--unknownSelectionField :: Name -> Ref -> GQLErrors-unknownSelectionField typeName Ref { refName , refPosition } = errorMessage refPosition text- where- text = "Cannot query field \"" <> refName <> "\" on type \"" <> typeName <> "\"."---- GQL:: Field \"hobby\" of type \"Hobby!\" must have a selection of subfields. Did you mean \"hobby { ... }\"?-subfieldsNotSelected :: Text -> Text -> Position -> GQLErrors-subfieldsNotSelected key typeName position = errorMessage position text- where- text = "Field \"" <> key <> "\" of type \""- <> typeName <> "\" must have a selection of subfields"
− src/Data/Morpheus/Error/Utils.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Utils- ( errorMessage- , globalErrorMessage- , badRequestError- )-where--import Data.Semigroup ((<>))-import Data.ByteString.Lazy.Char8 ( ByteString- , pack- )-import Data.Morpheus.Types.Internal.AST.Base- ( Position(..)- , GQLError(..)- , GQLErrors- )-import Data.Text ( Text )---errorMessage :: Position -> Text -> GQLErrors-errorMessage position message = [GQLError { message, locations = [position] }]--globalErrorMessage :: Text -> GQLErrors-globalErrorMessage message = [GQLError { message, locations = [] }]--badRequestError :: String -> ByteString-badRequestError = ("Bad Request. Could not decode Request body: " <>) . pack
− src/Data/Morpheus/Error/Variable.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Error.Variable- ( uninitializedVariable- , incompatibleVariableType- )-where--import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Types.Internal.AST- ( GQLErrors- , Ref(..)- , Variable(..)- , TypeRef- )-import Data.Semigroup ( (<>) )-import Data.Morpheus.Rendering.RenderGQL- ( RenderGQL(..) )---- query M ( $v : String ) { a(p:$v) } -> "Variable \"$v\" of type \"String\" used in position expecting type \"LANGUAGE\"."-incompatibleVariableType :: Ref -> Variable s -> TypeRef -> GQLErrors-incompatibleVariableType - (Ref variableName argPosition) - Variable { variableType } - argumentType =- errorMessage argPosition text- where- text =- "Variable \"$"- <> variableName- <> "\" of type \""- <> render variableType- <> "\" used in position expecting type \""- <> render argumentType- <> "\"."--uninitializedVariable :: Variable s -> GQLErrors-uninitializedVariable Variable { variableName, variableType, variablePosition} = - errorMessage - variablePosition - $ "Variable \"$" <> variableName - <> "\" of required type \""- <> render variableType <> "\" was not provided."
− src/Data/Morpheus/Execution/Client/Aeson.hs
@@ -1,171 +0,0 @@-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Execution.Client.Aeson- ( deriveFromJSON- , deriveToJSON- , takeValueType- )-where--import Data.Aeson-import Data.Aeson.Types-import qualified Data.HashMap.Lazy as H- ( lookup )-import Data.Semigroup ( (<>) )-import Data.Text ( append- , Text- , unpack- )-import Language.Haskell.TH--import Data.Morpheus.Execution.Internal.Utils- ( nameSpaceType )------- MORPHEUS-import Data.Morpheus.Execution.Internal.Declare- ( isEnum )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , isFieldNullable- , ConsD(..)- , TypeD(..)- , Key- )-import Data.Morpheus.Types.Internal.TH- ( destructRecord- , instanceFunD- , instanceHeadT- )---- FromJSON-deriveFromJSON :: TypeD -> Q Dec-deriveFromJSON TypeD { tCons = [] , tName } =- fail $ "Type " <> unpack tName <> " Should Have at least one Constructor"-deriveFromJSON TypeD { tName, tNamespace, tCons = [cons] } = defineFromJSON- name- (aesonObject tNamespace)- cons- where name = nameSpaceType tNamespace tName-deriveFromJSON typeD@TypeD { tName, tCons, tNamespace }- | isEnum tCons = defineFromJSON name (aesonFromJSONEnumBody tName) tCons- | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD- where name = nameSpaceType tNamespace tName--aesonObject :: [Key] -> ConsD -> ExpQ-aesonObject tNamespace con@ConsD { cName } = appE- [|withObject name|]- (lamE [varP (mkName "o")] (aesonObjectBody tNamespace con))- where name = unpack $ nameSpaceType tNamespace cName--aesonObjectBody :: [Key] -> ConsD -> ExpQ-aesonObjectBody namespace ConsD { cName, cFields } = handleFields cFields- where- consName = mkName $ unpack $ nameSpaceType namespace cName- ----------------------------------------------------------- handleFields [] = fail $ "Type \""<>unpack cName <>"\" is Empty Object"- handleFields fields = startExp fields- ----------------------------------------------------------- where- defField field@FieldDefinition { fieldName }- | isFieldNullable field = [|o .:? fName|]- | otherwise = [|o .: fName|]- where fName = unpack fieldName- --------------------------------------------------------- startExp fNames = uInfixE (conE consName)- (varE '(<$>))- (applyFields fNames)- where- applyFields [] = fail "No Empty fields"- applyFields [x] = defField x- applyFields (x : xs) =- uInfixE (defField x) (varE '(<*>)) (applyFields xs)--aesonUnionObject :: [Key] -> TypeD -> ExpQ-aesonUnionObject namespace TypeD { tCons } = appE- (varE 'takeValueType)- (lamCaseE (map buildMatch tCons <> [elseCaseEXP]))- where- buildMatch cons@ConsD { cName } = match objectPattern body []- where- objectPattern = tupP [litP (stringL $ unpack cName), varP $ mkName "o"]- body = normalB $ aesonObjectBody namespace cons--takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a-takeValueType f (Object hMap) = case H.lookup "__typename" hMap of- Nothing -> fail "key \"__typename\" not found on object"- Just (String x) -> pure (unpack x, hMap) >>= f- Just val ->- fail $ "key \"__typename\" should be string but found: " <> show val-takeValueType _ _ = fail "expected Object"--defineFromJSON :: Key -> (t -> ExpQ) -> t -> DecQ-defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method]- where- iHead = instanceHeadT ''FromJSON tName []- ------------------------------------------ method = instanceFunD 'parseJSON [] (parseJ cFields)--aesonFromJSONEnumBody :: Text -> [ConsD] -> ExpQ-aesonFromJSONEnumBody tName cons = lamCaseE handlers- where- handlers = map buildMatch cons <> [elseCaseEXP]- where- buildMatch ConsD { cName } = match enumPat body []- where- enumPat = litP $ stringL $ unpack cName- body = normalB $ appE (varE 'pure) (conE $ mkName $ unpack $ append tName cName)--elseCaseEXP :: MatchQ-elseCaseEXP = match (varP varName) body []- where- varName = mkName "invalidValue"- body = normalB $ appE- (varE $ mkName "fail")- (uInfixE (appE (varE 'show) (varE varName))- (varE '(<>))- (stringE " is Not Valid Union Constructor")- )--aesonToJSONEnumBody :: Text -> [ConsD] -> ExpQ-aesonToJSONEnumBody tName cons = lamCaseE handlers- where- handlers = map buildMatch cons- where- buildMatch ConsD { cName } = match enumPat body []- where- enumPat = conP (mkName $ unpack $ append tName cName) []- body = normalB $ litE (stringL $ unpack cName)---- ToJSON-deriveToJSON :: TypeD -> Q [Dec]-deriveToJSON TypeD { tCons = [] } =- fail "Type Should Have at least one Constructor"-deriveToJSON TypeD { tName, tCons = [ConsD { cFields }] } =- pure <$> instanceD (cxt []) appHead methods- where- appHead = instanceHeadT ''ToJSON tName []- ------------------------------------------------------------------- -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...]- methods = [funD 'toJSON [clause argsE (normalB body) []]]- where- argsE = [destructRecord tName varNames]- body = appE (varE 'object) (listE $ map (decodeVar . unpack) varNames)- decodeVar name = [|name .= $(varName)|] where varName = varE $ mkName name- varNames = map fieldName cFields-deriveToJSON TypeD { tName, tCons }- | isEnum tCons- = let methods = [funD 'toJSON clauses]- clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []]- in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) methods- |- otherwise- = fail "Input Unions are not yet supported"
− src/Data/Morpheus/Execution/Client/Build.hs
@@ -1,98 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Execution.Client.Build- ( defineQuery- )-where--import Data.Semigroup ( (<>) )-import Language.Haskell.TH-import Data.Text ( unpack )------- MORPHEUS-import Data.Morpheus.Error.Client.Client- ( renderGQLErrors- , gqlWarnings- )-import Data.Morpheus.Execution.Client.Aeson- ( deriveFromJSON- , deriveToJSON- )-import Data.Morpheus.Execution.Client.Compile- ( validateWith )-import Data.Morpheus.Execution.Client.Fetch- ( deriveFetch )-import Data.Morpheus.Execution.Internal.Declare- ( declareType - , Scope(..)- )--import Data.Morpheus.Types.Internal.AST- ( GQLQuery(..)- , DataTypeKind(..)- , Schema- , isOutputObject- , ClientType(..)- , ClientQuery(..)- , TypeD(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , Result(..)- )--defineQuery :: IO (Eventless Schema) -> (GQLQuery, String) -> Q [Dec]-defineQuery ioSchema queryRoot = do- schema <- runIO ioSchema- case schema >>= (`validateWith` queryRoot) of- Failure errors -> fail (renderGQLErrors errors)- Success { result, warnings } -> gqlWarnings warnings >> defineQueryD result--defineQueryD :: ClientQuery -> Q [Dec]-defineQueryD ClientQuery { queryTypes = rootType : subTypes, queryText, queryArgsType }- = do- rootDecs <- defineOperationType (queryArgumentType queryArgsType)- queryText- rootType- subTypeDecs <- concat <$> traverse declareT subTypes- return $ rootDecs ++ subTypeDecs- where- declareT ClientType { clientType, clientKind }- | isOutputObject clientKind || clientKind == KindUnion = withToJSON- declareOutputType- clientType- | clientKind == KindEnum = withToJSON declareInputType clientType- | otherwise = declareInputType clientType-defineQueryD ClientQuery { queryTypes = [] } = return []--declareOutputType :: TypeD -> Q [Dec]-declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD]--declareInputType :: TypeD -> Q [Dec]-declareInputType typeD = do- toJSONDec <- deriveToJSON typeD- pure $ declareType CLIENT True Nothing [''Show] typeD : toJSONDec--withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec]-withToJSON f datatype = do- toJson <- deriveFromJSON datatype- dec <- f datatype- pure (toJson : dec)--queryArgumentType :: Maybe TypeD -> (Type, Q [Dec])-queryArgumentType Nothing = (ConT $ mkName "()", pure [])-queryArgumentType (Just rootType@TypeD { tName }) =- (ConT $ mkName $ unpack tName, declareInputType rootType)--defineOperationType :: (Type, Q [Dec]) -> String -> ClientType -> Q [Dec]-defineOperationType (argType, argumentTypes) query ClientType { clientType } =- do- rootType <- withToJSON declareOutputType clientType- typeClassFetch <- deriveFetch argType (tName clientType) query- argsT <- argumentTypes- pure $ rootType <> typeClassFetch <> argsT
− src/Data/Morpheus/Execution/Client/Compile.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Execution.Client.Compile- ( compileSyntax- , validateWith- )-where--import qualified Data.Text as T- ( pack )-import Language.Haskell.TH------- Morpheus---import Data.Morpheus.Error.Client.Client- ( renderGQLErrors- , gqlWarnings- )--import Data.Morpheus.Execution.Client.Selection- ( operationTypes )-import Data.Morpheus.Parsing.Request.Parser- ( parseGQL )-import qualified Data.Morpheus.Types.Internal.AST- as O- ( Operation(..) )-import Data.Morpheus.Types.IO ( GQLRequest(..) )--import Data.Morpheus.Types.Internal.AST- ( GQLQuery(..)- , Schema- , ClientQuery(..)- , VALIDATION_MODE(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , Result(..)- )-import Data.Morpheus.Validation.Query.Validation- ( validateRequest )--compileSyntax :: String -> Q Exp-compileSyntax queryText = case parseGQL request of- Failure errors -> fail (renderGQLErrors errors)- Success { result, warnings } ->- gqlWarnings warnings >> [|(result, queryText)|]- where- request = GQLRequest { query = T.pack queryText- , operationName = Nothing- , variables = Nothing- }--validateWith :: Schema -> (GQLQuery, String) -> Eventless ClientQuery-validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do- validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest- (queryArgsType, queryTypes) <- operationTypes- schema- (O.operationArguments operation)- validOperation- return ClientQuery { queryText, queryTypes, queryArgsType }
− src/Data/Morpheus/Execution/Client/Fetch.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Execution.Client.Fetch- ( Fetch(..)- , deriveFetch- )-where--import Control.Monad ( (>=>) )-import Data.Aeson ( FromJSON- , ToJSON(..)- , eitherDecode- , encode- )-import Data.ByteString.Lazy ( ByteString )-import Data.Text ( pack- , unpack- , Text- )-import Language.Haskell.TH---import qualified Data.Aeson as A-import qualified Data.Aeson.Types as A------- MORPHEUS-import Data.Morpheus.Types.Internal.TH- ( instanceHeadT- , typeInstanceDec- )-import Data.Morpheus.Types.IO ( GQLRequest(..)- , JSONResponse(..)- )---fixVars :: A.Value -> Maybe A.Value-fixVars x | x == A.emptyArray = Nothing- | otherwise = Just x--class Fetch a where- type Args a :: *- __fetch ::- (Monad m, Show a, ToJSON (Args a), FromJSON a)- => String- -> Text- -> (ByteString -> m ByteString)- -> Args a- -> m (Either String a)- __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq)- where- gqlReq = GQLRequest {operationName = Just opName, query = pack strQuery, variables = fixVars (toJSON vars)}- -------------------------------------------------------------- processResponse JSONResponse {responseData = Just x} = Right x- processResponse invalidResponse = Left (show invalidResponse)- fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a)---deriveFetch :: Type -> Text -> String -> Q [Dec]-deriveFetch resultType typeName queryString =- pure <$> instanceD (cxt []) iHead methods- where- iHead = instanceHeadT ''Fetch typeName []- methods =- [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []]- , pure $ typeInstanceDec ''Args (ConT $ mkName $ unpack typeName) resultType- ]
− src/Data/Morpheus/Execution/Client/Selection.hs
@@ -1,313 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Execution.Client.Selection- ( operationTypes- )-where--import Data.Semigroup ( (<>) )-import Data.Text ( Text- , pack- )------ MORPHEUS-import Data.Morpheus.Error.Client.Client- ( deprecatedField )-import Data.Morpheus.Error.Utils ( globalErrorMessage )-import Data.Morpheus.Execution.Internal.Utils- ( nameSpaceType )-import Data.Morpheus.Types.Internal.AST- ( Operation(..)- , Key- , Name- , RAW- , VALID- , Variable(..)- , VariableDefinitions- , Selection(..)- , SelectionContent(..)- , SelectionSet- , Ref(..)- , FieldDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , DataTypeKind(..)- , Schema(..)- , TypeRef(..)- , DataEnumValue(..)- , ConsD(..)- , ClientType(..)- , TypeD(..)- , ArgumentsDefinition(..)- , getOperationName- , getOperationDataType- , lookupDeprecated- , lookupDeprecatedReason- , typeFromScalar- , removeDuplicates- , Position- , GQLErrors- , UnionTag(..)- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- , selectBy- , keyOf- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , Failure(..)- , Result(..)- , LibUpdater- , resolveUpdates- )---compileError :: Text -> GQLErrors-compileError x =- globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;"--operationTypes- :: Schema- -> VariableDefinitions RAW- -> Operation VALID- -> Eventless (Maybe TypeD, [ClientType])-operationTypes lib variables = genOperation- where- genOperation operation@Operation { operationName, operationSelection } = do- datatype <- getOperationDataType operation lib- (queryTypes, enums) <- genRecordType []- (getOperationName operationName)- datatype- operationSelection- inputTypeRequests <- resolveUpdates []- $ map (scanInputTypes lib . typeConName . variableType) (toList variables)- inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)- pure- ( rootArguments (getOperationName operationName <> "Args")- , queryTypes <> inputTypesAndEnums- )- -------------------------------------------------------------------------- buildListedTypes =- fmap concat . traverse (buildInputType lib) . removeDuplicates- -------------------------------------------------------------------------- -- generates argument types for Operation Head- rootArguments :: Text -> Maybe TypeD- rootArguments argsName | null variables = Nothing- | otherwise = Just rootArgumentsType-- where- rootArgumentsType :: TypeD- rootArgumentsType = TypeD- { tName = argsName- , tNamespace = []- , tCons = [ConsD { cName = argsName, cFields = map fieldD (toList variables) }]- , tMeta = Nothing- }- where- fieldD :: Variable RAW -> FieldDefinition- fieldD Variable { variableName, variableType } = FieldDefinition- { fieldName = variableName- , fieldArgs = NoArguments- , fieldType = variableType- , fieldMeta = Nothing- }- ---------------------------------------------------------- -- generates selection Object Types- genRecordType- :: [Name]- -> Name- -> TypeDefinition- -> SelectionSet VALID- -> Eventless ([ClientType], [Name])- genRecordType path tName dataType recordSelSet = do- (con, subTypes, requests) <- genConsD tName dataType recordSelSet- pure- ( ClientType- { clientType = TypeD { tName- , tNamespace = path- , tCons = [con]- , tMeta = Nothing- }- , clientKind = KindObject Nothing- }- : subTypes- , requests- )- where- genConsD- :: Name- -> TypeDefinition- -> SelectionSet VALID- -> Eventless (ConsD, [ClientType], [Text])- genConsD cName datatype selSet = do- (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet)- pure (ConsD { cName, cFields }, concat subTypes, concat requests)- where- genField- :: Selection VALID- -> Eventless (FieldDefinition, [ClientType], [Text])- genField - sel@Selection - { selectionName- , selectionPosition- } =- do- (fieldDataType, fieldType) <- lookupFieldType lib- fieldPath- datatype- selectionPosition- selectionName- (subTypes, requests) <- subTypesBySelection fieldDataType sel- pure- ( FieldDefinition - { fieldName- , fieldType- , fieldArgs = NoArguments- , fieldMeta = Nothing- }- , subTypes- , requests- )- where- fieldPath = path <> [fieldName]- -------------------------------- fieldName = keyOf sel- ------------------------------------------- subTypesBySelection- :: TypeDefinition -> Selection VALID -> Eventless ([ClientType], [Text])- subTypesBySelection dType Selection { selectionContent = SelectionField }- = leafType dType- --withLeaf buildLeaf dType- subTypesBySelection dType Selection { selectionContent = SelectionSet selectionSet }- = genRecordType fieldPath (typeFrom [] dType) dType selectionSet- ---- UNION- subTypesBySelection dType Selection { selectionContent = UnionSelection unionSelections }- = do- (tCons, subTypes, requests) <-- unzip3 <$> traverse getUnionType (toList unionSelections)- pure- ( ClientType- { clientType = TypeD { tNamespace = fieldPath- , tName = typeFrom [] dType- , tCons- , tMeta = Nothing- }- , clientKind = KindUnion- }- : concat subTypes- , concat requests- )- where- getUnionType (UnionTag selectedTyName selectionVariant) = do- conDatatype <- getType lib selectedTyName- genConsD selectedTyName conDatatype selectionVariant--scanInputTypes :: Schema -> Key -> LibUpdater [Key]-scanInputTypes lib name collected | name `elem` collected = pure collected- | otherwise = getType lib name >>= scanInpType- where- scanInpType TypeDefinition { typeContent, typeName } = scanType typeContent- where- scanType (DataInputObject fields) = resolveUpdates- (name : collected) (map toInputTypeD $ toList fields)- where- toInputTypeD :: FieldDefinition -> LibUpdater [Key]- toInputTypeD FieldDefinition { fieldType = TypeRef { typeConName } } =- scanInputTypes lib typeConName- scanType (DataEnum _) = pure (collected <> [typeName])- scanType _ = pure collected--buildInputType :: Schema -> Text -> Eventless [ClientType]-buildInputType lib name = getType lib name >>= generateTypes- where- generateTypes TypeDefinition { typeName, typeContent } = subTypes typeContent- where- subTypes (DataInputObject inputFields) = do- fields <- traverse toFieldD (toList inputFields)- pure- [ ClientType- { clientType = TypeD- { tName = typeName- , tNamespace = []- , tCons = [ ConsD { cName = typeName- , cFields = fields- }- ]- , tMeta = Nothing- }- , clientKind = KindInputObject- }- ]- where- toFieldD :: FieldDefinition -> Eventless FieldDefinition- toFieldD field@FieldDefinition { fieldType } = do- typeConName <- typeFrom [] <$> getType lib (typeConName fieldType)- pure $ field { fieldType = fieldType { typeConName } }- subTypes (DataEnum enumTags) = pure- [ ClientType- { clientType = TypeD { tName = typeName- , tNamespace = []- , tCons = map enumOption enumTags- , tMeta = Nothing- }- , clientKind = KindEnum- }- ]- where- enumOption DataEnumValue { enumName } =- ConsD { cName = enumName, cFields = [] }- subTypes _ = pure []--lookupFieldType- :: Schema- -> [Key]- -> TypeDefinition- -> Position- -> Text- -> Eventless (TypeDefinition, TypeRef)-lookupFieldType lib path TypeDefinition { typeContent = DataObject { objectFields }, typeName } refPosition key- = selectBy selError key objectFields >>= processDeprecation- where- selError = compileError $ "cant find field \"" <> pack (show objectFields) <> "\""- processDeprecation FieldDefinition { fieldType = alias@TypeRef { typeConName }, fieldMeta } = - checkDeprecated >> (trans <$> getType lib typeConName)- where- trans x =- (x, alias { typeConName = typeFrom path x, typeArgs = Nothing })- ------------------------------------------------------------------- checkDeprecated :: Eventless ()- checkDeprecated = case fieldMeta >>= lookupDeprecated of- Just deprecation -> Success { result = (), warnings, events = [] }- where- warnings = deprecatedField typeName- Ref { refName = key, refPosition }- (lookupDeprecatedReason deprecation)- Nothing -> pure ()-lookupFieldType _ _ dt _ _ =- failure (compileError $ "Type should be output Object \"" <> pack (show dt))---leafType :: TypeDefinition -> Eventless ([ClientType], [Text])-leafType TypeDefinition { typeName, typeContent } = fromKind typeContent- where- fromKind :: TypeContent -> Eventless ([ClientType], [Text])- fromKind DataEnum{} = pure ([], [typeName])- fromKind DataScalar{} = pure ([], [])- fromKind _ = failure $ compileError "Invalid schema Expected scalar"--getType :: Schema -> Text -> Eventless TypeDefinition-getType lib typename = selectBy (compileError typename) typename lib --typeFrom :: [Name] -> TypeDefinition -> Name-typeFrom path TypeDefinition { typeName, typeContent } = __typeFrom typeContent- where- __typeFrom DataScalar{} = typeFromScalar typeName- __typeFrom DataObject{} = nameSpaceType path typeName- __typeFrom DataUnion{} = nameSpaceType path typeName- __typeFrom _ = typeName
− src/Data/Morpheus/Execution/Document/Compile.hs
@@ -1,60 +0,0 @@-{-#LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Execution.Document.Compile- ( compileDocument- , gqlDocument- , gqlDocumentNamespace- )-where--import qualified Data.Text as T- ( pack )-import Language.Haskell.TH-import Language.Haskell.TH.Quote------- Morpheus-import Data.Morpheus.Error.Client.Client- ( renderGQLErrors- , gqlWarnings- )-import Data.Morpheus.Execution.Document.Convert- ( toTHDefinitions )-import Data.Morpheus.Execution.Document.Declare- ( declareTypes )-import Data.Morpheus.Parsing.Document.TypeSystem- ( parseSchema )-import Data.Morpheus.Validation.Document.Validation-import Data.Morpheus.Types.Internal.Resolving- ( Result(..) )---gqlDocumentNamespace :: QuasiQuoter-gqlDocumentNamespace = QuasiQuoter { quoteExp = notHandled "Expressions"- , quotePat = notHandled "Patterns"- , quoteType = notHandled "Types"- , quoteDec = compileDocument True- }- where- notHandled things =- error $ things ++ " are not supported by the GraphQL QuasiQuoter"--gqlDocument :: QuasiQuoter-gqlDocument = QuasiQuoter { quoteExp = notHandled "Expressions"- , quotePat = notHandled "Patterns"- , quoteType = notHandled "Types"- , quoteDec = compileDocument False- }- where- notHandled things =- error $ things ++ " are not supported by the GraphQL QuasiQuoter"--compileDocument :: Bool -> String -> Q [Dec]-compileDocument namespace documentTXT =- case- parseSchema (T.pack documentTXT)- >>= validatePartialDocument- of- Failure errors -> fail (renderGQLErrors errors)- Success { result = schema, warnings } ->- gqlWarnings warnings >> toTHDefinitions namespace schema >>= declareTypes namespace
− src/Data/Morpheus/Execution/Document/Convert.hs
@@ -1,182 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}--- {-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Execution.Document.Convert- ( toTHDefinitions- )-where--import Data.Semigroup ( (<>) )-import Data.Text (unpack)-import Language.Haskell.TH ---- MORPHEUS-import Data.Morpheus.Types.Internal.TH (infoTyVars)-import Data.Morpheus.Execution.Internal.Utils- ( capital )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , TypeRef(..)- , DataEnumValue(..)- , ConsD(..)- , GQLTypeD(..)- , TypeD(..)- , Key- , InputFieldsDefinition(..)- , ArgumentsDefinition(..)- , hasArguments- , lookupWith- , toHSFieldDefinition- , hsTypeName- , kindOf- )-import Data.Morpheus.Types.Internal.Operation - (Listable(..))--m_ :: Key-m_ = "m"--getTypeArgs :: Key -> [TypeDefinition] -> Q (Maybe Key)-getTypeArgs "__TypeKind" _ = pure Nothing-getTypeArgs "Boolean" _ = pure Nothing-getTypeArgs "String" _ = pure Nothing-getTypeArgs "Int" _ = pure Nothing-getTypeArgs "Float" _ = pure Nothing-getTypeArgs key lib = case typeContent <$> lookupWith typeName key lib of- Just x -> pure (kindToTyArgs x)- Nothing -> getTyArgs <$> reify (mkName $ unpack key)--getTyArgs :: Info -> Maybe Key-getTyArgs x - | null (infoTyVars x) = Nothing- | otherwise = Just m_ --kindToTyArgs :: TypeContent -> Maybe Key-kindToTyArgs DataObject{} = Just m_-kindToTyArgs DataUnion{} = Just m_-kindToTyArgs _ = Nothing--toTHDefinitions :: Bool -> [TypeDefinition] -> Q [GQLTypeD]-toTHDefinitions namespace lib = traverse renderTHType lib- where- renderTHType :: TypeDefinition -> Q GQLTypeD- renderTHType x = generateType x- where- genArgsTypeName :: Key -> Key- genArgsTypeName fieldName | namespace = hsTypeName (typeName x) <> argTName- | otherwise = argTName- where argTName = capital fieldName <> "Args"- ---------------------------------------------------------------------------------------------- genResField :: FieldDefinition -> Q FieldDefinition- genResField field@FieldDefinition { fieldName, fieldArgs, fieldType = typeRef@TypeRef { typeConName } }- = do - typeArgs <- getTypeArgs typeConName lib - pure $ field - { fieldType = typeRef { typeConName = hsTypeName typeConName, typeArgs }- , fieldArgs = fieldArguments- }- where- fieldArguments- | hasArguments fieldArgs = fieldArgs { argumentsTypename = Just $ genArgsTypeName fieldName }- | otherwise = fieldArgs- --------------------------------------------- generateType :: TypeDefinition -> Q GQLTypeD- generateType typeOriginal@TypeDefinition { typeName, typeContent, typeMeta } = genType- typeContent- where- buildType :: [ConsD] -> TypeD- buildType tCons = TypeD- { tName = hsTypeName typeName- , tMeta = typeMeta- , tNamespace = []- , tCons - }- buildObjectCons :: [FieldDefinition] -> [ConsD]- buildObjectCons cFields = - [ ConsD - { cName = hsTypeName typeName - , cFields- } - ]- typeKindD = kindOf typeOriginal- genType :: TypeContent -> Q GQLTypeD- genType (DataEnum tags) = pure GQLTypeD- { typeD = TypeD { tName = hsTypeName typeName- , tNamespace = []- , tCons = map enumOption tags- , tMeta = typeMeta- }- , typeArgD = []- , ..- }- where- enumOption DataEnumValue { enumName } =- ConsD { cName = hsTypeName enumName, cFields = [] }- genType DataScalar {} = fail "Scalar Types should defined By Native Haskell Types"- genType DataInputUnion {} = fail "Input Unions not Supported"- genType DataInterface {} = fail "interfaces must be eliminated in Validation"- genType (DataInputObject fields) = pure GQLTypeD- { typeD = buildType $ buildObjectCons $ genInputFields fields- , typeArgD = []- , ..- }- genType DataObject {objectFields} = do- typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (toList objectFields)- objCons <- buildObjectCons <$> traverse genResField (toList objectFields)- pure GQLTypeD- { typeD = buildType objCons- , typeArgD- , ..- }- genType (DataUnion members) = - pure GQLTypeD- { typeD = buildType (map unionCon members)- , typeArgD = []- , ..- }- where- unionCon memberName = ConsD- { cName- , cFields = [ FieldDefinition- { fieldName = "un" <> cName- , fieldType = TypeRef { typeConName = utName- , typeArgs = Just m_- , typeWrappers = []- }- , fieldMeta = Nothing- , fieldArgs = NoArguments- }- ]- }- where- cName = hsTypeName typeName <> utName- utName = hsTypeName memberName---genArgumentType :: (Key -> Key) -> FieldDefinition -> Q [TypeD]-genArgumentType _ FieldDefinition { fieldArgs = NoArguments } = pure []-genArgumentType namespaceWith FieldDefinition { fieldName, fieldArgs } = pure- [ TypeD- { tName- , tNamespace = []- , tCons = [ ConsD { cName = hsTypeName tName- , cFields = genArguments fieldArgs- }- ]- , tMeta = Nothing- }- ]- where tName = namespaceWith (hsTypeName fieldName)--genArguments :: ArgumentsDefinition -> [FieldDefinition]-genArguments = genInputFields . InputFieldsDefinition . arguments--genInputFields :: InputFieldsDefinition -> [FieldDefinition]-genInputFields = map toHSFieldDefinition . toList
− src/Data/Morpheus/Execution/Document/Declare.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Execution.Document.Declare- ( declareTypes- )-where--import Data.Semigroup ( (<>) )-import Language.Haskell.TH----- MORPHEUS-import Data.Morpheus.Execution.Document.Decode- ( deriveDecode )-import Data.Morpheus.Execution.Document.Encode- ( deriveEncode )-import Data.Morpheus.Execution.Document.GQLType- ( deriveGQLType )-import Data.Morpheus.Execution.Document.Introspect- ( deriveObjectRep- , instanceIntrospect- )-import Data.Morpheus.Execution.Internal.Declare- ( declareType- , Scope(..)- )-import Data.Morpheus.Types.Internal.AST- ( isInput- , isObject- , GQLTypeD(..)- )--declareTypes :: Bool -> [GQLTypeD] -> Q [Dec]-declareTypes namespace = fmap concat . traverse (declareGQLType namespace)--declareGQLType :: Bool -> GQLTypeD -> Q [Dec]-declareGQLType namespace gqlType@GQLTypeD { typeD, typeKindD, typeArgD, typeOriginal }- = do- mainType <- declareMainType- argTypes <- declareArgTypes- gqlInstances <- deriveGQLInstances- typeClasses <- deriveGQLType gqlType- introspectEnum <- instanceIntrospect typeOriginal- pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum- where- deriveGQLInstances = concat <$> sequence gqlInstances- where- gqlInstances- | isObject typeKindD && isInput typeKindD- = [deriveObjectRep (typeD, Nothing), deriveDecode typeD]- | isObject typeKindD- = [deriveObjectRep (typeD, Just typeKindD), deriveEncode gqlType]- | otherwise- = []- --------------------------------------------------- declareArgTypes = do- introspectArgs <- concat <$> traverse deriveArgsRep typeArgD- decodeArgs <- concat <$> traverse deriveDecode typeArgD- return $ argsTypeDecs <> decodeArgs <> introspectArgs- where- deriveArgsRep args = deriveObjectRep (args, Nothing)- ----------------------------------------------------- argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD- --------------------------------------------------- declareMainType = declareT- where- declareT =- pure [declareType SERVER namespace (Just typeKindD) derivingClasses typeD]- derivingClasses | isInput typeKindD = [''Show]- | otherwise = []
− src/Data/Morpheus/Execution/Document/Decode.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MonoLocalBinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Execution.Document.Decode- ( deriveDecode- )-where--import Data.Text ( Text )-import Language.Haskell.TH------- MORPHEUS-import Data.Morpheus.Execution.Internal.Decode- ( decodeFieldWith- , decodeObjectExpQ- , withObject- )-import Data.Morpheus.Execution.Server.Decode- ( Decode(..)- , DecodeType(..)- )-import Data.Morpheus.Types.Internal.AST- ( TypeD(..)- , ValidValue- )-import Data.Morpheus.Types.Internal.TH- ( instanceHeadT )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )--(.:) :: Decode a => ValidValue -> Text -> Eventless a-value .: selectorName = withObject (decodeFieldWith decode selectorName) value--deriveDecode :: TypeD -> Q [Dec]-deriveDecode TypeD { tName, tCons = [cons] } =- pure <$> instanceD (cxt []) appHead methods- where- appHead = instanceHeadT ''DecodeType tName []- methods = [funD 'decodeType [clause argsE (normalB body) []]]- where- argsE = map (varP . mkName) ["o"]- body = decodeObjectExpQ [|(.:)|] cons-deriveDecode _ = pure []
− src/Data/Morpheus/Execution/Document/Encode.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Execution.Document.Encode- ( deriveEncode- )-where--import Data.Text ( unpack )-import Data.Typeable ( Typeable )-import Language.Haskell.TH-import Data.Semigroup ( (<>) )------- MORPHEUS-import Data.Morpheus.Execution.Server.Encode- ( Encode(..)- , ExploreResolvers(..)- )-import Data.Morpheus.Types.GQLType ( TRUE )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , QUERY- , SUBSCRIPTION- , isSubscription- , ConsD(..)- , GQLTypeD(..)- , TypeD(..)- , Key- )-import Data.Morpheus.Types.Internal.Resolving- ( Resolver- , MapStrategy(..)- , LiftOperation- , Deriving(..)- , ObjectDeriving(..)- )-import Data.Morpheus.Types.Internal.TH- ( applyT- , destructRecord- , instanceHeadMultiT- , typeT- )----m_ :: Key-m_ = "m"--fo_ :: Key-fo_ = "fieldOperationKind"--po_ :: Key-po_ = "parentOparation"--e_ :: Key-e_ = "encodeEvent"--encodeVars :: [Key]-encodeVars = [e_, m_]--encodeVarsT :: [TypeQ]-encodeVarsT = map (varT . mkName . unpack) encodeVars--deriveEncode :: GQLTypeD -> Q [Dec]-deriveEncode GQLTypeD { typeKindD, typeD = TypeD { tName, tCons = [ConsD { cFields }] } }- = pure <$> instanceD (cxt constrains) appHead methods- where- subARgs = conT ''SUBSCRIPTION : encodeVarsT- instanceArgs | isSubscription typeKindD = subARgs- | otherwise = map (varT . mkName . unpack) (po_ : encodeVars)- mainType = applyT (mkName $ unpack tName) [mainTypeArg]- where- mainTypeArg | isSubscription typeKindD = applyT ''Resolver subARgs- | otherwise = typeT ''Resolver (fo_ : encodeVars)- ------------------------------------------------------------------------------------------ typeables- | isSubscription typeKindD- = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]- | otherwise- = [ iLiftOp po_- , iLiftOp fo_- , typeT ''MapStrategy [fo_, po_]- , iTypeable fo_- , iTypeable po_- ]- -------------------------- iLiftOp op = applyT ''LiftOperation [varT $ mkName $ unpack op]- -------------------------- iTypeable name = typeT ''Typeable [name]- -------------------------------------------- -- defines Constraint: (Typeable m, Monad m)- constrains =- typeables- <> [ typeT ''Monad [m_]- , applyT ''Encode (mainType : instanceArgs)- , iTypeable e_- , iTypeable m_- ]- -------------------------------------------------------------------- -- defines: instance <constraint> => ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where- appHead = instanceHeadMultiT ''ExploreResolvers- (conT ''TRUE)- (mainType : instanceArgs)- ------------------------------------------------------------------- -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]- methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]- where- argsE = [varP (mkName "_"), destructRecord tName varNames]- body = appE (varE 'pure) - $ appE - (conE 'DerivingObject ) - $ appE - (appE (conE 'ObjectDeriving)- (stringE (unpack tName))- )- (listE $ map (decodeVar . unpack) varNames)- decodeVar name = [| (name, encode $(varName))|]- where varName = varE $ mkName name- varNames = map fieldName cFields-deriveEncode _ = pure []
− src/Data/Morpheus/Execution/Document/GQLType.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Execution.Document.GQLType- ( deriveGQLType- )-where--import Data.Text ( pack- , unpack- )-import Language.Haskell.TH-import Data.Semigroup ( (<>) )------ MORPHEUS-import Data.Morpheus.Execution.Internal.Declare- ( tyConArgs )-import Data.Morpheus.Kind ( ENUM- , SCALAR- , WRAPPER- , INPUT- , OUTPUT- )-import Data.Morpheus.Types.GQLType ( GQLType(..)- , TRUE- )-import Data.Morpheus.Types.Internal.AST- ( DataTypeKind(..)- , Meta(..)- , isObject- , isSchemaTypeName- , GQLTypeD(..)- , TypeD(..)- , Key- )-import Data.Morpheus.Types.Internal.TH- ( instanceHeadT- , typeT- , typeInstanceDec- , instanceProxyFunD- )-import Data.Typeable ( Typeable )--deriveGQLType :: GQLTypeD -> Q [Dec]-deriveGQLType GQLTypeD { typeD = TypeD { tName, tMeta }, typeKindD } =- pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)- where- functions = map- instanceProxyFunD- [('__typeName, [|toHSTypename tName|]), ('description, descriptionValue)]- where- descriptionValue = case tMeta >>= metaDescription of- Nothing -> [| Nothing |]- Just desc -> [| Just desc |]- --------------------------------- typeArgs = tyConArgs typeKindD- --------------------------------- iHead = instanceHeadT ''GQLType tName typeArgs- headSig = typeT (mkName $ unpack tName) typeArgs- ---------------------------------------------------- constrains = map conTypeable typeArgs- where conTypeable name = typeT ''Typeable [name]- -------------------------------------------------- typeFamilies | isObject typeKindD = [deriveKIND, deriveCUSTOM]- | otherwise = [deriveKIND]- where- deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE- deriveKIND = deriveInstance ''KIND (kindName typeKindD)- -------------------------------------------------------- deriveInstance :: Name -> Name -> Q Dec- deriveInstance insName tyName = do- typeN <- headSig- pure $ typeInstanceDec insName typeN (ConT tyName)--kindName :: DataTypeKind -> Name-kindName KindObject {} = ''OUTPUT-kindName KindScalar = ''SCALAR-kindName KindEnum = ''ENUM-kindName KindUnion = ''OUTPUT-kindName KindInputObject = ''INPUT-kindName KindList = ''WRAPPER-kindName KindNonNull = ''WRAPPER-kindName KindInputUnion = ''INPUT--toHSTypename :: Key -> Key-toHSTypename = pack . hsTypename . unpack- where- hsTypename ('S' : name) | isSchemaTypeName (pack name) = name- hsTypename name = name
− src/Data/Morpheus/Execution/Document/Introspect.hs
@@ -1,95 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Execution.Document.Introspect- ( deriveObjectRep , instanceIntrospect- ) where--import Data.Maybe(maybeToList)-import Data.Proxy (Proxy (..))-import Data.Text (unpack,Text)-import Data.Typeable (Typeable)-import Language.Haskell.TH ---- MORPHEUS-import Data.Morpheus.Execution.Internal.Declare (tyConArgs)-import Data.Morpheus.Execution.Server.Introspect (Introspect (..), introspectObjectFields, IntrospectRep (..),TypeScope(..))-import Data.Morpheus.Types.GQLType (GQLType (__typeName), TRUE)-import Data.Morpheus.Types.Internal.AST ( ConsD (..)- , TypeD (..)- , TypeDefinition(..)- , TypeContent(..)- , ArgumentsDefinition(..)- , FieldDefinition (..)- , insertType- , DataTypeKind(..)- , TypeRef (..)- , unsafeFromFields- , unsafeFromInputFields- )-import Data.Morpheus.Types.Internal.TH (instanceFunD, instanceProxyFunD,instanceHeadT, instanceHeadMultiT, typeT)--instanceIntrospect :: TypeDefinition -> Q [Dec]-instanceIntrospect TypeDefinition { typeName, typeContent = DataEnum enumType , .. } - -- FIXME: dirty fix for introspection- | typeName `elem` ["__DirectiveLocation","__TypeKind"] = pure []- | otherwise = pure <$> instanceD (cxt []) iHead [defineIntrospect]- where- ------------------------------------------------ iHead = instanceHeadT ''Introspect typeName []- defineIntrospect = instanceProxyFunD ('introspect,body)- where- body =[| insertType TypeDefinition { typeContent = DataEnum enumType, .. } |]-instanceIntrospect _ = pure []---- [(FieldDefinition, TypeUpdater)]-deriveObjectRep :: (TypeD, Maybe DataTypeKind) -> Q [Dec]-deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) =- pure <$> instanceD (cxt constrains) iHead methods- where- mainTypeName = typeT (mkName $ unpack tName) typeArgs- typeArgs = concatMap tyConArgs (maybeToList tKind)- constrains = map conTypeable typeArgs- where- conTypeable name = typeT ''Typeable [name]- ------------------------------------------------ iHead = instanceHeadMultiT ''IntrospectRep (conT ''TRUE) [mainTypeName]- methods = [instanceFunD 'introspectRep ["_proxy1", "_proxy2"] body]- where- body - | tKind == Just KindInputObject || null tKind = [| (DataInputObject $ unsafeFromInputFields $(buildFields cFields), concat $(buildTypes cFields))|]- | otherwise = [| (DataObject [] $ unsafeFromFields $(buildFields cFields), concat $(buildTypes cFields))|]-deriveObjectRep _ = pure []- -buildTypes :: [FieldDefinition] -> ExpQ-buildTypes = listE . concatMap introspectField- where- introspectField FieldDefinition {fieldType, fieldArgs } =- [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgs- where- inputTypes ArgumentsDefinition { argumentsTypename = Just argsTypeName }- | argsTypeName /= "()" = [[| snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]]- where- tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}- inputTypes _ = []--conTX :: Text -> Q Type -conTX = conT . mkName . unpack--varTX :: Text -> Q Type -varTX = varT . mkName . unpack--proxyT :: TypeRef -> Q Exp-proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]- where- genSig (Just m) = appT (conTX typeConName) (varTX m)- genSig _ = conTX typeConName--buildFields :: [FieldDefinition] -> ExpQ-buildFields = listE . map buildField- where- buildField f@FieldDefinition {fieldType } = [| f { fieldType = fieldType {typeConName = __typeName $(proxyT fieldType) } } |]
− src/Data/Morpheus/Execution/Internal/Declare.hs
@@ -1,117 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE GADTs #-}--module Data.Morpheus.Execution.Internal.Declare- ( declareType- , isEnum- , tyConArgs- , Scope(..)- )-where--import Data.Maybe ( maybe )-import Data.Semigroup ( (<>) )-import Data.Text ( unpack )-import GHC.Generics ( Generic )-import Language.Haskell.TH---- MORPHEUS-import Data.Morpheus.Execution.Internal.Utils- ( nameSpaceType- , nameSpaceWith- )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , DataTypeKind(..)- , DataTypeKind(..)- , TypeRef(..)- , TypeWrapper(..)- , isOutputObject- , isSubscription- , ConsD(..)- , TypeD(..)- , Key- , isOutputObject- , ArgumentsDefinition(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( UnSubResolver )--type Arrow = (->)---m_ :: Key-m_ = "m"--declareTypeRef :: Bool -> TypeRef -> Type-declareTypeRef isSub TypeRef { typeConName, typeWrappers, typeArgs } = wrappedT- typeWrappers- where- wrappedT :: [TypeWrapper] -> Type- wrappedT (TypeList : xs) = AppT (ConT ''[]) $ wrappedT xs- wrappedT (TypeMaybe : xs) = AppT (ConT ''Maybe) $ wrappedT xs- wrappedT [] = decType typeArgs- ------------------------------------------------------- typeName = ConT (mkName $ unpack typeConName)- --------------------------------------------- decType _ | isSub =- AppT typeName (AppT (ConT ''UnSubResolver) (VarT $ mkName $ unpack m_))- decType (Just par) = AppT typeName (VarT $ mkName $ unpack par)- decType _ = typeName--tyConArgs :: DataTypeKind -> [Key]-tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = [m_]- | otherwise = []--data Scope = CLIENT | SERVER- deriving Eq---- declareType-declareType :: Scope -> Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec-declareType scope namespace kindD derivingList TypeD { tName, tCons, tNamespace } =- DataD [] (genName tName) tVars Nothing cons- $ map derive (''Generic : derivingList)- where- genName = mkName . unpack . nameSpaceType tNamespace- tVars = maybe [] (declareTyVar . tyConArgs) kindD- where declareTyVar = map (PlainTV . mkName . unpack)- defBang = Bang NoSourceUnpackedness NoSourceStrictness- derive className = DerivClause Nothing [ConT className]- cons- | scope == CLIENT && isEnum tCons = map consE tCons- | otherwise = map consR tCons- consE ConsD { cName } = NormalC (genName $ tName <> cName) []- consR ConsD { cName, cFields } = RecC (genName cName)- (map declareField cFields)-- where- declareField FieldDefinition { fieldName, fieldArgs, fieldType } =- (fName, defBang, fiType)- where- fName | namespace = mkName $ unpack (nameSpaceWith tName fieldName)- | otherwise = mkName (unpack fieldName)- fiType = genFieldT fieldArgs- where- monadVar = VarT $ mkName $ unpack m_- ---------------------------- genFieldT ArgumentsDefinition { argumentsTypename = Just argsTypename } = AppT- (AppT arrowType argType)- (AppT monadVar result)- where- argType = ConT $ mkName (unpack argsTypename)- arrowType = ConT ''Arrow- genFieldT _- | (isOutputObject <$> kindD) == Just True = AppT monadVar result- | otherwise = result- ------------------------------------------------- result = declareTypeRef (maybe False isSubscription kindD) fieldType--isEnum :: [ConsD] -> Bool-isEnum = all (null . cFields)
− src/Data/Morpheus/Execution/Internal/Decode.hs
@@ -1,92 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Execution.Internal.Decode- ( withObject- , withMaybe- , withList- , withEnum- , withUnion- , decodeFieldWith- , decodeObjectExpQ- )-where--import Data.Text ( unpack )-import Language.Haskell.TH ( ExpQ- , conE- , mkName- , uInfixE- , varE- )---- MORPHEUS-import Data.Morpheus.Error.Internal ( - internalTypeMismatch- )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , Key- , ConsD(..) - , ValidObject- , Value(..)- , ValidValue- , Message- , ObjectEntry(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless - , Failure(..) - )-import Data.Morpheus.Types.Internal.Operation- ( selectBy- , selectOr- , empty- )--decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ-decodeObjectExpQ fieldDecoder ConsD { cName, cFields } = handleFields cFields- where- consName = conE (mkName $ unpack cName)- ----------------------------------------------------------------------------------- handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames)- where- applyFields [] = fail "No Empty fields"- applyFields [x ] = defField x- applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)- ------------------------------------------------------------------------- defField FieldDefinition { fieldName } = uInfixE (varE (mkName "o"))- fieldDecoder- [|fName|]- where fName = unpack fieldName--withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a-withObject f (Object object) = f object-withObject _ isType = internalTypeMismatch "Object" isType--withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a)-withMaybe _ Null = pure Nothing-withMaybe decode x = Just <$> decode x--withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a]-withList decode (List li) = traverse decode li-withList _ isType = internalTypeMismatch "List" isType--withEnum :: (Key -> Eventless a) -> ValidValue -> Eventless a-withEnum decode (Enum value) = decode value-withEnum _ isType = internalTypeMismatch "Enum" isType--withUnion :: (Key -> ValidObject -> ValidObject -> Eventless a) -> ValidObject -> Eventless a-withUnion decoder unions = do - (enum :: ValidValue) <- entryValue <$> selectBy ("__typename not found on Input Union" :: Message) "__typename" unions- case enum of - (Enum key) -> selectOr notfound onFound key unions- where - notfound = withObject (decoder key unions) (Object empty)- onFound = withObject (decoder key unions) . entryValue- _ -> failure ("__typename must be Enum" :: Message)--decodeFieldWith :: (ValidValue -> Eventless a) -> Key -> ValidObject -> Eventless a-decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue)
− src/Data/Morpheus/Execution/Internal/Utils.hs
@@ -1,37 +0,0 @@-module Data.Morpheus.Execution.Internal.Utils- ( capital- , nonCapital- , nameSpaceWith- , nameSpaceType- )-where--import Data.Char ( toLower- , toUpper- )-import Data.Semigroup ( (<>) )-import Data.Text ( Text- , unpack- , pack- )-import qualified Data.Text as T- ( concat )---nameSpaceType :: [Text] -> Text -> Text-nameSpaceType list name = T.concat $ map capital (list <> [name])--nameSpaceWith :: Text -> Text -> Text-nameSpaceWith nSpace name = nonCapital nSpace <> capital name--nonCapital :: Text -> Text-nonCapital = pack . __nonCapital . unpack- where- __nonCapital [] = []- __nonCapital (x : xs) = toLower x : xs--capital :: Text -> Text-capital = pack . __capital . unpack- where- __capital [] = []- __capital (x : xs) = toUpper x : xs
− src/Data/Morpheus/Execution/Server/Decode.hs
@@ -1,234 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TupleSections #-}--module Data.Morpheus.Execution.Server.Decode- ( decodeArguments- , Decode(..)- , DecodeType(..)- )-where--import Data.Proxy ( Proxy(..) )-import Data.Semigroup ( Semigroup(..) )-import Data.Text ( pack )-import GHC.Generics---- MORPHEUS-import Data.Morpheus.Error.Internal ( internalTypeMismatch- , internalError- )-import Data.Morpheus.Execution.Internal.Decode- ( decodeFieldWith- , withList- , withMaybe- , withObject- , withUnion- )-import Data.Morpheus.Kind ( ENUM- , GQL_KIND- , SCALAR- , OUTPUT- , INPUT- )-import Data.Morpheus.Types.GQLScalar ( GQLScalar(..)- , toScalar- )-import Data.Morpheus.Types.GQLType ( GQLType(KIND, __typeName) )-import Data.Morpheus.Types.Internal.AST- ( Name- , Argument(..)- , ObjectEntry(..)- , ValidObject- , Value(..)- , ValidValue- , Arguments- , VALID- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , Failure(..)- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- )----- GENERIC-decodeArguments :: DecodeType a => Arguments VALID -> Eventless a-decodeArguments = decodeType . Object . fmap toEntry- where - toEntry (Argument name value _) = ObjectEntry name value---- | Decode GraphQL query arguments and input values-class Decode a where- decode :: ValidValue -> Eventless a--instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where- decode = decodeKind (Proxy @(KIND a))--instance Decode a => Decode (Maybe a) where- decode = withMaybe decode--instance Decode a => Decode [a] where- decode = withList decode---- | Decode GraphQL type with Specific Kind-class DecodeKind (kind :: GQL_KIND) a where- decodeKind :: Proxy kind -> ValidValue -> Eventless a---- SCALAR-instance (GQLScalar a) => DecodeKind SCALAR a where- decodeKind _ value = case toScalar value >>= parseValue of- Right scalar -> return scalar- Left errorMessage -> internalTypeMismatch errorMessage value---- ENUM-instance DecodeType a => DecodeKind ENUM a where- decodeKind _ = decodeType---- TODO: remove -instance DecodeType a => DecodeKind OUTPUT a where- decodeKind _ = decodeType---- INPUT_OBJECT and INPUT_UNION-instance DecodeType a => DecodeKind INPUT a where- decodeKind _ = decodeType---class DecodeType a where- decodeType :: ValidValue -> Eventless a--instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a))=> DecodeType a where- decodeType = fmap to . decodeRep . (, Cont D_CONS "")---- data Inpuz =--- InputHuman Human -- direct link: { __typename: Human, Human: {field: ""} }--- | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} }--- | IndexedType Int Text -- { __typename: InputRecord, _0:2 , _1:"" }--- | Zeus -- { __typename: Zeus }--- deriving (Generic, GQLType)--decideUnion- :: ([Name], value -> Eventless (f1 a))- -> ([Name], value -> Eventless (f2 a))- -> Name- -> value- -> Eventless ((:+:) f1 f2 a)-decideUnion (left, f1) (right, f2) name value- | name `elem` left- = L1 <$> f1 value- | name `elem` right- = R1 <$> f2 value- | otherwise- = failure $ "Constructor \"" <> name <> "\" could not find in Union"--data Tag = D_CONS | D_UNION deriving (Eq ,Ord)--data Cont = Cont {- contKind:: Tag,- typeName :: Name-}--data Info = Info {- kind :: Tag,- tagName :: [Name]-}--instance Semigroup Info where- Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2)- Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2)- Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2)------- GENERICS----class DecodeRep f where- tags :: Proxy f -> Name -> Info- decodeRep :: (ValidValue,Cont) -> Eventless (f a)--instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where- tags _ = tags (Proxy @f)- decodeRep (x, y) = M1 <$> decodeRep- (x, y { typeName = pack $ datatypeName (undefined :: (M1 D d f a)) })--getEnumTag :: ValidObject -> Eventless Name-getEnumTag x = case toList x of - [ObjectEntry "enum" (Enum value)] -> pure value- _ -> internalError "bad union enum object"--instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where- tags _ = tags (Proxy @a) <> tags (Proxy @b)- decodeRep = __decode- where-- __decode (Object obj, cont) = withUnion handleUnion obj- where- handleUnion name unions object- | name == typeName cont <> "EnumObject"- = getEnumTag object >>= __decode . (, ctx) . Enum- | [name] == l1- = L1 <$> decodeRep (Object object, ctx)- | [name] == r1- = R1 <$> decodeRep (Object object, ctx)- | otherwise- = decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx)- l1 = tagName l1t- r1 = tagName r1t- l1t = tags (Proxy @a) (typeName cont)- r1t = tags (Proxy @b) (typeName cont)- ctx = cont { contKind = kind (l1t <> r1t) }- __decode (Enum name, cxt) = decideUnion- (tagName $ tags (Proxy @a) (typeName cxt), decodeRep)- (tagName $ tags (Proxy @b) (typeName cxt), decodeRep)- name- (Enum name, cxt)- __decode _ = internalError "lists and scalars are not allowed in Union"--instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where- decodeRep = fmap M1 . decodeFields- tags _ baseName = getTag (refType (Proxy @a))- where- getTag (Just memberRef)- | isUnionRef memberRef = Info { kind = D_UNION, tagName = [memberRef] }- | otherwise = Info { kind = D_CONS, tagName = [consName] }- getTag Nothing = Info { kind = D_CONS, tagName = [consName] }- --------- consName = pack $ conName unsafeType- ----------- isUnionRef x = baseName <> x == consName- --------------------------- unsafeType :: (M1 C c U1 x)- unsafeType = undefined--class DecodeFields f where- refType :: Proxy f -> Maybe Name- decodeFields :: (ValidValue,Cont) -> Eventless (f a)--instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where- refType _ = Nothing- decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql--instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where- refType _ = Just $ __typeName (Proxy @a)- decodeFields (value, Cont { contKind })- | contKind == D_UNION = M1 . K1 <$> decode value- | otherwise = __decode value- where- __decode = fmap (M1 . K1) . decodeRec- fieldName = pack $ selName (undefined :: M1 S s f a)- decodeRec = withObject (decodeFieldWith decode fieldName)--instance DecodeFields U1 where- refType _ = Nothing- decodeFields _ = pure U1
− src/Data/Morpheus/Execution/Server/Encode.hs
@@ -1,311 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE GADTs #-}--module Data.Morpheus.Execution.Server.Encode- ( EncodeCon- , Encode(..)- , ExploreResolvers(..)- , deriveModel- )-where--import Data.Map ( Map )-import qualified Data.Map as M- ( toList )-import Data.Proxy ( Proxy(..) )-import Data.Semigroup ( (<>) )-import Data.Set ( Set )-import qualified Data.Set as S- ( toList )-import Data.Text ( pack )-import GHC.Generics---- MORPHEUS-import Data.Morpheus.Execution.Server.Decode- ( DecodeType- , decodeArguments- )-import Data.Morpheus.Kind ( ENUM- , GQL_KIND- , ResContext(..)- , SCALAR- , OUTPUT- , VContext(..)- )-import Data.Morpheus.Types.Types ( MapKind- , Pair(..)- , mapKindFromList- )-import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) )-import Data.Morpheus.Types.GQLType ( GQLType(..) )-import Data.Morpheus.Types.Internal.AST- ( Name- , OperationType(..)- , QUERY- , SUBSCRIPTION- , MUTATION- , Message- )-import Data.Morpheus.Types.Internal.Operation- (Merge(..))-import Data.Morpheus.Types.Internal.Resolving- ( MapStrategy(..)- , LiftOperation- , Resolver- , toResolver- , Deriving(..)- , FieldRes- , GQLRootResolver(..)- , ResolverModel(..)- , unsafeBind- , failure- , ObjectDeriving(..)- , Eventless- , liftStateless- )--class Encode resolver o e (m :: * -> *) where- encode :: resolver -> Resolver o e m (Deriving o e m)--instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m , LiftOperation o) => Encode a o e m where- encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a)---- MAYBE-instance (Monad m , LiftOperation o,Encode a o e m) => Encode (Maybe a) o e m where- encode = maybe (pure DerivingNull) encode---- LIST []-instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where- encode = fmap DerivingList . traverse encode---- Tuple (a,b)-instance Encode (Pair k v) o e m => Encode (k, v) o e m where- encode (key, value) = encode (Pair key value)---- Set-instance Encode [a] o e m => Encode (Set a) o e m where- encode = encode . S.toList---- Map-instance (Eq k, Monad m,LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where- encode value =- encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m))---- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance - ( DecodeType a- , Generic a- , Monad m- , LiftOperation fo- , Encode b fo e m- , MapStrategy fo o- )- => Encode (a -> Resolver fo e m b) o e m where- encode x - = mapStrategy - $ toResolver decodeArguments x `unsafeBind` encode---- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance - ( Monad m- , LiftOperation o- , Encode b fo e m- , MapStrategy fo o- )- => Encode (Resolver fo e m b) o e m where- encode = mapStrategy . (`unsafeBind` encode)---- ENCODE GQL KIND-class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where- encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m (Deriving o e m)---- SCALAR-instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where- encodeKind = pure . DerivingScalar . serialize . unVContext---- ENUM-instance (Generic a, ExploreResolvers (CUSTOM a) a o e m, Monad m) => EncodeKind ENUM a o e m where- encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value--instance (Monad m,Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where- encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value--convertNode- :: (Monad m, LiftOperation o)- => ResNode o e m- -> Deriving o e m-convertNode ResNode { resDatatypeName, resKind = REP_OBJECT, resFields } =- DerivingObject (ObjectDeriving resDatatypeName $ map toFieldRes resFields)-convertNode ResNode { resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord }- = encodeUnion resFields- where- -- ENUM- encodeUnion [] = DerivingEnum resDatatypeName resTypeName- -- Type References --------------------------------------------------------------- encodeUnion [FieldNode { fieldTypeName, fieldResolver, isFieldObject }]- | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName- = DerivingUnion fieldTypeName fieldResolver- -- Inline Union Types ----------------------------------------------------------------------------- encodeUnion fields - = DerivingUnion- resTypeName- $ pure- $ DerivingObject - $ ObjectDeriving - resTypeName - (map toFieldRes resolvers)- where- resolvers | isResRecord = fields- | otherwise = setFieldNames fields---- Types & Constrains --------------------------------------------------------type GQL_RES a = (Generic a, GQLType a)--type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m)----- GENERICS -------------------------------------------------class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where- exploreResolvers :: Proxy custom -> a -> Eventless (Deriving o e m)--instance (Generic a,Monad m,LiftOperation o,TypeRep (Rep a) o e m ) => ExploreResolvers 'False a o e m where- exploreResolvers _ value = - pure - $ convertNode- $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)------- HELPERS -----------------------------objectResolvers- :: forall a o e m- . ( ExploreResolvers (CUSTOM a) a o e m- , Monad m- , LiftOperation o- )- => a- -> Eventless (Deriving o e m)-objectResolvers value - = exploreResolvers (Proxy @(CUSTOM a)) value - >>= constraintOnject - where- constraintOnject obj@DerivingObject {} - = pure obj- constraintOnject _ - = failure ("resolver must be an object" :: Message)--type Con o e m a - = ExploreResolvers - (CUSTOM - (a (Resolver o e m))- ) - (a (Resolver o e m)) - o - e - m--deriveModel- :: forall e m query mut sub schema. - ( Con QUERY e m query- , Con QUERY e m schema- , Con MUTATION e m mut- , Con SUBSCRIPTION e m sub- , Applicative m- , Monad m- )- => GQLRootResolver m e query mut sub- -> schema (Resolver QUERY e m)- -> ResolverModel e m-deriveModel - GQLRootResolver - { queryResolver- , mutationResolver- , subscriptionResolver - }- schema- = ResolverModel - { query - = do - schema' <- objectResolvers schema- root' <- objectResolvers queryResolver - root' <:> schema'- , mutation = objectResolvers mutationResolver- , subscription = objectResolvers subscriptionResolver- }--toFieldRes :: FieldNode o e m -> FieldRes o e m-toFieldRes FieldNode { fieldSelName, fieldResolver } =- (fieldSelName, fieldResolver)---- NEW AUTOMATIC DERIVATION SYSTEM-data REP_KIND = REP_UNION | REP_OBJECT--data ResNode o e m = ResNode {- resDatatypeName :: Name,- resTypeName :: Name,- resKind :: REP_KIND,- resFields :: [FieldNode o e m],- isResRecord :: Bool- }--data FieldNode o e m = FieldNode {- fieldTypeName :: Name,- fieldSelName :: Name,- fieldResolver :: Resolver o e m (Deriving o e m),- isFieldObject :: Bool- }---- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text }-setFieldNames :: [FieldNode o e m] -> [FieldNode o e m]-setFieldNames = zipWith setFieldName ([0 ..] :: [Int])- where setFieldName i field = field { fieldSelName = "_" <> pack (show i) }--class TypeRep f o e (m :: * -> *) where- typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m--instance (Datatype d,TypeRep f o e m) => TypeRep (M1 D d f) o e m where- typeResolvers context (M1 src) = (typeResolvers context src)- { resDatatypeName = pack $ datatypeName (undefined :: M1 D d f a) }----- UNION OR OBJECT -instance (TypeRep a o e m,TypeRep b o e m) => TypeRep (a :+: b) o e m where- typeResolvers context (L1 x) =- (typeResolvers context x) { resKind = REP_UNION }- typeResolvers context (R1 x) =- (typeResolvers context x) { resKind = REP_UNION }--instance (FieldRep f o e m,Constructor c) => TypeRep (M1 C c f) o e m where- typeResolvers context (M1 src) = ResNode { resDatatypeName = ""- , resTypeName = pack (conName proxy)- , resKind = REP_OBJECT- , resFields = fieldRep context src- , isResRecord = conIsRecord proxy- }- where proxy = undefined :: (M1 C c U1 x)-- --- FIELDS -class FieldRep f o e (m :: * -> *) where- fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m]--instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where- fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b--instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where- fieldRep _ m@(M1 (K1 src)) =- [ FieldNode { fieldSelName = pack (selName m)- , fieldTypeName = __typeName (Proxy @a)- , fieldResolver = encode src- , isFieldObject = isObjectKind (Proxy @a)- }- ]--instance FieldRep U1 o e m where- fieldRep _ _ = []
− src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Execution.Server.Generics.EnumRep- ( EnumRep(..)- )-where--import Data.Proxy ( Proxy(..) )-import Data.Semigroup ( (<>) )-import Data.Text ( Text- , pack- )-import GHC.Generics---- MORPHEUS-import Data.Morpheus.Error.Internal ( internalError )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )--class EnumRep f where- encodeRep :: f a -> Text- decodeEnum :: Text -> Eventless (f a)- enumTags :: Proxy f -> [Text]--instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where- encodeRep (M1 src) = encodeRep src- decodeEnum = fmap M1 . decodeEnum- enumTags _ = enumTags (Proxy @f)--instance (Constructor c) => EnumRep (M1 C c U1) where- encodeRep m@(M1 _) = pack $ conName m- decodeEnum _ = pure $ M1 U1- enumTags _ = [pack $ conName (undefined :: (M1 C c U1 x))]--instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where- encodeRep (L1 x) = encodeRep x- encodeRep (R1 x) = encodeRep x- decodeEnum name- | name `elem` enumTags (Proxy @a) = L1 <$> decodeEnum name- | name `elem` enumTags (Proxy @b) = R1 <$> decodeEnum name- | otherwise = internalError- ("Constructor \"" <> name <> "\" could not find in Union")- enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b)
− src/Data/Morpheus/Execution/Server/Interpreter.hs
@@ -1,64 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE RankNTypes #-}--module Data.Morpheus.Execution.Server.Interpreter- ( Interpreter(..)- )-where----- MORPHEUS-import Data.Morpheus.Types.Internal.Subscription- ( Stream- , Input- , toOutStream- )-import Data.Morpheus.Execution.Server.Resolve- ( RootResCon- , coreResolver- , statelessResolver- )-import Data.Morpheus.Types.Internal.Resolving- ( GQLRootResolver(..)- )-import Data.Morpheus.Types.IO ( GQLRequest- , GQLResponse- , MapAPI(..)- )---- | main query processor and resolver--- possible versions of interpreter------ 1. with effect and state: where 'GQLState' is State Monad of subscriptions------ @--- k :: GQLState -> a -> IO a--- @------ 2. without effect and state: stateless query processor without any effect,--- if you don't need any subscription use this one , is simple and fast------ @--- k :: a -> IO a--- -- or--- k :: GQLRequest -> IO GQLResponse--- @-class Interpreter e m a b where- interpreter ::- Monad m- => (RootResCon m e query mut sub) - => GQLRootResolver m e query mut sub- -> a- -> b--instance Interpreter e m GQLRequest (m GQLResponse) where- interpreter = statelessResolver--instance Interpreter e m (Input api) (Stream api e m) where- interpreter root = toOutStream (coreResolver root)--instance ( MapAPI a ) => - Interpreter e m a (m a) where- interpreter root = mapAPI (interpreter root)
− src/Data/Morpheus/Execution/Server/Introspect.hs
@@ -1,496 +0,0 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Execution.Server.Introspect- ( TypeUpdater- , Introspect(..)- , IntrospectRep(..)- , IntroCon- , updateLib- , buildType- , introspectObjectFields- , TypeScope(..)- )-where--import Data.Map ( Map )-import Data.Proxy ( Proxy(..) )-import Data.Set ( Set )-import Data.Text ( Text- , pack- )-import GHC.Generics-import Data.Semigroup ( (<>) )-import Data.List ( partition )---- MORPHEUS-import Data.Morpheus.Error.Utils ( globalErrorMessage )-import Data.Morpheus.Error.Schema ( nameCollisionError )-import Data.Morpheus.Execution.Server.Generics.EnumRep- ( EnumRep(..) )-import Data.Morpheus.Kind ( Context(..)- , ENUM- , GQL_KIND- , SCALAR- , OUTPUT- , INPUT- )-import Data.Morpheus.Types.Types ( MapKind- , Pair- )-import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) )-import Data.Morpheus.Types.GQLType ( GQLType(..) )-import Data.Morpheus.Types.Internal.Resolving- ( Failure(..)- , resolveUpdates- , Resolver- )-import Data.Morpheus.Types.Internal.AST- ( Name- , ArgumentsDefinition(..)- , Meta(..)- , FieldDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , Key- , createAlias- , defineType- , isTypeDefined- , toListField- , toNullableField- , createEnumValue- , TypeUpdater- , DataFingerprint(..)- , DataUnion- , FieldsDefinition(..)- , InputFieldsDefinition(..)- , TypeRef(..)- , Message- , unsafeFromFields- )-import Data.Morpheus.Types.Internal.Operation- ( Empty(..)- , Singleton(..)- )--type IntroCon a = (GQLType a, IntrospectRep (CUSTOM a) a)----- | Generates internal GraphQL Schema for query validation and introspection rendering-class Introspect a where- isObject :: proxy a -> Bool- default isObject :: GQLType a => proxy a -> Bool- isObject _ = isObjectKind (Proxy @a)- field :: proxy a -> Text -> FieldDefinition- introspect :: proxy a -> TypeUpdater- ------------------------------------------------ default field :: GQLType a =>- proxy a -> Text -> FieldDefinition- field _ = buildField (Proxy @a) NoArguments--instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect a where- introspect _ = introspectKind (Context :: Context (KIND a) a)---- Maybe-instance Introspect a => Introspect (Maybe a) where- isObject _ = False- field _ = toNullableField . field (Proxy @a)- introspect _ = introspect (Proxy @a)---- List-instance Introspect a => Introspect [a] where- isObject _ = False- field _ = toListField . field (Proxy @a)- introspect _ = introspect (Proxy @a)---- Tuple-instance Introspect (Pair k v) => Introspect (k, v) where- isObject _ = True- field _ = field (Proxy @(Pair k v))- introspect _ = introspect (Proxy @(Pair k v))---- Set-instance Introspect [a] => Introspect (Set a) where- isObject _ = False- field _ = field (Proxy @[a])- introspect _ = introspect (Proxy @[a])---- Map-instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where- isObject _ = True- field _ = field (Proxy @(MapKind k v Maybe))- introspect _ = introspect (Proxy @(MapKind k v Maybe))---- Resolver : a -> Resolver b-instance (GQLType b, IntrospectRep 'False a, Introspect b) => Introspect (a -> m b) where- isObject _ = False- field _ name = fieldObj { fieldArgs }- where- fieldObj = field (Proxy @b) name- fieldArgs = ArgumentsDefinition Nothing $ unFieldsDefinition $ fst $ introspectObjectFields- (Proxy :: Proxy 'False)- (__typeName (Proxy @b), OutputType, Proxy @a)- introspect _ typeLib = resolveUpdates typeLib- (introspect (Proxy @b) : inputs)- where- name = "Arguments for " <> __typeName (Proxy @b)- inputs :: [TypeUpdater]- inputs =- snd $ introspectObjectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a)---- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY-instance (GQLType b, Introspect b) => Introspect (Resolver fo e m b) where- isObject _ = False- field _ = field (Proxy @b)- introspect _ = introspect (Proxy @b)----- | Introspect With specific Kind: 'kind': object, scalar, enum ...-class IntrospectKind (kind :: GQL_KIND) a where- introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema---- SCALAR-instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where- introspectKind _ = updateLib scalarType [] (Proxy @a)- where scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a)---- ENUM-instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where- introspectKind _ = updateLib enumType [] (Proxy @a)- where- enumType =- buildType $ DataEnum $ map createEnumValue $ enumTags (Proxy @(Rep a))--instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind INPUT a where- introspectKind _ = derivingData (Proxy @a) InputType--instance (GQL_TYPE a, IntrospectRep (CUSTOM a) a) => IntrospectKind OUTPUT a where- introspectKind _ = derivingData (Proxy @a) OutputType--derivingData- :: forall a- . (GQLType a, IntrospectRep (CUSTOM a) a)- => Proxy a- -> TypeScope- -> TypeUpdater-derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a)- where- (datatypeContent, updates) = introspectRep- (Proxy @(CUSTOM a))- (Proxy @a, scope, baseName, baseFingerprint)- baseName = __typeName (Proxy @a)- baseFingerprint = __typeFingerprint (Proxy @a)--type GQL_TYPE a = (Generic a, GQLType a)--fromInput :: InputFieldsDefinition -> FieldsDefinition-fromInput = FieldsDefinition . unInputFieldsDefinition--toInput :: FieldsDefinition -> InputFieldsDefinition-toInput = InputFieldsDefinition . unFieldsDefinition--introspectObjectFields- :: IntrospectRep custom a- => proxy1 (custom :: Bool)- -> (Name, TypeScope, proxy2 a)- -> (FieldsDefinition, [TypeUpdater])-introspectObjectFields p1 (name, scope, proxy) = withObject- (introspectRep p1 (proxy, scope, "", DataFingerprint "" []))- where- withObject (DataObject {objectFields}, ts) = (objectFields, ts)- withObject (DataInputObject x, ts) = (fromInput x, ts)- withObject _ = (empty, [introspectFailure (name <> " should have only one nonempty constructor")])--introspectFailure :: Message -> TypeUpdater-introspectFailure = const . failure . globalErrorMessage . ("invalid schema: " <>)---- Object Fields-class IntrospectRep (custom :: Bool) a where- introspectRep :: proxy1 custom -> ( proxy2 a,TypeScope,Name,DataFingerprint) -> (TypeContent, [TypeUpdater])--instance (TypeRep (Rep a) , Generic a) => IntrospectRep 'False a where- introspectRep _ (_, scope, name, fing) =- derivingDataContent (Proxy @a) (name, fing) scope--buildField :: GQLType a => Proxy a -> ArgumentsDefinition -> Text -> FieldDefinition-buildField proxy fieldArgs fieldName = FieldDefinition- { fieldType = createAlias $ __typeName proxy- , fieldMeta = Nothing- , ..- }--buildType :: GQLType a => TypeContent -> Proxy a -> TypeDefinition-buildType typeContent proxy = TypeDefinition- { typeName = __typeName proxy- , typeFingerprint = __typeFingerprint proxy- , typeMeta = Just Meta { metaDescription = description proxy- , metaDirectives = []- }- , typeContent- }--updateLib- :: GQLType a- => (Proxy a -> TypeDefinition)- -> [TypeUpdater]- -> Proxy a- -> TypeUpdater-updateLib typeBuilder stack proxy lib =- case isTypeDefined (__typeName proxy) lib of- Nothing -> resolveUpdates- (defineType (typeBuilder proxy) lib)- stack- Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib- -- throw error if 2 different types has same name- Just _ -> failure $ nameCollisionError (__typeName proxy)----- NEW AUTOMATIC DERIVATION SYSTEM--data ConsRep = ConsRep {- consName :: Key,- consIsRecord :: Bool,- consFields :: [FieldRep]-}--data FieldRep = FieldRep {- fieldTypeName :: Name,- fieldData :: FieldDefinition,- fieldTypeUpdater :: TypeUpdater,- fieldIsObject :: Bool-}--data ResRep = ResRep {- enumCons :: [Name],- unionRef :: [Name],- unionRecordRep :: [ConsRep ]-}--isEmpty :: ConsRep -> Bool-isEmpty ConsRep { consFields = [] } = True-isEmpty _ = False--isUnionRef :: Name -> ConsRep -> Bool-isUnionRef baseName ConsRep { consName, consFields = [FieldRep { fieldIsObject = True, fieldTypeName }] }- = consName == baseName <> fieldTypeName-isUnionRef _ _ = False--setFieldNames :: ConsRep -> ConsRep-setFieldNames cons@ConsRep { consFields } = cons- { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields- }- where- setFieldName i fieldR@FieldRep { fieldData = fieldD } = fieldR { fieldData = fieldD { fieldName } }- where fieldName = "_" <> pack (show i)--analyseRep :: Name -> [ConsRep] -> ResRep-analyseRep baseName cons = ResRep- { enumCons = map consName enumRep- , unionRef = map fieldTypeName $ concatMap consFields unionRefRep- , unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep- }- where- (enumRep , left1 ) = partition isEmpty cons- (unionRefRep , left2 ) = partition (isUnionRef baseName) left1- (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2--derivingDataContent- :: forall a- . (Generic a, TypeRep (Rep a))- => Proxy a- -> (Name, DataFingerprint)- -> TypeScope- -> (TypeContent, [TypeUpdater])-derivingDataContent _ (baseName, baseFingerprint) scope =- builder $ typeRep $ Proxy @(Rep a)- where- builder [ConsRep { consFields }] = buildObject scope consFields- builder cons = genericUnion scope cons- where- genericUnion InputType = buildInputUnion (baseName, baseFingerprint)- genericUnion OutputType =- buildUnionType (baseName, baseFingerprint) DataUnion (DataObject [])---buildInputUnion- :: (Name, DataFingerprint) -> [ConsRep ] -> (TypeContent, [TypeUpdater])-buildInputUnion (baseName, baseFingerprint) cons = datatype- (analyseRep baseName cons)- where- datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } =- (DataEnum (map createEnumValue enumCons), types)- datatype ResRep { unionRef, unionRecordRep, enumCons } =- (DataInputUnion typeMembers, types <> unionTypes)- where- typeMembers =- map (, True) (unionRef <> unionMembers) <> map (, False) enumCons- (unionMembers, unionTypes) =- buildUnions (DataInputObject . toInput) baseFingerprint unionRecordRep- types = map fieldTypeUpdater $ concatMap consFields cons--buildUnionType- :: (Name, DataFingerprint)- -> (DataUnion -> TypeContent)- -> (FieldsDefinition -> TypeContent)- -> [ConsRep]- -> (TypeContent, [TypeUpdater])-buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype- (analyseRep baseName cons)- where- datatype ResRep { unionRef = [], unionRecordRep = [], enumCons } =- (DataEnum (map createEnumValue enumCons), types)- datatype ResRep { unionRef, unionRecordRep, enumCons } =- (wrapUnion typeMembers, types <> enumTypes <> unionTypes)- where- typeMembers = unionRef <> enumMembers <> unionMembers- (enumMembers, enumTypes) =- buildUnionEnum wrapObject baseName baseFingerprint enumCons- (unionMembers, unionTypes) =- buildUnions wrapObject baseFingerprint unionRecordRep- types = map fieldTypeUpdater $ concatMap consFields cons---buildObject :: TypeScope -> [FieldRep] -> (TypeContent, [TypeUpdater])-buildObject isOutput consFields = (wrapWith fields, types)- where- (fields, types) = buildDataObject consFields- wrapWith | isOutput == OutputType = DataObject [] - | otherwise = DataInputObject . toInput --buildDataObject :: [FieldRep] -> (FieldsDefinition , [TypeUpdater])-buildDataObject consFields = (fields, types)- where- fields = unsafeFromFields $ map fieldData consFields- types = map fieldTypeUpdater consFields--buildUnions- :: (FieldsDefinition -> TypeContent)- -> DataFingerprint- -> [ConsRep]- -> ([Name], [TypeUpdater])-buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons)- where- buildURecType consRep = pure . defineType- (buildUnionRecord wrapObject baseFingerprint consRep)- members = map consName cons--buildUnionRecord- :: (FieldsDefinition -> TypeContent) -> DataFingerprint -> ConsRep -> TypeDefinition-buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } = TypeDefinition - { typeName = consName- , typeFingerprint- , typeMeta = Nothing- , typeContent = wrapObject $ unsafeFromFields $ map fieldData consFields- }--buildUnionEnum- :: (FieldsDefinition -> TypeContent)- -> Name- -> DataFingerprint- -> [Name]- -> ([Name], [TypeUpdater])-buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates)- where- members | null enums = []- | otherwise = [enumTypeWrapperName]- enumTypeName = baseName <> "Enum"- enumTypeWrapperName = enumTypeName <> "Object"- -------------------------- updates :: [TypeUpdater]- updates- | null enums- = []- | otherwise- = [ buildEnumObject wrapObject- enumTypeWrapperName- baseFingerprint- enumTypeName- , buildEnum enumTypeName baseFingerprint enums- ]--buildEnum :: Name -> DataFingerprint -> [Name] -> TypeUpdater-buildEnum typeName typeFingerprint tags = pure . defineType- TypeDefinition - { typeMeta = Nothing- , typeContent = DataEnum $ map createEnumValue tags- , ..- }--buildEnumObject- :: (FieldsDefinition -> TypeContent)- -> Name- -> DataFingerprint- -> Name- -> TypeUpdater-buildEnumObject wrapObject typeName typeFingerprint enumTypeName =- pure . defineType- TypeDefinition- { typeName- , typeFingerprint- , typeMeta = Nothing- , typeContent = wrapObject $ singleton - FieldDefinition - { fieldName = "enum"- , fieldArgs = NoArguments- , fieldType = createAlias enumTypeName- , fieldMeta = Nothing- }- }--data TypeScope = InputType | OutputType deriving (Show,Eq,Ord)---- GENERIC UNION-class TypeRep f where- typeRep :: Proxy f -> [ConsRep]--instance TypeRep f => TypeRep (M1 D d f) where- typeRep _ = typeRep (Proxy @f)---- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'-instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where- typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b)--instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where- typeRep _ =- [ ConsRep { consName = pack $ conName (undefined :: (M1 C c f a))- , consFields = conRep (Proxy @f)- , consIsRecord = conIsRecord (undefined :: (M1 C c f a))- }- ]--class ConRep f where- conRep :: Proxy f -> [FieldRep]---- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'-instance (ConRep a, ConRep b) => ConRep (a :*: b) where- conRep _ = conRep (Proxy @a) <> conRep (Proxy @b)--instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where- conRep _ =- [ FieldRep { fieldTypeName = typeConName $ fieldType fieldData- , fieldData = fieldData- , fieldTypeUpdater = introspect (Proxy @a)- , fieldIsObject = isObject (Proxy @a)- }- ]- where- name = pack $ selName (undefined :: M1 S s (Rec0 ()) ())- fieldData = field (Proxy @a) name--instance ConRep U1 where- conRep _ = []
− src/Data/Morpheus/Execution/Server/Resolve.hs
@@ -1,188 +0,0 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}---module Data.Morpheus.Execution.Server.Resolve- ( statelessResolver- , RootResCon- , fullSchema- , coreResolver- , EventCon- )-where---import Data.Functor.Identity ( Identity(..) )-import Data.Proxy ( Proxy(..) )---- MORPHEUS-import Data.Morpheus.Execution.Server.Encode- ( EncodeCon- , deriveModel- )-import Data.Morpheus.Execution.Server.Introspect- ( IntroCon- , introspectObjectFields- , TypeScope(..)- )-import Data.Morpheus.Parsing.Request.Parser- ( parseGQL )-import Data.Morpheus.Schema.SchemaAPI ( defaultTypes- , hiddenRootFields- , schemaAPI- )-import Data.Morpheus.Types.GQLType ( GQLType(CUSTOM) )-import Data.Morpheus.Types.Internal.AST- ( Operation(..)- , DataFingerprint(..)- , TypeContent(..)- , Schema(..)- , TypeDefinition(..)- , MUTATION- , QUERY- , SUBSCRIPTION- , initTypeLib- , ValidValue- , Name- , VALIDATION_MODE(..)- , Selection(..)- , SelectionContent(..)- , FieldsDefinition(..)- )-import Data.Morpheus.Types.Internal.Operation- ( Merge(..)- , empty- )-import Data.Morpheus.Types.Internal.Resolving- ( GQLRootResolver(..)- , Resolver- , GQLChannel(..)- , ResponseStream- , Eventless- , cleanEvents- , ResultT(..)- , resolveUpdates- , Context(..)- , runResolverModel- )-import Data.Morpheus.Types.IO ( GQLRequest(..)- , GQLResponse(..)- , renderResponse- )-import Data.Morpheus.Validation.Query.Validation- ( validateRequest )-import Data.Typeable ( Typeable )---type EventCon event- = (Eq (StreamChannel event), Typeable event, GQLChannel event)--type IntrospectConstraint m event query mutation subscription- = ( IntroCon (query (Resolver QUERY event m))- , IntroCon (mutation (Resolver MUTATION event m))- , IntroCon (subscription (Resolver SUBSCRIPTION event m))- )--type RootResCon m event query mutation subscription- = ( EventCon event- , Typeable m- , IntrospectConstraint m event query mutation subscription- , EncodeCon QUERY event m (query (Resolver QUERY event m))- , EncodeCon MUTATION event m (mutation (Resolver MUTATION event m))- , EncodeCon- SUBSCRIPTION- event- m- (subscription (Resolver SUBSCRIPTION event m))- )--statelessResolver- :: (Monad m, RootResCon m event query mut sub)- => GQLRootResolver m event query mut sub- -> GQLRequest- -> m GQLResponse-statelessResolver root req =- renderResponse <$> runResultT (coreResolver root req)--coreResolver- :: forall event m query mut sub- . (Monad m, RootResCon m event query mut sub)- => GQLRootResolver m event query mut sub- -> GQLRequest- -> ResponseStream event m ValidValue-coreResolver root request- = validRequest >>= execOperator- where- validRequest- :: Monad m => ResponseStream event m Context- validRequest = cleanEvents $ ResultT $ pure $ do- schema <- fullSchema $ Identity root- operation <- parseGQL request >>= validateRequest schema FULL_VALIDATION- pure $ Context {- schema- , operation- , currentTypeName = "Root"- , currentSelection = Selection- { selectionName = "Root"- , selectionArguments = empty- , selectionPosition = operationPosition operation- , selectionAlias = Nothing- , selectionContent = SelectionSet (operationSelection operation)- }- }- ----------------------------------------------------------- execOperator ctx@Context {schema } = runResolverModel (deriveModel root (schemaAPI schema)) ctx--fullSchema- :: forall proxy m event query mutation subscription- . (IntrospectConstraint m event query mutation subscription)- => proxy (GQLRootResolver m event query mutation subscription)- -> Eventless Schema-fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema- where- querySchema = do- fs <- hiddenRootFields <:> fields- resolveUpdates (initTypeLib (operatorType fs "Query")) (defaultTypes : types)- where- (fields, types) = introspectObjectFields- (Proxy @(CUSTOM (query (Resolver QUERY event m))))- ("type for query", OutputType, Proxy @(query (Resolver QUERY event m)))- ------------------------------- mutationSchema lib = resolveUpdates- (lib { mutation = maybeOperator fields "Mutation" })- types- where- (fields, types) = introspectObjectFields- (Proxy @(CUSTOM (mutation (Resolver MUTATION event m))))- ( "type for mutation"- , OutputType- , Proxy @(mutation (Resolver MUTATION event m))- )- ------------------------------- subscriptionSchema lib = resolveUpdates- (lib { subscription = maybeOperator fields "Subscription" })- types- where- (fields, types) = introspectObjectFields- (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m))))- ( "type for subscription"- , OutputType- , Proxy @(subscription (Resolver SUBSCRIPTION event m))- )- maybeOperator :: FieldsDefinition -> Name -> Maybe TypeDefinition- maybeOperator (FieldsDefinition x) | null x = const Nothing- maybeOperator fields = Just . operatorType fields- -------------------------------------------------- operatorType :: FieldsDefinition -> Name -> TypeDefinition- operatorType fields typeName = TypeDefinition - { typeContent = DataObject [] fields- , typeName- , typeFingerprint = DataFingerprint typeName []- , typeMeta = Nothing- }
src/Data/Morpheus/Kind.hs view
@@ -1,27 +1,29 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -- | associating types to GraphQL Kinds module Data.Morpheus.Kind- ( SCALAR- , OBJECT- , ENUM- , WRAPPER- , UNION- , INPUT_OBJECT- , GQL_KIND- , Context(..)- , VContext(..)- , ResContext(..)- , OUTPUT- , INPUT+ ( SCALAR,+ OBJECT,+ ENUM,+ WRAPPER,+ UNION,+ INPUT_OBJECT,+ GQL_KIND,+ Context (..),+ VContext (..),+ ResContext (..),+ OUTPUT,+ INPUT,+ INTERFACE, ) where -import Data.Morpheus.Types.Internal.AST- ( OperationType(..) )+import Data.Morpheus.Types.Internal.AST+ ( OperationType (..),+ ) data GQL_KIND = SCALAR@@ -29,15 +31,17 @@ | INPUT | OUTPUT | WRAPPER+ | INTERFACE -data ResContext (kind :: GQL_KIND) (operation:: OperationType) event (m :: * -> * ) value = ResContext+data ResContext (kind :: GQL_KIND) (operation :: OperationType) event (m :: * -> *) value = ResContext --type ObjectConstraint a =+ -- | context , like Proxy with multiple parameters -- * 'kind': object, scalar, enum ... -- * 'a': actual gql type-data Context (kind :: GQL_KIND) a =- Context+data Context (kind :: GQL_KIND) a+ = Context newtype VContext (kind :: GQL_KIND) a = VContext { unVContext :: a@@ -59,13 +63,18 @@ type INPUT = 'INPUT {-# DEPRECATED INPUT_OBJECT "use more generalised kind: INPUT" #-}+ -- | GraphQL input Object type INPUT_OBJECT = 'INPUT {-# DEPRECATED UNION "use: deriving(GQLType), INPORTANT: only types with <type constructor name><constructor name> will sustain their form, other union constructors will be wrapped inside an new object" #-}+ -- | GraphQL Union type UNION = 'OUTPUT {-# DEPRECATED OBJECT "use: deriving(GQLType), will be automatically inferred" #-}+ -- | GraphQL Object type OBJECT = 'OUTPUT++type INTERFACE = 'INTERFACE
− src/Data/Morpheus/Parsing/Document/TypeSystem.hs
@@ -1,205 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parsing.Document.TypeSystem- ( parseSchema- )-where--import Data.Text ( Text )-import Text.Megaparsec ( label- , sepBy1- , (<|>)- , eof- , manyTill- )---- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser- , processParser- )-import Data.Morpheus.Parsing.Internal.Pattern- ( fieldsDefinition- , optionalDirectives- , typDeclaration- , enumValueDefinition- , inputFieldsDefinition- )-import Data.Morpheus.Parsing.Internal.Terms- ( keyword- , operator- , optDescription- , parseName- , pipeLiteral- , sepByAnd- , collection- , spaceAndComments- )-import Data.Morpheus.Types.Internal.AST- ( DataFingerprint(..)- , TypeContent(..)- , TypeDefinition(..)- , Name- , Description- , Meta(..)- , ScalarDefinition(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )---- Scalars : https://graphql.github.io/graphql-spec/June2018/#sec-Scalars------ ScalarTypeDefinition:--- Description(opt) scalar Name Directives(Const)(opt)----scalarTypeDefinition :: Maybe Description -> Parser TypeDefinition-scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do- typeName <- typDeclaration "scalar"- metaDirectives <- optionalDirectives- pure TypeDefinition - { typeName- , typeMeta = Just Meta { metaDescription, metaDirectives }- , typeFingerprint = DataFingerprint typeName []- , typeContent = DataScalar $ ScalarDefinition pure- }---- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects------ ObjectTypeDefinition:--- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)------ ImplementsInterfaces--- implements &(opt) NamedType--- ImplementsInterfaces & NamedType------ FieldsDefinition--- { FieldDefinition(list) }------ FieldDefinition--- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)----objectTypeDefinition :: Maybe Description -> Parser TypeDefinition-objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do- typeName <- typDeclaration "type"- objectImplements <- optionalImplementsInterfaces- metaDirectives <- optionalDirectives- objectFields <- fieldsDefinition- -- build object- pure TypeDefinition- { typeName- , typeMeta = Just Meta { metaDescription, metaDirectives }- , typeFingerprint = DataFingerprint typeName []- , typeContent = DataObject { objectImplements, objectFields }- }--optionalImplementsInterfaces :: Parser [Name]-optionalImplementsInterfaces = implements <|> pure []- where- implements =- label "ImplementsInterfaces" $ keyword "implements" *> sepByAnd parseName---- Interfaces: https://graphql.github.io/graphql-spec/June2018/#sec-Interfaces------ InterfaceTypeDefinition--- Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt)----interfaceTypeDefinition :: Maybe Description -> Parser TypeDefinition-interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do- typeName <- typDeclaration "interface"- metaDirectives <- optionalDirectives- fields <- fieldsDefinition- -- build interface- pure TypeDefinition - { typeName- , typeMeta = Just Meta { metaDescription, metaDirectives }- , typeFingerprint = DataFingerprint typeName []- , typeContent = DataInterface fields- }---- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions------ UnionTypeDefinition:--- Description(opt) union Name Directives(Const)(opt) UnionMemberTypes(opt)------ UnionMemberTypes:--- = |(opt) NamedType--- UnionMemberTypes | NamedType----unionTypeDefinition :: Maybe Description -> Parser TypeDefinition-unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do- typeName <- typDeclaration "union"- metaDirectives <- optionalDirectives- memberTypes <- unionMemberTypes- -- build union- pure TypeDefinition - { typeName- , typeMeta = Just Meta { metaDescription, metaDirectives }- , typeFingerprint = DataFingerprint typeName []- , typeContent = DataUnion memberTypes- }- where unionMemberTypes = operator '=' *> parseName `sepBy1` pipeLiteral---- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums------ EnumTypeDefinition--- Description(opt) enum Name Directives(Const)(opt) EnumValuesDefinition(opt)------ EnumValuesDefinition--- { EnumValueDefinition(list) }------ EnumValueDefinition--- Description(opt) EnumValue Directives(Const)(opt)----enumTypeDefinition :: Maybe Description -> Parser TypeDefinition-enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do- typeName <- typDeclaration "enum"- metaDirectives <- optionalDirectives- enumValuesDefinitions <- collection enumValueDefinition- -- build enum- pure TypeDefinition - { typeName- , typeContent = DataEnum enumValuesDefinitions- , typeFingerprint = DataFingerprint typeName []- , typeMeta = Just Meta { metaDescription, metaDirectives }- }---- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects------ InputObjectTypeDefinition--- Description(opt) input Name Directives(Const)(opt) InputFieldsDefinition(opt)------ InputFieldsDefinition:--- { InputValueDefinition(list) }----inputObjectTypeDefinition :: Maybe Description -> Parser TypeDefinition-inputObjectTypeDefinition metaDescription =- label "InputObjectTypeDefinition" $ do- typeName <- typDeclaration "input"- metaDirectives <- optionalDirectives- fields <- inputFieldsDefinition- -- build input- pure TypeDefinition - { typeName- , typeContent = DataInputObject fields- , typeFingerprint = DataFingerprint typeName []- , typeMeta = Just Meta { metaDescription, metaDirectives }- }--parseDataType :: Parser TypeDefinition-parseDataType = label "TypeDefinition" $ do - description <- optDescription- -- scalar | enum | input | object | union | interface- inputObjectTypeDefinition description- <|> unionTypeDefinition description- <|> enumTypeDefinition description- <|> scalarTypeDefinition description- <|> objectTypeDefinition description- <|> interfaceTypeDefinition description--parseSchema :: Text -> Eventless [TypeDefinition]-parseSchema = processParser request- where- request = label "DocumentTypes" $ do- spaceAndComments- manyTill parseDataType eof
− src/Data/Morpheus/Parsing/Internal/Arguments.hs
@@ -1,62 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Parsing.Internal.Arguments- ( maybeArguments, - parseArgumentsOpt- )-where--import Text.Megaparsec ( label)---- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser- , getLocation- )-import Data.Morpheus.Parsing.Internal.Terms- ( parseAssignment- , uniqTupleOpt- , token- )-import Data.Morpheus.Parsing.Internal.Value- ( parseRawValue - , parseValue- )-import Data.Morpheus.Types.Internal.AST- ( Argument(..)- , Arguments- , RAW- , VALID- )----- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments------ Arguments[Const]--- ( Argument[Const](list) )------ Argument[Const]--- Name : Value[Const]-valueArgument :: Parser (Argument RAW)-valueArgument = - label "Argument" $ do- argumentPosition <- getLocation- (argumentName, argumentValue )<- parseAssignment token parseRawValue- pure $ Argument { argumentName, argumentValue, argumentPosition }--parseArgument :: Parser (Argument VALID)-parseArgument = - label "Argument" $ do- argumentPosition <- getLocation- (argumentName, argumentValue )<- parseAssignment token parseValue- pure $ Argument { argumentName, argumentValue, argumentPosition }--parseArgumentsOpt :: Parser (Arguments VALID)-parseArgumentsOpt = - label "Arguments" - $ uniqTupleOpt parseArgument--maybeArguments :: Parser (Arguments RAW)-maybeArguments = - label "Arguments" - $ uniqTupleOpt valueArgument
− src/Data/Morpheus/Parsing/Internal/Internal.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Parsing.Internal.Internal- ( Parser- , Position- , getLocation- , processParser- )-where--import qualified Data.List.NonEmpty as NonEmpty-import Data.Morpheus.Types.Internal.AST- ( Position(..)- , GQLError(..)- , GQLErrors- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , failure- , Result(..)- )-import Data.Text ( Text- , pack- )-import Text.Megaparsec ( ParseError- , ParseErrorBundle- ( ParseErrorBundle- )- , ParsecT- , SourcePos- , attachSourcePos- , bundleErrors- , bundlePosState- , errorOffset- , getSourcePos- , parseErrorPretty- , runParserT- , SourcePos(..)- , unPos- )-import Data.Void (Void)--getLocation :: Parser Position-getLocation = fmap toLocation getSourcePos--toLocation :: SourcePos -> Position-toLocation SourcePos { sourceLine, sourceColumn } =- Position { line = unPos sourceLine, column = unPos sourceColumn }--type MyError = Void-type Parser = ParsecT MyError Text Eventless-type ErrorBundle = ParseErrorBundle Text MyError--processParser :: Parser a -> Text -> Eventless a-processParser parser txt = case runParserT parser [] txt of- Success { result } -> case result of- Right root -> pure root- Left parseError -> failure (processErrorBundle parseError) - Failure { errors } -> failure errors--processErrorBundle :: ErrorBundle -> GQLErrors-processErrorBundle = map parseErrorToGQLError . bundleToErrors- where- parseErrorToGQLError :: (ParseError Text MyError, SourcePos) -> GQLError- parseErrorToGQLError (err, position) = GQLError- { message = pack (parseErrorPretty err)- , locations = [toLocation position]- }- bundleToErrors- :: ErrorBundle -> [(ParseError Text MyError, SourcePos)]- bundleToErrors ParseErrorBundle { bundleErrors, bundlePosState } =- NonEmpty.toList $ fst $ attachSourcePos errorOffset- bundleErrors- bundlePosState
− src/Data/Morpheus/Parsing/Internal/Pattern.hs
@@ -1,152 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Parsing.Internal.Pattern- ( inputValueDefinition- , fieldsDefinition- , typDeclaration- , optionalDirectives- , enumValueDefinition- , inputFieldsDefinition- )-where--import Text.Megaparsec ( label- , many- , (<|>)- )---- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser )-import Data.Morpheus.Parsing.Internal.Terms- ( keyword- , litAssignment- , operator- , optDescription- , parseName- , parseType- , setOf- , uniqTuple- )-import Data.Morpheus.Parsing.Internal.Arguments- ( parseArgumentsOpt )-import Data.Morpheus.Parsing.Internal.Value- ( parseDefaultValue )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , Directive(..)- , Meta(..)- , DataEnumValue(..)- , Name- , ArgumentsDefinition(..)- , FieldsDefinition(..)- , InputFieldsDefinition(..)- )---- EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition------ EnumValueDefinition--- Description(opt) EnumValue Directives(Const)(opt)----enumValueDefinition :: Parser DataEnumValue-enumValueDefinition = label "EnumValueDefinition" $ do- metaDescription <- optDescription- enumName <- parseName- metaDirectives <- optionalDirectives- return $ DataEnumValue- { enumName- , enumMeta = Just Meta { metaDescription, metaDirectives }- }---- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition------ InputValueDefinition--- Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt)----inputValueDefinition :: Parser FieldDefinition-inputValueDefinition = label "InputValueDefinition" $ do- metaDescription <- optDescription- fieldName <- parseName- litAssignment -- ':'- fieldType <- parseType- _ <- parseDefaultValue- metaDirectives <- optionalDirectives- pure FieldDefinition - { fieldArgs = NoArguments- , fieldName- , fieldType- , fieldMeta = Just Meta { metaDescription, metaDirectives }- }---- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments------ ArgumentsDefinition:--- ( InputValueDefinition(list) )----argumentsDefinition :: Parser ArgumentsDefinition-argumentsDefinition = label "ArgumentsDefinition" - $ uniqTuple inputValueDefinition- <|> pure NoArguments---- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition------ FieldsDefinition :--- { FieldDefinition(list) }----fieldsDefinition :: Parser FieldsDefinition-fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition---- FieldDefinition--- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)----fieldDefinition :: Parser FieldDefinition-fieldDefinition = label "FieldDefinition" $ do- metaDescription <- optDescription- fieldName <- parseName- fieldArgs <- argumentsDefinition- litAssignment -- ':'- fieldType <- parseType- metaDirectives <- optionalDirectives- pure FieldDefinition - { fieldName- , fieldArgs- , fieldType- , fieldMeta = Just Meta { metaDescription, metaDirectives }- }- --- InputFieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives--- InputFieldsDefinition:--- { InputValueDefinition(list) }----inputFieldsDefinition :: Parser InputFieldsDefinition-inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition---- Directives : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Directives------ example: @directive ( arg1: "value" , .... )------ Directives[Const]--- Directive[Const](list)----optionalDirectives :: Parser [Directive]-optionalDirectives = label "Directives" $ many directive---- Directive[Const]------ @ Name Arguments[Const](opt)-directive :: Parser Directive-directive = label "Directive" $ do- operator '@'- directiveName <- parseName- directiveArgs <- parseArgumentsOpt- pure Directive { directiveName, directiveArgs }---- typDeclaration : Not in spec ,start part of type definitions------ typDeclaration--- Description(opt) scalar Name----typDeclaration :: Name -> Parser Name-typDeclaration kind = do- keyword kind- parseName
− src/Data/Morpheus/Parsing/Internal/Terms.hs
@@ -1,282 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TupleSections #-}--module Data.Morpheus.Parsing.Internal.Terms- ( token- , qualifier- , variable- , spaceAndComments- , spaceAndComments1- , pipeLiteral- -------------- , collection- , setOf- , uniqTuple- , uniqTupleOpt- , parseTypeCondition- , spreadLiteral- , parseNonNull- , parseAssignment- , parseWrappedType- , litEquals- , litAssignment- , parseTuple- , parseAlias- , sepByAnd- , parseName- , parseType- , keyword- , operator- , optDescription- , optionalList- , parseNegativeSign- )-where--import Control.Monad ((>=>))-import Data.Functor ( ($>) )-import Data.Text ( Text- , pack- , strip- )-import Text.Megaparsec ( between- , label- , try- , many- , manyTill- , optional- , sepBy- , sepEndBy- , skipMany- , skipManyTill- , try- , (<?>)- , (<|>)- )-import Text.Megaparsec.Char ( char- , digitChar- , letterChar- , newline- , printChar- , space- , space1- , string- )---- MORPHEUS-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- , KeyOf- )-import Data.Morpheus.Parsing.Internal.Internal- ( Parser- , Position- , getLocation- )-import Data.Morpheus.Types.Internal.AST- ( DataTypeWrapper(..)- , Key- , Description- , Name- , toHSWrappers- , convertToHaskellName- , Ref(..)- , TypeRef(..)- )----- Name : https://graphql.github.io/graphql-spec/June2018/#sec-Names------ Name :: /[_A-Za-z][_0-9A-Za-z]*/-----parseNegativeSign :: Parser Bool-parseNegativeSign = (char '-' $> True <* spaceAndComments) <|> pure False--parseName :: Parser Name-parseName = token--keyword :: Key -> Parser ()-keyword word = string word *> space1 *> spaceAndComments--operator :: Char -> Parser ()-operator x = char x *> spaceAndComments---- LITERALS-braces :: Parser [a] -> Parser [a]-braces =- between - (char '{' *> spaceAndComments) - (char '}' *> spaceAndComments)--pipeLiteral :: Parser ()-pipeLiteral = char '|' *> spaceAndComments--litEquals :: Parser ()-litEquals = char '=' *> spaceAndComments--litAssignment :: Parser ()-litAssignment = char ':' *> spaceAndComments---- PRIMITIVE--------------------------------------token :: Parser Text-token = label "token" $ do- firstChar <- letterChar <|> char '_'- restToken <- many $ letterChar <|> char '_' <|> digitChar- spaceAndComments- return $ convertToHaskellName $ pack $ firstChar : restToken--qualifier :: Parser (Text, Position)-qualifier = label "qualifier" $ do- position <- getLocation- value <- token- return (value, position)----- Variable : https://graphql.github.io/graphql-spec/June2018/#Variable------ Variable : $Name----variable :: Parser Ref-variable = label "variable" $ do- refPosition <- getLocation- _ <- char '$'- refName <- token- spaceAndComments- pure $ Ref { refName, refPosition }--spaceAndComments1 :: Parser ()-spaceAndComments1 = space1 *> spaceAndComments---- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description------ Description:--- StringValue--- TODO: should support """ and "----optDescription :: Parser (Maybe Description)-optDescription = optional parseDescription--parseDescription :: Parser Text-parseDescription =- strip . pack <$> (blockDescription <|> singleLine) <* spaceAndComments- where- blockDescription =- blockQuotes- *> manyTill (printChar <|> newline) blockQuotes- <* spaceAndComments- where blockQuotes = string "\"\"\""- ----------------------------- singleLine =- stringQuote *> manyTill printChar stringQuote <* spaceAndComments- where stringQuote = char '"'---- Ignored Tokens : https://graphql.github.io/graphql-spec/June2018/#sec-Source-Text.Ignored-Tokens--- Ignored:--- UnicodeBOM--- WhiteSpace--- LineTerminator--- Comment--- Comma--- TODO: implement as in specification-spaceAndComments :: Parser ()-spaceAndComments = ignoredTokens--ignoredTokens :: Parser ()-ignoredTokens =- label "IgnoredTokens" $ space *> skipMany inlineComment *> space- where inlineComment = char '#' *> skipManyTill printChar newline *> space- ---------------------------------------------------------------------------- COMPLEX-sepByAnd :: Parser a -> Parser [a]-sepByAnd entry = entry `sepBy` (char '&' *> spaceAndComments)--------------------------------collection :: Parser a -> Parser [a]-collection entry = braces (entry `sepEndBy` many (char ',' *> spaceAndComments))--setOf :: (Listable c a , KeyOf a) => Parser a -> Parser c-setOf = collection >=> fromList--parseNonNull :: Parser [DataTypeWrapper]-parseNonNull = do- wrapper <- (char '!' $> [NonNullType]) <|> pure []- spaceAndComments- return wrapper--optionalList :: Parser [a] -> Parser [a] -optionalList x = x <|> pure []--parseTuple :: Parser a -> Parser [a]-parseTuple parser = label "Tuple" $ between- (char '(' *> spaceAndComments)- (char ')' *> spaceAndComments)- (parser `sepBy` (many (char ',') *> spaceAndComments) <?> "empty Tuple value!"- )--uniqTuple :: (Listable c a , KeyOf a) => Parser a -> Parser c-uniqTuple = parseTuple >=> fromList--uniqTupleOpt :: (Listable c a , KeyOf a) => Parser a -> Parser c-uniqTupleOpt = optionalList . parseTuple >=> fromList--parseAssignment :: (Show a, Show b) => Parser a -> Parser b -> Parser (a, b)-parseAssignment nameParser valueParser = label "assignment" $ do- name' <- nameParser- litAssignment- value' <- valueParser- pure (name', value')---- Type Conditions: https://graphql.github.io/graphql-spec/June2018/#sec-Type-Conditions------ TypeCondition:--- on NamedType----parseTypeCondition :: Parser Text-parseTypeCondition = do- _ <- string "on"- space1- token--spreadLiteral :: Parser Position-spreadLiteral = do- index <- getLocation- _ <- string "..."- space- return index--parseWrappedType :: Parser ([DataTypeWrapper], Text)-parseWrappedType = (unwrapped <|> wrapped) <* spaceAndComments- where- unwrapped :: Parser ([DataTypeWrapper], Text)- unwrapped = ([], ) <$> token <* spaceAndComments- ----------------------------------------------- wrapped :: Parser ([DataTypeWrapper], Text)- wrapped = between- (char '[' *> spaceAndComments)- (char ']' *> spaceAndComments)- (do- (wrappers, name) <- unwrapped <|> wrapped- nonNull' <- parseNonNull- return ((ListType : nonNull') ++ wrappers, name)- )---- Field Alias : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Alias--- Alias--- Name:-parseAlias :: Parser (Maybe Key)-parseAlias = try (optional alias) <|> pure Nothing- where alias = label "alias" $ token <* char ':' <* spaceAndComments---parseType :: Parser TypeRef-parseType = do- (wrappers, typeConName) <- parseWrappedType- nonNull <- parseNonNull- pure TypeRef { typeConName- , typeArgs = Nothing- , typeWrappers = toHSWrappers $ nonNull ++ wrappers- }
− src/Data/Morpheus/Parsing/Internal/Value.hs
@@ -1,132 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Parsing.Internal.Value- ( parseValue- , enumValue- , parseDefaultValue- , parseRawValue- )-where--import Data.Functor ( ($>) )-import Data.Text ( pack )-import Text.Megaparsec ( anySingleBut- , between- , choice- , label- , many- , optional- , sepBy- , (<|>)- )-import Text.Megaparsec.Char ( char- , string- )-import Text.Megaparsec.Char.Lexer ( scientific )------- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser )-import Data.Morpheus.Parsing.Internal.Terms- ( litEquals- , parseAssignment- , spaceAndComments- , token- , parseNegativeSign- , variable- , setOf- )-import Data.Morpheus.Types.Internal.AST- ( ScalarValue(..)- , Value(..)- , RawValue- , ValidValue- , decodeScientific- , Value(..)- , ResolvedValue- , OrderedMap- , ObjectEntry(..)- )--valueNull :: Parser (Value a)-valueNull = string "null" $> Null--booleanValue :: Parser (Value a)-booleanValue = boolTrue <|> boolFalse- where- boolTrue = string "true" $> Scalar (Boolean True)- boolFalse = string "false" $> Scalar (Boolean False)--valueNumber :: Parser (Value a)-valueNumber = do- isNegative <- parseNegativeSign- Scalar . decodeScientific . signedNumber isNegative <$> scientific- where- signedNumber isNegative number | isNegative = -number- | otherwise = number--enumValue :: Parser (Value a)-enumValue = do- enum <- Enum <$> token- spaceAndComments- return enum--escaped :: Parser Char-escaped = label "escaped" $ do- x <- anySingleBut '\"'- if x == '\\' then choice (zipWith escapeChar codes replacements) else pure x- where- replacements = ['\b', '\n', '\f', '\r', '\t', '\\', '\"', '/']- codes = ['b', 'n', 'f', 'r', 't', '\\', '\"', '/']- escapeChar code replacement = char code >> return replacement--stringValue :: Parser (Value a)-stringValue = label "stringValue" $ Scalar . String . pack <$> between- (char '"')- (char '"')- (many escaped)--listValue :: Parser a -> Parser [a]-listValue parser = label "ListValue" $ between- (char '[' *> spaceAndComments)- (char ']' *> spaceAndComments)- (parser `sepBy` (many (char ',') *> spaceAndComments))--objectEntry :: Parser (Value a) -> Parser (ObjectEntry a)-objectEntry parser = label "ObjectEntry" $ do - (entryName,entryValue) <- parseAssignment token parser- pure ObjectEntry { entryName, entryValue }--objectValue :: Parser (Value a) -> Parser (OrderedMap (ObjectEntry a))-objectValue = label "ObjectValue" . setOf . objectEntry--structValue :: Parser (Value a) -> Parser (Value a)-structValue parser =- label "Value"- $ ( parsePrimitives- <|> (Object <$> objectValue parser)- <|> (List <$> listValue parser)- )- <* spaceAndComments--parsePrimitives :: Parser (Value a)-parsePrimitives =- valueNull <|> booleanValue <|> valueNumber <|> enumValue <|> stringValue--parseDefaultValue :: Parser (Maybe ResolvedValue)-parseDefaultValue = optional $ do- litEquals- parseV- where- parseV :: Parser ResolvedValue- parseV = structValue parseV---parseValue :: Parser ValidValue-parseValue = structValue parseValue--parseRawValue :: Parser RawValue-parseRawValue = (VariableValue <$> variable) <|> structValue parseRawValue
− src/Data/Morpheus/Parsing/JSONSchema/Parse.hs
@@ -1,110 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Parsing.JSONSchema.Parse- ( decodeIntrospection- )-where--import Data.Aeson-import Data.ByteString.Lazy ( ByteString )-import Data.Morpheus.Error.Internal ( internalError )-import Data.Morpheus.Parsing.JSONSchema.Types- ( EnumValue(..)- , Field(..)- , InputValue(..)- , Introspection(..)- , Schema(..)- , Type(..)- )-import Data.Morpheus.Schema.TypeKind ( TypeKind(..) )-import qualified Data.Morpheus.Types.Internal.AST as AST- ( Schema)-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition- , TypeDefinition(..)- , TypeContent(..)- , DataTypeWrapper(..)- , TypeWrapper- , createArgument- , createDataTypeLib- , createEnumType- , createField- , createScalarType- , createType- , createUnionType- , toHSWrappers- , ArgumentsDefinition(..)- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..))-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )-import Data.Morpheus.Types.IO ( JSONResponse(..) )-import Data.Semigroup ( (<>) )-import Data.Text ( Text- , pack- )--decodeIntrospection :: ByteString -> Eventless AST.Schema-decodeIntrospection jsonDoc = case jsonSchema of- Left errors -> internalError $ pack errors- Right JSONResponse { responseData = Just Introspection { __schema = Schema { types } } }- -> traverse parse types >>= createDataTypeLib . concat- Right res -> internalError (pack $ show res)- where- jsonSchema :: Either String (JSONResponse Introspection)- jsonSchema = eitherDecode jsonDoc--class ParseJSONSchema a b where- parse :: a -> Eventless b--instance ParseJSONSchema Type [TypeDefinition] where- parse Type { name = Just typeName, kind = SCALAR } =- pure [createScalarType typeName]- parse Type { name = Just typeName, kind = ENUM, enumValues = Just enums } =- pure [createEnumType typeName (map enumName enums)]- parse Type { name = Just typeName, kind = UNION, possibleTypes = Just unions }- = case traverse name unions of- Nothing -> internalError "ERROR: GQL ERROR"- Just uni -> pure [createUnionType typeName uni]- parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields }- = do- (fields :: [FieldDefinition]) <- traverse parse iFields- fs <- fromList fields- pure [createType typeName $ DataInputObject fs]- parse Type { name = Just typeName, kind = OBJECT, fields = Just oFields } =- do- (fields :: [FieldDefinition]) <- traverse parse oFields- fs <- fromList fields- pure [createType typeName $ DataObject [] fs] - parse _ = pure []--instance ParseJSONSchema Field FieldDefinition where- parse Field { fieldName, fieldArgs, fieldType } = do- fType <- fieldTypeFromJSON fieldType- args <- traverse genArg fieldArgs >>= fromList - pure $ createField (ArgumentsDefinition Nothing args) fieldName fType- where- genArg InputValue { inputName = argName, inputType = argType } =- createArgument argName <$> fieldTypeFromJSON argType--instance ParseJSONSchema InputValue FieldDefinition where- parse InputValue { inputName, inputType } = createField NoArguments inputName <$> fieldTypeFromJSON inputType--fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], Text)-fieldTypeFromJSON = fmap toHs . fieldTypeRec []- where- toHs (w, t) = (toHSWrappers w, t)- fieldTypeRec- :: [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], Text)- fieldTypeRec acc Type { kind = LIST, ofType = Just ofType } =- fieldTypeRec (ListType : acc) ofType- fieldTypeRec acc Type { kind = NON_NULL, ofType = Just ofType } =- fieldTypeRec (NonNullType : acc) ofType- fieldTypeRec acc Type { name = Just name } = pure (acc, name)- fieldTypeRec _ x = internalError $ "Unsuported Field" <> pack (show x)
− src/Data/Morpheus/Parsing/JSONSchema/Types.hs
@@ -1,77 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Parsing.JSONSchema.Types- ( Introspection(..)- , Schema(..)- , Type(..)- , Field(..)- , InputValue(..)- , EnumValue(..)- ) where--import Data.Aeson-import Data.Text (Text)-import GHC.Generics (Generic)------- MORPHEUS-import Data.Morpheus.Schema.TypeKind (TypeKind)---- TYPES FOR DECODING JSON INTROSPECTION----newtype Introspection = Introspection- { __schema :: Schema- } deriving (Generic, Show, FromJSON)--newtype Schema = Schema- { types :: [Type]- } deriving (Generic, Show, FromJSON)---- TYPE-data Type = Type- { kind :: TypeKind- , name :: Maybe Text- , fields :: Maybe [Field]- , interfaces :: Maybe [Type]- , possibleTypes :: Maybe [Type]- , enumValues :: Maybe [EnumValue]- , inputFields :: Maybe [InputValue]- , ofType :: Maybe Type- } deriving (Generic, Show, FromJSON)---- FIELD-data Field = Field- { fieldName :: Text- , fieldArgs :: [InputValue]- , fieldType :: Type- } deriving (Show, Generic)--instance FromJSON Field where- parseJSON = withObject "Field" objectParser- where- objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type"---- INPUT-data InputValue = InputValue- { inputName :: Text- , inputType :: Type- } deriving (Show, Generic)--instance FromJSON InputValue where- parseJSON = withObject "InputValue" objectParser- where- objectParser o = InputValue <$> o .: "name" <*> o .: "type"---- ENUM-newtype EnumValue = EnumValue- { enumName :: Text- } deriving (Generic, Show)--instance FromJSON EnumValue where- parseJSON = withObject "EnumValue" objectParser- where- objectParser o = EnumValue <$> o .: "name"
− src/Data/Morpheus/Parsing/Request/Operation.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Parsing.Request.Operation- ( parseOperation- )-where--import Data.Functor ( ($>) )-import Text.Megaparsec ( label- , optional- , (<?>)- , (<|>)- )-import Text.Megaparsec.Char ( string )------- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser- , getLocation- )-import Data.Morpheus.Parsing.Internal.Pattern- ( optionalDirectives )-import Data.Morpheus.Parsing.Internal.Terms- ( operator- , uniqTupleOpt- , parseName- , parseType- , spaceAndComments1- , variable- )-import Data.Morpheus.Parsing.Internal.Value- ( parseDefaultValue )-import Data.Morpheus.Parsing.Request.Selection- ( parseSelectionSet )-import Data.Morpheus.Types.Internal.Operation - (empty)-import Data.Morpheus.Types.Internal.AST- ( Operation(..)- , Variable(..)- , OperationType(..)- , Ref(..)- , VariableContent(..)- , RAW- )----- Variables : https://graphql.github.io/graphql-spec/June2018/#VariableDefinition------ VariableDefinition--- Variable : Type DefaultValue(opt)----variableDefinition :: Parser (Variable RAW)-variableDefinition = label "VariableDefinition" $ do- (Ref variableName variablePosition) <- variable- operator ':'- variableType <- parseType- variableValue <- DefaultValue <$> parseDefaultValue- pure Variable{..}---- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations------ OperationDefinition--- OperationType Name(opt) VariableDefinitions(opt) Directives(opt) SelectionSet------ OperationType: one of--- query, mutation, subscription-parseOperationDefinition :: Parser (Operation RAW)-parseOperationDefinition = label "OperationDefinition" $ do- operationPosition <- getLocation- operationType <- parseOperationType- operationName <- optional parseName- operationArguments <- uniqTupleOpt variableDefinition- -- TODO: handle directives- _directives <- optionalDirectives- operationSelection <- parseSelectionSet- pure Operation {..}--parseOperationType :: Parser OperationType-parseOperationType = label "OperationType" $ do- kind <-- (string "query" $> Query)- <|> (string "mutation" $> Mutation)- <|> (string "subscription" $> Subscription)- spaceAndComments1- return kind--parseAnonymousQuery :: Parser (Operation RAW)-parseAnonymousQuery = label "AnonymousQuery" $ do- operationPosition <- getLocation- operationSelection <- parseSelectionSet- pure- (Operation { operationName = Nothing- , operationType = Query- , operationArguments = empty- , ..- }- )- <?> "can't parse AnonymousQuery"--parseOperation :: Parser (Operation RAW)-parseOperation = parseAnonymousQuery <|> parseOperationDefinition
− src/Data/Morpheus/Parsing/Request/Parser.hs
@@ -1,56 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parsing.Request.Parser- ( parseGQL- , processParser- )-where--import qualified Data.Aeson as Aeson- ( Value(..) )-import Data.HashMap.Lazy ( toList )-import Data.Text ( Text )-import Text.Megaparsec ( eof- , label- , manyTill- )------- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser- , processParser- )-import Data.Morpheus.Parsing.Internal.Terms- ( spaceAndComments )-import Data.Morpheus.Parsing.Request.Operation- ( parseOperation )-import Data.Morpheus.Parsing.Request.Selection- ( parseFragmentDefinition )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )-import Data.Morpheus.Types.Internal.AST- ( replaceValue- , GQLQuery(..)- , ResolvedValue- )-import Data.Morpheus.Types.IO ( GQLRequest(..) )-import Data.Morpheus.Types.Internal.Operation- (fromList)--request :: Parser GQLQuery-request = label "GQLQuery" $ do- spaceAndComments- operation <- parseOperation- fragments <- manyTill parseFragmentDefinition eof >>= fromList- pure GQLQuery { operation, fragments, inputVariables = [] }--parseGQL :: GQLRequest -> Eventless GQLQuery-parseGQL GQLRequest { query, variables } = setVariables <$> processParser request query - where- setVariables root = root { inputVariables = toVariableMap variables }- toVariableMap :: Maybe Aeson.Value -> [(Text, ResolvedValue)]- toVariableMap (Just (Aeson.Object x)) = map toMorpheusValue (toList x)- where toMorpheusValue (key, value) = (key, replaceValue value)- toVariableMap _ = []
− src/Data/Morpheus/Parsing/Request/Selection.hs
@@ -1,133 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Parsing.Request.Selection- ( parseSelectionSet- , parseFragmentDefinition- )-where--import Text.Megaparsec ( label- , try- , (<|>)- )------- MORPHEUS-import Data.Morpheus.Parsing.Internal.Internal- ( Parser- , getLocation- )-import Data.Morpheus.Parsing.Internal.Pattern- ( optionalDirectives )-import Data.Morpheus.Parsing.Internal.Terms- ( keyword- , parseAlias- , parseName- , parseTypeCondition- , setOf- , spreadLiteral- , token- )-import Data.Morpheus.Parsing.Internal.Arguments- ( maybeArguments )-import Data.Morpheus.Types.Internal.AST- ( Selection(..)- , SelectionContent(..)- , Ref(..)- , Fragment(..)- , Arguments- , RAW- , SelectionSet- , Name- , Position- )----- Selection Sets : https://graphql.github.io/graphql-spec/June2018/#sec-Selection-Sets------ SelectionSet:--- { Selection(list) }------ Selection:--- Field--- FragmentSpread--- InlineFragment----parseSelectionSet :: Parser (SelectionSet RAW)-parseSelectionSet = label "SelectionSet" $ setOf parseSelection- where- parseSelection =- label "Selection"- $ try inlineFragment- <|> try spread- <|> parseSelectionField---- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields------ Field--- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt)----parseSelectionField :: Parser (Selection RAW)-parseSelectionField = label "SelectionField" $ do- selectionPosition <- getLocation- selectionAlias <- parseAlias- selectionName <- parseName- selectionArguments <- maybeArguments- -- TODO: handle Directives- _directives <- optionalDirectives- selSet selectionName selectionAlias selectionArguments <|> pure Selection { selectionContent = SelectionField, ..}- where- ------------------------------------------ selSet :: Name -> Maybe Name -> Arguments RAW -> Parser (Selection RAW)- selSet selectionName selectionAlias selectionArguments = label "body" $ do- selectionPosition <- getLocation- selectionSet <- parseSelectionSet- pure Selection { selectionContent = SelectionSet selectionSet, ..}------- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments------ FragmentName : Name------- FragmentSpread--- ...FragmentName Directives(opt)----spread :: Parser (Selection RAW)-spread = label "FragmentSpread" $ do- refPosition <- spreadLiteral- refName <- token- -- TODO: handle Directives- _directives <- optionalDirectives- pure $ Spread Ref { .. }---- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition------ FragmentDefinition:--- fragment FragmentName TypeCondition Directives(opt) SelectionSet----parseFragmentDefinition :: Parser Fragment-parseFragmentDefinition = label "FragmentDefinition" $ do- keyword "fragment"- fragmentPosition <- getLocation- fragmentName <- parseName- fragmentBody fragmentName fragmentPosition---- Inline Fragments : https://graphql.github.io/graphql-spec/June2018/#sec-Inline-Fragments------ InlineFragment:--- ... TypeCondition(opt) Directives(opt) SelectionSet----inlineFragment :: Parser (Selection RAW)-inlineFragment = label "InlineFragment" $ do- fragmentPosition <- spreadLiteral- InlineFragment <$> fragmentBody "INLINE_FRAGMENT" fragmentPosition--fragmentBody :: Name -> Position -> Parser Fragment-fragmentBody fragmentName fragmentPosition = label "FragmentBody" $ do- fragmentType <- parseTypeCondition- -- TODO: handle Directives- _directives <- optionalDirectives- fragmentSelection <- parseSelectionSet- pure $ Fragment { .. }
− src/Data/Morpheus/Rendering/RenderGQL.hs
@@ -1,116 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GADTs #-}--module Data.Morpheus.Rendering.RenderGQL- ( RenderGQL(..)- , renderGraphQLDocument- , renderWrapped- )-where--import Data.ByteString.Lazy.Char8 ( ByteString )-import Data.Semigroup ( (<>) )-import Data.Text ( Text- , intercalate- )-import qualified Data.Text.Lazy as LT- ( fromStrict )-import Data.Text.Lazy.Encoding ( encodeUtf8 )---- MORPHEUS-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , InputFieldsDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , Schema- , DataTypeWrapper(..)- , Key- , TypeRef(..)- , TypeWrapper(..)- , allDataTypes- , createInputUnionFields- , fieldVisibility- , isDefaultTypeName- , toGQLWrapper- , DataEnumValue(..)- , convertToJSONName- , ArgumentsDefinition(..)- , Name- , FieldsDefinition(..)- , unsafeFromFields- )-import Data.Morpheus.Types.Internal.Operation - ( Listable(..)- )--renderGraphQLDocument :: Schema -> ByteString-renderGraphQLDocument lib =- encodeUtf8 $ LT.fromStrict $ intercalate "\n\n" $ map render visibleTypes- where- visibleTypes = filter (not . isDefaultTypeName . typeName) (allDataTypes lib)--class RenderGQL a where- render :: a -> Key--instance RenderGQL TypeDefinition where- render TypeDefinition { typeName, typeContent } = __render typeContent- where- __render DataInterface { interfaceFields } = "interface " <> typeName <> render interfaceFields- __render DataScalar{} = "scalar " <> typeName- __render (DataEnum tags) = "enum " <> typeName <> renderObject render tags- __render (DataUnion members) =- "union "- <> typeName- <> " =\n "- <> intercalate ("\n" <> renderIndent <> "| ") members- __render (DataInputObject fields ) = "input " <> typeName <> render fields- __render (DataInputUnion members) = "input " <> typeName <> render fieldsDef- where- fieldsDef = unsafeFromFields fields- fields = createInputUnionFields typeName (fmap fst members)- __render DataObject {objectFields} = "type " <> typeName <> render objectFields---ignoreHidden :: [FieldDefinition] -> [FieldDefinition]-ignoreHidden = filter fieldVisibility---- OBJECT-instance RenderGQL FieldsDefinition where- render = renderObject render . ignoreHidden . toList- -instance RenderGQL InputFieldsDefinition where- render = renderObject render . ignoreHidden . toList--instance RenderGQL FieldDefinition where - render FieldDefinition { fieldName, fieldType, fieldArgs } =- convertToJSONName fieldName <> render fieldArgs <> ": " <> render fieldType--instance RenderGQL ArgumentsDefinition where - render NoArguments = ""- render arguments = "(" <> intercalate ", " (map render $ toList arguments) <> ")"--instance RenderGQL DataEnumValue where- render DataEnumValue { enumName } = enumName--instance RenderGQL TypeRef where- render TypeRef { typeConName, typeWrappers } = renderWrapped typeConName typeWrappers--instance RenderGQL Key where- render = id--renderWrapped :: RenderGQL a => a -> [TypeWrapper] -> Name-renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)- where- showGQLWrapper [] = render x- showGQLWrapper (ListType:xs) = "[" <> showGQLWrapper xs <> "]"- showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!"--renderIndent :: Text-renderIndent = " "--renderObject :: (a -> Text) -> [a] -> Text-renderObject f list =- " { \n " <> intercalate ("\n" <> renderIndent) (map f list) <> "\n}"
− src/Data/Morpheus/Rendering/RenderIntrospection.hs
@@ -1,255 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts , FlexibleInstances #-}--module Data.Morpheus.Rendering.RenderIntrospection- ( render- , createObjectType- )-where--import Data.Semigroup ( (<>) )-import Data.Text ( Text )-import Data.Maybe ( isJust )----- Morpheus-import Data.Morpheus.Schema.Schema-import Data.Morpheus.Schema.TypeKind ( TypeKind(..) )-import Data.Morpheus.Types.Internal.AST- ( DataInputUnion- , FieldDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , DataTypeKind(..)- , Schema- , DataTypeWrapper(..)- , DataUnion- , Meta(..)- , TypeRef(..)- , createInputUnionFields- , fieldVisibility- , kindOf- , lookupDataType- , toGQLWrapper- , DataEnumValue(..)- , lookupDeprecated- , DataInputUnion- , lookupDeprecatedReason- , convertToJSONName- , ArgumentsDefinition(..)- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Failure(..) )--constRes :: Applicative m => a -> b -> m a-constRes = const . pure--type Result m a = Schema -> m a--class RenderSchema a b where- render :: (Monad m, Failure Text m) => a -> Schema -> m (b m)--instance RenderSchema TypeDefinition S__Type where- render TypeDefinition { typeName , typeMeta, typeContent } = __render typeContent- where- __render- :: (Monad m, Failure Text m) => TypeContent -> Schema -> m (S__Type m)- __render DataScalar{} =- constRes $ createLeafType SCALAR typeName typeMeta Nothing- __render (DataEnum enums) = constRes- $ createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums)- __render (DataInputObject fields) = \lib ->- createInputObject typeName typeMeta- <$> traverse (`renderinputValue` lib) (toList fields)- __render DataObject {objectFields} = \lib ->- createObjectType typeName (typeMeta >>= metaDescription)- <$> (Just <$> traverse (`render` lib) (filter fieldVisibility $ toList objectFields))- __render (DataUnion union) =- constRes $ typeFromUnion (typeName, typeMeta, union)- __render (DataInputUnion members) =- renderInputUnion (typeName, typeMeta, members)--createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m-createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue- { s__EnumValueName = pure enumName- , s__EnumValueDescription = pure (enumMeta >>= metaDescription)- , s__EnumValueIsDeprecated = pure (isJust deprecated)- , s__EnumValueDeprecationReason = pure (deprecated >>= lookupDeprecatedReason)- }- where deprecated = enumMeta >>= lookupDeprecated--renderArguments :: (Monad m, Failure Text m) => ArgumentsDefinition -> Schema -> m [S__InputValue m] -renderArguments ArgumentsDefinition { arguments} lib = traverse (`renderinputValue` lib) $ toList arguments-renderArguments NoArguments _ = pure []--instance RenderSchema FieldDefinition S__Field where- render field@FieldDefinition { fieldName ,fieldType = TypeRef { typeConName }, fieldArgs, fieldMeta } lib- = do- kind <- renderTypeKind <$> lookupKind typeConName lib- pure S__Field- { s__FieldName = pure (convertToJSONName fieldName)- , s__FieldDescription = pure (fieldMeta >>= metaDescription)- , s__FieldArgs = renderArguments fieldArgs lib - , s__FieldType' =- pure (applyTypeWrapper field $ createType kind typeConName Nothing $ Just [])- , s__FieldIsDeprecated = pure (isJust deprecated)- , s__FieldDeprecationReason = pure- (deprecated >>= lookupDeprecatedReason)- }- where deprecated = fieldMeta >>= lookupDeprecated--renderTypeKind :: DataTypeKind -> TypeKind-renderTypeKind KindScalar = SCALAR-renderTypeKind (KindObject _) = OBJECT-renderTypeKind KindUnion = UNION-renderTypeKind KindInputUnion = INPUT_OBJECT-renderTypeKind KindEnum = ENUM-renderTypeKind KindInputObject = INPUT_OBJECT-renderTypeKind KindList = LIST-renderTypeKind KindNonNull = NON_NULL--applyTypeWrapper :: Monad m => FieldDefinition -> S__Type m -> S__Type m-applyTypeWrapper FieldDefinition { fieldType = TypeRef { typeWrappers } } typ =- foldr wrapByTypeWrapper typ (toGQLWrapper typeWrappers)--wrapByTypeWrapper :: Monad m => DataTypeWrapper -> S__Type m -> S__Type m-wrapByTypeWrapper ListType = wrapAs LIST-wrapByTypeWrapper NonNullType = wrapAs NON_NULL--lookupKind :: (Monad m, Failure Text m) => Text -> Result m DataTypeKind-lookupKind name lib = case lookupDataType name lib of- Nothing -> failure $ "Kind Not Found: " <> name- Just value -> pure (kindOf value)--renderinputValue- :: (Monad m, Failure Text m)- => FieldDefinition- -> Result m (S__InputValue m)-renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input--createInputObjectType- :: (Monad m, Failure Text m) => FieldDefinition -> Result m (S__Type m)-createInputObjectType field@FieldDefinition { fieldType = TypeRef { typeConName } } lib- = do- kind <- renderTypeKind <$> lookupKind typeConName lib- pure $ applyTypeWrapper field $ createType kind typeConName Nothing $ Just []---renderInputUnion- :: (Monad m, Failure Text m)- => (Text, Maybe Meta, DataInputUnion)- -> Result m (S__Type m)-renderInputUnion (key, meta, fields) lib =- createInputObject key meta <$> traverse- createField- (createInputUnionFields key $ map fst $ filter snd fields)- where- createField field =- createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib--createLeafType- :: Monad m- => TypeKind- -> Text- -> Maybe Meta- -> Maybe [S__EnumValue m]- -> S__Type m-createLeafType kind name meta enums = S__Type- { s__TypeKind = pure kind- , s__TypeName = pure $ Just name- , s__TypeDescription = pure (meta >>= metaDescription)- , s__TypeFields = constRes Nothing- , s__TypeOfType = pure Nothing- , s__TypeInterfaces = pure Nothing- , s__TypePossibleTypes = pure Nothing- , s__TypeEnumValues = constRes enums- , s__TypeInputFields = pure Nothing- }--typeFromUnion :: Monad m => (Text, Maybe Meta, DataUnion) -> S__Type m-typeFromUnion (name, typeMeta, typeContent) = S__Type- { s__TypeKind = pure UNION- , s__TypeName = pure $ Just name- , s__TypeDescription = pure (typeMeta >>= metaDescription)- , s__TypeFields = constRes Nothing- , s__TypeOfType = pure Nothing- , s__TypeInterfaces = pure Nothing- , s__TypePossibleTypes =- pure $ Just (map (\x -> createObjectType x Nothing $ Just []) typeContent)- , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = pure Nothing- }--createObjectType- :: Monad m => Text -> Maybe Text -> Maybe [S__Field m] -> S__Type m-createObjectType name description fields = S__Type- { s__TypeKind = pure OBJECT- , s__TypeName = pure $ Just name- , s__TypeDescription = pure description- , s__TypeFields = constRes fields- , s__TypeOfType = pure Nothing- , s__TypeInterfaces = pure $ Just []- , s__TypePossibleTypes = pure Nothing- , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = pure Nothing- }--createInputObject- :: Monad m => Text -> Maybe Meta -> [S__InputValue m] -> S__Type m-createInputObject name meta fields = S__Type- { s__TypeKind = pure INPUT_OBJECT- , s__TypeName = pure $ Just name- , s__TypeDescription = pure (meta >>= metaDescription)- , s__TypeFields = constRes Nothing- , s__TypeOfType = pure Nothing- , s__TypeInterfaces = pure Nothing- , s__TypePossibleTypes = pure Nothing- , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = pure $ Just fields- }--createType- :: Monad m- => TypeKind- -> Text- -> Maybe Text- -> Maybe [S__Field m]- -> S__Type m-createType kind name description fields = S__Type- { s__TypeKind = pure kind- , s__TypeName = pure $ Just name- , s__TypeDescription = pure description- , s__TypeFields = constRes fields- , s__TypeOfType = pure Nothing- , s__TypeInterfaces = pure Nothing- , s__TypePossibleTypes = pure Nothing- , s__TypeEnumValues = constRes $ Just []- , s__TypeInputFields = pure Nothing- }--wrapAs :: Monad m => TypeKind -> S__Type m -> S__Type m-wrapAs kind contentType = S__Type { s__TypeKind = pure kind- , s__TypeName = pure Nothing- , s__TypeDescription = pure Nothing- , s__TypeFields = constRes Nothing- , s__TypeOfType = pure $ Just contentType- , s__TypeInterfaces = pure Nothing- , s__TypePossibleTypes = pure Nothing- , s__TypeEnumValues = constRes Nothing- , s__TypeInputFields = pure Nothing- }--createInputValueWith- :: Monad m => Text -> Maybe Meta -> S__Type m -> S__InputValue m-createInputValueWith name meta ivType = S__InputValue- { s__InputValueName = pure (convertToJSONName name)- , s__InputValueDescription = pure (meta >>= metaDescription)- , s__InputValueType' = pure ivType- , s__InputValueDefaultValue = pure Nothing- }
− src/Data/Morpheus/Schema/Schema.hs
@@ -1,124 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE FlexibleContexts #-}---module Data.Morpheus.Schema.Schema- ( Root(..)- , Root__typeArgs(..)- , S__Schema(..)- , S__Type(..)- , S__Field(..)- , S__EnumValue(..)- , S__InputValue(..)- )-where--import Data.Text ( Text )---- MORPHEUS-import Data.Morpheus.Execution.Document.Compile- ( gqlDocumentNamespace )-import Data.Morpheus.Schema.TypeKind ( TypeKind )--type S__TypeKind = TypeKind--[gqlDocumentNamespace|--type __Schema {- types: [__Type!]!- queryType: __Type!- mutationType: __Type- subscriptionType: __Type- directives: [__Directive!]!-}--type __Type {- kind: __TypeKind!- name: String- description: String-- # OBJECT and INTERFACE only- fields(includeDeprecated: Boolean = false): [__Field!]-- # OBJECT only- interfaces: [__Type!]-- # INTERFACE and UNION only- possibleTypes: [__Type!]-- # ENUM only- enumValues(includeDeprecated: Boolean = false): [__EnumValue!]-- # INPUT_OBJECT only- inputFields: [__InputValue!]-- # NON_NULL and LIST only- ofType: __Type-}--type __Field {- name: String!- description: String- args: [__InputValue!]!- type: __Type!- isDeprecated: Boolean!- deprecationReason: String-}--type __InputValue {- name: String!- description: String- type: __Type!- defaultValue: String-}--type __EnumValue {- name: String!- description: String- isDeprecated: Boolean!- deprecationReason: String-}--type __Directive {- name: String!- description: String- locations: [__DirectiveLocation!]!- args: [__InputValue!]!-}--enum __DirectiveLocation {- QUERY- MUTATION- SUBSCRIPTION- FIELD- FRAGMENT_DEFINITION- FRAGMENT_SPREAD- INLINE_FRAGMENT- SCHEMA- SCALAR- OBJECT- FIELD_DEFINITION- ARGUMENT_DEFINITION- INTERFACE- UNION- ENUM- ENUM_VALUE- INPUT_OBJECT- INPUT_FIELD_DEFINITION-}--type Root {- __type(name: String!): __Type- __schema : __Schema!-}--|]
− src/Data/Morpheus/Schema/SchemaAPI.hs
@@ -1,97 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Schema.SchemaAPI- ( hiddenRootFields- , defaultTypes- , schemaAPI- )-where--import Data.Proxy-import Data.Text ( Text )---- MORPHEUS-import Data.Morpheus.Execution.Server.Introspect- ( introspectObjectFields- , TypeUpdater- , introspect- , TypeScope(..)- )-import Data.Morpheus.Rendering.RenderIntrospection- ( createObjectType- , render- )-import Data.Morpheus.Schema.Schema ( Root(..)- , Root__typeArgs(..)- , S__Schema(..)- , S__Type- )-import Data.Morpheus.Types.GQLType ( CUSTOM )-import Data.Morpheus.Types.ID ( ID )-import Data.Morpheus.Types.Internal.AST- ( Schema(..)- , QUERY- , TypeDefinition(..)- , allDataTypes- , lookupDataType- , FieldsDefinition- )-import Data.Morpheus.Types.Internal.Resolving- ( Resolver- , resolveUpdates- )---convertTypes- :: Monad m => Schema -> Resolver QUERY e m [S__Type (Resolver QUERY e m)]-convertTypes lib = traverse (`render` lib) (allDataTypes lib)--buildSchemaLinkType- :: Monad m => TypeDefinition -> S__Type (Resolver QUERY e m)-buildSchemaLinkType TypeDefinition { typeName } = createObjectType typeName Nothing $ Just []--findType- :: Monad m- => Text- -> Schema- -> Resolver QUERY e m (Maybe (S__Type (Resolver QUERY e m)))-findType name lib = renderT (lookupDataType name lib)- where- renderT (Just datatype) = Just <$> render datatype lib- renderT Nothing = pure Nothing--initSchema- :: Monad m- => Schema- -> Resolver QUERY e m (S__Schema (Resolver QUERY e m))-initSchema lib = pure S__Schema- { s__SchemaTypes = convertTypes lib- , s__SchemaQueryType = pure $ buildSchemaLinkType $ query lib- , s__SchemaMutationType = pure $ buildSchemaLinkType <$> mutation lib- , s__SchemaSubscriptionType = pure $ buildSchemaLinkType <$> subscription lib- , s__SchemaDirectives = pure []- }--hiddenRootFields :: FieldsDefinition-hiddenRootFields = fst $ introspectObjectFields- (Proxy :: Proxy (CUSTOM (Root Maybe)))- ("Root", OutputType, Proxy @(Root Maybe))--defaultTypes :: TypeUpdater-defaultTypes = flip- resolveUpdates- [ introspect (Proxy @Bool)- , introspect (Proxy @Int)- , introspect (Proxy @Float)- , introspect (Proxy @Text)- , introspect (Proxy @ID)- , introspect (Proxy @(S__Schema Maybe))- ]--schemaAPI :: Monad m => Schema -> Root (Resolver QUERY e m)-schemaAPI lib = Root { root__type, root__schema = initSchema lib }- where root__type (Root__typeArgs name) = findType name lib
− src/Data/Morpheus/Schema/TypeKind.hs
@@ -1,29 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Schema.TypeKind- ( TypeKind(..)- )-where--import Data.Aeson ( FromJSON(..) )-import Data.Morpheus.Kind ( ENUM )-import Data.Morpheus.Types.GQLType ( GQLType(KIND, __typeName) )-import GHC.Generics--instance GQLType TypeKind where- type KIND TypeKind = ENUM- __typeName = const "__TypeKind"--data TypeKind- = SCALAR- | OBJECT- | INTERFACE- | UNION- | ENUM- | INPUT_OBJECT- | LIST- | NON_NULL- deriving (Eq, Generic, FromJSON, Show)
src/Data/Morpheus/Server.hs view
@@ -1,54 +1,65 @@-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} -- | GraphQL Wai Server Applications module Data.Morpheus.Server- ( webSocketsApp- , httpPubApp+ ( webSocketsApp,+ httpPubApp,+ subscriptionApp,+ ServerConstraint, ) where --import Control.Monad.IO.Unlift ( MonadUnliftIO- , withRunInIO- )-import Control.Monad.IO.Class ( MonadIO(..) )-import Network.WebSockets ( Connection- , sendTextData- , receiveData- , ServerApp- )-import qualified Network.WebSockets as WS-+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift+ ( MonadUnliftIO,+ withRunInIO,+ ) -- MORPHEUS-import Data.Morpheus.Types.Internal.Resolving - ( GQLChannel(..) )-import Data.Morpheus.Types.IO ( MapAPI(..) )-import Data.Morpheus.Types.Internal.Subscription- ( connectionThread- , Input(..)- , Stream- , Store(..)- , Scope(..)- , HTTP- , WS- , runStreamHTTP- , acceptApolloRequest- , initDefaultStore- , publishEventWith- ) +import Data.Morpheus.Types.IO (MapAPI (..))+import Data.Morpheus.Types.Internal.Resolving+ ( GQLChannel (..),+ )+import Data.Morpheus.Types.Internal.Subscription+ ( HTTP,+ Input (..),+ Scope (..),+ Store (..),+ Stream,+ WS,+ acceptApolloRequest,+ connectionThread,+ initDefaultStore,+ publishEventWith,+ runStreamHTTP,+ )+import Network.WebSockets+ ( Connection,+ ServerApp,+ receiveData,+ sendTextData,+ )+import qualified Network.WebSockets as WS +type ServerConstraint e m =+ ( MonadIO m,+ MonadUnliftIO m,+ Eq (StreamChannel e),+ GQLChannel e+ )+ -- support old version of Websockets pingThread :: Connection -> IO () -> IO ()+ #if MIN_VERSION_websockets(0,12,6) pingThread connection = WS.withPingThread connection 30 (return ()) #else@@ -56,46 +67,71 @@ #endif defaultWSScope :: MonadIO m => Store e m -> Connection -> Scope WS e m-defaultWSScope Store { writeStore } connection = ScopeWS - { listener = liftIO (receiveData connection)- , callback = liftIO . sendTextData connection- , update = writeStore- }+defaultWSScope Store {writeStore} connection =+ ScopeWS+ { listener = liftIO (receiveData connection),+ callback = liftIO . sendTextData connection,+ update = writeStore+ } -httpPubApp- :: - ( MonadIO m,- MapAPI a- )- => (Input HTTP -> Stream HTTP e m)- -> (e -> m ())- -> a- -> m a-httpPubApp api httpCallback - = mapAPI - ( runStreamHTTP ScopeHTTP { httpCallback }- . api - . Request+httpPubApp ::+ ( MonadIO m,+ MapAPI a+ ) =>+ (Input HTTP -> Stream HTTP e m) ->+ (e -> m ()) ->+ a ->+ m a+httpPubApp api httpCallback =+ mapAPI+ ( runStreamHTTP ScopeHTTP {httpCallback}+ . api+ . Request ) -- | Wai WebSocket Server App for GraphQL subscriptions-webSocketsApp- :: ( MonadIO m - , MonadUnliftIO m- , (Eq (StreamChannel e)) - , (GQLChannel e) +subscriptionApp ::+ ( MonadUnliftIO m,+ (Eq (StreamChannel e)),+ (GQLChannel e)+ ) =>+ ( Store e m ->+ (Scope WS e m -> m ()) ->+ m app+ ) ->+ (Input WS -> Stream WS e m) ->+ m (app, e -> m ())+subscriptionApp appWrapper api =+ do+ store <- initDefaultStore+ app <- appWrapper store (connectionThread api)+ pure+ ( app,+ publishEventWith store )- => (Input WS -> Stream WS e m)- -> m (ServerApp , e -> m ())-webSocketsApp api = withRunInIO handle- where- handle runIO = do - store <- initDefaultStore - pure (wsApp store, publishEventWith store)- where- wsApp store pending = do- connection <- acceptApolloRequest pending- let scope = defaultWSScope store connection- pingThread - connection - $ runIO (connectionThread api scope)++webSocketsWrapper ::+ (MonadUnliftIO m, MonadIO m) =>+ Store e m ->+ (Scope WS e m -> m ()) ->+ m ServerApp+webSocketsWrapper store handler =+ withRunInIO $+ \runIO ->+ pure $+ \pending -> do+ conn <- acceptApolloRequest pending+ pingThread+ conn+ $ runIO (handler (defaultWSScope store conn))++-- | Wai WebSocket Server App for GraphQL subscriptions+webSocketsApp ::+ ( MonadIO m,+ MonadUnliftIO m,+ (Eq (StreamChannel e)),+ (GQLChannel e)+ ) =>+ (Input WS -> Stream WS e m) ->+ m (ServerApp, e -> m ())+webSocketsApp = subscriptionApp webSocketsWrapper
+ src/Data/Morpheus/Server/Deriving/Decode.hs view
@@ -0,0 +1,241 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Server.Deriving.Decode+ ( decodeArguments,+ Decode (..),+ DecodeType (..),+ )+where++-- MORPHEUS+import Data.Morpheus.Error+ ( internalError,+ internalTypeMismatch,+ )+import Data.Morpheus.Internal.Utils+ ( elems,+ )+import Data.Morpheus.Kind+ ( ENUM,+ GQL_KIND,+ INPUT,+ OUTPUT,+ SCALAR,+ )+import Data.Morpheus.Server.Deriving.Utils+ ( conNameProxy,+ datatypeNameProxy,+ selNameProxy,+ )+import Data.Morpheus.Server.Internal.TH.Decode+ ( decodeFieldWith,+ withList,+ withMaybe,+ withObject,+ withUnion,+ )+import Data.Morpheus.Server.Types.GQLScalar+ ( GQLScalar (..),+ toScalar,+ )+import Data.Morpheus.Server.Types.GQLType (GQLType (KIND, __typeName))+import Data.Morpheus.Types.Internal.AST+ ( Argument (..),+ Arguments,+ ObjectEntry (..),+ TypeName (..),+ VALID,+ ValidObject,+ ValidValue,+ Value (..),+ msg,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ Failure (..),+ )+import Data.Proxy (Proxy (..))+import Data.Semigroup (Semigroup (..))+import GHC.Generics++-- GENERIC+decodeArguments :: DecodeType a => Arguments VALID -> Eventless a+decodeArguments = decodeType . Object . fmap toEntry+ where+ toEntry (Argument name value _) = ObjectEntry name value++-- | Decode GraphQL query arguments and input values+class Decode a where+ decode :: ValidValue -> Eventless a++instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where+ decode = decodeKind (Proxy @(KIND a))++instance Decode a => Decode (Maybe a) where+ decode = withMaybe decode++instance Decode a => Decode [a] where+ decode = withList decode++-- | Decode GraphQL type with Specific Kind+class DecodeKind (kind :: GQL_KIND) a where+ decodeKind :: Proxy kind -> ValidValue -> Eventless a++-- SCALAR+instance (GQLScalar a) => DecodeKind SCALAR a where+ decodeKind _ value = case toScalar value >>= parseValue of+ Right scalar -> return scalar+ Left errorMessage -> internalTypeMismatch (msg errorMessage) value++-- ENUM+instance DecodeType a => DecodeKind ENUM a where+ decodeKind _ = decodeType++-- TODO: remove+instance DecodeType a => DecodeKind OUTPUT a where+ decodeKind _ = decodeType++-- INPUT_OBJECT and INPUT_UNION+instance DecodeType a => DecodeKind INPUT a where+ decodeKind _ = decodeType++class DecodeType a where+ decodeType :: ValidValue -> Eventless a++instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a)) => DecodeType a where+ decodeType = fmap to . decodeRep . (,Cont D_CONS "")++-- data Inpuz =+-- InputHuman Human -- direct link: { __typename: Human, Human: {field: ""} }+-- | InputRecord { name :: Text, age :: Int } -- { __typename: InputRecord, InputRecord: {field: ""} }+-- | IndexedType Int Text -- { __typename: InputRecord, _0:2 , _1:"" }+-- | Zeus -- { __typename: Zeus }+-- deriving (Generic, GQLType)++decideUnion ::+ ([TypeName], value -> Eventless (f1 a)) ->+ ([TypeName], value -> Eventless (f2 a)) ->+ TypeName ->+ value ->+ Eventless ((:+:) f1 f2 a)+decideUnion (left, f1) (right, f2) name value+ | name `elem` left =+ L1 <$> f1 value+ | name `elem` right =+ R1 <$> f2 value+ | otherwise =+ failure $+ "Constructor \""+ <> msg name+ <> "\" could not find in Union"++data Tag = D_CONS | D_UNION deriving (Eq, Ord)++data Cont = Cont+ { contKind :: Tag,+ typeName :: TypeName+ }++data Info = Info+ { kind :: Tag,+ tagName :: [TypeName]+ }++instance Semigroup Info where+ Info D_UNION t1 <> Info _ t2 = Info D_UNION (t1 <> t2)+ Info _ t1 <> Info D_UNION t2 = Info D_UNION (t1 <> t2)+ Info D_CONS t1 <> Info D_CONS t2 = Info D_CONS (t1 <> t2)++--+-- GENERICS+--+class DecodeRep f where+ tags :: Proxy f -> TypeName -> Info+ decodeRep :: (ValidValue, Cont) -> Eventless (f a)++instance (Datatype d, DecodeRep f) => DecodeRep (M1 D d f) where+ tags _ = tags (Proxy @f)+ decodeRep (x, y) =+ M1+ <$> decodeRep+ (x, y {typeName = datatypeNameProxy (Proxy @d)})++getEnumTag :: ValidObject -> Eventless TypeName+getEnumTag x = case elems x of+ [ObjectEntry "enum" (Enum value)] -> pure value+ _ -> internalError "bad union enum object"++instance (DecodeRep a, DecodeRep b) => DecodeRep (a :+: b) where+ tags _ = tags (Proxy @a) <> tags (Proxy @b)+ decodeRep = __decode+ where+ __decode (Object obj, cont) = withUnion handleUnion obj+ where+ handleUnion name unions object+ | name == typeName cont <> "EnumObject" =+ getEnumTag object >>= __decode . (,ctx) . Enum+ | [name] == l1 =+ L1 <$> decodeRep (Object object, ctx)+ | [name] == r1 =+ R1 <$> decodeRep (Object object, ctx)+ | otherwise =+ decideUnion (l1, decodeRep) (r1, decodeRep) name (Object unions, ctx)+ l1 = tagName l1t+ r1 = tagName r1t+ l1t = tags (Proxy @a) (typeName cont)+ r1t = tags (Proxy @b) (typeName cont)+ ctx = cont {contKind = kind (l1t <> r1t)}+ __decode (Enum name, cxt) =+ decideUnion+ (tagName $ tags (Proxy @a) (typeName cxt), decodeRep)+ (tagName $ tags (Proxy @b) (typeName cxt), decodeRep)+ name+ (Enum name, cxt)+ __decode _ = internalError "lists and scalars are not allowed in Union"++instance (Constructor c, DecodeFields a) => DecodeRep (M1 C c a) where+ decodeRep = fmap M1 . decodeFields+ tags _ baseName = getTag (refType (Proxy @a))+ where+ getTag (Just memberRef)+ | isUnionRef memberRef = Info {kind = D_UNION, tagName = [memberRef]}+ | otherwise = Info {kind = D_CONS, tagName = [consName]}+ getTag Nothing = Info {kind = D_CONS, tagName = [consName]}+ --------+ consName = conNameProxy (Proxy @c)+ ----------+ isUnionRef x = baseName <> x == consName++class DecodeFields f where+ refType :: Proxy f -> Maybe TypeName+ decodeFields :: (ValidValue, Cont) -> Eventless (f a)++instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where+ refType _ = Nothing+ decodeFields gql = (:*:) <$> decodeFields gql <*> decodeFields gql++instance (Selector s, GQLType a, Decode a) => DecodeFields (M1 S s (K1 i a)) where+ refType _ = Just $ __typeName (Proxy @a)+ decodeFields (value, Cont {contKind})+ | contKind == D_UNION = M1 . K1 <$> decode value+ | otherwise = __decode value+ where+ __decode = fmap (M1 . K1) . decodeRec+ fieldName = selNameProxy (Proxy @s)+ decodeRec = withObject (decodeFieldWith decode fieldName)++instance DecodeFields U1 where+ refType _ = Nothing+ decodeFields _ = pure U1
+ src/Data/Morpheus/Server/Deriving/Encode.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Server.Deriving.Encode+ ( EncodeCon,+ Encode (..),+ ExploreResolvers (..),+ deriveModel,+ )+where++import Data.Map (Map)+import qualified Data.Map as M+ ( toList,+ )+-- MORPHEUS++import Data.Morpheus.Kind+ ( ENUM,+ GQL_KIND,+ INTERFACE,+ OUTPUT,+ ResContext (..),+ SCALAR,+ VContext (..),+ )+import Data.Morpheus.Server.Deriving.Decode+ ( DecodeType,+ decodeArguments,+ )+import Data.Morpheus.Server.Deriving.Utils+ ( conNameProxy,+ datatypeNameProxy,+ isRecordProxy,+ )+import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..))+import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Server.Types.Types+ ( MapKind,+ Pair (..),+ mapKindFromList,+ )+import Data.Morpheus.Types+ ( GQLRootResolver (..),+ )+import Data.Morpheus.Types.Internal.AST+ ( FieldName,+ FieldName (..),+ MUTATION,+ Message,+ OperationType (..),+ QUERY,+ SUBSCRIPTION,+ TypeName,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ FieldResModel,+ LiftOperation,+ MapStrategy (..),+ ObjectResModel (..),+ ResModel (..),+ Resolver,+ RootResModel (..),+ failure,+ liftStateless,+ toResolver,+ unsafeBind,+ )+import Data.Proxy (Proxy (..))+import Data.Semigroup ((<>))+import Data.Set (Set)+import qualified Data.Set as S+ ( toList,+ )+import Data.Text (pack)+import GHC.Generics++class Encode resolver o e (m :: * -> *) where+ encode :: resolver -> Resolver o e m (ResModel o e m)++instance {-# OVERLAPPABLE #-} (EncodeKind (KIND a) a o e m, LiftOperation o) => Encode a o e m where+ encode resolver = encodeKind (VContext resolver :: VContext (KIND a) a)++-- MAYBE+instance (Monad m, LiftOperation o, Encode a o e m) => Encode (Maybe a) o e m where+ encode = maybe (pure ResNull) encode++-- LIST []+instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where+ encode = fmap ResList . traverse encode++-- Tuple (a,b)+instance Encode (Pair k v) o e m => Encode (k, v) o e m where+ encode (key, value) = encode (Pair key value)++-- Set+instance Encode [a] o e m => Encode (Set a) o e m where+ encode = encode . S.toList++-- Map+instance (Eq k, Monad m, LiftOperation o, Encode (MapKind k v (Resolver o e m)) o e m) => Encode (Map k v) o e m where+ encode value =+ encode ((mapKindFromList $ M.toList value) :: MapKind k v (Resolver o e m))++-- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY+instance+ ( DecodeType a,+ Generic a,+ Monad m,+ LiftOperation fo,+ Encode b fo e m,+ MapStrategy fo o+ ) =>+ Encode (a -> Resolver fo e m b) o e m+ where+ encode x =+ mapStrategy $+ toResolver decodeArguments x `unsafeBind` encode++-- GQL a -> Resolver b, MUTATION, SUBSCRIPTION, QUERY+instance+ ( Monad m,+ LiftOperation o,+ Encode b fo e m,+ MapStrategy fo o+ ) =>+ Encode (Resolver fo e m b) o e m+ where+ encode = mapStrategy . (`unsafeBind` encode)++-- ENCODE GQL KIND+class EncodeKind (kind :: GQL_KIND) a o e (m :: * -> *) where+ encodeKind :: LiftOperation o => VContext kind a -> Resolver o e m (ResModel o e m)++-- SCALAR+instance (GQLScalar a, Monad m) => EncodeKind SCALAR a o e m where+ encodeKind = pure . ResScalar . serialize . unVContext++-- ENUM+instance (Generic a, ExploreResolvers (CUSTOM a) a o e m, Monad m) => EncodeKind ENUM a o e m where+ encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value++instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where+ encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value++instance (Monad m, Generic a, ExploreResolvers (CUSTOM a) a o e m) => EncodeKind INTERFACE a o e m where+ encodeKind (VContext value) = liftStateless $ exploreResolvers (Proxy @(CUSTOM a)) value++convertNode ::+ (Monad m, LiftOperation o) =>+ ResNode o e m ->+ ResModel o e m+convertNode ResNode {resDatatypeName, resKind = REP_OBJECT, resFields} =+ ResObject (ObjectResModel resDatatypeName $ map toFieldRes resFields)+convertNode ResNode {resDatatypeName, resKind = REP_UNION, resFields, resTypeName, isResRecord} =+ encodeUnion resFields+ where+ -- ENUM+ encodeUnion [] = ResEnum resDatatypeName resTypeName+ -- Type References --------------------------------------------------------------+ encodeUnion [FieldNode {fieldTypeName, fieldResolver, isFieldObject}]+ | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName =+ ResUnion fieldTypeName fieldResolver+ -- Inline Union Types ----------------------------------------------------------------------------+ encodeUnion fields =+ ResUnion+ resTypeName+ $ pure+ $ ResObject+ $ ObjectResModel+ resTypeName+ (map toFieldRes resolvers)+ where+ resolvers+ | isResRecord = fields+ | otherwise = setFieldNames fields++-- Types & Constrains -------------------------------------------------------+type GQL_RES a = (Generic a, GQLType a)++type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m)++--- GENERICS ------------------------------------------------+class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where+ exploreResolvers :: Proxy custom -> a -> Eventless (ResModel o e m)++instance (Generic a, Monad m, LiftOperation o, TypeRep (Rep a) o e m) => ExploreResolvers 'False a o e m where+ exploreResolvers _ value =+ pure+ $ convertNode+ $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)++----- HELPERS ----------------------------+objectResolvers ::+ forall a o e m.+ ( ExploreResolvers (CUSTOM a) a o e m,+ Monad m,+ LiftOperation o+ ) =>+ a ->+ Eventless (ResModel o e m)+objectResolvers value =+ exploreResolvers (Proxy @(CUSTOM a)) value+ >>= constraintOnject+ where+ constraintOnject obj@ResObject {} =+ pure obj+ constraintOnject _ =+ failure ("resolver must be an object" :: Message)++type Con o e m a =+ ExploreResolvers+ ( CUSTOM+ (a (Resolver o e m))+ )+ (a (Resolver o e m))+ o+ e+ m++deriveModel ::+ forall e m query mut sub.+ ( Con QUERY e m query,+ Con MUTATION e m mut,+ Con SUBSCRIPTION e m sub,+ Applicative m,+ Monad m+ ) =>+ GQLRootResolver m e query mut sub ->+ RootResModel e m+deriveModel+ GQLRootResolver+ { queryResolver,+ mutationResolver,+ subscriptionResolver+ } =+ RootResModel+ { query = objectResolvers queryResolver,+ mutation = objectResolvers mutationResolver,+ subscription = objectResolvers subscriptionResolver+ }++toFieldRes :: FieldNode o e m -> FieldResModel o e m+toFieldRes FieldNode {fieldSelName, fieldResolver} =+ (fieldSelName, fieldResolver)++-- NEW AUTOMATIC DERIVATION SYSTEM+data REP_KIND = REP_UNION | REP_OBJECT++data ResNode o e m = ResNode+ { resDatatypeName :: TypeName,+ resTypeName :: TypeName,+ resKind :: REP_KIND,+ resFields :: [FieldNode o e m],+ isResRecord :: Bool+ }++data FieldNode o e m = FieldNode+ { fieldTypeName :: TypeName,+ fieldSelName :: FieldName,+ fieldResolver :: Resolver o e m (ResModel o e m),+ isFieldObject :: Bool+ }++-- setFieldNames :: Power Int Text -> Power { _1 :: Int, _2 :: Text }+setFieldNames :: [FieldNode o e m] -> [FieldNode o e m]+setFieldNames = zipWith setFieldName ([0 ..] :: [Int])+ where+ setFieldName i field = field {fieldSelName = FieldName $ "_" <> pack (show i)}++class TypeRep f o e (m :: * -> *) where+ typeResolvers :: ResContext OUTPUT o e m value -> f a -> ResNode o e m++instance (Datatype d, TypeRep f o e m) => TypeRep (M1 D d f) o e m where+ typeResolvers context (M1 src) =+ (typeResolvers context src)+ { resDatatypeName = datatypeNameProxy (Proxy @d)+ }++--- UNION OR OBJECT+instance (TypeRep a o e m, TypeRep b o e m) => TypeRep (a :+: b) o e m where+ typeResolvers context (L1 x) =+ (typeResolvers context x) {resKind = REP_UNION}+ typeResolvers context (R1 x) =+ (typeResolvers context x) {resKind = REP_UNION}++instance (FieldRep f o e m, Constructor c) => TypeRep (M1 C c f) o e m where+ typeResolvers context (M1 src) =+ ResNode+ { resDatatypeName = "",+ resTypeName = conNameProxy (Proxy @c),+ resKind = REP_OBJECT,+ resFields = fieldRep context src,+ isResRecord = isRecordProxy (Proxy @c)+ }++--- FIELDS+class FieldRep f o e (m :: * -> *) where+ fieldRep :: ResContext OUTPUT o e m value -> f a -> [FieldNode o e m]++instance (FieldRep f o e m, FieldRep g o e m) => FieldRep (f :*: g) o e m where+ fieldRep context (a :*: b) = fieldRep context a <> fieldRep context b++instance (Selector s, GQLType a, Encode a o e m) => FieldRep (M1 S s (K1 s2 a)) o e m where+ fieldRep _ m@(M1 (K1 src)) =+ [ FieldNode+ { fieldSelName = FieldName $ pack (selName m),+ fieldTypeName = __typeName (Proxy @a),+ fieldResolver = encode src,+ isFieldObject = isObjectKind (Proxy @a)+ }+ ]++instance FieldRep U1 o e m where+ fieldRep _ _ = []
+ src/Data/Morpheus/Server/Deriving/Interpreter.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}++module Data.Morpheus.Server.Deriving.Interpreter+ ( Interpreter (..),+ )+where++-- MORPHEUS++import Data.Morpheus.Server.Deriving.Resolve+ ( RootResCon,+ coreResolver,+ statelessResolver,+ )+import Data.Morpheus.Types+ ( GQLRootResolver (..),+ )+import Data.Morpheus.Types.IO+ ( GQLRequest,+ GQLResponse,+ MapAPI (..),+ )+import Data.Morpheus.Types.Internal.Subscription+ ( Input,+ Stream,+ toOutStream,+ )++-- | main query processor and resolver+-- possible versions of interpreter+--+-- 1. with effect and state: where 'GQLState' is State Monad of subscriptions+--+-- @+-- k :: GQLState -> a -> IO a+-- @+--+-- 2. without effect and state: stateless query processor without any effect,+-- if you don't need any subscription use this one , is simple and fast+--+-- @+-- k :: a -> IO a+-- -- or+-- k :: GQLRequest -> IO GQLResponse+-- @+class Interpreter e m a b where+ interpreter ::+ Monad m =>+ (RootResCon m e query mut sub) =>+ GQLRootResolver m e query mut sub ->+ a ->+ b++instance Interpreter e m GQLRequest (m GQLResponse) where+ interpreter = statelessResolver++instance Interpreter e m (Input api) (Stream api e m) where+ interpreter root = toOutStream (coreResolver root)++instance+ (MapAPI a) =>+ Interpreter e m a (m a)+ where+ interpreter root = mapAPI (interpreter root)
+ src/Data/Morpheus/Server/Deriving/Introspect.hs view
@@ -0,0 +1,572 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++module Data.Morpheus.Server.Deriving.Introspect+ ( TypeUpdater,+ Introspect (..),+ DeriveTypeContent (..),+ IntroCon,+ updateLib,+ buildType,+ introspectObjectFields,+ deriveCustomInputObjectType,+ TypeScope (..),+ )+where++import Data.List (partition)+import Data.Map (Map)+-- MORPHEUS++import Data.Morpheus.Error (globalErrorMessage)+import Data.Morpheus.Internal.Utils+ ( empty,+ singleton,+ )+import Data.Morpheus.Kind+ ( Context (..),+ ENUM,+ GQL_KIND,+ INPUT,+ INTERFACE,+ OUTPUT,+ SCALAR,+ )+import Data.Morpheus.Server.Deriving.Utils+ ( EnumRep (..),+ conNameProxy,+ isRecordProxy,+ selNameProxy,+ )+import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..))+import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Server.Types.Types+ ( MapKind,+ Pair,+ )+import Data.Morpheus.Types.Internal.AST+ ( ANY,+ ArgumentsDefinition (..),+ DataFingerprint (..),+ DataUnion,+ FALSE,+ FieldDefinition (..),+ FieldName,+ FieldName (..),+ FieldsDefinition,+ IN,+ Message,+ Meta (..),+ OUT,+ TRUE,+ TypeCategory,+ TypeContent (..),+ TypeDefinition (..),+ TypeName (..),+ TypeRef (..),+ TypeUpdater,+ createAlias,+ createEnumValue,+ defineType,+ fieldsToArguments,+ msg,+ toAny,+ toAny,+ toListField,+ toNullableField,+ unsafeFromFields,+ updateSchema,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Failure (..),+ Resolver,+ resolveUpdates,+ )+import Data.Proxy (Proxy (..))+import Data.Semigroup ((<>))+import Data.Set (Set)+import Data.Text+ ( pack,+ )+import GHC.Generics++type IntroCon a = (GQLType a, DeriveTypeContent (CUSTOM a) a)++-- | Generates internal GraphQL Schema for query validation and introspection rendering+class Introspect a where+ isObject :: proxy a -> Bool+ default isObject :: GQLType a => proxy a -> Bool+ isObject _ = isObjectKind (Proxy @a)+ field :: proxy a -> FieldName -> FieldDefinition cat+ introspect :: proxy a -> TypeUpdater++ -----------------------------------------------+ default field ::+ GQLType a =>+ proxy a ->+ FieldName ->+ FieldDefinition cat+ field _ = buildField (Proxy @a) NoArguments++instance {-# OVERLAPPABLE #-} (GQLType a, IntrospectKind (KIND a) a) => Introspect a where+ introspect _ = introspectKind (Context :: Context (KIND a) a)++-- Maybe+instance Introspect a => Introspect (Maybe a) where+ isObject _ = False+ field _ = toNullableField . field (Proxy @a)+ introspect _ = introspect (Proxy @a)++-- List+instance Introspect a => Introspect [a] where+ isObject _ = False+ field _ = toListField . field (Proxy @a)+ introspect _ = introspect (Proxy @a)++-- Tuple+instance Introspect (Pair k v) => Introspect (k, v) where+ isObject _ = True+ field _ = field (Proxy @(Pair k v))+ introspect _ = introspect (Proxy @(Pair k v))++-- Set+instance Introspect [a] => Introspect (Set a) where+ isObject _ = False+ field _ = field (Proxy @[a])+ introspect _ = introspect (Proxy @[a])++-- Map+instance Introspect (MapKind k v Maybe) => Introspect (Map k v) where+ isObject _ = True+ field _ = field (Proxy @(MapKind k v Maybe))+ introspect _ = introspect (Proxy @(MapKind k v Maybe))++-- Resolver : a -> Resolver b+instance (GQLType b, DeriveTypeContent 'False a, Introspect b) => Introspect (a -> m b) where+ isObject _ = False+ field _ name = fieldObj {fieldArgs}+ where+ fieldObj = field (Proxy @b) name+ fieldArgs =+ fieldsToArguments $ mockFieldsDefinition $ fst $+ introspectObjectFields+ (Proxy :: Proxy 'False)+ (__typeName (Proxy @b), InputType, Proxy @a)+ introspect _ typeLib =+ resolveUpdates+ typeLib+ (introspect (Proxy @b) : inputs)+ where+ name = "Arguments for " <> __typeName (Proxy @b)+ inputs :: [TypeUpdater]+ inputs =+ snd $ introspectObjectFields (Proxy :: Proxy 'False) (name, InputType, Proxy @a)++-- GQL Resolver b, MUTATION, SUBSCRIPTION, QUERY+instance (GQLType b, Introspect b) => Introspect (Resolver fo e m b) where+ isObject _ = False+ field _ = field (Proxy @b)+ introspect _ = introspect (Proxy @b)++-- | Introspect With specific Kind: 'kind': object, scalar, enum ...+class IntrospectKind (kind :: GQL_KIND) a where+ introspectKind :: Context kind a -> TypeUpdater -- Generates internal GraphQL Schema++-- SCALAR+instance (GQLType a, GQLScalar a) => IntrospectKind SCALAR a where+ introspectKind _ = updateLib scalarType [] (Proxy @a)+ where+ scalarType = buildType $ DataScalar $ scalarValidator (Proxy @a)++-- ENUM+instance (GQL_TYPE a, EnumRep (Rep a)) => IntrospectKind ENUM a where+ introspectKind _ = updateLib enumType [] (Proxy @a)+ where+ enumType =+ buildType $ DataEnum $ map (createEnumValue . TypeName) $ enumTags (Proxy @(Rep a))++instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind INPUT a where+ introspectKind _ = derivingData (Proxy @a) InputType++instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind OUTPUT a where+ introspectKind _ = derivingData (Proxy @a) OutputType++instance (GQL_TYPE a, DeriveTypeContent (CUSTOM a) a) => IntrospectKind INTERFACE a where+ introspectKind _ = updateLib (buildType (DataInterface (mockFieldsDefinition fields) :: TypeContent TRUE OUT)) types (Proxy @a)+ where+ (fields, types) =+ introspectObjectFields+ (Proxy @(CUSTOM a))+ (baseName, OutputType, Proxy @a)+ baseName = __typeName (Proxy @a)++derivingData ::+ forall a cat.+ (GQLType a, DeriveTypeContent (CUSTOM a) a) =>+ Proxy a ->+ TypeScope cat ->+ TypeUpdater+derivingData _ scope = updateLib (buildType datatypeContent) updates (Proxy @a)+ where+ (datatypeContent, updates) =+ deriveTypeContent+ (Proxy @(CUSTOM a))+ (Proxy @a, unzip $ implements (Proxy @a), scope, baseName, baseFingerprint)+ baseName = __typeName (Proxy @a)+ baseFingerprint = __typeFingerprint (Proxy @a)++type GQL_TYPE a = (Generic a, GQLType a)++deriveCustomInputObjectType ::+ DeriveTypeContent TRUE a =>+ (TypeName, proxy a) ->+ TypeUpdater+deriveCustomInputObjectType (name, proxy) =+ flip+ resolveUpdates+ (deriveCustomObjectType (name, InputType, proxy))++deriveCustomObjectType ::+ DeriveTypeContent TRUE a =>+ (TypeName, TypeScope cat, proxy a) ->+ [TypeUpdater]+deriveCustomObjectType = snd . introspectObjectFields (Proxy :: Proxy TRUE)++introspectObjectFields ::+ DeriveTypeContent custom a =>+ proxy1 (custom :: Bool) ->+ (TypeName, TypeScope cat, proxy2 a) ->+ (FieldsDefinition cat, [TypeUpdater])+introspectObjectFields p1 (name, scope, proxy) =+ withObject name (deriveTypeContent p1 (proxy, ([], []), scope, "", DataFingerprint "" []))++withObject :: TypeName -> (TypeContent TRUE (cat :: TypeCategory), [TypeUpdater]) -> (FieldsDefinition cat2, [TypeUpdater])+withObject _ (DataObject {objectFields}, ts) = (mockFieldsDefinition objectFields, ts)+withObject _ (DataInputObject {inputObjectFields}, ts) = (mockFieldsDefinition inputObjectFields, ts)+withObject name _ = (empty, [introspectFailure (msg name <> " should have only one nonempty constructor")])++introspectFailure :: Message -> TypeUpdater+introspectFailure = const . failure . globalErrorMessage . ("invalid schema: " <>)++-- Object Fields+class DeriveTypeContent (custom :: Bool) a where+ deriveTypeContent :: proxy1 custom -> (proxy2 a, ([TypeName], [TypeUpdater]), TypeScope cat, TypeName, DataFingerprint) -> (TypeContent TRUE ANY, [TypeUpdater])++instance (TypeRep (Rep a), Generic a) => DeriveTypeContent FALSE a where+ deriveTypeContent _ (_, interfaces, scope, baseName, baseFingerprint) =+ fa $ builder $ typeRep $ Proxy @(Rep a)+ where+ fa (x, y) = (toAny x, y)+ builder [ConsRep {consFields}] = buildObject interfaces scope consFields+ builder cons = genericUnion scope cons+ where+ genericUnion InputType = buildInputUnion (baseName, baseFingerprint)+ genericUnion OutputType = buildUnionType (baseName, baseFingerprint) DataUnion (DataObject [])++buildField :: GQLType a => Proxy a -> ArgumentsDefinition -> FieldName -> FieldDefinition cat+buildField proxy fieldArgs fieldName =+ FieldDefinition+ { fieldType = createAlias $ __typeName proxy,+ fieldMeta = Nothing,+ ..+ }++buildType :: GQLType a => TypeContent TRUE cat -> Proxy a -> TypeDefinition cat+buildType typeContent proxy =+ TypeDefinition+ { typeName = __typeName proxy,+ typeFingerprint = __typeFingerprint proxy,+ typeMeta =+ Just+ Meta+ { metaDescription = description proxy,+ metaDirectives = []+ },+ typeContent+ }++updateLib ::+ GQLType a =>+ (Proxy a -> TypeDefinition cat) ->+ [TypeUpdater] ->+ Proxy a ->+ TypeUpdater+updateLib f stack proxy = updateSchema (__typeName proxy) (__typeFingerprint proxy) stack f proxy++-- NEW AUTOMATIC DERIVATION SYSTEM++data ConsRep = ConsRep+ { consName :: TypeName,+ consIsRecord :: Bool,+ consFields :: [FieldRep]+ }++data FieldRep = FieldRep+ { fieldTypeName :: TypeName,+ fieldData :: FieldDefinition ANY,+ fieldTypeUpdater :: TypeUpdater,+ fieldIsObject :: Bool+ }++data ResRep = ResRep+ { enumCons :: [TypeName],+ unionRef :: [TypeName],+ unionRecordRep :: [ConsRep]+ }++isEmpty :: ConsRep -> Bool+isEmpty ConsRep {consFields = []} = True+isEmpty _ = False++isUnionRef :: TypeName -> ConsRep -> Bool+isUnionRef baseName ConsRep {consName, consFields = [FieldRep {fieldIsObject = True, fieldTypeName}]} =+ consName == baseName <> fieldTypeName+isUnionRef _ _ = False++setFieldNames :: ConsRep -> ConsRep+setFieldNames cons@ConsRep {consFields} =+ cons+ { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields+ }+ where+ setFieldName i fieldR@FieldRep {fieldData = fieldD} = fieldR {fieldData = fieldD {fieldName}}+ where+ fieldName = FieldName ("_" <> pack (show i))++analyseRep :: TypeName -> [ConsRep] -> ResRep+analyseRep baseName cons =+ ResRep+ { enumCons = map consName enumRep,+ unionRef = map fieldTypeName $ concatMap consFields unionRefRep,+ unionRecordRep = unionRecordRep <> map setFieldNames anyonimousUnionRep+ }+ where+ (enumRep, left1) = partition isEmpty cons+ (unionRefRep, left2) = partition (isUnionRef baseName) left1+ (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2++buildInputUnion ::+ (TypeName, DataFingerprint) -> [ConsRep] -> (TypeContent TRUE IN, [TypeUpdater])+buildInputUnion (baseName, baseFingerprint) cons =+ datatype+ (analyseRep baseName cons)+ where+ datatype :: ResRep -> (TypeContent TRUE IN, [TypeUpdater])+ datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} =+ (DataEnum (map createEnumValue enumCons), types)+ datatype ResRep {unionRef, unionRecordRep, enumCons} =+ (DataInputUnion typeMembers, types <> unionTypes)+ where+ typeMembers :: [(TypeName, Bool)]+ typeMembers =+ map (,True) (unionRef <> unionMembers) <> map (,False) enumCons+ (unionMembers, unionTypes) =+ buildUnions wrapInputObject baseFingerprint unionRecordRep+ types = map fieldTypeUpdater $ concatMap consFields cons+ wrapInputObject :: (FieldsDefinition IN -> TypeContent TRUE IN)+ wrapInputObject = DataInputObject++buildUnionType ::+ (TypeName, DataFingerprint) ->+ (DataUnion -> TypeContent TRUE cat) ->+ (FieldsDefinition cat -> TypeContent TRUE cat) ->+ [ConsRep] ->+ (TypeContent TRUE cat, [TypeUpdater])+buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons =+ datatype+ (analyseRep baseName cons)+ where+ --datatype :: ResRep -> (TypeContent TRUE cat, [TypeUpdater])+ datatype ResRep {unionRef = [], unionRecordRep = [], enumCons} =+ (DataEnum (map createEnumValue enumCons), types)+ datatype ResRep {unionRef, unionRecordRep, enumCons} =+ (wrapUnion typeMembers, types <> enumTypes <> unionTypes)+ where+ typeMembers = unionRef <> enumMembers <> unionMembers+ (enumMembers, enumTypes) =+ buildUnionEnum wrapObject baseName baseFingerprint enumCons+ (unionMembers, unionTypes) =+ buildUnions wrapObject baseFingerprint unionRecordRep+ types = map fieldTypeUpdater $ concatMap consFields cons++buildObject :: ([TypeName], [TypeUpdater]) -> TypeScope cat -> [FieldRep] -> (TypeContent TRUE cat, [TypeUpdater])+buildObject (interfaces, interfaceTypes) scope consFields =+ ( wrapWith scope (mockFieldsDefinition fields),+ types <> interfaceTypes+ )+ where+ (fields, types) = buildDataObject consFields+ --- wrap with+ wrapWith :: TypeScope cat -> FieldsDefinition cat -> TypeContent TRUE cat+ wrapWith InputType = DataInputObject+ wrapWith OutputType = DataObject interfaces++buildDataObject :: [FieldRep] -> (FieldsDefinition ANY, [TypeUpdater])+buildDataObject consFields = (fields, types)+ where+ fields = unsafeFromFields $ map fieldData consFields+ types = map fieldTypeUpdater consFields++buildUnions ::+ (FieldsDefinition cat -> TypeContent TRUE cat) ->+ DataFingerprint ->+ [ConsRep] ->+ ([TypeName], [TypeUpdater])+buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons)+ where+ buildURecType consRep =+ pure+ . defineType+ (buildUnionRecord wrapObject baseFingerprint consRep)+ members = map consName cons++mockFieldsDefinition :: FieldsDefinition a -> FieldsDefinition b+mockFieldsDefinition = fmap mockFieldDefinition++mockFieldDefinition :: FieldDefinition a -> FieldDefinition b+mockFieldDefinition FieldDefinition {..} = FieldDefinition {..}++buildUnionRecord ::+ (FieldsDefinition cat -> TypeContent TRUE cat) -> DataFingerprint -> ConsRep -> TypeDefinition cat+buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} =+ TypeDefinition+ { typeName = consName,+ typeFingerprint,+ typeMeta = Nothing,+ typeContent =+ wrapObject+ $ mockFieldsDefinition+ $ unsafeFromFields+ $ map fieldData consFields+ }++buildUnionEnum ::+ (FieldsDefinition cat -> TypeContent TRUE cat) ->+ TypeName ->+ DataFingerprint ->+ [TypeName] ->+ ([TypeName], [TypeUpdater])+buildUnionEnum wrapObject baseName baseFingerprint enums = (members, updates)+ where+ members+ | null enums = []+ | otherwise = [enumTypeWrapperName]+ enumTypeName = baseName <> "Enum"+ enumTypeWrapperName = enumTypeName <> "Object"+ -------------------------+ updates :: [TypeUpdater]+ updates+ | null enums =+ []+ | otherwise =+ [ buildEnumObject+ wrapObject+ enumTypeWrapperName+ baseFingerprint+ enumTypeName,+ buildEnum enumTypeName baseFingerprint enums+ ]++buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> TypeUpdater+buildEnum typeName typeFingerprint tags =+ pure+ . defineType+ TypeDefinition+ { typeMeta = Nothing,+ typeContent = DataEnum $ map createEnumValue tags,+ ..+ }++buildEnumObject ::+ (FieldsDefinition cat -> TypeContent TRUE cat) ->+ TypeName ->+ DataFingerprint ->+ TypeName ->+ TypeUpdater+buildEnumObject wrapObject typeName typeFingerprint enumTypeName =+ pure+ . defineType+ TypeDefinition+ { typeName,+ typeFingerprint,+ typeMeta = Nothing,+ typeContent =+ wrapObject $+ singleton+ FieldDefinition+ { fieldName = "enum",+ fieldArgs = NoArguments,+ fieldType = createAlias enumTypeName,+ fieldMeta = Nothing+ }+ }++data TypeScope (cat :: TypeCategory) where+ InputType :: TypeScope IN+ OutputType :: TypeScope OUT++deriving instance Show (TypeScope cat)++deriving instance Eq (TypeScope cat)++deriving instance Ord (TypeScope cat)++-- GENERIC UNION+class TypeRep f where+ typeRep :: Proxy f -> [ConsRep]++instance TypeRep f => TypeRep (M1 D d f) where+ typeRep _ = typeRep (Proxy @f)++-- | recursion for Object types, both of them : 'INPUT_OBJECT' and 'OBJECT'+instance (TypeRep a, TypeRep b) => TypeRep (a :+: b) where+ typeRep _ = typeRep (Proxy @a) <> typeRep (Proxy @b)++instance (ConRep f, Constructor c) => TypeRep (M1 C c f) where+ typeRep _ =+ [ ConsRep+ { consName = conNameProxy (Proxy @c),+ consFields = conRep (Proxy @f),+ consIsRecord = isRecordProxy (Proxy @c)+ }+ ]++class ConRep f where+ conRep :: Proxy f -> [FieldRep]++-- | recursion for Object types, both of them : 'UNION' and 'INPUT_UNION'+instance (ConRep a, ConRep b) => ConRep (a :*: b) where+ conRep _ = conRep (Proxy @a) <> conRep (Proxy @b)++instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where+ conRep _ =+ [ FieldRep+ { fieldTypeName = typeConName $ fieldType fieldData,+ fieldData = fieldData,+ fieldTypeUpdater = introspect (Proxy @a),+ fieldIsObject = isObject (Proxy @a)+ }+ ]+ where+ name = selNameProxy (Proxy @s)+ fieldData = field (Proxy @a) name++instance ConRep U1 where+ conRep _ = []
+ src/Data/Morpheus/Server/Deriving/Resolve.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Data.Morpheus.Server.Deriving.Resolve+ ( statelessResolver,+ RootResCon,+ fullSchema,+ coreResolver,+ EventCon,+ )+where++import Data.Functor.Identity (Identity (..))+-- MORPHEUS++import Data.Morpheus.Core+ ( runApi,+ )+import Data.Morpheus.Server.Deriving.Encode+ ( EncodeCon,+ deriveModel,+ )+import Data.Morpheus.Server.Deriving.Introspect+ ( IntroCon,+ TypeScope (..),+ introspectObjectFields,+ )+import Data.Morpheus.Server.Types.GQLType (GQLType (CUSTOM))+import Data.Morpheus.Types+ ( GQLRootResolver (..),+ )+import Data.Morpheus.Types.IO+ ( GQLRequest (..),+ GQLResponse (..),+ renderResponse,+ )+import Data.Morpheus.Types.Internal.AST+ ( DataFingerprint (..),+ FieldsDefinition,+ MUTATION,+ OUT,+ QUERY,+ SUBSCRIPTION,+ Schema (..),+ TypeContent (..),+ TypeDefinition (..),+ TypeName,+ ValidValue,+ initTypeLib,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ GQLChannel (..),+ Resolver,+ ResponseStream,+ ResultT (..),+ cleanEvents,+ resolveUpdates,+ )+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)++type EventCon event =+ (Eq (StreamChannel event), Typeable event, GQLChannel event)++type IntrospectConstraint m event query mutation subscription =+ ( IntroCon (query (Resolver QUERY event m)),+ IntroCon (mutation (Resolver MUTATION event m)),+ IntroCon (subscription (Resolver SUBSCRIPTION event m))+ )++type RootResCon m event query mutation subscription =+ ( EventCon event,+ Typeable m,+ IntrospectConstraint m event query mutation subscription,+ EncodeCon QUERY event m (query (Resolver QUERY event m)),+ EncodeCon MUTATION event m (mutation (Resolver MUTATION event m)),+ EncodeCon+ SUBSCRIPTION+ event+ m+ (subscription (Resolver SUBSCRIPTION event m))+ )++statelessResolver ::+ (Monad m, RootResCon m event query mut sub) =>+ GQLRootResolver m event query mut sub ->+ GQLRequest ->+ m GQLResponse+statelessResolver root req =+ renderResponse <$> runResultT (coreResolver root req)++coreResolver ::+ forall event m query mut sub.+ (Monad m, RootResCon m event query mut sub) =>+ GQLRootResolver m event query mut sub ->+ GQLRequest ->+ ResponseStream event m ValidValue+coreResolver root request =+ validRequest+ >>= execOperator+ where+ validRequest ::+ Monad m => ResponseStream event m Schema+ validRequest = cleanEvents $ ResultT $ pure $ fullSchema $ Identity root+ --------------------------------------+ execOperator schema = runApi schema (deriveModel root) request++fullSchema ::+ forall proxy m event query mutation subscription.+ (IntrospectConstraint m event query mutation subscription) =>+ proxy (GQLRootResolver m event query mutation subscription) ->+ Eventless Schema+fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema+ where+ querySchema =+ resolveUpdates (initTypeLib (operatorType fields "Query")) types+ where+ (fields, types) =+ introspectObjectFields+ (Proxy @(CUSTOM (query (Resolver QUERY event m))))+ ("type for query", OutputType, Proxy @(query (Resolver QUERY event m)))+ ------------------------------+ mutationSchema lib =+ resolveUpdates+ (lib {mutation = maybeOperator fields "Mutation"})+ types+ where+ (fields, types) =+ introspectObjectFields+ (Proxy @(CUSTOM (mutation (Resolver MUTATION event m))))+ ( "type for mutation",+ OutputType,+ Proxy @(mutation (Resolver MUTATION event m))+ )+ ------------------------------+ subscriptionSchema lib =+ resolveUpdates+ (lib {subscription = maybeOperator fields "Subscription"})+ types+ where+ (fields, types) =+ introspectObjectFields+ (Proxy @(CUSTOM (subscription (Resolver SUBSCRIPTION event m))))+ ( "type for subscription",+ OutputType,+ Proxy @(subscription (Resolver SUBSCRIPTION event m))+ )+ maybeOperator :: FieldsDefinition OUT -> TypeName -> Maybe (TypeDefinition OUT)+ maybeOperator fields+ | null fields = const Nothing+ | otherwise = Just . operatorType fields+ -------------------------------------------------+ operatorType :: FieldsDefinition OUT -> TypeName -> TypeDefinition OUT+ operatorType fields typeName =+ TypeDefinition+ { typeContent = DataObject [] fields,+ typeName,+ typeFingerprint = DataFingerprint typeName [],+ typeMeta = Nothing+ }
+ src/Data/Morpheus/Server/Deriving/Utils.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Server.Deriving.Utils+ ( EnumRep (..),+ datatypeNameProxy,+ conNameProxy,+ selNameProxy,+ isRecordProxy,+ )+where++import Data.Morpheus.Types.Internal.AST+ ( FieldName,+ FieldName (..),+ TypeName (..),+ convertToJSONName,+ )+import Data.Proxy (Proxy (..))+import Data.Text+ ( Text,+ pack,+ )+import GHC.Generics++-- MORPHEUS+class EnumRep (f :: * -> *) where+ enumTags :: Proxy f -> [Text]++instance EnumRep f => EnumRep (M1 D c f) where+ enumTags _ = enumTags (Proxy @f)++instance (Constructor c) => EnumRep (M1 C c U1) where+ enumTags _ = [pack $ conName (undefined :: (M1 C c U1 x))]++instance (EnumRep a, EnumRep b) => EnumRep (a :+: b) where+ enumTags _ = enumTags (Proxy @a) ++ enumTags (Proxy @b)++datatypeNameProxy :: forall f (d :: Meta). Datatype d => f d -> TypeName+datatypeNameProxy _ = TypeName $ pack $ datatypeName (undefined :: (M1 D d f a))++conNameProxy :: forall f (c :: Meta). Constructor c => f c -> TypeName+conNameProxy _ = TypeName $ pack $ conName (undefined :: M1 C c U1 a)++selNameProxy :: forall f (s :: Meta). Selector s => f s -> FieldName+selNameProxy _ = convertToJSONName $ FieldName $ pack $ selName (undefined :: M1 S s f a)++isRecordProxy :: forall f (c :: Meta). Constructor c => f c -> Bool+isRecordProxy _ = conIsRecord (undefined :: (M1 C c f a))
+ src/Data/Morpheus/Server/Document/Compile.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE NamedFieldPuns #-}++module Data.Morpheus.Server.Document.Compile+ ( compileDocument,+ gqlDocument,+ gqlDocumentNamespace,+ )+where++--+-- Morpheus++import Data.Morpheus.Core+ ( parseTypeDefinitions,+ )+import Data.Morpheus.Error+ ( gqlWarnings,+ renderGQLErrors,+ )+import Data.Morpheus.Server.Document.Convert+ ( toTHDefinitions,+ )+import Data.Morpheus.Server.Document.Declare+ ( declare,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Result (..),+ )+import qualified Data.Text as T+ ( pack,+ )+import Language.Haskell.TH+import Language.Haskell.TH.Quote++gqlDocumentNamespace :: QuasiQuoter+gqlDocumentNamespace =+ QuasiQuoter+ { quoteExp = notHandled "Expressions",+ quotePat = notHandled "Patterns",+ quoteType = notHandled "Types",+ quoteDec = compileDocument True+ }+ where+ notHandled things =+ error $ things ++ " are not supported by the GraphQL QuasiQuoter"++gqlDocument :: QuasiQuoter+gqlDocument =+ QuasiQuoter+ { quoteExp = notHandled "Expressions",+ quotePat = notHandled "Patterns",+ quoteType = notHandled "Types",+ quoteDec = compileDocument False+ }+ where+ notHandled things =+ error $ things ++ " are not supported by the GraphQL QuasiQuoter"++compileDocument :: Bool -> String -> Q [Dec]+compileDocument namespace documentTXT =+ case parseTypeDefinitions (T.pack documentTXT) of+ Failure errors -> fail (renderGQLErrors errors)+ Success {result = schema, warnings} ->+ gqlWarnings warnings >> toTHDefinitions namespace schema >>= declare namespace
+ src/Data/Morpheus/Server/Document/Convert.hs view
@@ -0,0 +1,205 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Server.Document.Convert+ ( toTHDefinitions,+ )+where++-- MORPHEUS+import Data.Morpheus.Internal.TH+ ( infoTyVars,+ mkTypeName,+ )+import Data.Morpheus.Internal.Utils+ ( capitalTypeName,+ elems,+ singleton,+ )+import Data.Morpheus.Types.Internal.AST+ ( ANY,+ ArgumentsDefinition (..),+ ConsD,+ DataTypeKind (..),+ FieldDefinition (..),+ FieldName,+ FieldsDefinition,+ GQLTypeD (..),+ OUT,+ TRUE,+ TypeContent (..),+ TypeD (..),+ TypeDefinition (..),+ TypeName,+ TypeRef (..),+ argumentsToFields,+ hasArguments,+ hsTypeName,+ kindOf,+ lookupWith,+ mkCons,+ mkConsEnum,+ toFieldName,+ )+import Data.Semigroup ((<>))+import Language.Haskell.TH++m_ :: TypeName+m_ = "m"++getTypeArgs :: TypeName -> [TypeDefinition ANY] -> Q (Maybe TypeName)+getTypeArgs "__TypeKind" _ = pure Nothing+getTypeArgs "Boolean" _ = pure Nothing+getTypeArgs "String" _ = pure Nothing+getTypeArgs "Int" _ = pure Nothing+getTypeArgs "Float" _ = pure Nothing+getTypeArgs key lib = case typeContent <$> lookupWith typeName key lib of+ Just x -> pure (kindToTyArgs x)+ Nothing -> getTyArgs <$> reify (mkTypeName key)++getTyArgs :: Info -> Maybe TypeName+getTyArgs x+ | null (infoTyVars x) = Nothing+ | otherwise = Just m_++kindToTyArgs :: TypeContent TRUE ANY -> Maybe TypeName+kindToTyArgs DataObject {} = Just m_+kindToTyArgs DataUnion {} = Just m_+kindToTyArgs DataInterface {} = Just m_+kindToTyArgs _ = Nothing++toTHDefinitions :: Bool -> [TypeDefinition ANY] -> Q [GQLTypeD]+toTHDefinitions namespace lib = traverse renderTHType lib+ where+ renderTHType :: TypeDefinition ANY -> Q GQLTypeD+ renderTHType x = generateType x+ where+ genArgsTypeName :: FieldName -> TypeName+ genArgsTypeName fieldName+ | namespace = hsTypeName (typeName x) <> argTName+ | otherwise = argTName+ where+ argTName = capitalTypeName (fieldName <> "Args")+ ---------------------------------------------------------------------------------------------+ genResField :: FieldDefinition OUT -> Q (FieldDefinition OUT)+ genResField field@FieldDefinition {fieldName, fieldArgs, fieldType = typeRef@TypeRef {typeConName}} =+ do+ typeArgs <- getTypeArgs typeConName lib+ pure $+ field+ { fieldType = typeRef {typeConName = hsTypeName typeConName, typeArgs},+ fieldArgs = fieldArguments+ }+ where+ fieldArguments+ | hasArguments fieldArgs = fieldArgs {argumentsTypename = Just $ genArgsTypeName fieldName}+ | otherwise = fieldArgs+ --------------------------------------------+ generateType :: TypeDefinition ANY -> Q GQLTypeD+ generateType typeOriginal@TypeDefinition {typeName, typeContent, typeMeta} =+ genType+ typeContent+ where+ buildType :: [ConsD] -> TypeD+ buildType tCons =+ TypeD+ { tName = hsTypeName typeName,+ tMeta = typeMeta,+ tNamespace = [],+ tCons,+ tKind+ }+ buildObjectCons :: FieldsDefinition cat -> [ConsD]+ buildObjectCons fields = [mkCons typeName fields]+ tKind = kindOf typeOriginal+ genType :: TypeContent TRUE ANY -> Q GQLTypeD+ genType (DataEnum tags) =+ pure+ GQLTypeD+ { typeD =+ TypeD+ { tName = hsTypeName typeName,+ tNamespace = [],+ tCons = map mkConsEnum tags,+ tMeta = typeMeta,+ tKind+ },+ typeArgD = [],+ ..+ }+ genType DataScalar {} = fail "Scalar Types should defined By Native Haskell Types"+ genType DataInputUnion {} = fail "Input Unions not Supported"+ genType DataInterface {interfaceFields} = do+ typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (elems interfaceFields)+ objCons <- buildObjectCons <$> traverse genResField interfaceFields+ pure+ GQLTypeD+ { typeD = buildType objCons,+ typeArgD,+ ..+ }+ genType (DataInputObject fields) =+ pure+ GQLTypeD+ { typeD = buildType $ buildObjectCons fields,+ typeArgD = [],+ ..+ }+ genType DataObject {objectFields} = do+ typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (elems objectFields)+ objCons <- buildObjectCons <$> traverse genResField objectFields+ pure+ GQLTypeD+ { typeD = buildType objCons,+ typeArgD,+ ..+ }+ genType (DataUnion members) =+ pure+ GQLTypeD+ { typeD = buildType (map unionCon members),+ typeArgD = [],+ ..+ }+ where+ unionCon memberName =+ mkCons+ cName+ ( singleton+ FieldDefinition+ { fieldName = "un" <> toFieldName cName,+ fieldType =+ TypeRef+ { typeConName = utName,+ typeArgs = Just m_,+ typeWrappers = []+ },+ fieldMeta = Nothing,+ fieldArgs = NoArguments+ }+ )+ where+ cName = hsTypeName typeName <> utName+ utName = hsTypeName memberName++genArgumentType :: (FieldName -> TypeName) -> FieldDefinition OUT -> Q [TypeD]+genArgumentType _ FieldDefinition {fieldArgs = NoArguments} = pure []+genArgumentType namespaceWith FieldDefinition {fieldName, fieldArgs} =+ pure+ [ TypeD+ { tName,+ tNamespace = [],+ tCons =+ [ mkCons tName (argumentsToFields fieldArgs)+ ],+ tMeta = Nothing,+ tKind = KindInputObject+ }+ ]+ where+ tName = hsTypeName (namespaceWith fieldName)
+ src/Data/Morpheus/Server/Document/Declare.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Server.Document.Declare+ ( declare,+ )+where++-- MORPHEUS++import Data.Morpheus.Internal.TH+ ( Scope (..),+ declareType,+ )+import Data.Morpheus.Server.Document.Decode+ ( deriveDecode,+ )+import Data.Morpheus.Server.Document.Encode+ ( deriveEncode,+ )+import Data.Morpheus.Server.Document.GQLType+ ( deriveGQLType,+ )+import Data.Morpheus.Server.Document.Introspect+ ( deriveObjectRep,+ instanceIntrospect,+ )+import Data.Morpheus.Types.Internal.AST+ ( GQLTypeD (..),+ TypeD (..),+ isInput,+ isObject,+ )+import Data.Semigroup ((<>))+import Language.Haskell.TH++class Declare a where+ type DeclareCtx a :: *+ declare :: DeclareCtx a -> a -> Q [Dec]++instance Declare a => Declare [a] where+ type DeclareCtx [a] = DeclareCtx a+ declare namespace = fmap concat . traverse (declare namespace)++instance Declare GQLTypeD where+ type DeclareCtx GQLTypeD = Bool+ declare namespace gqlType@GQLTypeD {typeD = typeD@TypeD {tKind}, typeArgD, typeOriginal} =+ do+ mainType <- declareMainType+ argTypes <- declareArgTypes+ gqlInstances <- deriveGQLInstances+ typeClasses <- deriveGQLType gqlType+ introspectEnum <- instanceIntrospect typeOriginal+ pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum+ where+ deriveGQLInstances = concat <$> sequence gqlInstances+ where+ gqlInstances+ | isObject tKind && isInput tKind =+ [deriveObjectRep (typeD, Just typeOriginal, Nothing), deriveDecode typeD]+ | isObject tKind =+ [deriveObjectRep (typeD, Just typeOriginal, Just tKind), deriveEncode typeD]+ | otherwise =+ []+ --------------------------------------------------+ declareArgTypes = do+ introspectArgs <- concat <$> traverse deriveArgsRep typeArgD+ decodeArgs <- concat <$> traverse deriveDecode typeArgD+ return $ argsTypeDecs <> decodeArgs <> introspectArgs+ where+ deriveArgsRep args = deriveObjectRep (args, Nothing, Nothing)+ ----------------------------------------------------+ argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD+ --------------------------------------------------+ declareMainType = declareT+ where+ declareT =+ pure [declareType SERVER namespace (Just tKind) derivingClasses typeD]+ derivingClasses+ | isInput tKind = [''Show]+ | otherwise = []
+ src/Data/Morpheus/Server/Document/Decode.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.Document.Decode+ ( deriveDecode,+ )+where++--+-- MORPHEUS++import Data.Morpheus.Internal.TH+ ( instanceHeadT,+ nameVarP,+ )+import Data.Morpheus.Server.Deriving.Decode+ ( Decode (..),+ DecodeType (..),+ )+import Data.Morpheus.Server.Internal.TH.Decode+ ( decodeFieldWith,+ decodeObjectExpQ,+ withObject,+ )+import Data.Morpheus.Types.Internal.AST+ ( FieldName,+ TypeD (..),+ ValidValue,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ )+import Language.Haskell.TH++(.:) :: Decode a => ValidValue -> FieldName -> Eventless a+value .: selectorName = withObject (decodeFieldWith decode selectorName) value++deriveDecode :: TypeD -> Q [Dec]+deriveDecode TypeD {tName, tCons = [cons]} =+ pure <$> instanceD (cxt []) appHead methods+ where+ appHead = instanceHeadT ''DecodeType tName []+ methods = [funD 'decodeType [clause argsE (normalB body) []]]+ where+ argsE = map nameVarP ["o"]+ body = decodeObjectExpQ [|(.:)|] cons+deriveDecode _ = pure []
+ src/Data/Morpheus/Server/Document/Encode.hs view
@@ -0,0 +1,131 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.Document.Encode+ ( deriveEncode,+ )+where++--+-- MORPHEUS++import Data.Morpheus.Internal.TH+ ( applyT,+ destructRecord,+ instanceHeadMultiT,+ mkTypeName,+ nameStringE,+ nameVarE,+ nameVarP,+ nameVarT,+ typeT,+ )+import Data.Morpheus.Server.Deriving.Encode+ ( Encode (..),+ ExploreResolvers (..),+ )+import Data.Morpheus.Server.Types.GQLType (TRUE)+import Data.Morpheus.Types.Internal.AST+ ( ConsD (..),+ FieldDefinition (..),+ QUERY,+ SUBSCRIPTION,+ TypeD (..),+ TypeName (..),+ isSubscription,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( LiftOperation,+ MapStrategy (..),+ ObjectResModel (..),+ ResModel (..),+ Resolver,+ )+import Data.Semigroup ((<>))+import Data.Typeable (Typeable)+import Language.Haskell.TH++m_ :: TypeName+m_ = "m"++fo_ :: TypeName+fo_ = "fieldOperationKind"++po_ :: TypeName+po_ = "parentOparation"++e_ :: TypeName+e_ = "encodeEvent"++encodeVars :: [TypeName]+encodeVars = [e_, m_]++encodeVarsT :: [TypeQ]+encodeVarsT = map nameVarT encodeVars++deriveEncode :: TypeD -> Q [Dec]+deriveEncode TypeD {tName, tCons = [ConsD {cFields}], tKind} =+ pure <$> instanceD (cxt constrains) appHead methods+ where+ subARgs = conT ''SUBSCRIPTION : encodeVarsT+ instanceArgs+ | isSubscription tKind = subARgs+ | otherwise = map nameVarT (po_ : encodeVars)+ mainType = applyT (mkTypeName tName) [mainTypeArg]+ where+ mainTypeArg+ | isSubscription tKind = applyT ''Resolver subARgs+ | otherwise = typeT ''Resolver (fo_ : encodeVars)+ -----------------------------------------------------------------------------------------+ typeables+ | isSubscription tKind =+ [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]+ | otherwise =+ [ iLiftOp po_,+ iLiftOp fo_,+ typeT ''MapStrategy [fo_, po_],+ iTypeable fo_,+ iTypeable po_+ ]+ -------------------------+ iLiftOp op = applyT ''LiftOperation [nameVarT op]+ -------------------------+ iTypeable name = typeT ''Typeable [name]+ -------------------------------------------+ -- defines Constraint: (Typeable m, Monad m)+ constrains =+ typeables+ <> [ typeT ''Monad [m_],+ applyT ''Encode (mainType : instanceArgs),+ iTypeable e_,+ iTypeable m_+ ]+ -------------------------------------------------------------------+ -- defines: instance <constraint> => ObjectResolvers ('TRUE) (<Type> (ResolveT m)) (ResolveT m value) where+ appHead =+ instanceHeadMultiT+ ''ExploreResolvers+ (conT ''TRUE)+ (mainType : instanceArgs)+ ------------------------------------------------------------------+ -- defines: objectResolvers <Type field1 field2 ...> = [("field1",encode field1),("field2",encode field2), ...]+ methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]+ where+ argsE = [nameVarP "_", destructRecord tName varNames]+ body =+ appE (varE 'pure)+ $ appE+ (conE 'ResObject)+ $ appE+ ( appE+ (conE 'ObjectResModel)+ (nameStringE tName)+ )+ (listE $ map decodeVar varNames)+ decodeVar name = [|(name, encode $(varName))|]+ where+ varName = nameVarE name+ varNames = map fieldName cFields+deriveEncode _ = pure []
+ src/Data/Morpheus/Server/Document/GQLType.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.Document.GQLType+ ( deriveGQLType,+ )+where++--+-- MORPHEUS+import Data.Morpheus.Internal.TH+ ( instanceHeadT,+ instanceProxyFunD,+ mkTypeName,+ tyConArgs,+ typeInstanceDec,+ typeT,+ )+import Data.Morpheus.Kind+ ( ENUM,+ INPUT,+ INTERFACE,+ OUTPUT,+ SCALAR,+ WRAPPER,+ )+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ TRUE,+ )+import Data.Morpheus.Types (Resolver, interface)+import Data.Morpheus.Types.Internal.AST+ ( ANY,+ DataTypeKind (..),+ GQLTypeD (..),+ Meta (..),+ QUERY,+ TypeContent (..),+ TypeD (..),+ TypeDefinition (..),+ TypeName,+ isObject,+ )+import Data.Proxy (Proxy (..))+import Data.Semigroup ((<>))+import Data.Typeable (Typeable)+import Language.Haskell.TH++interfaceF :: Name -> ExpQ+interfaceF name = [|interface (Proxy :: (Proxy ($(conT name) (Resolver QUERY () Maybe))))|]++introspectInterface :: TypeName -> ExpQ+introspectInterface = interfaceF . mkTypeName++deriveGQLType :: GQLTypeD -> Q [Dec]+deriveGQLType GQLTypeD {typeD = TypeD {tName, tMeta, tKind}, typeOriginal} =+ pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)+ where+ functions =+ map+ instanceProxyFunD+ [ ('__typeName, [|tName|]),+ ('description, descriptionValue),+ ('implements, implementsFunc)+ ]+ where+ implementsFunc = listE $ map introspectInterface (interfacesFrom (Just typeOriginal))+ descriptionValue = case tMeta >>= metaDescription of+ Nothing -> [|Nothing|]+ Just desc -> [|Just desc|]+ --------------------------------+ typeArgs = tyConArgs tKind+ --------------------------------+ iHead = instanceHeadT ''GQLType tName typeArgs+ headSig = typeT (mkTypeName tName) typeArgs+ ---------------------------------------------------+ constrains = map conTypeable typeArgs+ where+ conTypeable name = typeT ''Typeable [name]+ -------------------------------------------------+ typeFamilies+ | isObject tKind = [deriveKIND, deriveCUSTOM]+ | otherwise = [deriveKIND]+ where+ deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE+ deriveKIND = deriveInstance ''KIND (kindName tKind)+ -------------------------------------------------------+ deriveInstance :: Name -> Name -> Q Dec+ deriveInstance insName tyName = do+ typeN <- headSig+ pure $ typeInstanceDec insName typeN (ConT tyName)++kindName :: DataTypeKind -> Name+kindName KindObject {} = ''OUTPUT+kindName KindScalar = ''SCALAR+kindName KindEnum = ''ENUM+kindName KindUnion = ''OUTPUT+kindName KindInputObject = ''INPUT+kindName KindList = ''WRAPPER+kindName KindNonNull = ''WRAPPER+kindName KindInputUnion = ''INPUT+kindName KindInterface = ''INTERFACE++interfacesFrom :: Maybe (TypeDefinition ANY) -> [TypeName]+interfacesFrom (Just TypeDefinition {typeContent = DataObject {objectImplements}}) = objectImplements+interfacesFrom _ = []
+ src/Data/Morpheus/Server/Document/Introspect.hs view
@@ -0,0 +1,135 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.Document.Introspect+ ( deriveObjectRep,+ instanceIntrospect,+ )+where++import Data.Maybe (maybeToList)+-- MORPHEUS+import Data.Morpheus.Internal.TH+ ( instanceFunD,+ instanceHeadMultiT,+ instanceHeadT,+ instanceProxyFunD,+ mkTypeName,+ nameConT,+ nameVarT,+ tyConArgs,+ typeT,+ )+import Data.Morpheus.Server.Deriving.Introspect+ ( DeriveTypeContent (..),+ Introspect (..),+ deriveCustomInputObjectType,+ )+import Data.Morpheus.Server.Types.GQLType+ ( GQLType (__typeName, implements),+ TRUE,+ )+import Data.Morpheus.Types.Internal.AST+ ( ANY,+ ArgumentsDefinition (..),+ ConsD (..),+ DataTypeKind (..),+ FieldDefinition (..),+ TypeContent (..),+ TypeD (..),+ TypeDefinition (..),+ TypeName,+ TypeRef (..),+ TypeUpdater,+ insertType,+ unsafeFromFields,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( resolveUpdates,+ )+import Data.Proxy (Proxy (..))+import Data.Typeable (Typeable)+import Language.Haskell.TH++instanceIntrospect :: TypeDefinition cat -> Q [Dec]+instanceIntrospect TypeDefinition {typeName, typeContent = DataEnum enumType, ..}+ -- FIXME: dirty fix for introspection+ | typeName `elem` ["__DirectiveLocation", "__TypeKind"] = pure []+ | otherwise = pure <$> instanceD (cxt []) iHead [defineIntrospect]+ where+ iHead = instanceHeadT ''Introspect typeName []+ defineIntrospect = instanceProxyFunD ('introspect, body)+ where+ body = [|insertType TypeDefinition {typeContent = DataEnum enumType, ..}|]+instanceIntrospect _ = pure []++-- [(FieldDefinition, TypeUpdater)]+deriveObjectRep :: (TypeD, Maybe (TypeDefinition ANY), Maybe DataTypeKind) -> Q [Dec]+deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, _, tKind) =+ pure <$> instanceD (cxt constrains) iHead methods+ where+ mainTypeName = typeT (mkTypeName tName) typeArgs+ typeArgs = concatMap tyConArgs (maybeToList tKind)+ constrains = map conTypeable typeArgs+ where+ conTypeable name = typeT ''Typeable [name]+ -----------------------------------------------+ iHead = instanceHeadMultiT ''DeriveTypeContent (conT ''TRUE) [mainTypeName]+ methods = [instanceFunD 'deriveTypeContent ["_proxy1", "_proxy2"] body]+ where+ body+ | tKind == Just KindInputObject || null tKind =+ [|+ ( DataInputObject+ (unsafeFromFields $(buildFields cFields)),+ $(typeUpdates)+ )+ |]+ | otherwise =+ [|+ ( DataObject+ (interfaceNames $(proxy))+ (unsafeFromFields $(buildFields cFields)),+ interfaceTypes $(proxy)+ : $(typeUpdates)+ )+ |]+ -------------------------------------------------------------+ typeUpdates = buildTypes cFields+ proxy = [|(Proxy :: Proxy $(mainTypeName))|]+deriveObjectRep _ = pure []++interfaceNames :: GQLType a => Proxy a -> [TypeName]+interfaceNames = map fst . implements++interfaceTypes :: GQLType a => Proxy a -> TypeUpdater+interfaceTypes = flip resolveUpdates . map snd . implements++buildTypes :: [FieldDefinition cat] -> ExpQ+buildTypes = listE . concatMap introspectField++introspectField :: FieldDefinition cat -> [ExpQ]+introspectField FieldDefinition {fieldType, fieldArgs} =+ [|introspect $(proxyT fieldType)|] : inputTypes fieldArgs+ where+ inputTypes :: ArgumentsDefinition -> [ExpQ]+ inputTypes ArgumentsDefinition {argumentsTypename = Just argsTypeName}+ | argsTypeName /= "()" = [[|deriveCustomInputObjectType (argsTypeName, $(proxyT tAlias))|]]+ where+ tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}+ inputTypes _ = []++proxyT :: TypeRef -> Q Exp+proxyT TypeRef {typeConName, typeArgs} = [|(Proxy :: Proxy $(genSig typeArgs))|]+ where+ genSig (Just m) = appT (nameConT typeConName) (nameVarT m)+ genSig _ = nameConT typeConName++buildFields :: [FieldDefinition cat] -> ExpQ+buildFields = listE . map buildField+ where+ buildField f@FieldDefinition {fieldType} = [|f {fieldType = fieldType {typeConName = __typeName $(proxyT fieldType)}}|]
+ src/Data/Morpheus/Server/Internal/TH/Decode.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Data.Morpheus.Server.Internal.TH.Decode+ ( withObject,+ withMaybe,+ withList,+ withEnum,+ withUnion,+ decodeFieldWith,+ decodeObjectExpQ,+ )+where++-- MORPHEUS+import Data.Morpheus.Error+ ( internalTypeMismatch,+ )+import Data.Morpheus.Internal.TH+ ( nameConE,+ nameVarE,+ )+import Data.Morpheus.Internal.Utils+ ( empty,+ selectBy,+ selectOr,+ )+import Data.Morpheus.Types.Internal.AST+ ( ConsD (..),+ FieldDefinition (..),+ FieldName,+ Message,+ ObjectEntry (..),+ TypeName (..),+ ValidObject,+ ValidValue,+ Value (..),+ toFieldName,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Eventless,+ Failure (..),+ )+import Language.Haskell.TH+ ( ExpQ,+ uInfixE,+ varE,+ )++decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ+decodeObjectExpQ fieldDecoder ConsD {cName, cFields} = handleFields cFields+ where+ consName = nameConE cName+ ----------------------------------------------------------------------------------+ handleFields fNames = uInfixE consName (varE '(<$>)) (applyFields fNames)+ where+ applyFields [] = fail "No Empty fields"+ applyFields [x] = defField x+ applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)+ ------------------------------------------------------------------------+ defField FieldDefinition {fieldName} =+ uInfixE+ (nameVarE "o")+ fieldDecoder+ [|fieldName|]++withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a+withObject f (Object object) = f object+withObject _ isType = internalTypeMismatch "Object" isType++withMaybe :: Monad m => (ValidValue -> m a) -> ValidValue -> m (Maybe a)+withMaybe _ Null = pure Nothing+withMaybe decode x = Just <$> decode x++withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a]+withList decode (List li) = traverse decode li+withList _ isType = internalTypeMismatch "List" isType++withEnum :: (TypeName -> Eventless a) -> ValidValue -> Eventless a+withEnum decode (Enum value) = decode value+withEnum _ isType = internalTypeMismatch "Enum" isType++withUnion :: (TypeName -> ValidObject -> ValidObject -> Eventless a) -> ValidObject -> Eventless a+withUnion decoder unions = do+ (enum :: ValidValue) <- entryValue <$> selectBy ("__typename not found on Input Union" :: Message) "__typename" unions+ case enum of+ (Enum key) -> selectOr notfound onFound (toFieldName key) unions+ where+ notfound = withObject (decoder key unions) (Object empty)+ onFound = withObject (decoder key unions) . entryValue+ _ -> failure ("__typename must be Enum" :: Message)++decodeFieldWith :: (ValidValue -> Eventless a) -> FieldName -> ValidObject -> Eventless a+decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue)
+ src/Data/Morpheus/Server/Types/GQLScalar.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Morpheus.Server.Types.GQLScalar+ ( GQLScalar (..),+ toScalar,+ )+where++import Data.Morpheus.Types.Internal.AST+ ( ScalarDefinition (..),+ ScalarValue (..),+ ValidValue,+ Value (..),+ )+import Data.Proxy (Proxy (..))+import Data.Text (Text)++toScalar :: ValidValue -> Either Text ScalarValue+toScalar (Scalar x) = pure x+toScalar _ = Left ""++-- | GraphQL Scalar+--+-- 'parseValue' and 'serialize' should be provided for every instances manually+class GQLScalar a where+ -- | value parsing and validating+ --+ -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'+ --+ -- invalid values can be reported with 'Left' constructor :+ --+ -- @+ -- parseValue String _ = Left "" -- without error message+ -- -- or+ -- parseValue String _ = Left "Error Message"+ -- @+ parseValue :: ScalarValue -> Either Text a++ -- | serialization of haskell type into scalar value+ serialize :: a -> ScalarValue++ scalarValidator :: Proxy a -> ScalarDefinition+ scalarValidator _ = ScalarDefinition {validateValue = validator}+ where+ validator value = do+ scalarValue' <- toScalar value+ (_ :: a) <- parseValue scalarValue'+ return value++instance GQLScalar Text where+ parseValue (String x) = pure x+ parseValue _ = Left ""+ serialize = String++instance GQLScalar Bool where+ parseValue (Boolean x) = pure x+ parseValue _ = Left ""+ serialize = Boolean++instance GQLScalar Int where+ parseValue (Int x) = pure x+ parseValue _ = Left ""+ serialize = Int++instance GQLScalar Float where+ parseValue (Float x) = pure x+ parseValue (Int x) = pure $ fromInteger $ toInteger x+ parseValue _ = Left ""+ serialize = Float
+ src/Data/Morpheus/Server/Types/GQLType.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++module Data.Morpheus.Server.Types.GQLType+ ( GQLType (..),+ TRUE,+ FALSE,+ )+where++import Data.Map (Map)+-- MORPHEUS+import Data.Morpheus.Kind+import Data.Morpheus.Server.Types.Types+ ( MapKind,+ Pair,+ Undefined (..),+ )+import Data.Morpheus.Types.Internal.AST+ ( DataFingerprint (..),+ QUERY,+ TypeName (..),+ TypeUpdater,+ internalFingerprint,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Resolver,+ )+import Data.Proxy (Proxy (..))+import Data.Set (Set)+import Data.Text+ ( Text,+ intercalate,+ pack,+ )+import Data.Typeable+ ( TyCon,+ TypeRep,+ Typeable,+ splitTyConApp,+ tyConFingerprint,+ tyConName,+ typeRep,+ typeRepTyCon,+ )++type TRUE = 'True++type FALSE = 'False++resolverCon :: TyCon+resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe)++-- | replaces typeName (A,B) with Pair_A_B+replacePairCon :: TyCon -> TyCon+replacePairCon x | hsPair == x = gqlPair+ where+ hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)+ gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int)+replacePairCon x = x++-- Ignores Resolver name from typeName+ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]+ignoreResolver (con, _) | con == resolverCon = []+ignoreResolver (con, args) =+ con : concatMap (ignoreResolver . splitTyConApp) args++-- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'.+--+-- @+-- ... deriving (Generic, GQLType)+-- @+--+-- if you want to add description+--+-- @+-- ... deriving (Generic)+--+-- instance GQLType ... where+-- description = const "your description ..."+-- @+class IsObject (a :: GQL_KIND) where+ isObject :: Proxy a -> Bool++instance IsObject SCALAR where+ isObject _ = False++instance IsObject ENUM where+ isObject _ = False++instance IsObject WRAPPER where+ isObject _ = False++instance IsObject INPUT where+ isObject _ = True++instance IsObject OUTPUT where+ isObject _ = True++instance IsObject INTERFACE where+ isObject _ = True++class IsObject (KIND a) => GQLType a where+ type KIND a :: GQL_KIND+ type KIND a = OUTPUT++ type CUSTOM a :: Bool+ type CUSTOM a = FALSE++ implements :: Proxy a -> [(TypeName, TypeUpdater)]+ implements _ = []++ description :: Proxy a -> Maybe Text+ description _ = Nothing++ isObjectKind :: Proxy a -> Bool+ isObjectKind _ = isObject (Proxy @(KIND a))++ __typeName :: Proxy a -> TypeName+ default __typeName ::+ (Typeable a) =>+ Proxy a ->+ TypeName+ __typeName _ = TypeName $ intercalate "_" (getName $ Proxy @a)+ where+ getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)++ __typeFingerprint :: Proxy a -> DataFingerprint+ default __typeFingerprint ::+ (Typeable a) =>+ Proxy a ->+ DataFingerprint+ __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a)+ where+ conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)++instance GQLType () where+ type KIND () = WRAPPER+ type CUSTOM () = 'False++instance Typeable m => GQLType (Undefined m) where+ type KIND (Undefined m) = WRAPPER+ type CUSTOM (Undefined m) = 'False++instance GQLType Int where+ type KIND Int = SCALAR+ __typeFingerprint _ = internalFingerprint "Int" []++instance GQLType Float where+ type KIND Float = SCALAR+ __typeFingerprint _ = internalFingerprint "Float" []++instance GQLType Text where+ type KIND Text = SCALAR+ __typeName _ = "String"+ __typeFingerprint _ = internalFingerprint "String" []++instance GQLType Bool where+ type KIND Bool = SCALAR+ __typeName _ = "Boolean"+ __typeFingerprint _ = internalFingerprint "Boolean" []++instance GQLType a => GQLType (Maybe a) where+ type KIND (Maybe a) = WRAPPER+ __typeName _ = __typeName (Proxy @a)+ __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance GQLType a => GQLType [a] where+ type KIND [a] = WRAPPER+ __typeName _ = __typeName (Proxy @a)+ __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where+ type KIND (a, b) = WRAPPER+ __typeName _ = __typeName $ Proxy @(Pair a b)++instance GQLType a => GQLType (Set a) where+ type KIND (Set a) = WRAPPER+ __typeName _ = __typeName (Proxy @a)+ __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where+ type KIND (Pair a b) = OUTPUT++instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where+ type KIND (MapKind a b m) = OUTPUT+ __typeName _ = __typeName (Proxy @(Map a b))+ __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b))++instance (Typeable k, Typeable v) => GQLType (Map k v) where+ type KIND (Map k v) = WRAPPER++instance GQLType a => GQLType (Either s a) where+ type KIND (Either s a) = WRAPPER+ __typeName _ = __typeName (Proxy @a)+ __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance GQLType a => GQLType (Resolver o e m a) where+ type KIND (Resolver o e m a) = WRAPPER+ __typeName _ = __typeName (Proxy @a)+ __typeFingerprint _ = __typeFingerprint (Proxy @a)++instance GQLType b => GQLType (a -> b) where+ type KIND (a -> b) = WRAPPER+ __typeName _ = __typeName (Proxy @b)+ __typeFingerprint _ = __typeFingerprint (Proxy @b)
+ src/Data/Morpheus/Server/Types/ID.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Morpheus.Server.Types.ID+ ( ID (..),+ )+where++import qualified Data.Aeson as A+import Data.Morpheus.Kind (SCALAR)+import Data.Morpheus.Server.Types.GQLScalar (GQLScalar (..))+import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Types.Internal.AST+ ( ScalarValue (..),+ internalFingerprint,+ )+import Data.Text+ ( Text,+ pack,+ )+import GHC.Generics (Generic)++-- | default GraphQL type,+-- parses only 'String' and 'Int' values,+-- serialized always as 'String'+newtype ID = ID+ { unpackID :: Text+ }+ deriving (Show, Generic)++instance GQLType ID where+ type KIND ID = SCALAR+ __typeFingerprint _ = internalFingerprint "ID" []++instance A.ToJSON ID where+ toJSON = A.toJSON . unpackID++instance A.FromJSON ID where+ parseJSON = fmap ID . A.parseJSON++instance GQLScalar ID where+ parseValue (Int x) = return (ID $ pack $ show x)+ parseValue (String x) = return (ID x)+ parseValue _ = Left ""+ serialize (ID x) = String x
+ src/Data/Morpheus/Server/Types/Types.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE KindSignatures #-}++module Data.Morpheus.Server.Types.Types+ ( Undefined (..),+ Pair (..),+ MapKind (..),+ MapArgs (..),+ mapKindFromList,+ )+where++import GHC.Generics (Generic)++data Undefined (m :: * -> *) = Undefined deriving (Show, Generic)++data Pair k v = Pair+ { key :: k,+ value :: v+ }+ deriving (Generic)++newtype MapArgs k = MapArgs+ { oneOf :: Maybe [k]+ }+ deriving (Generic)++data MapKind k v m = MapKind+ { size :: Int,+ pairs :: MapArgs k -> m [Pair k v]+ }+ deriving (Generic)++mapKindFromList :: (Eq k, Applicative m) => [(k, v)] -> MapKind k v m+mapKindFromList inputPairs =+ MapKind+ { size = length inputPairs,+ pairs = resolvePairs+ }+ where+ filterBy MapArgs {oneOf = Just list} =+ filter ((`elem` list) . fst) inputPairs+ filterBy _ = inputPairs+ resolvePairs = pure . (map toGQLTuple . filterBy)+ toGQLTuple (x, y) = Pair x y
src/Data/Morpheus/Types.hs view
@@ -1,104 +1,181 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeFamilies #-}+ -- | GQL Types module Data.Morpheus.Types- ( Event(..)- -- Type Classes- , GQLType(KIND, description)- , GQLScalar(parseValue, serialize)- , GQLRequest(..)- , GQLResponse(..)- , ID(..)- , ScalarValue(..)- , GQLRootResolver(..)- , constRes- , constMutRes- , Undefined(..)- , Res- , MutRes- , SubRes- , IORes- , IOMutRes- , IOSubRes- , Resolver- , QUERY- , MUTATION- , SUBSCRIPTION- , lift- , liftEither- , ResolveQ- , ResolveM- , ResolveS- , failRes- , WithOperation- , publish- , subscribe- , unsafeInternalContext- , SubField- , Input- , Stream+ ( Event (..),+ GQLType (KIND, description, implements),+ GQLScalar (parseValue, serialize),+ GQLRequest (..),+ GQLResponse (..),+ ID (..),+ ScalarValue (..),+ GQLRootResolver (..),+ constRes,+ constMutRes,+ Undefined (..),+ Resolver,+ QUERY,+ MUTATION,+ SUBSCRIPTION,+ lift,+ liftEither,+ failRes,+ WithOperation,+ publish,+ subscribe,+ unsafeInternalContext,+ Context (..),+ SubField,+ ComposedSubField,+ Input,+ Stream,+ WS,+ HTTP,+ -- Resolvers+ ResolverO,+ ComposedResolver,+ ResolverQ,+ ResolverM,+ ResolverS,+ -- Resolvers Deprecated+ ResolveQ,+ ResolveM,+ ResolveS,+ Res,+ MutRes,+ SubRes,+ IORes,+ IOMutRes,+ IOSubRes,+ interface, ) where -import Data.Text ( pack )-import Data.Either (either)-import Control.Monad.Trans.Class ( MonadTrans(..) )-+import Control.Monad.Trans.Class (MonadTrans (..))+import Data.Either (either) -- MORPHEUS-import Data.Morpheus.Types.GQLScalar ( GQLScalar- ( parseValue- , serialize- )- )-import Data.Morpheus.Types.GQLType ( GQLType(KIND, description) )-import Data.Morpheus.Types.ID ( ID(..) )-import Data.Morpheus.Types.Internal.AST- ( MUTATION- , QUERY- , SUBSCRIPTION- , ScalarValue(..)- , Message- )-import Data.Morpheus.Types.Internal.Resolving- ( Event(..)- , GQLRootResolver(..)- , Resolver- , WithOperation- , lift- , failure- , Failure- , pushEvents- , PushEvents(..)- , subscribe- , unsafeInternalContext- , UnSubResolver- )-import Data.Morpheus.Types.IO ( GQLRequest(..)- , GQLResponse(..)- )-import Data.Morpheus.Types.Types ( Undefined(..) )-import Data.Morpheus.Types.Internal.Subscription - ( Stream- , Input- ) +import Data.Morpheus.Server.Deriving.Introspect (Introspect (..))+import Data.Morpheus.Server.Types.GQLScalar+ ( GQLScalar+ ( parseValue,+ serialize+ ),+ )+import Data.Morpheus.Server.Types.GQLType (GQLType (..))+import Data.Morpheus.Server.Types.ID (ID (..))+import Data.Morpheus.Server.Types.Types (Undefined (..))+import Data.Morpheus.Types.IO+ ( GQLRequest (..),+ GQLResponse (..),+ )+import Data.Morpheus.Types.Internal.AST+ ( MUTATION,+ Message,+ QUERY,+ SUBSCRIPTION,+ ScalarValue (..),+ TypeName,+ TypeUpdater,+ msg,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Context (..),+ Event (..),+ Failure,+ PushEvents (..),+ Resolver,+ UnSubResolver,+ WithOperation,+ failure,+ lift,+ pushEvents,+ subscribe,+ unsafeInternalContext,+ )+import Data.Morpheus.Types.Internal.Subscription+ ( HTTP,+ Input,+ Stream,+ WS,+ )+import Data.Proxy (Proxy (..))++class FlexibleResolver (f :: * -> *) (a :: k) where+ type Flexible (m :: * -> *) a :: *+ type Composed (m :: * -> *) f a :: *++instance FlexibleResolver f (a :: *) where+ type Flexible m a = m a+ type Composed m f a = m (f a)++instance FlexibleResolver f (a :: (* -> *) -> *) where+ type Flexible m a = m (a m)+ type Composed m f a = m (f (a m))++-- Recursive Resolvers+type ResolverO o e m a =+ (WithOperation o) =>+ Flexible (Resolver o e m) a++type ComposedResolver o e m f a =+ (WithOperation o) =>+ Composed (Resolver o e m) f a++type ResolverQ e m a = Flexible (Resolver QUERY e m) a++type ResolverM e m a = Flexible (Resolver MUTATION e m) a++type ResolverS e m a = Resolver SUBSCRIPTION e m (a (Resolver QUERY e m))++{-# DEPRECATED Res "use ResolverQ" #-}+ type Res = Resolver QUERY++{-# DEPRECATED MutRes "use ResolverM" #-}+ type MutRes = Resolver MUTATION++{-# DEPRECATED SubRes "use ResolverS" #-}+ type SubRes = Resolver SUBSCRIPTION +{-# DEPRECATED IORes "use ResolverQ" #-}+ type IORes e = Res e IO++{-# DEPRECATED IOMutRes "use ResolverM" #-}+ type IOMutRes e = MutRes e IO++{-# DEPRECATED IOSubRes "use ResolverS" #-}+ type IOSubRes e = SubRes e IO --- Recursive Resolvers-type ResolveQ e m a = Res e m (a (Res e m))-type ResolveM e m a = MutRes e m (a (MutRes e m))-type ResolveS e m a = SubRes e m (a (Res e m))+{-# DEPRECATED ResolveQ "use ResolverQ" #-} +type ResolveQ e m a = ResolverQ e m a++{-# DEPRECATED ResolveM "use ResolverM" #-}++type ResolveM e m a = ResolverM e m a++{-# DEPRECATED ResolveS "use ResolverS" #-}++type ResolveS e m a = ResolverS e m a+ -- Subsciption Object Resolver Fields-type SubField m a = (m (a (UnSubResolver m))) +type SubField m a = (m (a (UnSubResolver m))) +type ComposedSubField m f a = (m (f (a (UnSubResolver m))))+ publish :: Monad m => [e] -> Resolver MUTATION e m () publish = pushEvents @@ -106,13 +183,31 @@ constRes :: (WithOperation o, Monad m) => b -> a -> Resolver o e m b constRes = const . pure -constMutRes :: Monad m => [e] -> a -> args -> MutRes e m a-constMutRes events value = const $ do - publish events +constMutRes :: Monad m => [e] -> a -> args -> ResolverM e m a+constMutRes events value = const $ do+ publish events pure value -failRes :: (WithOperation o, Monad m) => String -> Resolver o e m a-failRes = failure . pack+{-# DEPRECATED failRes "use \"fail\" from \"MonadFail\"" #-}+failRes ::+ ( Monad m,+ WithOperation o+ ) =>+ String ->+ Resolver o e m a+failRes = fail liftEither :: (MonadTrans t, Monad (t m), Failure Message (t m)) => Monad m => m (Either String a) -> t m a-liftEither x = lift x >>= either (failure . pack) pure+liftEither x = lift x >>= either (failure . msg) pure++-- | GraphQL Root resolver, also the interpreter generates a GQL schema from it.+-- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,+-- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it.+data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> *) (mut :: (* -> *) -> *) (sub :: (* -> *) -> *) = GQLRootResolver+ { queryResolver :: query (Resolver QUERY event m),+ mutationResolver :: mut (Resolver MUTATION event m),+ subscriptionResolver :: sub (Resolver SUBSCRIPTION event m)+ }++interface :: (GQLType a, Introspect a) => Proxy a -> (TypeName, TypeUpdater)+interface x = (__typeName x, introspect x)
− src/Data/Morpheus/Types/GQLScalar.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Types.GQLScalar- ( GQLScalar(..)- , toScalar- )-where--import Data.Morpheus.Types.Internal.AST.Data- ( ScalarDefinition(..) )-import Data.Morpheus.Types.Internal.AST- ( ScalarValue(..)- , ValidValue- , Value(..)- )-import Data.Proxy ( Proxy(..) )-import Data.Text ( Text )--toScalar :: ValidValue -> Either Text ScalarValue-toScalar (Scalar x) = pure x-toScalar _ = Left ""---- | GraphQL Scalar------ 'parseValue' and 'serialize' should be provided for every instances manually-class GQLScalar a where- -- | value parsing and validating- --- -- for exhaustive pattern matching should be handled all scalar types : 'Int', 'Float', 'String', 'Boolean'- --- -- invalid values can be reported with 'Left' constructor :- --- -- @- -- parseValue String _ = Left "" -- without error message- -- -- or- -- parseValue String _ = Left "Error Message"- -- @- --- parseValue :: ScalarValue -> Either Text a- -- | serialization of haskell type into scalar value- serialize :: a -> ScalarValue- scalarValidator :: Proxy a -> ScalarDefinition- scalarValidator _ = ScalarDefinition {validateValue = validator}- where- validator value = do- scalarValue' <- toScalar value- (_ :: a) <- parseValue scalarValue'- return value--instance GQLScalar Text where- parseValue (String x) = pure x- parseValue _ = Left ""- serialize = String--instance GQLScalar Bool where- parseValue (Boolean x) = pure x- parseValue _ = Left ""- serialize = Boolean--instance GQLScalar Int where- parseValue (Int x) = pure x- parseValue _ = Left ""- serialize = Int--instance GQLScalar Float where- parseValue (Float x) = pure x- parseValue (Int x) = pure $ fromInteger $ toInteger x- parseValue _ = Left ""- serialize = Float
− src/Data/Morpheus/Types/GQLType.hs
@@ -1,190 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}--module Data.Morpheus.Types.GQLType- ( GQLType(..)- , TRUE- , FALSE- )-where--import Data.Map ( Map )-import Data.Proxy ( Proxy(..) )-import Data.Set ( Set )-import Data.Text ( Text- , intercalate- , pack- )-import Data.Typeable ( TyCon- , TypeRep- , Typeable- , splitTyConApp- , tyConFingerprint- , tyConName- , typeRep- , typeRepTyCon- )---- MORPHEUS-import Data.Morpheus.Kind-import Data.Morpheus.Types.Types ( MapKind- , Pair- , Undefined(..)- )-import Data.Morpheus.Types.Internal.AST- ( DataFingerprint(..)- , QUERY- )-import Data.Morpheus.Types.Internal.Resolving- ( Resolver )--type TRUE = 'True--type FALSE = 'False--resolverCon :: TyCon-resolverCon = typeRepTyCon $ typeRep $ Proxy @(Resolver QUERY () Maybe)---- | replaces typeName (A,B) with Pair_A_B-replacePairCon :: TyCon -> TyCon-replacePairCon x | hsPair == x = gqlPair- where- hsPair = typeRepTyCon $ typeRep $ Proxy @(Int, Int)- gqlPair = typeRepTyCon $ typeRep $ Proxy @(Pair Int Int)-replacePairCon x = x---- Ignores Resolver name from typeName-ignoreResolver :: (TyCon, [TypeRep]) -> [TyCon]-ignoreResolver (con, _) | con == resolverCon = []-ignoreResolver (con, args) =- con : concatMap (ignoreResolver . splitTyConApp) args---- | GraphQL type, every graphQL type should have an instance of 'GHC.Generics.Generic' and 'GQLType'.------ @--- ... deriving (Generic, GQLType)--- @------ if you want to add description------ @--- ... deriving (Generic)------ instance GQLType ... where--- description = const "your description ..."--- @--class IsObject (a :: GQL_KIND) where- isObject :: Proxy a -> Bool--instance IsObject SCALAR where- isObject _ = False--instance IsObject ENUM where- isObject _ = False--instance IsObject WRAPPER where- isObject _ = False--instance IsObject INPUT where- isObject _ = True--instance IsObject OUTPUT where- isObject _ = True--class IsObject (KIND a) => GQLType a where- type KIND a :: GQL_KIND- type KIND a = OUTPUT- type CUSTOM a :: Bool- type CUSTOM a = FALSE- description :: Proxy a -> Maybe Text- description _ = Nothing- isObjectKind :: Proxy a -> Bool- isObjectKind _ = isObject (Proxy @(KIND a))- __typeName :: Proxy a -> Text- default __typeName :: (Typeable a) =>- Proxy a -> Text- __typeName _ = intercalate "_" (getName $ Proxy @a)- where- getName = fmap (map (pack . tyConName)) (map replacePairCon . ignoreResolver . splitTyConApp . typeRep)- __typeFingerprint :: Proxy a -> DataFingerprint- default __typeFingerprint :: (Typeable a) =>- Proxy a -> DataFingerprint- __typeFingerprint _ = DataFingerprint "Typeable" $ map show $ conFingerprints (Proxy @a)- where- conFingerprints = fmap (map tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep)--instance GQLType () where- type KIND () = WRAPPER- type CUSTOM () = 'False--instance Typeable m => GQLType (Undefined m) where- type KIND (Undefined m) = WRAPPER- type CUSTOM (Undefined m) = 'False--instance GQLType Int where- type KIND Int = SCALAR--instance GQLType Float where- type KIND Float = SCALAR--instance GQLType Text where- type KIND Text = SCALAR- __typeName = const "String"--instance GQLType Bool where- type KIND Bool = SCALAR- __typeName = const "Boolean"--instance GQLType a => GQLType (Maybe a) where- type KIND (Maybe a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)---instance GQLType a => GQLType [a] where- type KIND [a] = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)--instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (a, b) where- type KIND (a, b) = WRAPPER- __typeName _ = __typeName $ Proxy @(Pair a b)--instance GQLType a => GQLType (Set a) where- type KIND (Set a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)--instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (Pair a b) where- type KIND (Pair a b) = OUTPUT--instance (Typeable a, Typeable b, GQLType a, GQLType b) => GQLType (MapKind a b m) where- type KIND (MapKind a b m) = OUTPUT- __typeName _ = __typeName (Proxy @(Map a b))- __typeFingerprint _ = __typeFingerprint (Proxy @(Map a b))--instance (Typeable k, Typeable v) => GQLType (Map k v) where- type KIND (Map k v) = WRAPPER--instance GQLType a => GQLType (Either s a) where- type KIND (Either s a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)--instance GQLType a => GQLType (Resolver o e m a) where- type KIND (Resolver o e m a) = WRAPPER- __typeName _ = __typeName (Proxy @a)- __typeFingerprint _ = __typeFingerprint (Proxy @a)--instance GQLType b => GQLType (a -> b) where- type KIND (a -> b) = WRAPPER- __typeName _ = __typeName (Proxy @b)- __typeFingerprint _ = __typeFingerprint (Proxy @b)
− src/Data/Morpheus/Types/ID.hs
@@ -1,41 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Types.ID- ( ID(..)- )-where--import qualified Data.Aeson as A-import Data.Morpheus.Kind ( SCALAR )-import Data.Morpheus.Types.GQLScalar ( GQLScalar(..) )-import Data.Morpheus.Types.GQLType ( GQLType(KIND) )-import Data.Morpheus.Types.Internal.AST- ( ScalarValue(..) )-import Data.Text ( Text- , pack- )-import GHC.Generics ( Generic )---- | default GraphQL type,--- parses only 'String' and 'Int' values,--- serialized always as 'String'-newtype ID = ID- { unpackID :: Text- } deriving (Show, Generic)--instance GQLType ID where- type KIND ID = SCALAR--instance A.ToJSON ID where- toJSON = A.toJSON . unpackID--instance A.FromJSON ID where- parseJSON = fmap ID . A.parseJSON --instance GQLScalar ID where- parseValue (Int x) = return (ID $ pack $ show x)- parseValue (String x) = return (ID x)- parseValue _ = Left ""- serialize (ID x) = String x
− src/Data/Morpheus/Types/IO.hs
@@ -1,126 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}--module Data.Morpheus.Types.IO- ( GQLRequest(..)- , GQLResponse(..)- , JSONResponse(..)- , renderResponse- , MapAPI(..)- )-where---import Data.Aeson ( FromJSON(..)- , ToJSON(..)- , pairs- , withObject- , (.:?)- , (.=)- , object- , encode- )-import Data.Aeson.Parser ( eitherDecodeWith- , jsonNoDup- )-import qualified Data.Aeson as Aeson- ( Value(..) )-import qualified Data.HashMap.Lazy as LH- ( toList )-import GHC.Generics ( Generic )-import Data.Text ( Text )-import qualified Data.Text.Lazy as LT- ( Text- , fromStrict- , toStrict- )-import Data.Text.Lazy.Encoding ( decodeUtf8- , encodeUtf8- )-import Data.ByteString ( ByteString )-import qualified Data.ByteString.Lazy.Char8 as LB- ( ByteString- , fromStrict- , toStrict- )-import Data.Aeson.Internal ( formatError- , ifromJSON- )---- MORPHEUS-import Data.Morpheus.Error.Utils ( badRequestError )-import Data.Morpheus.Types.Internal.AST- ( Key - , GQLError(..)- , ValidValue- )-import Data.Morpheus.Types.Internal.Resolving.Core- ( Result(..)- , Failure(..)- )---decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest-decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of- Left (path, x) -> failure $ formatError path x- Right value -> pure value--class MapAPI a where - mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m a--instance MapAPI LB.ByteString where- mapAPI api request = case decodeNoDup request of- Left aesonError -> pure $ badRequestError aesonError- Right req -> encode <$> api req--instance MapAPI LT.Text where- mapAPI api = fmap decodeUtf8 . mapAPI api . encodeUtf8--instance MapAPI ByteString where- mapAPI api = fmap LB.toStrict . mapAPI api . LB.fromStrict--instance MapAPI Text where- mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict--renderResponse :: Result e ValidValue -> GQLResponse-renderResponse (Failure errors) = Errors errors-renderResponse Success { result } = Data result--instance FromJSON a => FromJSON (JSONResponse a) where- parseJSON = withObject "JSONResponse" objectParser- where objectParser o = JSONResponse <$> o .:? "data" <*> o .:? "errors"--data JSONResponse a = JSONResponse- { responseData :: Maybe a- , responseErrors :: Maybe [GQLError]- } deriving (Generic, Show, ToJSON)---- | GraphQL HTTP Request Body-data GQLRequest = GQLRequest- { query :: Key- , operationName :: Maybe Key- , variables :: Maybe Aeson.Value- } deriving (Show, Generic, FromJSON, ToJSON)---- | GraphQL Response-data GQLResponse- = Data ValidValue- | Errors [GQLError]- deriving (Show, Generic)--instance FromJSON GQLResponse where- parseJSON (Aeson.Object hm) = case LH.toList hm of- [("data" , value)] -> Data <$> parseJSON value- [("errors", value)] -> Errors <$> parseJSON value- _ -> fail "Invalid GraphQL Response"- parseJSON _ = fail "Invalid GraphQL Response"--instance ToJSON GQLResponse where- toJSON (Data gqlData) = object ["data" .= toJSON gqlData]- toJSON (Errors errors) = object ["errors" .= toJSON errors]- ----------------------------------------------------------- toEncoding (Data _data ) = pairs $ "data" .= _data- toEncoding (Errors _errors) = pairs $ "errors" .= _errors
− src/Data/Morpheus/Types/Internal/AST.hs
@@ -1,165 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Types.Internal.AST- (- -- BASE- Key- , Ref(..)- , Position(..)- , Message- , anonymousRef- , Name- , Description- , Stage- , RESOLVED- , VALID- , RAW- , VALIDATION_MODE(..)-- -- VALUE- , Value(..)- , ScalarValue(..)- , Object- , GQLValue(..)- , replaceValue- , decodeScientific- , convertToJSONName- , convertToHaskellName- , RawValue- , ValidValue- , RawObject- , ValidObject- , ResolvedObject- , ResolvedValue- , Named- , splitDuplicates- , removeDuplicates- -- Selection- , Argument(..)- , Arguments- , SelectionSet- , SelectionContent(..)- , Selection(..)- , Fragments- , Fragment(..)- , isOutputType- -- OPERATION- , Operation(..)- , Variable(..)- , VariableDefinitions- , DefaultValue- , getOperationName- , getOperationDataType- -- DSL- , ScalarDefinition(..)- , DataEnum- , FieldsDefinition(..)- , ArgumentDefinition- , DataUnion- , ArgumentsDefinition(..)- , FieldDefinition(..)- , InputFieldsDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , Schema(..)- , DataTypeWrapper(..)- , DataTypeKind(..)- , DataFingerprint(..)- , TypeWrapper(..)- , TypeRef(..)- , DataEnumValue(..)- , OperationType(..)- , QUERY- , MUTATION- , SUBSCRIPTION- , Meta(..)- , Directive(..)- , TypeUpdater- , TypeD(..)- , ConsD(..)- , ClientQuery(..)- , GQLTypeD(..)- , ClientType(..)- , DataInputUnion- , VariableContent(..)- , TypeLib- , isTypeDefined- , initTypeLib- , defineType- , isFieldNullable- , allDataTypes- , lookupDataType- , kindOf- , toNullableField- , toListField- , isObject- , isInput- , toHSWrappers- , isNullable- , toGQLWrapper- , isWeaker- , isSubscription- , isOutputObject- , sysTypes- , isDefaultTypeName- , isSchemaTypeName- , isPrimitiveTypeName- , isEntNode- , createField- , createArgument- , createDataTypeLib- , createEnumType- , createScalarType- , createType- , createUnionType- , createAlias- , createInputUnionFields- , fieldVisibility- , createEnumValue- , insertType- , lookupDeprecated- , lookupDeprecatedReason- , hasArguments- , lookupWith- , typeFromScalar- -- Temaplate Haskell- , toHSFieldDefinition- , hsTypeName- -- LOCAL- , GQLQuery(..)- , Variables- , isNullableWrapper- , unsafeFromFields- , unsafeFromInputFields- , OrderedMap- , GQLError(..)- , GQLErrors- , ObjectEntry(..)- , UnionTag(..)- , isInputDataType- , __inputname- )-where--import Data.Map ( Map )-import Language.Haskell.TH.Syntax ( Lift )---- Morpheus-import Data.Morpheus.Types.Internal.AST.Base-import Data.Morpheus.Types.Internal.AST.Value-import Data.Morpheus.Types.Internal.AST.Selection-import Data.Morpheus.Types.Internal.AST.Data-import Data.Morpheus.Types.Internal.AST.OrderedMap--type Variables = Map Key ResolvedValue--data GQLQuery = GQLQuery- { fragments :: Fragments- , operation :: Operation RAW- , inputVariables :: [(Key, ResolvedValue)]- } deriving (Show,Lift)
− src/Data/Morpheus/Types/Internal/AST/Base.hs
@@ -1,268 +0,0 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.Morpheus.Types.Internal.AST.Base- ( Key- , Ref(..)- , Position(..)- , Message- , Name- , Named- , Description- , VALID- , RAW- , TypeWrapper(..)- , Stage(..)- , RESOLVED- , TypeRef(..)- , VALIDATION_MODE(..)- , OperationType(..)- , QUERY- , MUTATION- , SUBSCRIPTION- , DataTypeKind(..)- , DataFingerprint(..)- , DataTypeWrapper(..)- , anonymousRef- , toHSWrappers- , toGQLWrapper- , sysTypes- , isNullable- , isWeaker- , isSubscription- , isOutputObject- , isDefaultTypeName- , isSchemaTypeName- , isPrimitiveTypeName- , isObject- , isInput- , isNullableWrapper- , isOutputType- , sysFields- , typeFromScalar- , hsTypeName- , toOperationType- , splitDuplicates- , removeDuplicates- , GQLError(..)- , GQLErrors- )-where--import Data.Semigroup ((<>))-import Data.Aeson ( FromJSON- , ToJSON- )-import Data.Text ( Text )-import GHC.Generics ( Generic )-import Language.Haskell.TH.Syntax ( Lift(..) )-import Instances.TH.Lift ()---type Key = Text-type Message = Text-type Name = Key-type Description = Key-data Stage = RAW | RESOLVED | VALID--data Position = Position- { line :: Int- , column :: Int- } deriving ( Show, Generic, FromJSON, ToJSON, Lift)---- Positions 2 Value withs same structire--- but different Positions should be Equal-instance Eq Position where- _ == _ = True--data GQLError = GQLError- { message :: Message- , locations :: [Position]- } deriving ( Show, Generic, FromJSON, ToJSON)--type GQLErrors = [GQLError]---type RAW = 'RAW-type RESOLVED = 'RESOLVED-type VALID = 'VALID--data VALIDATION_MODE- = WITHOUT_VARIABLES- | FULL_VALIDATION- deriving (Eq, Show)--data DataFingerprint = DataFingerprint Name [String] deriving (Show, Eq, Ord, Lift)--data OperationType- = Query- | Subscription- | Mutation- deriving (Show, Eq, Lift)--type QUERY = 'Query-type MUTATION = 'Mutation-type SUBSCRIPTION = 'Subscription--type Named a = (Name, a) ---- Refference with Position information ------ includes position for debugging, where Ref "a" 1 === Ref "a" 3----data Ref = Ref- { refName :: Key- , refPosition :: Position- } deriving (Show,Lift, Eq)--instance Ord Ref where- compare (Ref x _) (Ref y _) = compare x y--anonymousRef :: Key -> Ref-anonymousRef refName = Ref { refName, refPosition = Position 0 0 }---- TypeRef---------------------------------------------------------------------data TypeRef = TypeRef- { typeConName :: Name- , typeArgs :: Maybe Name- , typeWrappers :: [TypeWrapper]- } deriving (Show, Eq, Lift)--isNullable :: TypeRef -> Bool-isNullable TypeRef { typeWrappers = typeWrappers } = isNullableWrapper typeWrappers---- Kind-------------------------------------------------------------------------------------data DataTypeKind- = KindScalar- | KindObject (Maybe OperationType)- | KindUnion- | KindEnum- | KindInputObject- | KindList- | KindNonNull- | KindInputUnion- deriving (Eq, Show, Lift)--isSubscription :: DataTypeKind -> Bool-isSubscription (KindObject (Just Subscription)) = True-isSubscription _ = False--isOutputType :: DataTypeKind -> Bool-isOutputType (KindObject _) = True-isOutputType KindUnion = True-isOutputType _ = False--isOutputObject :: DataTypeKind -> Bool-isOutputObject (KindObject _) = True-isOutputObject _ = False--isObject :: DataTypeKind -> Bool-isObject (KindObject _) = True-isObject KindInputObject = True-isObject _ = False--isInput :: DataTypeKind -> Bool-isInput KindInputObject = True-isInput _ = False---- TypeWrappers-------------------------------------------------------------------------------------data TypeWrapper- = TypeList- | TypeMaybe- deriving (Show, Eq, Lift)--data DataTypeWrapper- = ListType- | NonNullType- deriving (Show, Lift)--isNullableWrapper :: [TypeWrapper] -> Bool-isNullableWrapper (TypeMaybe : _ ) = True-isNullableWrapper _ = False--isWeaker :: [TypeWrapper] -> [TypeWrapper] -> Bool-isWeaker (TypeMaybe : xs1) (TypeMaybe : xs2) = isWeaker xs1 xs2-isWeaker (TypeMaybe : _ ) _ = True-isWeaker (_ : xs1) (_ : xs2) = isWeaker xs1 xs2-isWeaker _ _ = False--toGQLWrapper :: [TypeWrapper] -> [DataTypeWrapper]-toGQLWrapper (TypeMaybe : (TypeMaybe : tw)) = toGQLWrapper (TypeMaybe : tw)-toGQLWrapper (TypeMaybe : (TypeList : tw)) = ListType : toGQLWrapper tw-toGQLWrapper (TypeList : tw) = [NonNullType, ListType] <> toGQLWrapper tw-toGQLWrapper [TypeMaybe ] = []-toGQLWrapper [] = [NonNullType]--toHSWrappers :: [DataTypeWrapper] -> [TypeWrapper]-toHSWrappers (NonNullType : (NonNullType : xs)) =- toHSWrappers (NonNullType : xs)-toHSWrappers (NonNullType : (ListType : xs)) = TypeList : toHSWrappers xs-toHSWrappers (ListType : xs) = [TypeMaybe, TypeList] <> toHSWrappers xs-toHSWrappers [] = [TypeMaybe]-toHSWrappers [NonNullType] = []--isDefaultTypeName :: Key -> Bool-isDefaultTypeName x = isSchemaTypeName x || isPrimitiveTypeName x--isSchemaTypeName :: Key -> Bool-isSchemaTypeName = (`elem` sysTypes)--isPrimitiveTypeName :: Key -> Bool-isPrimitiveTypeName = (`elem` ["String", "Float", "Int", "Boolean", "ID"])--sysTypes :: [Key]-sysTypes =- [ "__Schema"- , "__Type"- , "__Directive"- , "__TypeKind"- , "__Field"- , "__DirectiveLocation"- , "__InputValue"- , "__EnumValue"- ]--sysFields :: [Key]-sysFields = ["__typename","__schema","__type"]--typeFromScalar :: Name -> Name-typeFromScalar "Boolean" = "Bool"-typeFromScalar "Int" = "Int"-typeFromScalar "Float" = "Float"-typeFromScalar "String" = "Text"-typeFromScalar "ID" = "ID"-typeFromScalar _ = "ScalarValue"--hsTypeName :: Key -> Key-hsTypeName "String" = "Text"-hsTypeName "Boolean" = "Bool"-hsTypeName name | name `elem` sysTypes = "S" <> name-hsTypeName name = name--toOperationType :: Name -> Maybe OperationType-toOperationType "Subscription" = Just Subscription-toOperationType "Mutation" = Just Mutation-toOperationType "Query" = Just Query-toOperationType _ = Nothing--removeDuplicates :: Eq a => [a] -> [a]-removeDuplicates = fst . splitDuplicates---- elems -> (unique elements, duplicate elems)-splitDuplicates :: Eq a => [a] -> ([a],[a])-splitDuplicates = collectElems ([],[])- where- collectElems :: Eq a => ([a],[a]) -> [a] -> ([a],[a])- collectElems collected [] = collected- collectElems (collected,errors) (x:xs)- | x `elem` collected = collectElems (collected,errors <> [x]) xs- | otherwise = collectElems (collected <> [x],errors) xs
− src/Data/Morpheus/Types/Internal/AST/Data.hs
@@ -1,592 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}--module Data.Morpheus.Types.Internal.AST.Data- ( Arguments- , ScalarDefinition(..)- , DataEnum- , FieldsDefinition(..)- , ArgumentDefinition- , DataUnion- , ArgumentsDefinition(..)- , FieldDefinition(..)- , InputFieldsDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , Schema(..)- , DataEnumValue(..)- , TypeLib- , Meta(..)- , Directive(..)- , TypeUpdater- , TypeD(..)- , ConsD(..)- , ClientQuery(..)- , GQLTypeD(..)- , ClientType(..)- , DataInputUnion- , Argument(..)- , allDataTypes- , createField- , createArgument- , createDataTypeLib- , createEnumType- , createScalarType- , createType- , createUnionType- , createAlias- , createInputUnionFields- , createEnumValue- , defineType- , isTypeDefined- , initTypeLib- , isFieldNullable- , insertType- , fieldVisibility- , kindOf- , toNullableField- , toListField- , toHSFieldDefinition- , isEntNode- , lookupDataType- , lookupDeprecated- , lookupDeprecatedReason- , lookupWith- , hasArguments- , unsafeFromFields- , isInputDataType- , unsafeFromInputFields- , __inputname- )-where--import Data.HashMap.Lazy ( HashMap- , union- , elems- )-import qualified Data.HashMap.Lazy as HM-import Data.Semigroup ( Semigroup(..), (<>) )-import Language.Haskell.TH.Syntax ( Lift(..) )-import Instances.TH.Lift ( )-import Data.List ( find)---- MORPHEUS-import Data.Morpheus.Error.NameCollision- ( NameCollision(..)- )-import Data.Morpheus.Types.Internal.AST.OrderedMap- ( OrderedMap- , unsafeFromValues- )-import Data.Morpheus.Types.Internal.AST.Base- ( Key- , Position- , Name- , Message- , Description- , TypeWrapper(..)- , TypeRef(..)- , Stage- , VALID- , DataTypeKind(..)- , DataFingerprint(..)- , isNullable- , sysFields- , toOperationType- , hsTypeName- , GQLError(..)- )-import Data.Morpheus.Types.Internal.Operation - ( Empty(..)- , Selectable(..)- , Listable(..)- , Singleton(..)- , Listable(..)- , Merge(..)- , KeyOf(..)- )-import Data.Morpheus.Types.Internal.Resolving.Core- ( Failure(..)- , LibUpdater- , resolveUpdates- )-import Data.Morpheus.Types.Internal.AST.Value- ( Value(..) - , ValidValue- , ScalarValue(..)- )-import Data.Morpheus.Error.Schema ( nameCollisionError )---type DataEnum = [DataEnumValue]-type DataUnion = [Key]-type DataInputUnion = [(Key, Bool)]---- scalar--------------------------------------------------------------------newtype ScalarDefinition = ScalarDefinition- { validateValue :: ValidValue -> Either Key ValidValue }--instance Show ScalarDefinition where- show _ = "ScalarDefinition"--data Argument (valid :: Stage) = Argument - { argumentName :: Name- , argumentValue :: Value valid- , argumentPosition :: Position- } deriving ( Show, Eq, Lift )---instance KeyOf (Argument stage) where- keyOf = argumentName --instance NameCollision (Argument s) where - nameCollision _ Argument { argumentName, argumentPosition } - = GQLError - { message = "There can Be only One Argument Named \"" <> argumentName <> "\"",- locations = [argumentPosition] - }--type Arguments s = OrderedMap (Argument s)---- directive--------------------------------------------------------------------data Directive = Directive {- directiveName :: Name,- directiveArgs :: OrderedMap (Argument VALID)-} deriving (Show,Lift)--lookupDeprecated :: Meta -> Maybe Directive-lookupDeprecated Meta { metaDirectives } = find isDeprecation metaDirectives- where- isDeprecation Directive { directiveName = "deprecated" } = True- isDeprecation _ = False--lookupDeprecatedReason :: Directive -> Maybe Key-lookupDeprecatedReason Directive { directiveArgs } =- selectOr Nothing (Just . maybeString) "reason" directiveArgs - where- maybeString :: Argument VALID -> Name- maybeString Argument { argumentValue = (Scalar (String x)) } = x- maybeString _ = "can't read deprecated Reason Value"---- META-data Meta = Meta {- metaDescription:: Maybe Description,- metaDirectives :: [Directive]-} deriving (Show,Lift)----- ENUM VALUE-data DataEnumValue = DataEnumValue{- enumName :: Name,- enumMeta :: Maybe Meta-} deriving (Show, Lift)---- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema------------------------------------------------------------------------------- SchemaDefinition :--- schema Directives[Const](opt) { RootOperationTypeDefinition(list)}------ RootOperationTypeDefinition :--- OperationType: NamedType--data Schema = Schema- { types :: TypeLib- , query :: TypeDefinition- , mutation :: Maybe TypeDefinition- , subscription :: Maybe TypeDefinition- } deriving (Show)--type TypeLib = HashMap Key TypeDefinition--instance Selectable Schema TypeDefinition where - selectOr fb f name lib = maybe fb f (lookupDataType name lib)--initTypeLib :: TypeDefinition -> Schema-initTypeLib query = Schema { types = empty- , query = query- , mutation = Nothing- , subscription = Nothing- }---allDataTypes :: Schema -> [TypeDefinition]-allDataTypes = elems . typeRegister--typeRegister :: Schema -> TypeLib-typeRegister Schema { types, query, mutation, subscription } =- types `union` HM.fromList- (concatMap fromOperation [Just query, mutation, subscription])--createDataTypeLib :: Failure Message m => [TypeDefinition] -> m Schema-createDataTypeLib types = case popByKey "Query" types of- (Nothing ,_ ) -> failure ("INTERNAL: Query Not Defined" :: Message)- (Just query, lib1) -> do- let (mutation, lib2) = popByKey "Mutation" lib1- let (subscription, lib3) = popByKey "Subscription" lib2- pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription}----- 3.4 Types : https://graphql.github.io/graphql-spec/June2018/#sec-Types----------------------------------------------------------------------------- TypeDefinition :--- ScalarTypeDefinition--- ObjectTypeDefinition--- InterfaceTypeDefinition--- UnionTypeDefinition--- EnumTypeDefinition--- InputObjectTypeDefinition--data TypeDefinition = TypeDefinition- { typeName :: Key- , typeFingerprint :: DataFingerprint- , typeMeta :: Maybe Meta- , typeContent :: TypeContent- } deriving (Show)--data TypeContent- = DataScalar { dataScalar :: ScalarDefinition - }- | DataEnum { enumMembers :: DataEnum - }- | DataInputObject { inputObjectFields :: InputFieldsDefinition - }- | DataObject { objectImplements :: [Name],- objectFields :: FieldsDefinition - }- | DataUnion { unionMembers :: DataUnion - }- | DataInputUnion { inputUnionMembers :: [(Key,Bool)] - }- | DataInterface { interfaceFields :: FieldsDefinition - }- deriving (Show)--createType :: Key -> TypeContent -> TypeDefinition-createType typeName typeContent = TypeDefinition- { typeName- , typeMeta = Nothing- , typeFingerprint = DataFingerprint typeName []- , typeContent- }--createScalarType :: Name -> TypeDefinition-createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure)--createEnumType :: Name -> [Key] -> TypeDefinition-createEnumType typeName typeData = createType typeName (DataEnum enumValues)- where enumValues = map createEnumValue typeData--createEnumValue :: Name -> DataEnumValue-createEnumValue enumName = DataEnumValue { enumName, enumMeta = Nothing }--createUnionType :: Key -> [Key] -> TypeDefinition-createUnionType typeName typeData = createType typeName (DataUnion typeData)--isEntNode :: TypeContent -> Bool-isEntNode DataScalar{} = True-isEntNode DataEnum{} = True-isEntNode _ = False--isInputDataType :: TypeDefinition -> Bool-isInputDataType TypeDefinition { typeContent } = __isInput typeContent- where- __isInput DataScalar{} = True- __isInput DataEnum{} = True- __isInput DataInputObject{} = True- __isInput DataInputUnion{} = True- __isInput _ = False--kindOf :: TypeDefinition -> DataTypeKind-kindOf TypeDefinition { typeName, typeContent } = __kind typeContent- where- __kind DataScalar {} = KindScalar- __kind DataEnum {} = KindEnum- __kind DataInputObject {} = KindInputObject- __kind DataObject {} = KindObject (toOperationType typeName)- __kind DataUnion {} = KindUnion- __kind DataInputUnion {} = KindInputUnion- -- TODO:- -- __kind DataInterface {} = KindInterface--fromOperation :: Maybe TypeDefinition -> [(Name, TypeDefinition)]-fromOperation (Just datatype) = [(typeName datatype,datatype)]-fromOperation Nothing = []--lookupDataType :: Key -> Schema -> Maybe TypeDefinition-lookupDataType name = HM.lookup name . typeRegister--isTypeDefined :: Key -> Schema -> Maybe DataFingerprint-isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib--defineType :: TypeDefinition -> Schema -> Schema-defineType dt@TypeDefinition { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint } lib- = lib { types = HM.insert name unionTags (HM.insert typeName dt (types lib)) }- where- name = typeName <> "Tags"- unionTags = TypeDefinition- { typeName = name- , typeFingerprint- , typeMeta = Nothing- , typeContent = DataEnum $ map (createEnumValue . fst) enumKeys- }-defineType datatype lib =- lib { types = HM.insert (typeName datatype) datatype (types lib) }--insertType :: TypeDefinition -> TypeUpdater-insertType datatype@TypeDefinition { typeName } lib = case isTypeDefined typeName lib of- Nothing -> resolveUpdates (defineType datatype lib) []- Just fingerprint | fingerprint == typeFingerprint datatype -> return lib- -- throw error if 2 different types has same name- | otherwise -> failure $ nameCollisionError typeName--lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a -lookupWith f key = find ((== key) . f) ---- lookups and removes TypeDefinition from hashmap -popByKey :: Name -> [TypeDefinition] -> (Maybe TypeDefinition,[TypeDefinition])-popByKey name lib = case lookupWith typeName name lib of- Just dt@TypeDefinition { typeContent = DataObject {} } ->- (Just dt, filter ((/= name) . typeName) lib)- _ -> (Nothing, lib) ---- 3.6 Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects---------------------------------------------------------------------------------- ObjectTypeDefinition:--- Description(opt) type Name ImplementsInterfaces(opt) Directives(Const)(opt) FieldsDefinition(opt)------ ImplementsInterfaces--- implements &(opt) NamedType--- ImplementsInterfaces & NamedType------ FieldsDefinition--- { FieldDefinition(list) }-----newtype FieldsDefinition = FieldsDefinition - { unFieldsDefinition :: OrderedMap FieldDefinition } - deriving (Show, Empty)--unsafeFromFields :: [FieldDefinition] -> FieldsDefinition -unsafeFromFields = FieldsDefinition . unsafeFromValues--instance Merge FieldsDefinition where- merge path (FieldsDefinition x) (FieldsDefinition y) = FieldsDefinition <$> merge path x y--instance Selectable FieldsDefinition FieldDefinition where- selectOr fb f name (FieldsDefinition lib) = selectOr fb f name lib--instance Singleton FieldsDefinition FieldDefinition where - singleton = FieldsDefinition . singleton --instance Listable FieldsDefinition FieldDefinition where- fromAssoc ls = FieldsDefinition <$> fromAssoc ls - toAssoc = toAssoc . unFieldsDefinition- --- FieldDefinition--- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt)--- -data FieldDefinition = FieldDefinition- { fieldName :: Key- , fieldArgs :: ArgumentsDefinition- , fieldType :: TypeRef- , fieldMeta :: Maybe Meta- } deriving (Show,Lift)--instance KeyOf FieldDefinition where - keyOf = fieldName--instance Selectable FieldDefinition ArgumentDefinition where- selectOr fb f key FieldDefinition { fieldArgs } = selectOr fb f key fieldArgs --instance NameCollision FieldDefinition where - nameCollision name _ = GQLError { - message = "There can Be only One field Named \"" <> name <> "\"",- locations = []- }--fieldVisibility :: FieldDefinition -> Bool-fieldVisibility FieldDefinition { fieldName } = fieldName `notElem` sysFields--isFieldNullable :: FieldDefinition -> Bool-isFieldNullable = isNullable . fieldType--createField :: ArgumentsDefinition -> Key -> ([TypeWrapper], Key) -> FieldDefinition-createField dataArguments fieldName (typeWrappers, typeConName) = FieldDefinition- { fieldArgs = dataArguments- , fieldName- , fieldType = TypeRef { typeConName, typeWrappers, typeArgs = Nothing }- , fieldMeta = Nothing- }--toHSFieldDefinition :: FieldDefinition -> FieldDefinition-toHSFieldDefinition field@FieldDefinition { fieldType = tyRef@TypeRef { typeConName } } = field - { fieldType = tyRef { typeConName = hsTypeName typeConName } }--toNullableField :: FieldDefinition -> FieldDefinition-toNullableField dataField- | isNullable (fieldType dataField) = dataField- | otherwise = dataField { fieldType = nullable (fieldType dataField) }- where- nullable alias@TypeRef { typeWrappers } =- alias { typeWrappers = TypeMaybe : typeWrappers }--toListField :: FieldDefinition -> FieldDefinition-toListField dataField = dataField { fieldType = listW (fieldType dataField) }- where- listW alias@TypeRef { typeWrappers } =- alias { typeWrappers = TypeList : typeWrappers }------ 3.10 Input Objects: https://spec.graphql.org/June2018/#sec-Input-Objects------------------------------------------------------------------------------- InputObjectTypeDefinition--- Description(opt) input Name Directives(const,opt) InputFieldsDefinition(opt)------- InputFieldsDefinition--- { InputValueDefinition(list) }--newtype InputFieldsDefinition = InputFieldsDefinition - { unInputFieldsDefinition :: OrderedMap FieldDefinition } - deriving (Show, Empty)--unsafeFromInputFields :: [FieldDefinition] -> InputFieldsDefinition -unsafeFromInputFields = InputFieldsDefinition . unsafeFromValues--instance Merge InputFieldsDefinition where- merge path (InputFieldsDefinition x) (InputFieldsDefinition y) = InputFieldsDefinition <$> merge path x y--instance Selectable InputFieldsDefinition FieldDefinition where- selectOr fb f name (InputFieldsDefinition lib) = selectOr fb f name lib--instance Singleton InputFieldsDefinition FieldDefinition where - singleton = InputFieldsDefinition . singleton --instance Listable InputFieldsDefinition FieldDefinition where- fromAssoc ls = InputFieldsDefinition <$> fromAssoc ls - toAssoc = toAssoc . unInputFieldsDefinition----- 3.6.1 Field Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments--------------------------------------------------------------------------------------------------- ArgumentsDefinition:--- (InputValueDefinition(list))--data ArgumentsDefinition - = ArgumentsDefinition - { argumentsTypename :: Maybe Name- , arguments :: OrderedMap ArgumentDefinition- }- | NoArguments- deriving (Show, Lift)--type ArgumentDefinition = FieldDefinition ---instance Selectable ArgumentsDefinition ArgumentDefinition where- selectOr fb _ _ NoArguments = fb- selectOr fb f key (ArgumentsDefinition _ args) = selectOr fb f key args --instance Singleton ArgumentsDefinition ArgumentDefinition where- singleton = ArgumentsDefinition Nothing . singleton --instance Listable ArgumentsDefinition ArgumentDefinition where- toAssoc NoArguments = []- toAssoc (ArgumentsDefinition _ args) = toAssoc args- fromAssoc [] = pure NoArguments- fromAssoc args = ArgumentsDefinition Nothing <$> fromAssoc args--createArgument :: Key -> ([TypeWrapper], Key) -> FieldDefinition-createArgument = createField NoArguments--hasArguments :: ArgumentsDefinition -> Bool-hasArguments NoArguments = False-hasArguments _ = True------ https://spec.graphql.org/June2018/#InputValueDefinition--- InputValueDefinition--- Description(opt) Name: TypeDefaultValue(opt) Directives[Const](opt)--- TODO: implement inputValue---- data InputValueDefinition = InputValueDefinition--- { inputValueName :: Key--- , inputValueType :: TypeRef--- , inputValueMeta :: Maybe Meta--- } deriving (Show,Lift)--__inputname :: Name-__inputname = "inputname"--createInputUnionFields :: Key -> [Key] -> [FieldDefinition]-createInputUnionFields name members = fieldTag : map unionField members- where- fieldTag = FieldDefinition - { fieldName = __inputname- , fieldArgs = NoArguments- , fieldType = createAlias (name <> "Tags")- , fieldMeta = Nothing- }- unionField memberName = FieldDefinition- { fieldArgs = NoArguments- , fieldName = memberName- , fieldType = TypeRef { typeConName = memberName- , typeWrappers = [TypeMaybe]- , typeArgs = Nothing- }- , fieldMeta = Nothing- }------ OTHER-----------------------------------------------------------------------------------------------------createAlias :: Key -> TypeRef-createAlias typeConName =- TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing }--type TypeUpdater = LibUpdater Schema---- TEMPLATE HASKELL DATA TYPES-data ClientQuery = ClientQuery- { queryText :: String- , queryTypes :: [ClientType]- , queryArgsType :: Maybe TypeD- } deriving (Show)--data ClientType = ClientType {- clientType :: TypeD,- clientKind :: DataTypeKind-} deriving (Show)---- Document-data GQLTypeD = GQLTypeD- { typeD :: TypeD- , typeKindD :: DataTypeKind- , typeArgD :: [TypeD]- , typeOriginal:: TypeDefinition- } deriving (Show)--data TypeD = TypeD- { tName :: Name- , tNamespace :: [Name]- , tCons :: [ConsD]- , tMeta :: Maybe Meta- } deriving (Show)--data ConsD = ConsD- { cName :: Name- , cFields :: [FieldDefinition]- } deriving (Show)
− src/Data/Morpheus/Types/Internal/AST/MergeSet.hs
@@ -1,106 +0,0 @@-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Types.Internal.AST.MergeSet- ( MergeSet- , toOrderedMap- , concatTraverse- , join- )-where --import Data.Semigroup ((<>))-import Data.List (find, (\\))-import Data.Maybe (maybe)-import Language.Haskell.TH.Syntax ( Lift(..) )---- MORPHEUS-import Data.Morpheus.Types.Internal.Operation ( Merge(..)- , Empty(..)- , Singleton(..)- , Selectable(..)- , Listable(..)- , Failure(..)- , KeyOf(..)- , toPair- )-import Data.Morpheus.Types.Internal.AST.Base ( Named- , GQLErrors- , Ref- )-import Data.Morpheus.Types.Internal.AST.OrderedMap - ( OrderedMap(..) )-import qualified Data.Morpheus.Types.Internal.AST.OrderedMap as OM ---- set with mergeable components-newtype MergeSet a = MergeSet { - unpack :: [a]- } deriving ( Show, Eq, Functor, Foldable , Lift )--concatTraverse :: (KeyOf a, Eq a, Eq b, Merge a, Merge b, KeyOf b, Monad m, Failure GQLErrors m) => (a -> m (MergeSet b)) -> MergeSet a -> m (MergeSet b)-concatTraverse f smap = traverse f (toList smap) >>= join --join :: (Eq a, KeyOf a , Merge a, Monad m, Failure GQLErrors m) => [MergeSet a] -> m (MergeSet a)-join = __join empty- where- __join :: (Eq a,KeyOf a, Merge a, Monad m, Failure GQLErrors m) => MergeSet a ->[MergeSet a] -> m (MergeSet a)- __join acc [] = pure acc- __join acc (x:xs) = acc <:> x >>= (`__join` xs)--toOrderedMap :: KeyOf a => MergeSet a -> OrderedMap a-toOrderedMap = OM.unsafeFromValues . unpack--instance Traversable MergeSet where- traverse f = fmap MergeSet . traverse f . unpack--instance Empty (MergeSet a) where - empty = MergeSet []--instance (KeyOf a) => Singleton (MergeSet a) a where- singleton x = MergeSet [x]--instance KeyOf a => Selectable (MergeSet a) a where - selectOr fb _ "" _ = fb- selectOr fb f key (MergeSet ls) = maybe fb f (find ((key ==) . keyOf) ls)---- must merge files on collision -instance (KeyOf a, Merge a, Eq a) => Merge (MergeSet a) where - merge = safeJoin--instance (KeyOf a, Merge a, Eq a) => Listable (MergeSet a) a where- fromAssoc = safeFromList- toAssoc = map toPair . unpack --safeFromList :: (Monad m, KeyOf a, Eq a, Merge a ,Failure GQLErrors m) => [Named a] -> m (MergeSet a)-safeFromList = insertList [] empty . map snd--safeJoin :: (Monad m, KeyOf a, Eq a, Merge a ,Failure GQLErrors m) => [Ref] -> MergeSet a -> MergeSet a -> m (MergeSet a)-safeJoin path hm1 hm2 = insertList path hm1 (toList hm2)--insertList:: (Monad m, Eq a, KeyOf a, Merge a ,Failure GQLErrors m) => [Ref] -> MergeSet a -> [a] -> m (MergeSet a)-insertList _ smap [] = pure smap-insertList path smap (x:xs) = insert path smap x >>= flip (insertList path) xs--insert :: (Monad m, Eq a, KeyOf a , Merge a ,Failure GQLErrors m) => [Ref] -> MergeSet a -> a -> m (MergeSet a)-insert path mSet@(MergeSet ls) currentValue = MergeSet <$> __insert- where- __insert = selectOr - (pure $ ls <> [currentValue])- mergeWith- (keyOf currentValue) - mSet- ------------------- mergeWith oldValue- | oldValue == currentValue = pure ls- | otherwise = do - mergedValue <- merge path oldValue currentValue- pure $ ( ls \\ [oldValue]) <> [mergedValue]----
− src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs
@@ -1,111 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Types.Internal.AST.OrderedMap- ( OrderedMap(..)- , unsafeFromValues- , traverseWithKey- , foldWithKey- , update- )-where --import Data.HashMap.Lazy ( HashMap )-import qualified Data.HashMap.Lazy as HM -import Data.Semigroup ((<>))-import Data.Maybe (isJust,fromMaybe)-import Language.Haskell.TH.Syntax ( Lift(..) )---- MORPHEUS-import Data.Morpheus.Error.NameCollision (NameCollision(..))-import Data.Morpheus.Types.Internal.Operation ( Merge(..)- , Empty(..)- , Singleton(..)- , Selectable(..)- , Listable(..)- , Failure(..)- , KeyOf(..)- , toPair- )-import Data.Morpheus.Types.Internal.AST.Base ( Name- , Named- , GQLErrors- )----- OrderedMap -data OrderedMap a = OrderedMap { - mapKeys :: [Name], - mapEntries :: HashMap Name a - } deriving (Show, Eq, Functor)--traverseWithKey :: Applicative t => (Name -> a -> t b) -> OrderedMap a -> t (OrderedMap b)-traverseWithKey f (OrderedMap names hmap) = OrderedMap names <$> HM.traverseWithKey f hmap--foldWithKey :: NameCollision a => (Name -> a -> b -> b) -> b -> OrderedMap a -> b-foldWithKey f defValue om = foldr (uncurry f) defValue (toAssoc om)--update :: KeyOf a => a -> OrderedMap a -> OrderedMap a -update x (OrderedMap names values) = OrderedMap newNames $ HM.insert name x values- where- name = keyOf x- newNames - | name `elem` names = names- | otherwise = names <> [name]--instance Lift a => Lift (OrderedMap a) where- lift (OrderedMap names x) = [| OrderedMap names (HM.fromList ls) |]- where ls = HM.toList x--instance Foldable OrderedMap where- foldMap f OrderedMap { mapEntries } = foldMap f mapEntries--instance Traversable OrderedMap where- traverse f (OrderedMap names values) = OrderedMap names <$> traverse f values--instance Empty (OrderedMap a) where - empty = OrderedMap [] HM.empty--instance (KeyOf a) => Singleton (OrderedMap a) a where- singleton x = OrderedMap [keyOf x] $ HM.singleton (keyOf x) x --instance Selectable (OrderedMap a) a where - selectOr fb f key OrderedMap { mapEntries } = maybe fb f (HM.lookup key mapEntries)--instance NameCollision a => Merge (OrderedMap a) where - merge _ (OrderedMap k1 x) (OrderedMap k2 y) = OrderedMap (k1 <> k2) <$> safeJoin x y--instance NameCollision a => Listable (OrderedMap a) a where- fromAssoc = safeFromList- toAssoc OrderedMap { mapKeys, mapEntries } = map takeValue mapKeys- where - takeValue key = (key, fromMaybe (error "TODO:error") (key `HM.lookup` mapEntries ))--safeFromList :: (Failure GQLErrors m, Applicative m, NameCollision a) => [Named a] -> m (OrderedMap a)-safeFromList values = OrderedMap (map fst values) <$> safeUnionWith HM.empty values --unsafeFromValues :: KeyOf a => [a] -> OrderedMap a-unsafeFromValues x = OrderedMap (map keyOf x) $ HM.fromList $ map toPair x--safeJoin :: (Failure GQLErrors m, Applicative m, NameCollision a) => HashMap Name a -> HashMap Name a -> m (HashMap Name a)-safeJoin hm newls = safeUnionWith hm (HM.toList newls)--safeUnionWith :: (Failure GQLErrors m, Applicative m, NameCollision a) => HashMap Name a -> [Named a] -> m (HashMap Name a)-safeUnionWith hm names = case insertNoDups (hm,[]) names of - (res,dupps) | null dupps -> pure res- | otherwise -> failure $ map (uncurry nameCollision) dupps--type NoDupHashMap a = (HashMap Name a,[Named a])--insertNoDups :: NoDupHashMap a -> [Named a] -> NoDupHashMap a-insertNoDups collected [] = collected-insertNoDups (coll,errors) (pair@(name,value):xs)- | isJust (name `HM.lookup` coll) = insertNoDups (coll,errors <> [pair]) xs- | otherwise = insertNoDups (HM.insert name value coll,errors) xs
− src/Data/Morpheus/Types/Internal/AST/Selection.hs
@@ -1,247 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}--module Data.Morpheus.Types.Internal.AST.Selection- ( Selection(..)- , SelectionContent(..)- , SelectionSet- , UnionTag(..)- , UnionSelection- , Fragment(..)- , Fragments- , Operation(..)- , Variable(..)- , VariableDefinitions- , DefaultValue- , getOperationName- , getOperationDataType- )-where---import Data.Maybe ( fromMaybe , isJust )-import Data.Semigroup ( (<>) )-import Language.Haskell.TH.Syntax ( Lift(..) )-import qualified Data.Text as T---- MORPHEUS-import Data.Morpheus.Error.Operation ( mutationIsNotDefined - , subscriptionIsNotDefined- )-import Data.Morpheus.Types.Internal.AST.Base- ( Key- , Position- , Ref(..)- , Name- , VALID- , RAW- , Stage- , OperationType(..)- , GQLError(..)- , GQLErrors- , Message- )-import Data.Morpheus.Types.Internal.AST.Data- ( Schema(..)- , TypeDefinition(..)- , Arguments- )-import Data.Morpheus.Types.Internal.AST.Value- ( Variable(..)- , VariableDefinitions- , ResolvedValue- )-import Data.Morpheus.Types.Internal.AST.MergeSet- ( MergeSet )-import Data.Morpheus.Types.Internal.AST.OrderedMap- ( OrderedMap )-import Data.Morpheus.Types.Internal.Operation- ( KeyOf(..)- , Merge(..)- , Failure(..)- )-import Data.Morpheus.Error.NameCollision- ( NameCollision(..) )--data Fragment = Fragment- { fragmentName :: Name- , fragmentType :: Name- , fragmentPosition :: Position- , fragmentSelection :: SelectionSet RAW- } deriving ( Show, Eq, Lift)---- ERRORs-instance NameCollision Fragment where- nameCollision _ Fragment { fragmentName , fragmentPosition } = GQLError- { message = "There can be only one fragment named \"" <> fragmentName <> "\"."- , locations = [fragmentPosition]- }--instance KeyOf Fragment where - keyOf = fragmentName--type Fragments = OrderedMap Fragment--data SelectionContent (s :: Stage) where- SelectionField :: SelectionContent s- SelectionSet :: SelectionSet s -> SelectionContent s- UnionSelection :: UnionSelection -> SelectionContent VALID--instance Merge (SelectionContent s) where- merge path (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge path s1 s2- merge path (UnionSelection u1) (UnionSelection u2) = UnionSelection <$> merge path u1 u2- merge path oldC currC- | oldC == currC = pure oldC- | otherwise = failure [- GQLError {- message = T.concat $ map refName path,- locations = map refPosition path- }- ]--deriving instance Show (SelectionContent a)-deriving instance Eq (SelectionContent a)-deriving instance Lift (SelectionContent a)--data UnionTag = UnionTag {- unionTagName :: Name,- unionTagSelection :: SelectionSet VALID-} deriving (Show, Eq, Lift)---mergeConflict :: [Ref] -> GQLError -> GQLErrors-mergeConflict [] err = [err]-mergeConflict refs@(rootField:xs) err = [- GQLError {- message = renderSubfields <> message err,- locations = map refPosition refs <> locations err- }- ]- where - fieldConflicts ref = "\"" <> refName ref <> "\" conflict because "- renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref- renderStart = "Fields " <> fieldConflicts rootField- renderSubfields = - foldr- renderSubfield- renderStart- xs--instance Merge UnionTag where - merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) - = UnionTag oldTag <$> merge path oldSel currentSel--instance KeyOf UnionTag where- keyOf = unionTagName--type UnionSelection = MergeSet UnionTag--type SelectionSet s = MergeSet (Selection s)--data Selection (s :: Stage) where- Selection ::- { selectionName :: Name- , selectionAlias :: Maybe Name- , selectionPosition :: Position- , selectionArguments :: Arguments s- , selectionContent :: SelectionContent s- } -> Selection s- InlineFragment :: Fragment -> Selection RAW- Spread :: Ref -> Selection RAW--instance KeyOf (Selection s) where- keyOf Selection { selectionName , selectionAlias } = fromMaybe selectionName selectionAlias- keyOf InlineFragment {} = ""- keyOf Spread {} = ""--useDufferentAliases :: Message-useDufferentAliases - = "Use different aliases on the "- <> "fields to fetch both if this was intentional."--instance Merge (Selection a) where - merge path old@Selection{ selectionPosition = pos1 } current@Selection{ selectionPosition = pos2 }- = do- selectionName <- mergeName- let currentPath = path <> [Ref selectionName pos1]- selectionArguments <- mergeArguments currentPath- selectionContent <- merge currentPath (selectionContent old) (selectionContent current)- pure $ Selection {- selectionName,- selectionAlias = mergeAlias,- selectionPosition = pos1,- selectionArguments,- selectionContent- }- where - -- passes if: - -- * { user : user }- -- * { user1: user- -- user1: user- -- }- -- fails if:- -- * { user1: user- -- user1: product- -- }- mergeName - | selectionName old == selectionName current = pure $ selectionName current- | otherwise = failure $ mergeConflict path $ GQLError {- message = "\"" <> selectionName old <> "\" and \"" <> selectionName current - <> "\" are different fields. " <> useDufferentAliases,- locations = [pos1, pos2]- }- ---------------------- -- allias name is relevant only if they collide by allias like:- -- { user1: user- -- user1: user- -- }- mergeAlias - | all (isJust . selectionAlias) [old,current] = selectionAlias old- | otherwise = Nothing- --- arguments must be equal- mergeArguments currentPath- | selectionArguments old == selectionArguments current = pure $ selectionArguments current- | otherwise = failure $ mergeConflict currentPath $ GQLError - { message = "they have differing arguments. " <> useDufferentAliases- , locations = [pos1,pos2]- }- -- TODO:- merge path old current = failure $ mergeConflict path $ GQLError - { message = "can't merge. " <> useDufferentAliases- , locations = map selectionPosition [old,current]- }- -deriving instance Show (Selection a)-deriving instance Lift (Selection a)-deriving instance Eq (Selection a)--type DefaultValue = Maybe ResolvedValue--data Operation (s:: Stage) = Operation- { operationName :: Maybe Key- , operationType :: OperationType- , operationArguments :: VariableDefinitions s- , operationSelection :: SelectionSet s- , operationPosition :: Position- } deriving (Show,Lift)--getOperationName :: Maybe Key -> Key-getOperationName = fromMaybe "AnonymousOperation"--getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m TypeDefinition-getOperationDataType Operation { operationType = Query } lib = pure (query lib)-getOperationDataType Operation { operationType = Mutation, operationPosition } lib- = case mutation lib of- Just x -> pure x- Nothing -> failure $ mutationIsNotDefined operationPosition-getOperationDataType Operation { operationType = Subscription, operationPosition } lib- = case subscription lib of- Just x -> pure x- Nothing -> failure $ subscriptionIsNotDefined operationPosition
− src/Data/Morpheus/Types/Internal/AST/Value.hs
@@ -1,297 +0,0 @@-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DeriveLift #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TemplateHaskell #-}--module Data.Morpheus.Types.Internal.AST.Value- ( Value(..)- , ScalarValue(..)- , Object- , GQLValue(..)- , replaceValue- , decodeScientific- , convertToJSONName- , convertToHaskellName- , RawValue- , ValidValue- , RawObject- , ValidObject- , Variable(..)- , ResolvedValue- , ResolvedObject- , VariableContent(..)- , ObjectEntry(..)- , VariableDefinitions- )-where--import qualified Data.Aeson as A- ( FromJSON(..)- , ToJSON(..)- , Value(..)- , object- , pairs- , (.=)- )-import qualified Data.HashMap.Strict as M- ( toList )-import Data.Scientific ( Scientific- , floatingOrInteger- )-import Data.Semigroup ( (<>) )-import Data.Text ( Text- , unpack- )-import qualified Data.Text as T-import qualified Data.Vector as V- ( toList )-import GHC.Generics ( Generic )-import Instances.TH.Lift ( )-import Language.Haskell.TH.Syntax ( Lift(..) )---- MORPHEUS-import Data.Morpheus.Error.NameCollision- ( NameCollision(..) )-import Data.Morpheus.Types.Internal.AST.Base- ( Ref(..)- , Name- , RAW- , VALID- , Position- , Stage- , RESOLVED- , TypeRef- , GQLError(..)- , TypeRef(..)- )-import Data.Morpheus.Types.Internal.AST.OrderedMap- ( OrderedMap- , unsafeFromValues- , foldWithKey- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- , KeyOf(..)- )--isReserved :: Name -> Bool-isReserved "case" = True-isReserved "class" = True-isReserved "data" = True-isReserved "default" = True-isReserved "deriving" = True-isReserved "do" = True-isReserved "else" = True-isReserved "foreign" = True-isReserved "if" = True-isReserved "import" = True-isReserved "in" = True-isReserved "infix" = True-isReserved "infixl" = True-isReserved "infixr" = True-isReserved "instance" = True-isReserved "let" = True-isReserved "module" = True-isReserved "newtype" = True-isReserved "of" = True-isReserved "then" = True-isReserved "type" = True-isReserved "where" = True-isReserved "_" = True-isReserved _ = False--{-# INLINE isReserved #-}-convertToJSONName :: Text -> Text-convertToJSONName hsName- | not (T.null hsName) && isReserved name && (T.last hsName == '\'') = name- | otherwise = hsName- where name = T.init hsName--convertToHaskellName :: Text -> Text-convertToHaskellName name | isReserved name = name <> "'"- | otherwise = name---- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'.--- for performance reason type 'Text' represents GraphQl 'String' value-data ScalarValue- = Int Int- | Float Float- | String Text- | Boolean Bool- deriving (Show, Eq, Generic,Lift)--instance A.ToJSON ScalarValue where- toJSON (Float x) = A.toJSON x- toJSON (Int x) = A.toJSON x- toJSON (Boolean x) = A.toJSON x- toJSON (String x) = A.toJSON x--instance A.FromJSON ScalarValue where- parseJSON (A.Bool v) = pure $ Boolean v- parseJSON (A.Number v) = pure $ decodeScientific v- parseJSON (A.String v) = pure $ String v- parseJSON notScalar = fail $ "Expected Scalar got :" <> show notScalar--type family VAR (a:: Stage) :: Stage-type instance VAR RAW = RESOLVED-type instance VAR RESOLVED = RESOLVED-type instance VAR VALID = VALID--data VariableContent (stage:: Stage) where- DefaultValue ::Maybe ResolvedValue -> VariableContent RESOLVED- ValidVariableValue ::{ validVarContent::ValidValue }-> VariableContent VALID--instance Lift (VariableContent a) where- lift (DefaultValue x) = [| DefaultValue x |]- lift (ValidVariableValue x) = [| ValidVariableValue x |]--deriving instance Show (VariableContent a)-deriving instance Eq (VariableContent a)--data Variable (stage :: Stage) = Variable- { variableName :: Name- , variableType :: TypeRef- , variablePosition :: Position- , variableValue :: VariableContent (VAR stage)- } deriving (Show, Eq, Lift)--instance KeyOf (Variable s) where- keyOf = variableName--instance NameCollision (Variable s) where - nameCollision _ Variable { variableName , variablePosition } = GQLError { - message = "There can Be only One Variable Named \"" <> variableName <> "\"",- locations = [variablePosition]- }--type VariableDefinitions s = OrderedMap (Variable s)--data Value (stage :: Stage) where- ResolvedVariable::Ref -> Variable VALID -> Value RESOLVED- VariableValue ::Ref -> Value RAW- Object ::Object stage -> Value stage- List ::[Value stage] -> Value stage- Enum ::Name -> Value stage- Scalar ::ScalarValue -> Value stage- Null ::Value stage--deriving instance Eq (Value s)--data ObjectEntry (s :: Stage) = ObjectEntry {- entryName :: Name,- entryValue :: Value s- -- ObjectEntryposition :: Position-} deriving (Eq)--instance Show (ObjectEntry s) where - show (ObjectEntry name value) = unpack name <> ":" <> show value--instance NameCollision (ObjectEntry s) where - nameCollision _ ObjectEntry { entryName } = GQLError { - message = "There can Be only One field Named \"" <> entryName <> "\"",- locations = []- }--instance KeyOf (ObjectEntry s) where- keyOf = entryName--type Object a = OrderedMap (ObjectEntry a)-type ValidObject = Object VALID-type RawObject = Object RAW-type ResolvedObject = Object RESOLVED-type RawValue = Value RAW-type ValidValue = Value VALID-type ResolvedValue = Value RESOLVED--deriving instance Lift (Value a)-deriving instance Lift (ObjectEntry a)---instance Show (Value a) where- show Null = "null"- show (Enum x) = "" <> unpack x- show (Scalar x) = show x- show (ResolvedVariable Ref { refName } Variable { variableValue }) =- "($" <> unpack refName <> ": " <> show variableValue <> ") "- show (VariableValue Ref { refName }) = "$" <> unpack refName <> " "- show (Object keys ) = "{" <> foldWithKey toEntry "" keys <> "}"- where- toEntry :: Name -> ObjectEntry a -> String -> String- toEntry _ value "" = show value- toEntry _ value txt = txt <> ", " <> show value- show (List list) = "[" <> foldl toEntry "" list <> "]"- where- toEntry :: String -> Value a -> String- toEntry "" value = show value- toEntry txt value = txt <> ", " <> show value--instance A.ToJSON (Value a) where- toJSON (ResolvedVariable _ Variable { variableValue = ValidVariableValue x })- = A.toJSON x- toJSON (VariableValue Ref { refName }) =- A.String $ "($ref:" <> refName <> ")"- toJSON Null = A.Null- toJSON (Enum x ) = A.String x- toJSON (Scalar x ) = A.toJSON x- toJSON (List x ) = A.toJSON x- toJSON (Object fields) = A.object $ map toEntry (toList fields)- where toEntry (ObjectEntry key value) = key A..= A.toJSON value- -------------------------------------------- toEncoding (ResolvedVariable _ Variable { variableValue = ValidVariableValue x })- = A.toEncoding x- toEncoding (VariableValue Ref { refName }) =- A.toEncoding $ "($ref:" <> refName <> ")"- toEncoding Null = A.toEncoding A.Null- toEncoding (Enum x ) = A.toEncoding x- toEncoding (Scalar x ) = A.toEncoding x- toEncoding (List x ) = A.toEncoding x- toEncoding (Object ordmap) - | null ordmap = A.toEncoding $ A.object []- | otherwise = A.pairs $ foldl1 (<>) $ map encodeField (toList ordmap)- where encodeField (ObjectEntry key value) = convertToJSONName key A..= value--decodeScientific :: Scientific -> ScalarValue-decodeScientific v = case floatingOrInteger v of- Left float -> Float float- Right int -> Int int--replaceValue :: A.Value -> Value a-replaceValue (A.Bool v) = gqlBoolean v-replaceValue (A.Number v) = Scalar $ decodeScientific v-replaceValue (A.String v) = gqlString v-replaceValue (A.Object v) = gqlObject $ map replace (M.toList v)- where- --replace :: (a, A.Value) -> (a, Value a)- replace (key, val) = (key, replaceValue val)-replaceValue (A.Array li) = gqlList (map replaceValue (V.toList li))-replaceValue A.Null = gqlNull--instance A.FromJSON (Value a) where- parseJSON = pure . replaceValue---- DEFAULT VALUES-class GQLValue a where- gqlNull :: a- gqlScalar :: ScalarValue -> a- gqlBoolean :: Bool -> a- gqlString :: Text -> a- gqlList :: [a] -> a- gqlObject :: [(Name, a)] -> a---- build GQL Values for Subscription Resolver-instance GQLValue (Value a) where- gqlNull = Null- gqlScalar = Scalar- gqlBoolean = Scalar . Boolean- gqlString = Scalar . String- gqlList = List- gqlObject = Object . unsafeFromValues . map toEntry- where - toEntry (key,value) = ObjectEntry key value
− src/Data/Morpheus/Types/Internal/Operation.hs
@@ -1,100 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}---module Data.Morpheus.Types.Internal.Operation- ( Empty(..) - , Selectable(..)- , Singleton(..)- , Listable(..)- , Merge(..)- , Failure(..)- , KeyOf(..)- , toPair- , selectBy- , member- , keys- )- where --import Data.List (find)-import Data.Text ( Text )-import Instances.TH.Lift ( )-import Data.HashMap.Lazy ( HashMap )-import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.Types.Internal.AST.Base ( Name- , Named- , GQLErrors- , Ref(..)- )-import Text.Megaparsec.Internal ( ParsecT(..) )-import Text.Megaparsec.Stream ( Stream )--class Empty a where - empty :: a--instance Empty (HashMap k v) where- empty = HM.empty--class Selectable c a | c -> a where - selectOr :: d -> (a -> d) -> Name -> c -> d--instance KeyOf a => Selectable [a] a where- selectOr fb f key lib = maybe fb f (find ((key ==) . keyOf) lib)--instance Selectable (HashMap Text a) a where - selectOr fb f key lib = maybe fb f (HM.lookup key lib)--selectBy :: (Failure e m, Selectable c a, Monad m) => e -> Name -> c -> m a-selectBy err = selectOr (failure err) pure--member :: forall a c. Selectable c a => Name -> c -> Bool-member = selectOr False toTrue- where - toTrue :: a -> Bool- toTrue _ = True--class KeyOf a => Singleton c a | c -> a where- singleton :: a -> c--class KeyOf a where - keyOf :: a -> Name--instance KeyOf Ref where- keyOf = refName--toPair :: KeyOf a => a -> (Name,a)-toPair x = (keyOf x, x)--class Listable c a | c -> a where- size :: c -> Int- size = length . toList - fromAssoc :: (Monad m, Failure GQLErrors m) => [Named a] -> m c- toAssoc :: c -> [Named a]- fromList :: (KeyOf a, Monad m, Failure GQLErrors m) => [a] -> m c- -- TODO: fromValues- toList = map snd . toAssoc - fromList = fromAssoc . map toPair - -- TODO: toValues - toList :: c -> [a] --keys :: Listable c a => c -> [Name]-keys = map fst . toAssoc--class Merge a where - (<:>) :: (Monad m, Failure GQLErrors m) => a -> a -> m a- (<:>) = merge []- merge :: (Monad m, Failure GQLErrors m) => [Ref] -> a -> a -> m a--class Applicative f => Failure error (f :: * -> *) where- failure :: error -> f v--instance Failure error (Either error) where- failure = Left--instance (Stream s, Ord e, Failure [a] m) => Failure [a] (ParsecT e s m) where- failure x = ParsecT $ \_ _ _ _ _ -> failure x
− src/Data/Morpheus/Types/Internal/Resolving.hs
@@ -1,39 +0,0 @@-module Data.Morpheus.Types.Internal.Resolving- ( Event(..)- , GQLRootResolver(..)- , UnSubResolver- , Resolver- , MapStrategy(..)- , LiftOperation- , runResolverModel- , toResolver- , lift- , SubEvent- , Eventless- , Failure(..)- , GQLChannel(..)- , ResponseEvent(..)- , ResponseStream- , cleanEvents- , Result(..)- , ResultT(..)- , unpackEvents- , LibUpdater- , resolveUpdates- , setTypeName- , ObjectDeriving(..)- , Deriving(..)- , FieldRes- , WithOperation- , PushEvents(..)- , subscribe- , Context(..)- , unsafeInternalContext- , ResolverModel(..)- , unsafeBind- , liftStateless- )-where--import Data.Morpheus.Types.Internal.Resolving.Resolver-import Data.Morpheus.Types.Internal.Resolving.Core
− src/Data/Morpheus/Types/Internal/Resolving/Core.hs
@@ -1,184 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.Morpheus.Types.Internal.Resolving.Core- ( Eventless- , Result(..)- , Failure(..)- , ResultT(..)- , unpackEvents- , LibUpdater- , resolveUpdates- , mapEvent- , cleanEvents- , Event(..)- , Channel(..)- , GQLChannel(..)- , PushEvents(..)- , statelessToResultT- )-where--import Control.Monad ( foldM )-import Data.Function ( (&) )-import Control.Monad.Trans.Class ( MonadTrans(..) )-import Control.Applicative ( liftA2 )-import Data.Morpheus.Types.Internal.Operation- ( - Failure(..)- )-import Data.Morpheus.Types.Internal.AST.Base- ( GQLErrors- , GQLError(..)- )-import Data.Text ( Text- , pack- )-import Data.Semigroup ( (<>) )---type Eventless = Result ()---- EVENTS-class PushEvents e m where - pushEvents :: [e] -> m () ---- Channel-newtype Channel event = Channel {- _unChannel :: StreamChannel event-}--instance (Eq (StreamChannel event)) => Eq (Channel event) where- Channel x == Channel y = x == y--class GQLChannel a where- type StreamChannel a :: *- streamChannels :: a -> [Channel a]--instance GQLChannel () where- type StreamChannel () = ()- streamChannels _ = []--instance GQLChannel (Event channel content) where- type StreamChannel (Event channel content) = channel- streamChannels Event { channels } = map Channel channels--data Event e c = Event- { channels :: [e], content :: c}---unpackEvents :: Result event a -> [event]-unpackEvents Success { events } = events-unpackEvents _ = []------- Result-------data Result events a - = Success { result :: a , warnings :: GQLErrors , events:: [events] }- | Failure { errors :: GQLErrors } deriving (Functor)--instance Applicative (Result e) where- pure x = Success x [] []- Success f w1 e1 <*> Success x w2 e2 = Success (f x) (w1 <> w2) (e1 <> e2)- Failure e1 <*> Failure e2 = Failure (e1 <> e2)- Failure e <*> Success _ w _ = Failure (e <> w)- Success _ w _ <*> Failure e = Failure (e <> w)--instance Monad (Result e) where- return = pure- Success v w1 e1 >>= fm = case fm v of- (Success x w2 e2) -> Success x (w1 <> w2) (e1 <> e2)- (Failure e ) -> Failure (e <> w1)- Failure e >>= _ = Failure e--instance Failure [GQLError] (Result ev) where- failure = Failure--instance Failure Text Eventless where- failure text =- Failure [GQLError { message = "INTERNAL: " <> text, locations = [] }]--instance PushEvents events (Result events) where- pushEvents events = Success { result = (), warnings = [], events } ---- ResultT-newtype ResultT event (m :: * -> * ) a - = ResultT - { - runResultT :: m (Result event a) - }- deriving (Functor)--statelessToResultT - :: Applicative m - => Eventless a - -> ResultT e m a-statelessToResultT - = cleanEvents- . ResultT - . pure --instance Applicative m => Applicative (ResultT event m) where- pure = ResultT . pure . pure- ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) app1 app2--instance Monad m => Monad (ResultT event m) where- return = pure- (ResultT m1) >>= mFunc = ResultT $ do- result1 <- m1- case result1 of- Failure errors -> pure $ Failure errors- Success value1 w1 e1 -> do- result2 <- runResultT (mFunc value1)- case result2 of- Failure errors -> pure $ Failure (errors <> w1)- Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2)--instance MonadTrans (ResultT event) where- lift = ResultT . fmap pure--instance Applicative m => Failure String (ResultT event m) where- failure x =- ResultT $ pure $ Failure [GQLError { message = pack x, locations = [] }]--instance Monad m => Failure GQLErrors (ResultT event m) where- failure = ResultT . pure . failure--instance Applicative m => PushEvents event (ResultT event m) where- pushEvents = ResultT . pure . pushEvents--cleanEvents- :: Functor m- => ResultT e m a- -> ResultT e' m a-cleanEvents resT = ResultT $ replace <$> runResultT resT- where- replace (Success v w _) = Success v w []- replace (Failure e ) = Failure e--mapEvent- :: Monad m- => (e -> e')- -> ResultT e m value- -> ResultT e' m value-mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma- where- mapEv Success { result, warnings, events } =- Success { result, warnings, events = map func events }- mapEv (Failure err) = Failure err---- Helper Functions-type LibUpdater lib = lib -> Eventless lib--resolveUpdates :: lib -> [LibUpdater lib] -> Eventless lib-resolveUpdates = foldM (&)
− src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs
@@ -1,571 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Data.Morpheus.Types.Internal.Resolving.Resolver- ( Event(..)- , GQLRootResolver(..)- , UnSubResolver- , Resolver- , MapStrategy(..)- , LiftOperation- , unsafeBind- , toResolver- , lift- , subscribe- , SubEvent- , GQLChannel(..)- , ResponseEvent(..)- , ResponseStream- , ObjectDeriving(..)- , Deriving(..)- , FieldRes- , WithOperation- , Context(..)- , unsafeInternalContext- , runResolverModel- , setTypeName- , ResolverModel(..)- , liftStateless- )-where--import Control.Monad.Fail (MonadFail(..))-import Control.Monad.Trans.Class ( MonadTrans(..))-import Control.Monad.IO.Class ( MonadIO(..) )-import Data.Maybe ( maybe )-import Data.Semigroup ( (<>)- , Semigroup(..)- )-import Control.Monad.Trans.Reader (ReaderT(..), ask,mapReaderT, withReaderT)-import Data.Text (pack)---- MORPHEUS-import Data.Morpheus.Error.Internal ( internalResolvingError )-import Data.Morpheus.Error.Selection ( subfieldsNotSelected )-import Data.Morpheus.Types.Internal.AST.Selection- ( Selection(..)- , SelectionContent(..)- , SelectionSet- , UnionTag(..)- , UnionSelection- , Operation(..)- )-import Data.Morpheus.Types.Internal.AST.Base- ( Message- , Name- , OperationType- , QUERY- , MUTATION- , SUBSCRIPTION- , GQLErrors- , GQLError(..)- , VALID- , OperationType(..)- )-import Data.Morpheus.Types.Internal.AST.Data- ( Schema- , Arguments- )-import Data.Morpheus.Types.Internal.AST.MergeSet- (toOrderedMap)-import Data.Morpheus.Types.Internal.Operation- ( selectOr- , empty- , keyOf- , Merge(..)- )-import Data.Morpheus.Types.Internal.Resolving.Core- ( Eventless- , Result(..)- , Failure(..)- , ResultT(..)- , cleanEvents- , mapEvent- , Event(..)- , Channel(..)- , StreamChannel- , GQLChannel(..)- , PushEvents(..)- , statelessToResultT- )-import Data.Morpheus.Types.Internal.AST.Value- ( GQLValue(..)- , ValidValue- , ObjectEntry(..)- , Value(..)- , ScalarValue(..)- )-import Data.Morpheus.Types.IO ( renderResponse- , GQLResponse- )--type WithOperation (o :: OperationType) = LiftOperation o--type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m--data ResponseEvent event (m :: * -> *)- = Publish event- | Subscribe (SubEvent event m)--type SubEvent event m = Event (Channel event) (event -> m GQLResponse)--data Context - = Context - { currentSelection :: Selection VALID- , schema :: Schema- , operation :: Operation VALID- , currentTypeName :: Name- } deriving (Show)---- Resolver Internal State-newtype ResolverState event m a - = ResolverState - {- runResolverState :: ReaderT Context (ResultT event m) a- } - deriving - ( Functor- , Applicative- , Monad- )--instance Monad m => MonadFail (ResolverState event m) where - fail = failure . pack--instance MonadTrans (ResolverState e) where- lift = ResolverState . lift . lift--instance (Monad m) => Failure Message (ResolverState e m) where- failure message = ResolverState $ do - selection <- currentSelection <$> ask - lift $ failure [resolverFailureMessage selection message]--instance (Monad m) => Failure GQLErrors (ResolverState e m) where- failure = ResolverState . lift . failure --instance (Monad m) => PushEvents e (ResolverState e m) where- pushEvents = ResolverState . lift . pushEvents --mapResolverState :: - ( ReaderT Context (ResultT e m) a- -> ReaderT Context (ResultT e' m') a' - ) -> ResolverState e m a- -> ResolverState e' m' a'-mapResolverState f (ResolverState x) = ResolverState (f x)--getState :: (Monad m) => ResolverState e m (Selection VALID)-getState = ResolverState $ currentSelection <$> ask --mapState :: (Context -> Context ) -> ResolverState e m a -> ResolverState e m a-mapState f = mapResolverState (withReaderT f)---- clear evets and starts new resolver with diferenct type of events but with same value--- use properly. only if you know what you are doing-clearStateResolverEvents :: (Functor m) => ResolverState e m a -> ResolverState e' m a-clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents)--resolverFailureMessage :: Selection VALID -> Message -> GQLError-resolverFailureMessage Selection { selectionName, selectionPosition } message = GQLError- { message = "Failure on Resolving Field \"" <> selectionName <> "\": " <> message- , locations = [selectionPosition]- }---- --- GraphQL Field Resolver--------------------------------------------------------------------data Resolver (o::OperationType) event (m :: * -> * ) value where- ResolverQ :: { runResolverQ :: ResolverState () m value } -> Resolver QUERY event m value- ResolverM :: { runResolverM :: ResolverState event m value } -> Resolver MUTATION event m value- ResolverS :: { runResolverS :: ResolverState (Channel event) m (ReaderT event (Resolver QUERY event m) value) } -> Resolver SUBSCRIPTION event m value--instance Show (Resolver o e m value) where- show ResolverQ {} = "Resolver QUERY e m a"- show ResolverM {} = "Resolver MUTATION e m a"- show ResolverS {} = "Resolver SUBSCRIPTION e m a"--deriving instance (Functor m) => Functor (Resolver o e m)---- Applicative-instance (LiftOperation o ,Monad m) => Applicative (Resolver o e m) where- pure = packResolver . pure- ResolverQ r1 <*> ResolverQ r2 = ResolverQ $ r1 <*> r2- ResolverM r1 <*> ResolverM r2 = ResolverM $ r1 <*> r2- ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2---- Monad -instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where- return = pure- (>>=) = unsafeBind---- MonadIO-instance (MonadIO m) => MonadIO (Resolver QUERY e m) where- liftIO = lift . liftIO- -instance (MonadIO m) => MonadIO (Resolver MUTATION e m) where- liftIO = lift . liftIO---- Monad Transformers -instance MonadTrans (Resolver QUERY e) where- lift = packResolver . lift--instance MonadTrans (Resolver MUTATION e) where- lift = packResolver . lift---- Failure-instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where- failure = packResolver .failure--instance (LiftOperation o, Monad m) => Failure GQLErrors (Resolver o e m) where- failure = packResolver . failure ---- PushEvents-instance (Monad m) => PushEvents e (Resolver MUTATION e m) where- pushEvents = packResolver . pushEvents --liftStateless - :: ( LiftOperation o - , Monad m- )- => Eventless a - -> Resolver o e m a -liftStateless - = packResolver - . ResolverState- . ReaderT - . const- . statelessToResultT---class LiftOperation (o::OperationType) where- packResolver :: Monad m => ResolverState e m a -> Resolver o e m a- withResolver :: Monad m => ResolverState e m a -> (a -> Resolver o e m b) -> Resolver o e m b---- packResolver-instance LiftOperation QUERY where- packResolver = ResolverQ . clearStateResolverEvents- withResolver ctxRes toRes = ResolverQ $ do - v <- clearStateResolverEvents ctxRes - runResolverQ $ toRes v--instance LiftOperation MUTATION where- packResolver = ResolverM- withResolver ctxRes toRes = ResolverM $ ctxRes >>= runResolverM . toRes --instance LiftOperation SUBSCRIPTION where- packResolver = ResolverS . pure . lift . packResolver- withResolver ctxRes toRes = ResolverS $ do - value <- clearStateResolverEvents ctxRes- runResolverS $ toRes value---mapResolverContext :: Monad m => (Context -> Context) -> Resolver o e m a -> Resolver o e m a -mapResolverContext f (ResolverQ res) = ResolverQ (mapState f res)-mapResolverContext f (ResolverM res) = ResolverM (mapState f res) -mapResolverContext f (ResolverS resM) = ResolverS $ do- res <- resM- pure $ ReaderT $ \e -> ResolverQ $ mapState f (runResolverQ (runReaderT res e)) --setSelection :: Monad m => Selection VALID -> Resolver o e m a -> Resolver o e m a -setSelection currentSelection - = mapResolverContext (\ctx -> ctx { currentSelection })--setTypeName :: Monad m => Name -> Resolver o e m a -> Resolver o e m a -setTypeName currentTypeName - = mapResolverContext (\ctx -> ctx { currentTypeName } )---- unsafe variant of >>= , not for public api. user can be confused: --- ignores `channels` on second Subsciption, only returns events from first Subscription monad.--- reason: second monad is waiting for `event` until he does not have some event can't tell which --- channel does it want to listen-unsafeBind- :: forall o e m a b- . Monad m- => Resolver o e m a- -> (a -> Resolver o e m b)- -> Resolver o e m b -unsafeBind (ResolverQ x) m2 = ResolverQ (x >>= runResolverQ . m2)-unsafeBind (ResolverM x) m2 = ResolverM (x >>= runResolverM . m2)-unsafeBind (ResolverS res) m2 = ResolverS $ do - (readResA :: ReaderT e (Resolver QUERY e m) a ) <- res - pure $ ReaderT $ \e -> ResolverQ $ do - let (resA :: Resolver QUERY e m a) = runReaderT readResA e- (valA :: a) <- runResolverQ resA- (readResB :: ReaderT e (Resolver QUERY e m) b) <- clearStateResolverEvents $ runResolverS (m2 valA) - runResolverQ $ runReaderT readResB e--subscribe - :: forall e m a - . ( PushEvents (Channel e) (ResolverState (Channel e) m)- , Monad m- ) - => [StreamChannel e] - -> Resolver QUERY e m (e -> Resolver QUERY e m a) - -> Resolver SUBSCRIPTION e m a-subscribe ch res = ResolverS $ do - pushEvents (map Channel ch :: [Channel e])- (eventRes :: e -> Resolver QUERY e m a) <- clearStateResolverEvents (runResolverQ res)- pure $ ReaderT eventRes--unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m Context-unsafeInternalContext = packResolver $ ResolverState ask ---- Converts Subscription Resolver Type to Query Resolver-type family UnSubResolver (a :: * -> * ) :: (* -> *)-type instance UnSubResolver (Resolver SUBSCRIPTION e m) = Resolver QUERY e m---- map Resolving strategies -class MapStrategy - (from :: OperationType) - (to :: OperationType) where- mapStrategy- :: Monad m - => Resolver from e m (Deriving from e m) - -> Resolver to e m (Deriving to e m) --instance MapStrategy o o where- mapStrategy = id--data Deriving (o :: OperationType) e (m :: * -> * ) - = DerivingNull- | DerivingScalar ScalarValue- | DerivingEnum Name Name- | DerivingList [Deriving o e m]- | DerivingObject (ObjectDeriving o e m)- | DerivingUnion Name (Resolver o e m (Deriving o e m))- deriving (Show)---data ObjectDeriving o e m - = ObjectDeriving {- __typename :: Name,- objectFields :: [- ( Name- , Resolver o e m (Deriving o e m) - )- ]- } deriving (Show)- -instance MapStrategy QUERY SUBSCRIPTION where- mapStrategy = ResolverS . pure . lift . fmap mapDeriving- -mapDeriving - :: ( MapStrategy o o'- , Monad m- )- => Deriving o e m - -> Deriving o' e m-mapDeriving DerivingNull = DerivingNull-mapDeriving (DerivingScalar x) = DerivingScalar x -mapDeriving (DerivingEnum typeName enum) = DerivingEnum typeName enum-mapDeriving (DerivingList x) = DerivingList $ map mapDeriving x-mapDeriving (DerivingObject x) = DerivingObject (mapObjectDeriving x)-mapDeriving (DerivingUnion name x) = DerivingUnion name (mapStrategy x)--mapObjectDeriving - :: ( MapStrategy o o'- , Monad m- )- => ObjectDeriving o e m - -> ObjectDeriving o' e m-mapObjectDeriving (ObjectDeriving tyname x) - = ObjectDeriving tyname- $ map (mapEntry mapStrategy) x--mapEntry :: (a -> b) -> (Name, a) -> (Name, b)-mapEntry f (name,value) = (name, f value) ------- Selection Processing-toResolver- :: forall o e m a b. (LiftOperation o, Monad m)- => (Arguments VALID -> Eventless a)- -> ( a -> Resolver o e m b)- -> Resolver o e m b-toResolver toArgs = withResolver args - where - args :: ResolverState e m a- args = do- Selection { selectionArguments } <- getState- let resT = ResultT $ pure $ toArgs selectionArguments- ResolverState $ lift $ cleanEvents resT---- DataResolver-type FieldRes o e m- = (Name, Resolver o e m (Deriving o e m))--instance Merge (Deriving o e m) where- merge p (DerivingObject x) (DerivingObject y) - = DerivingObject <$> merge p x y- merge _ _ _ - = failure $ internalResolvingError "can't merge: incompatible resolvers" --instance Merge (ObjectDeriving o e m) where- merge _ (ObjectDeriving tyname x) (ObjectDeriving _ y) - = pure $ ObjectDeriving tyname (x <> y)---pickSelection :: Name -> UnionSelection -> SelectionSet VALID-pickSelection = selectOr empty unionTagSelection--withObject- :: (LiftOperation o, Monad m)- => (SelectionSet VALID -> Resolver o e m value)- -> Selection VALID- -> Resolver o e m value-withObject f Selection { selectionName, selectionContent , selectionPosition } = checkContent selectionContent- where- checkContent (SelectionSet selection) = f selection- checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition)--lookupRes - :: (LiftOperation o, Monad m) - => Selection VALID- -> ObjectDeriving o e m - -> Resolver o e m ValidValue-lookupRes- Selection { selectionName } - | selectionName == "__typename" - = pure . Scalar . String . __typename- | otherwise - = maybe - (pure gqlNull) - (`unsafeBind` runDataResolver)- . lookup selectionName- . objectFields--resolveObject- :: forall o e m. (LiftOperation o , Monad m)- => SelectionSet VALID- -> Deriving o e m- -> Resolver o e m ValidValue-resolveObject selectionSet (DerivingObject drv@ObjectDeriving { __typename }) =- Object . toOrderedMap <$> traverse resolver selectionSet- where- resolver :: Selection VALID -> Resolver o e m (ObjectEntry VALID)- resolver sel - = setSelection sel - $ setTypeName __typename - $ ObjectEntry (keyOf sel) <$> lookupRes sel drv-resolveObject _ _ =- failure $ internalResolvingError "expected object as resolver"--toEventResolver :: Monad m => ReaderT event (Resolver QUERY event m) ValidValue -> Context -> event -> m GQLResponse-toEventResolver (ReaderT subRes) sel event = do - value <- runResultT $ runReaderT (runResolverState $ runResolverQ (subRes event)) sel- pure $ renderResponse value---runDataResolver :: (Monad m, LiftOperation o) => Deriving o e m -> Resolver o e m ValidValue-runDataResolver = withResolver getState . __encode- where- __encode obj sel@Selection { selectionContent } = encodeNode obj selectionContent - where - -- LIST- encodeNode (DerivingList x) _ = List <$> traverse runDataResolver x- -- Object ------------------ encodeNode objDrv@DerivingObject{} _ = withObject (`resolveObject` objDrv) sel- -- ENUM- encodeNode (DerivingEnum _ enum) SelectionField = pure $ gqlString enum- encodeNode (DerivingEnum typename enum) unionSel@UnionSelection{} - = encodeNode (unionDrv (typename <> "EnumObject")) unionSel- where- unionDrv name - = DerivingUnion name - $ pure - $ DerivingObject - $ ObjectDeriving name [("enum", pure $ DerivingScalar $ String enum)]- encodeNode DerivingEnum {} _ =- failure ( "wrong selection on enum value" :: Message)- -- UNION- encodeNode (DerivingUnion typename unionRef) (UnionSelection selections)- = unionRef >>= resolveObject currentSelection - where currentSelection = pickSelection typename selections- encodeNode (DerivingUnion name _) _ - = failure ("union Resolver \""<> name <> "\" should only recieve UnionSelection" :: Message)- -- SCALARS- encodeNode DerivingNull _ = pure Null- encodeNode (DerivingScalar x) SelectionField = pure $ Scalar x- encodeNode DerivingScalar {} _ - = failure ("scalar Resolver should only recieve SelectionField" :: Message)--runResolver- :: Monad m- => Resolver o event m ValidValue- -> Context- -> ResponseStream event m ValidValue-runResolver (ResolverQ resT) sel = cleanEvents $ (runReaderT $ runResolverState resT) sel-runResolver (ResolverM resT) sel = mapEvent Publish $ (runReaderT $ runResolverState resT) sel -runResolver (ResolverS resT) sel = ResultT $ do - (readResValue :: Result (Channel event1) (ReaderT event (Resolver QUERY event m) ValidValue)) <- runResultT $ (runReaderT $ runResolverState resT) sel- pure $ case readResValue of - Failure x -> Failure x- Success { warnings ,result , events = channels } -> do- let eventRes = toEventResolver result sel- Success {- events = [Subscribe $ Event channels eventRes],- warnings,- result = gqlNull- } --runRootDataResolver - :: (Monad m , LiftOperation o) - => Eventless (Deriving o e m)- -> Context - -> ResponseStream e m (Value VALID)-runRootDataResolver - res - ctx@Context { operation = Operation { operationSelection } } - = do- root <- statelessToResultT res- runResolver (resolveObject operationSelection root) ctx------------------------------------------------------------------------ | GraphQL Root resolver, also the interpreter generates a GQL schema from it.--- 'queryResolver' is required, 'mutationResolver' and 'subscriptionResolver' are optional,--- if your schema does not supports __mutation__ or __subscription__ , you can use __()__ for it.-data GQLRootResolver (m :: * -> *) event (query :: (* -> *) -> * ) (mut :: (* -> *) -> * ) (sub :: (* -> *) -> * ) = GQLRootResolver- { queryResolver :: query (Resolver QUERY event m)- , mutationResolver :: mut (Resolver MUTATION event m)- , subscriptionResolver :: sub (Resolver SUBSCRIPTION event m)- }--data ResolverModel e m- = ResolverModel - { query :: Eventless (Deriving QUERY e m)- , mutation :: Eventless (Deriving MUTATION e m)- , subscription :: Eventless (Deriving SUBSCRIPTION e m)- }--runResolverModel :: Monad m => ResolverModel e m -> Context -> ResponseStream e m (Value VALID)-runResolverModel - ResolverModel - { query- , mutation - , subscription - }- ctx@Context { operation = Operation { operationType} } - = selectByOperation operationType- where- selectByOperation Query - = runRootDataResolver query ctx- selectByOperation Mutation - = runRootDataResolver mutation ctx- selectByOperation Subscription - = runRootDataResolver subscription ctx-
src/Data/Morpheus/Types/Internal/Subscription.hs view
@@ -1,72 +1,87 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Subscription- ( connectionThread- , toOutStream- , runStreamWS- , runStreamHTTP- , Stream- , Scope(..)- , Input(..)- , WS- , HTTP- , acceptApolloRequest- , publish- , Store(..)- , initDefaultStore- , publishEventWith+ ( connect,+ disconnect,+ connectionThread,+ toOutStream,+ runStreamWS,+ runStreamHTTP,+ Stream,+ Scope (..),+ Input (..),+ WS,+ HTTP,+ acceptApolloRequest,+ publish,+ Store (..),+ initDefaultStore,+ publishEventWith,+ GQLChannel (..),+ ClientConnectionStore,+ empty,+ toList,+ connectionSessionIds,+ SessionID, ) where +import Control.Concurrent+ ( modifyMVar_,+ newMVar,+ readMVar,+ )+import Control.Exception (finally)+import Control.Monad (forever)+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.IO.Unlift+ ( MonadUnliftIO,+ withRunInIO,+ )+-- MORPHEUS -import Control.Exception ( finally )-import Control.Monad ( forever )-import Control.Concurrent ( readMVar- , newMVar- , modifyMVar_- )-import Data.UUID.V4 ( nextRandom )-import Control.Monad.IO.Class ( MonadIO(..) )-import Control.Monad.IO.Unlift ( MonadUnliftIO- , withRunInIO- )+import Data.Morpheus.Internal.Utils+ ( empty,+ )+import Data.Morpheus.Types.Internal.Resolving+ ( GQLChannel (..),+ )+import Data.Morpheus.Types.Internal.Subscription.Apollo+ ( acceptApolloRequest,+ )+import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore+ ( ClientConnectionStore,+ SessionID,+ connectionSessionIds,+ delete,+ publish,+ toList,+ )+import Data.Morpheus.Types.Internal.Subscription.Stream+ ( HTTP,+ Input (..),+ Scope (..),+ Stream,+ WS,+ runStreamHTTP,+ runStreamWS,+ toOutStream,+ )+import Data.UUID.V4 (nextRandom) --- MORPHEUS-import Data.Morpheus.Types.Internal.Operation- (empty)-import Data.Morpheus.Types.Internal.Resolving- ( GQLChannel(..) )-import Data.Morpheus.Types.Internal.Subscription.Apollo- ( acceptApolloRequest )-import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore- ( delete - , publish- , ClientConnectionStore- )-import Data.Morpheus.Types.Internal.Subscription.Stream- ( toOutStream- , runStreamWS- , runStreamHTTP- , Stream- , Scope(..)- , Input(..)- , WS- , HTTP- )- connect :: MonadIO m => m (Input WS) connect = Init <$> liftIO nextRandom -disconnect:: Scope WS e m -> Input WS -> m ()-disconnect ScopeWS { update } (Init clientID) = update (delete clientID)+disconnect :: Scope WS e m -> Input WS -> m ()+disconnect ScopeWS {update} (Init clientID) = update (delete clientID) -- | PubSubStore interface -- shared GraphQL state between __websocket__ and __http__ server,@@ -74,58 +89,59 @@ -- to work properly Morpheus needs all entries of ClientConnectionStore (+ client Callbacks) -- that why it is recomended that you use many local ClientStores on evenry server node -- rathen then single centralized Store.--- -data Store e m = Store - { readStore :: m (ClientConnectionStore e m)- , writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()+data Store e m = Store+ { readStore :: m (ClientConnectionStore e m),+ writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m () } -publishEventWith :: - ( MonadIO m- , (Eq (StreamChannel event)) - , (GQLChannel event) - ) => Store event m -> event -> m ()+publishEventWith ::+ ( MonadIO m,+ (Eq (StreamChannel event)),+ (GQLChannel event)+ ) =>+ Store event m ->+ event ->+ m () publishEventWith store event = readStore store >>= publish event -- | initializes empty GraphQL state-initDefaultStore :: - ( MonadIO m- , (Eq (StreamChannel event)) - , (GQLChannel event) - ) - => IO (Store event m)+initDefaultStore ::+ ( MonadIO m,+ MonadIO m2,+ (Eq (StreamChannel event)),+ (GQLChannel event)+ ) =>+ m2 (Store event m) initDefaultStore = do- store <- newMVar empty- pure Store - { readStore = liftIO $ readMVar store- , writeStore = \changes -> liftIO $ modifyMVar_ store (return . changes)- }-+ store <- liftIO $ newMVar empty+ pure+ Store+ { readStore = liftIO $ readMVar store,+ writeStore = \changes -> liftIO $ modifyMVar_ store (return . changes)+ } finallyM :: MonadUnliftIO m => m () -> m () -> m () finallyM loop end = withRunInIO $ \runIO -> finally (runIO loop) (runIO end) --connectionThread - :: ( MonadUnliftIO m- ) - => (Input WS -> Stream WS e m) - -> Scope WS e m- -> m ()+connectionThread ::+ ( MonadUnliftIO m+ ) =>+ (Input WS -> Stream WS e m) ->+ Scope WS e m ->+ m () connectionThread api scope = do- input <- connect + input <- connect finallyM (connectionLoop api scope input) (disconnect scope input) -connectionLoop - :: Monad m - => (Input WS -> Stream WS e m) - -> Scope WS e m - -> Input WS - -> m ()-connectionLoop api scope input- = forever- $ runStreamWS scope - $ api input-+connectionLoop ::+ Monad m =>+ (Input WS -> Stream WS e m) ->+ Scope WS e m ->+ Input WS ->+ m ()+connectionLoop api scope input =+ forever+ $ runStreamWS scope+ $ api input
src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs view
@@ -1,59 +1,67 @@-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Data.Morpheus.Types.Internal.Subscription.Apollo- ( ApolloAction(..)- , apolloFormat- , acceptApolloRequest- , toApolloResponse- , Validation- ) where--import Data.Maybe ( maybe ) -import Control.Monad.IO.Class ( MonadIO(..) )-import Data.Aeson ( FromJSON (..)- , ToJSON (..)- , Value (..)- , eitherDecode- , encode- , pairs- , withObject- , (.:)- , (.:?)- , (.=)- )-import Data.ByteString.Lazy.Char8 ( ByteString- , pack- )-import Data.Semigroup ( (<>) )-import Data.Text ( Text - , unpack- )-import GHC.Generics ( Generic )-import Network.WebSockets ( AcceptRequest (..)- , RequestHead- , getRequestSubprotocols- , PendingConnection- , Connection- , acceptRequestWith- , pendingRequest- )+ ( ApolloAction (..),+ apolloFormat,+ acceptApolloRequest,+ toApolloResponse,+ Validation,+ )+where +import Control.Monad.IO.Class (MonadIO (..))+import Data.Aeson+ ( (.:),+ (.:?),+ (.=),+ FromJSON (..),+ ToJSON (..),+ Value (..),+ eitherDecode,+ encode,+ pairs,+ withObject,+ )+import Data.ByteString.Lazy.Char8+ ( ByteString,+ pack,+ )+import Data.Maybe (maybe) -- MORPHEUS-import Data.Morpheus.Types.IO ( GQLResponse - , GQLRequest (..)- )+import Data.Morpheus.Types.IO+ ( GQLRequest (..),+ GQLResponse,+ )+import Data.Morpheus.Types.Internal.AST+ ( FieldName,+ Token,+ )+import Data.Semigroup ((<>))+import Data.Text+ ( Text,+ unpack,+ )+import GHC.Generics (Generic)+import Network.WebSockets+ ( AcceptRequest (..),+ Connection,+ PendingConnection,+ RequestHead,+ acceptRequestWith,+ getRequestSubprotocols,+ pendingRequest,+ ) type ID = Text -data ApolloSubscription payload =- ApolloSubscription- { apolloId :: Maybe ID- , apolloType :: Text- , apolloPayload :: Maybe payload- }+data ApolloSubscription payload = ApolloSubscription+ { apolloId :: Maybe ID,+ apolloType :: Text,+ apolloPayload :: Maybe payload+ } deriving (Show, Generic) instance FromJSON a => FromJSON (ApolloSubscription a) where@@ -62,34 +70,33 @@ objectParser o = ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload" -data RequestPayload =- RequestPayload- { payloadOperationName :: Maybe Text- , payloadQuery :: Maybe Text- , payloadVariables :: Maybe Value- }+data RequestPayload = RequestPayload+ { payloadOperationName :: Maybe FieldName,+ payloadQuery :: Maybe Token,+ payloadVariables :: Maybe Value+ } deriving (Show, Generic) instance FromJSON RequestPayload where parseJSON = withObject "ApolloPayload" objectParser where objectParser o =- RequestPayload <$> o .:? "operationName" <*> o .:? "query" <*>- o .:? "variables"+ RequestPayload <$> o .:? "operationName" <*> o .:? "query"+ <*> o .:? "variables" instance ToJSON a => ToJSON (ApolloSubscription a) where toEncoding (ApolloSubscription id' type' payload') = pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload' -acceptApolloRequest - :: MonadIO m - => PendingConnection - -> m Connection-acceptApolloRequest pending - = liftIO - $ acceptRequestWith- pending- (acceptApolloSubProtocol (pendingRequest pending))+acceptApolloRequest ::+ MonadIO m =>+ PendingConnection ->+ m Connection+acceptApolloRequest pending =+ liftIO $+ acceptRequestWith+ pending+ (acceptApolloSubProtocol (pendingRequest pending)) acceptApolloSubProtocol :: RequestHead -> AcceptRequest acceptApolloSubProtocol reqHead =@@ -117,28 +124,29 @@ validateReq :: Either String (ApolloSubscription RequestPayload) -> Validation ApolloAction validateReq = either (Left . pack) validateSub -------------------------------------- validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction- validateSub ApolloSubscription { apolloType = "connection_init" }- = pure ConnectionInit - validateSub ApolloSubscription { apolloType = "start", apolloId , apolloPayload }- = do+ validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction+ validateSub ApolloSubscription {apolloType = "connection_init"} =+ pure ConnectionInit+ validateSub ApolloSubscription {apolloType = "start", apolloId, apolloPayload} =+ do sessionId <- validateSession apolloId- payload <- validatePayload apolloPayload+ payload <- validatePayload apolloPayload pure $ SessionStart sessionId payload- validateSub ApolloSubscription { apolloType = "stop", apolloId }- = SessionStop <$> validateSession apolloId- validateSub ApolloSubscription { apolloType } - = Left $ "Unknown Request type \""<> pack (unpack apolloType) <> "\"."+ validateSub ApolloSubscription {apolloType = "stop", apolloId} =+ SessionStop <$> validateSession apolloId+ validateSub ApolloSubscription {apolloType} =+ Left $ "Unknown Request type \"" <> pack (unpack apolloType) <> "\"." -------------------------------------------- validateSession :: Maybe ID -> Validation ID validateSession = maybe (Left "\"id\" was not provided") Right ------------------------------------- validatePayload = maybe (Left "\"payload\" was not provided") validatePayloadContent -------------------------------------- validatePayloadContent RequestPayload - { payloadQuery - , payloadOperationName = operationName- , payloadVariables = variables- } = do- query <- maybe (Left "\"payload.query\" was not provided") Right payloadQuery- pure $ GQLRequest {query, operationName, variables}+ validatePayloadContent+ RequestPayload+ { payloadQuery,+ payloadOperationName = operationName,+ payloadVariables = variables+ } = do+ query <- maybe (Left "\"payload.query\" was not provided") Right payloadQuery+ pure $ GQLRequest {query, operationName, variables}
src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs view
@@ -1,162 +1,178 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE KindSignatures #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE TypeFamilies #-} module Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore- ( ID- , Session- , ClientConnectionStore- , Updates(..)- , startSession- , endSession- , empty- , insert- , delete- , publish+ ( ID,+ Session,+ SessionID,+ ClientConnectionStore,+ ClientConnection,+ Updates (..),+ startSession,+ endSession,+ empty,+ insert,+ delete,+ publish,+ toList,+ connectionSessionIds, ) where -import Data.List ( intersect )-import Data.Foldable ( traverse_ )-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Semigroup ( (<>) )-import Data.Text ( Text )-import Data.UUID ( UUID )-import Data.HashMap.Lazy ( HashMap , keys)-import qualified Data.HashMap.Lazy as HM ( empty- , insert- , delete- , adjust- , elems- , toList- )--+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Foldable (traverse_)+import Data.HashMap.Lazy (HashMap, keys)+import qualified Data.HashMap.Lazy as HM+ ( adjust,+ delete,+ elems,+ empty,+ insert,+ insertWith,+ keys,+ toList,+ )+import Data.List (intersect) -- MORPHEUS-import Data.Morpheus.Types.Internal.Subscription.Apollo- ( toApolloResponse- )-import Data.Morpheus.Types.Internal.Operation- (Empty(..))-import Data.Morpheus.Types.Internal.Resolving- ( SubEvent - , Event(..)- , GQLChannel(..)- ) -type ID = UUID+import Data.Morpheus.Internal.Utils+ ( Collection (..),+ KeyOf (..),+ )+import Data.Morpheus.Types.Internal.Resolving+ ( Event (..),+ GQLChannel (..),+ SubEvent,+ )+import Data.Morpheus.Types.Internal.Subscription.Apollo+ ( toApolloResponse,+ )+import Data.Semigroup ((<>))+import Data.Text (Text)+import Data.UUID (UUID) -type SesionID = Text+type ID = UUID -type Session = (ID, SesionID)+type SessionID = Text +type Session = (ID, SessionID) -data ClientConnection e ( m :: * -> * ) =- ClientConnection- { connectionId :: ID- , connectionCallback :: ByteString -> m ()+data ClientConnection e (m :: * -> *) = ClientConnection+ { connectionId :: ID,+ connectionCallback :: ByteString -> m (), -- one connection can have multiple subsciprion session- , connectionSessions :: HashMap SesionID (SubEvent e m)- }+ connectionSessions :: HashMap SessionID (SubEvent e m)+ } +connectionSessionIds :: ClientConnection e m -> [SessionID]+connectionSessionIds = HM.keys . connectionSessions+ instance Show (ClientConnection e m) where- show ClientConnection { connectionId, connectionSessions } =+ show ClientConnection {connectionId, connectionSessions} = "Connection { id: " <> show connectionId <> ", sessions: " <> show (keys connectionSessions) <> " }" -publish- :: ( Eq (StreamChannel event)- , GQLChannel event- , Monad m- ) - => event - -> ClientConnectionStore event m - -> m ()+publish ::+ ( Eq (StreamChannel event),+ GQLChannel event,+ Monad m+ ) =>+ event ->+ ClientConnectionStore event m ->+ m () publish event = traverse_ sendMessage . elems- where- sendMessage ClientConnection { connectionSessions, connectionCallback }- | null connectionSessions = pure ()- | otherwise = traverse_ send (filterByChannels connectionSessions)- where- send (sid, Event { content = subscriptionRes }) - = toApolloResponse sid <$> subscriptionRes event >>= connectionCallback- ---------------------------- filterByChannels = filter- ( not- . null- . intersect (streamChannels event)- . channels- . snd- ) . HM.toList--+ where+ sendMessage ClientConnection {connectionSessions, connectionCallback}+ | null connectionSessions = pure ()+ | otherwise = traverse_ send (filterByChannels connectionSessions)+ where+ send (sid, Event {content = subscriptionRes}) =+ toApolloResponse sid <$> subscriptionRes event >>= connectionCallback+ ---------------------------+ filterByChannels =+ filter+ ( not+ . null+ . intersect (streamChannels event)+ . channels+ . snd+ )+ . HM.toList -newtype Updates e ( m :: * -> * ) = - Updates {- _runUpdate:: ClientConnectionStore e m -> ClientConnectionStore e m - }+newtype Updates e (m :: * -> *) = Updates+ { _runUpdate :: ClientConnectionStore e m -> ClientConnectionStore e m+ } -updateClient- :: (ClientConnection e m -> ClientConnection e m ) - -> ID- -> Updates e m -updateClient f cid = Updates (adjust f cid)+updateClient ::+ (ClientConnection e m -> ClientConnection e m) ->+ ID ->+ Updates e m+updateClient f cid = Updates (adjust f cid) -endSession :: Session -> Updates e m +endSession :: Session -> Updates e m endSession (clientId, sessionId) = updateClient endSub clientId- where- endSub client = client { connectionSessions = HM.delete sessionId (connectionSessions client) }--startSession :: SubEvent e m -> Session -> Updates e m -startSession subscriptions (clientId, sessionId) = updateClient startSub clientId- where- startSub client = client { connectionSessions = HM.insert sessionId subscriptions (connectionSessions client) }-+ where+ endSub client = client {connectionSessions = HM.delete sessionId (connectionSessions client)} +startSession :: SubEvent e m -> Session -> Updates e m+startSession subscriptions (clientId, sessionId) = updateClient startSub clientId+ where+ startSub client = client {connectionSessions = HM.insert sessionId subscriptions (connectionSessions client)} -- stores active client connections -- every registered client has ID -- when client connection is closed client(including all its subsciprions) can By removed By its ID-newtype ClientConnectionStore e ( m :: * -> * ) = - ClientConnectionStore - { unpackStore :: HashMap ID (ClientConnection e m)- } deriving (Show)+newtype ClientConnectionStore e (m :: * -> *) = ClientConnectionStore+ { unpackStore :: HashMap ID (ClientConnection e m)+ }+ deriving (Show) -type StoreMap e m- = ClientConnectionStore e m - -> ClientConnectionStore e m+type StoreMap e m =+ ClientConnectionStore e m ->+ ClientConnectionStore e m -mapStore - :: ( HashMap ID (ClientConnection e m) - -> HashMap ID (ClientConnection e m)- )- -> StoreMap e m+mapStore ::+ ( HashMap ID (ClientConnection e m) ->+ HashMap ID (ClientConnection e m)+ ) ->+ StoreMap e m mapStore f = ClientConnectionStore . f . unpackStore -elems :: ClientConnectionStore e m -> [ClientConnection e m]+elems :: ClientConnectionStore e m -> [ClientConnection e m] elems = HM.elems . unpackStore -instance Empty (ClientConnectionStore e m) where- empty = ClientConnectionStore HM.empty+toList :: ClientConnectionStore e m -> [(UUID, ClientConnection e m)]+toList = HM.toList . unpackStore -insert - :: ID- -> (ByteString -> m ())- -> StoreMap e m-insert connectionId connectionCallback = mapStore (HM.insert connectionId c)+instance KeyOf (ClientConnection e m) where+ type KEY (ClientConnection e m) = ID+ keyOf = connectionId++instance Collection (ClientConnection e m) (ClientConnectionStore e m) where+ empty = ClientConnectionStore empty+ singleton = ClientConnectionStore . singleton++-- returns original store, if connection with same id already exist+insert ::+ ID ->+ (ByteString -> m ()) ->+ StoreMap e m+insert connectionId connectionCallback = mapStore (HM.insertWith (curry snd) connectionId c) where- c = ClientConnection { connectionId , connectionCallback, connectionSessions = HM.empty }+ c = ClientConnection {connectionId, connectionCallback, connectionSessions = HM.empty} -adjust - :: (ClientConnection e m -> ClientConnection e m ) - -> ID- -> StoreMap e m+adjust ::+ (ClientConnection e m -> ClientConnection e m) ->+ ID ->+ StoreMap e m adjust f key = mapStore (HM.adjust f key) -delete - :: ID- -> StoreMap e m+delete ::+ ID ->+ StoreMap e m delete key = mapStore (HM.delete key)
src/Data/Morpheus/Types/Internal/Subscription/Stream.hs view
@@ -1,235 +1,242 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} module Data.Morpheus.Types.Internal.Subscription.Stream- ( toOutStream- , runStreamWS- , runStreamHTTP- , Stream- , Scope(..)- , Input(..)- , API(..)- , HTTP- , WS+ ( toOutStream,+ runStreamWS,+ runStreamHTTP,+ Stream,+ Scope (..),+ Input (..),+ API (..),+ HTTP,+ WS, ) where -import Data.Foldable ( traverse_ )-import Data.ByteString.Lazy.Char8 (ByteString)-+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Foldable (traverse_) -- MORPHEUS-import Data.Morpheus.Error.Utils ( globalErrorMessage- )-import Data.Morpheus.Types.Internal.AST- ( Value(..)- , VALID- , GQLErrors- )-import Data.Morpheus.Types.IO ( GQLRequest(..) - , GQLResponse(..)- )-import Data.Morpheus.Types.Internal.Operation- ( failure )-import Data.Morpheus.Types.Internal.Resolving- ( GQLChannel(..)- , ResponseEvent(..)- , ResponseStream- , runResultT- , Result(..)- , ResultT(..)- )-import Data.Morpheus.Types.Internal.Subscription.Apollo- ( ApolloAction(..)- , apolloFormat- , toApolloResponse- )-import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore- ( ClientConnectionStore- , insert- , ID- , Updates(..)- , startSession- , endSession- , Session- )- +import Data.Morpheus.Error+ ( globalErrorMessage,+ )+import Data.Morpheus.Internal.Utils+ ( failure,+ )+import Data.Morpheus.Types.IO+ ( GQLRequest (..),+ GQLResponse (..),+ )+import Data.Morpheus.Types.Internal.AST+ ( GQLErrors,+ Message,+ VALID,+ Value (..),+ )+import Data.Morpheus.Types.Internal.Resolving+ ( GQLChannel (..),+ ResponseEvent (..),+ ResponseStream,+ Result (..),+ ResultT (..),+ runResultT,+ )+import Data.Morpheus.Types.Internal.Subscription.Apollo+ ( ApolloAction (..),+ apolloFormat,+ toApolloResponse,+ )+import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore+ ( ClientConnectionStore,+ ID,+ Session,+ Updates (..),+ endSession,+ insert,+ startSession,+ )+ data API = HTTP | WS type WS = 'WS -type HTTP = 'HTTP +type HTTP = 'HTTP -data Input - (api:: API) +data+ Input+ (api :: API) where- Init :: ID -> Input WS - Request :: GQLRequest -> Input HTTP + Init :: ID -> Input WS+ Request :: GQLRequest -> Input HTTP run :: Scope WS e m -> Updates e m -> m ()-run ScopeWS { update } (Updates changes) = update changes+run ScopeWS {update} (Updates changes) = update changes -data Scope (api :: API ) event (m :: * -> * ) where- ScopeHTTP :: +data Scope (api :: API) event (m :: * -> *) where+ ScopeHTTP :: { httpCallback :: event -> m ()- } -> Scope HTTP event m- ScopeWS :: - { listener :: m ByteString- , callback :: ByteString -> m ()- , update :: (ClientConnectionStore event m -> ClientConnectionStore event m) -> m ()- } -> Scope WS event m-+ } ->+ Scope HTTP event m+ ScopeWS ::+ { listener :: m ByteString,+ callback :: ByteString -> m (),+ update :: (ClientConnectionStore event m -> ClientConnectionStore event m) -> m ()+ } ->+ Scope WS event m -data Stream - (api:: API) - e - (m :: * -> * ) +data+ Stream+ (api :: API)+ e+ (m :: * -> *) where- StreamWS - :: - { streamWS :: Scope WS e m -> m (Either ByteString [Updates e m])- } -> Stream WS e m- StreamHTTP- :: + StreamWS ::+ { streamWS :: Scope WS e m -> m (Either ByteString [Updates e m])+ } ->+ Stream WS e m+ StreamHTTP :: { streamHTTP :: Scope HTTP e m -> m GQLResponse- } -> Stream HTTP e m+ } ->+ Stream HTTP e m -handleResponseStream- :: ( Eq (StreamChannel e)- , GQLChannel e- , Monad m- )- => Session- -> ResponseStream e m (Value VALID)- -> Stream WS e m -handleResponseStream session (ResultT res) - = StreamWS $ const $ unfoldR <$> res - where- execute Publish {} = apolloError $ globalErrorMessage "websocket can only handle subscriptions, not mutations"- execute (Subscribe sub) = Right $ startSession sub session- --------------------------- unfoldR Success { events } = traverse execute events- unfoldR Failure { errors } = apolloError errors- --------------------------- apolloError :: GQLErrors -> Either ByteString a- apolloError = Left . toApolloResponse (snd session) . Errors +handleResponseStream ::+ ( Eq (StreamChannel e),+ GQLChannel e,+ Monad m+ ) =>+ Session ->+ ResponseStream e m (Value VALID) ->+ Stream WS e m+handleResponseStream session (ResultT res) =+ StreamWS $ const $ unfoldR <$> res+ where+ execute Publish {} = apolloError $ globalErrorMessage "websocket can only handle subscriptions, not mutations"+ execute (Subscribe sub) = Right $ startSession sub session+ --------------------------+ unfoldR Success {events} = traverse execute events+ unfoldR Failure {errors} = apolloError errors+ --------------------------+ apolloError :: GQLErrors -> Either ByteString a+ apolloError = Left . toApolloResponse (snd session) . Errors -handleWSRequest - :: ( Monad m- , Eq (StreamChannel e)- , GQLChannel e- , Functor m- ) - => ( GQLRequest- -> ResponseStream e m (Value VALID)- )- -> ID- -> ByteString- -> Stream WS e m+handleWSRequest ::+ ( Monad m,+ Eq (StreamChannel e),+ GQLChannel e,+ Functor m+ ) =>+ ( GQLRequest ->+ ResponseStream e m (Value VALID)+ ) ->+ ID ->+ ByteString ->+ Stream WS e m handleWSRequest gqlApp clientId = handle . apolloFormat- where + where --handle :: Applicative m => Validation ApolloAction -> Stream WS e m handle = either (liftWS . Left) handleAction -------------------------------------------------- -- handleAction :: ApolloAction -> Stream WS e m handleAction ConnectionInit = liftWS $ Right []- handleAction (SessionStart sessionId request)- = handleResponseStream (clientId, sessionId) (gqlApp request) - handleAction (SessionStop sessionId)- = liftWS - $ Right [endSession (clientId, sessionId)]+ handleAction (SessionStart sessionId request) =+ handleResponseStream (clientId, sessionId) (gqlApp request)+ handleAction (SessionStop sessionId) =+ liftWS $+ Right [endSession (clientId, sessionId)] -liftWS - :: Applicative m - => Either ByteString [Updates e m]- -> Stream WS e m-liftWS = StreamWS . const . pure +liftWS ::+ Applicative m =>+ Either ByteString [Updates e m] ->+ Stream WS e m+liftWS = StreamWS . const . pure -runStreamWS - :: (Monad m) - => Scope WS e m- -> Stream WS e m - -> m ()-runStreamWS scope@ScopeWS{ callback } StreamWS { streamWS } - = streamWS scope +runStreamWS ::+ (Monad m) =>+ Scope WS e m ->+ Stream WS e m ->+ m ()+runStreamWS scope@ScopeWS {callback} StreamWS {streamWS} =+ streamWS scope >>= either callback (traverse_ (run scope)) -runStreamHTTP- :: (Monad m) - => Scope HTTP e m- -> Stream HTTP e m - -> m GQLResponse-runStreamHTTP scope StreamHTTP { streamHTTP } - = streamHTTP scope+runStreamHTTP ::+ (Monad m) =>+ Scope HTTP e m ->+ Stream HTTP e m ->+ m GQLResponse+runStreamHTTP scope StreamHTTP {streamHTTP} =+ streamHTTP scope -toOutStream - :: ( Monad m- , Eq (StreamChannel e)- , GQLChannel e- , Functor m- ) - => ( GQLRequest- -> ResponseStream e m (Value VALID)- )- -> Input api- -> Stream api e m-toOutStream app (Init clienId) - = StreamWS handle - where- handle ws@ScopeWS { listener , callback } = do- let runS (StreamWS x) = x ws- bla <- listener >>= runS . handleWSRequest app clienId- pure $ (Updates (insert clienId callback) :) <$> bla+toOutStream ::+ ( Monad m,+ Eq (StreamChannel e),+ GQLChannel e,+ Functor m+ ) =>+ ( GQLRequest ->+ ResponseStream e m (Value VALID)+ ) ->+ Input api ->+ Stream api e m+toOutStream app (Init clienId) =+ StreamWS handle+ where+ handle ws@ScopeWS {listener, callback} = do+ let runS (StreamWS x) = x ws+ bla <- listener >>= runS . handleWSRequest app clienId+ pure $ (Updates (insert clienId callback) :) <$> bla toOutStream app (Request req) = StreamHTTP $ handleResponseHTTP (app req) +handleResponseHTTP ::+ ( Eq (StreamChannel e),+ GQLChannel e,+ Monad m+ ) =>+ ResponseStream e m (Value VALID) ->+ Scope HTTP e m ->+ m GQLResponse handleResponseHTTP- :: ( Eq (StreamChannel e)- , GQLChannel e- , Monad m- )- => ResponseStream e m (Value VALID)- -> Scope HTTP e m- -> m GQLResponse -handleResponseHTTP res- ScopeHTTP { httpCallback } = do+ ScopeHTTP {httpCallback} = do x <- runResultT (handleRes res execute)- case x of - Success r _ events-> do + case x of+ Success r _ events -> do traverse_ httpCallback events- pure $ Data r + pure $ Data r Failure err -> pure (Errors err) where- execute (Publish event) = pure event- execute Subscribe {} = failure ("http can't handle subscription" :: String)+ execute (Publish event) = pure event+ execute Subscribe {} = failure ("http can't handle subscription" :: Message) -handleRes- :: ( Eq (StreamChannel e)- , GQLChannel e- , Monad m- )- => ResponseStream e m a- -> (ResponseEvent e m -> ResultT e' m e')- -> ResultT e' m a+handleRes ::+ ( Eq (StreamChannel e),+ GQLChannel e,+ Monad m+ ) =>+ ResponseStream e m a ->+ (ResponseEvent e m -> ResultT e' m e') ->+ ResultT e' m a handleRes res execute = ResultT $ runResultT res >>= runResultT . unfoldRes execute -unfoldRes - :: (Monad m) - => (e -> ResultT e' m e')- -> Result e a- -> ResultT e' m a-unfoldRes execute Success { events, result, warnings } = do+unfoldRes ::+ (Monad m) =>+ (e -> ResultT e' m e') ->+ Result e a ->+ ResultT e' m a+unfoldRes execute Success {events, result, warnings} = do events' <- traverse execute events- ResultT $ pure $ Success - { result- , warnings- , events = events'- }-unfoldRes _ Failure { errors } = ResultT $ pure $ Failure { errors }+ ResultT $ pure $+ Success+ { result,+ warnings,+ events = events'+ }+unfoldRes _ Failure {errors} = ResultT $ pure $ Failure {errors}
− src/Data/Morpheus/Types/Internal/TH.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE OverloadedStrings #-}---module Data.Morpheus.Types.Internal.TH where--import Language.Haskell.TH-import Data.Text (Text,unpack)--apply :: Name -> [Q Exp] -> Q Exp-apply n = foldl appE (conE n)--applyT :: Name -> [Q Type] -> Q Type-applyT name = foldl appT (conT name)--typeT :: Name -> [Text] -> Q Type-typeT name li = applyT name (map (varT . mkName . unpack) li)--instanceHeadT :: Name -> Text -> [Text] -> Q Type-instanceHeadT cName iType tArgs = applyT cName [applyT (mkName $ unpack iType) (map (varT . mkName . unpack) tArgs)]--instanceProxyFunD :: (Name,ExpQ) -> DecQ-instanceProxyFunD (name,body) = instanceFunD name ["_"] body--instanceFunD :: Name -> [Text] -> ExpQ -> Q Dec-instanceFunD name args body = funD name [clause (map (varP . mkName. unpack) args) (normalB body) []]--instanceHeadMultiT :: Name -> Q Type -> [Q Type] -> Q Type-instanceHeadMultiT className iType li = applyT className (iType : li)----- "User" -> ["name","id"] -> (User name id)-destructRecord :: Text -> [Text] -> PatQ-destructRecord conName fields = conP (mkName $ unpack conName) (map (varP . mkName .unpack) fields)--typeInstanceDec :: Name -> Type -> Type -> Dec-#if MIN_VERSION_template_haskell(2,15,0)--- fix breaking changes -typeInstanceDec typeFamily arg res = TySynInstD (TySynEqn Nothing (AppT (ConT typeFamily) arg) res) -#else--- -typeInstanceDec typeFamily arg res = TySynInstD typeFamily (TySynEqn [arg] res)-#endif---infoTyVars :: Info -> [TyVarBndr]-infoTyVars (TyConI x) = decArgs x-infoTyVars _ = []- -decArgs :: Dec -> [TyVarBndr]-decArgs (DataD _ _ args _ _ _) = args -decArgs (NewtypeD _ _ args _ _ _) = args -decArgs (TySynD _ args _) = args-decArgs _ = []
− src/Data/Morpheus/Types/Internal/Validation.hs
@@ -1,354 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Types.Internal.Validation- ( Validator- , SelectionValidator- , InputValidator- , BaseValidator- , InputSource(..)- , Context(..)- , SelectionContext(..)- , runValidator- , askSchema- , askContext- , askFragments- , askFieldType- , askTypeMember- , selectRequired- , selectKnown- , Constraint(..)- , constraint- , withScope- , withScopeType- , withScopePosition- , askScopeTypeName- , selectWithDefaultValue- , askScopePosition- , askInputFieldType- , askInputMember- , startInput- , withInputScope- , inputMessagePrefix- , checkUnused- , Prop(..)- , constraintInputUnion- )- where--import Data.Semigroup ( (<>)- , Semigroup(..)- )-import Control.Monad.Trans.Reader ( ReaderT(..)- , ask- , withReaderT- )---- MORPHEUS-import Data.Morpheus.Types.Internal.Operation- ( Failure(..) - , Selectable- , selectBy- , selectOr- , KeyOf(..)- , member- , size- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )-import Data.Morpheus.Types.Internal.AST- ( Name- , Position- , Message- , Ref(..)- , TypeRef(..)- , Fragments- , Schema- , FieldDefinition(..)- , FieldsDefinition(..)- , TypeDefinition(..)- , TypeContent(..)- , isInputDataType- , isFieldNullable- , Value(..)- , Object- , entryValue- , __inputname- )-import Data.Morpheus.Types.Internal.Validation.Validator- ( Validator(..)- , Constraint(..)- , Target(..)- , InputSource(..)- , InputContext(..)- , Context(..)- , Prop(..)- , renderInputPrefix- , Resolution- , SelectionValidator- , InputValidator- , BaseValidator- , SelectionContext(..)- )-import Data.Morpheus.Types.Internal.Validation.Error - ( MissingRequired(..)- , KindViolation(..)- , Unknown(..)- , InternalError(..)- , Unused(..)- )--getUnused :: (KeyOf b ,Selectable ca a) => ca -> [b] -> [b]-getUnused uses = filter (not . (`member` uses) . keyOf)--failOnUnused :: Unused b => [b] -> Validator ctx () -failOnUnused x - | null x = return ()- | otherwise = do- (gctx,_) <- Validator ask- failure $ map (unused gctx) x--checkUnused :: (KeyOf b ,Selectable ca a, Unused b) => ca -> [b] -> Validator ctx () -checkUnused uses = failOnUnused . getUnused uses--constraint - :: forall (a :: Target) inp ctx. KindViolation a inp - => Constraint ( a :: Target) - -> inp - -> TypeDefinition - -> Validator ctx (Resolution a)-constraint OBJECT _ TypeDefinition { typeContent = DataObject { objectFields } , typeName } - = pure (typeName, objectFields)-constraint INPUT _ x | isInputDataType x = pure x -constraint target ctx _ = failure [kindViolation target ctx]--selectRequired - :: ( Selectable c value- , MissingRequired c ctx- )- => Ref - -> c- -> Validator ctx value-selectRequired selector container - = do - (gctx,ctx) <- Validator ask- selectBy- [missingRequired gctx ctx selector container] - (keyOf selector) - container--selectWithDefaultValue - :: ( Selectable values value- , MissingRequired values ctx- )- => value- -> FieldDefinition- -> values- -> Validator ctx value-selectWithDefaultValue - fallbackValue - field@FieldDefinition { fieldName }- values- = selectOr - handleNullable - pure- fieldName- values - where- ------------------- handleNullable- | isFieldNullable field = pure fallbackValue- | otherwise = failSelection- ------------------ failSelection = do- (gctx, ctx) <- Validator ask- failure [missingRequired gctx ctx (Ref fieldName (scopePosition gctx)) values]--selectKnown - :: ( Selectable c a- , Unknown c ctx- , KeyOf (UnknownSelector c)- ) - => UnknownSelector c - -> c - -> Validator ctx a-selectKnown selector lib - = do - (gctx, ctx) <- Validator ask- selectBy- (unknown gctx ctx lib selector) - (keyOf selector) - lib--askFieldType- :: FieldDefinition- -> SelectionValidator TypeDefinition-askFieldType field@FieldDefinition{ fieldType = TypeRef { typeConName } }- = do- schema <- askSchema- selectBy- [internalError field] - typeConName - schema--askTypeMember- :: Name- -> SelectionValidator (Name, FieldsDefinition)-askTypeMember - name- = askSchema- >>= selectOr notFound pure name - >>= constraintOBJECT - where - notFound = do- scopeType <- askScopeTypeName- failure $- "Type \"" <> name- <> "\" referenced by union \"" <> scopeType - <> "\" can't found in Schema."- --------------------------------------- constraintOBJECT TypeDefinition { typeName , typeContent } = con typeContent- where- con DataObject { objectFields } = pure (typeName, objectFields)- con _ = do - scopeType <- askScopeTypeName- failure $- "Type \"" <> typeName- <> "\" referenced by union \"" <> scopeType - <> "\" must be an OBJECT."--askInputFieldType- :: FieldDefinition- -> InputValidator TypeDefinition-askInputFieldType field@FieldDefinition{ fieldName , fieldType = TypeRef { typeConName } }- = askSchema- >>= selectBy- [internalError field] - typeConName - >>= constraintINPUT- where- constraintINPUT x - | isInputDataType x = pure x- | otherwise = failure $- "Type \"" <> typeName x- <> "\" referenced by field \"" <> fieldName- <> "\" must be an input type."--askInputMember- :: Name- -> InputValidator TypeDefinition-askInputMember - name- = askSchema- >>= selectOr notFound pure name - >>= constraintINPUT_OBJECT - where - typeInfo tName- = "Type \"" <> tName <> "\" referenced by inputUnion " - notFound = do- scopeType <- askScopeTypeName- failure $ typeInfo name <> scopeType <> "\" can't found in Schema."- --------------------------------------- constraintINPUT_OBJECT tyDef@TypeDefinition { typeName , typeContent } = con typeContent- where- con DataInputObject { } = pure tyDef- con _ = do - scopeType <- askScopeTypeName- failure $ typeInfo typeName <> "\"" <> scopeType <> "\" must be an INPUT_OBJECT."--startInput :: InputSource -> InputValidator a -> Validator ctx a-startInput inputSource - = setContext - $ const InputContext - { inputSource - , inputPath = [] - }- -withInputScope :: Prop -> InputValidator a -> InputValidator a-withInputScope prop = setContext update- where- update ctx@InputContext { inputPath = old } - = ctx { inputPath = old <> [prop] }--runValidator :: Validator ctx a -> Context -> ctx -> Eventless a-runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX,ctx) --askContext :: Validator ctx ctx-askContext = snd <$> Validator ask--askSchema :: Validator ctx Schema-askSchema = schema . fst <$> Validator ask- -askFragments :: Validator ctx Fragments-askFragments = fragments . fst <$> Validator ask--askScopeTypeName :: Validator ctx Name-askScopeTypeName = scopeTypeName . fst <$> Validator ask--askScopePosition :: Validator ctx Position-askScopePosition = scopePosition . fst <$> Validator ask--setContext - :: (c' -> c) - -> Validator c a - -> Validator c' a-setContext f = Validator . withReaderT ( \(x,y) -> (x,f y)) . _runValidator--setGlobalContext - :: (Context -> Context) - -> Validator c a - -> Validator c a-setGlobalContext f = Validator . withReaderT ( \(x,y) -> (f x,y)) . _runValidator--withScope :: Name -> Ref -> Validator ctx a -> Validator ctx a-withScope scopeTypeName (Ref scopeSelectionName scopePosition) = setGlobalContext update- where- update ctx = ctx { scopeTypeName , scopePosition , scopeSelectionName}--withScopePosition :: Position -> Validator ctx a -> Validator ctx a-withScopePosition scopePosition = setGlobalContext update- where- update ctx = ctx { scopePosition }--withScopeType :: Name -> Validator ctx a -> Validator ctx a-withScopeType scopeTypeName = setGlobalContext update- where- update ctx = ctx { scopeTypeName }--inputMessagePrefix :: InputValidator Message -inputMessagePrefix = renderInputPrefix <$> askContext---constraintInputUnion- :: forall stage. [(Name, Bool)]- -> Object stage- -> Either Message (Name, Maybe (Value stage))-constraintInputUnion tags hm = do- (enum :: Value stage) <- entryValue <$> selectBy - ("valid input union should contain \"" <> __inputname <> "\" and actual value")- __inputname- hm- tyName <- isPosibeInputUnion tags enum- case size hm of- 1 -> pure (tyName, Nothing)- 2 -> do- value <- entryValue <$> selectBy - ("value for Union \""<> tyName <> "\" was not Provided.") - tyName - hm- pure (tyName , Just value)- _ -> failure ("input union can have only one variant." :: Message)--isPosibeInputUnion :: [(Name, Bool)] -> Value stage -> Either Message Name-isPosibeInputUnion tags (Enum name) = case lookup name tags of- Nothing -> failure (name <> " is not posible union type" :: Message)- _ -> pure name-isPosibeInputUnion _ _ = failure $ "\""<> __inputname <> "\" must be Enum"
− src/Data/Morpheus/Types/Internal/Validation/Error.hs
@@ -1,201 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.Morpheus.Types.Internal.Validation.Error- ( MissingRequired(..)- , KindViolation(..)- , Unknown(..)- , InternalError(..)- , Target(..)- , Unused(..)- )- where--import Data.Semigroup ((<>))---- MORPHEUS-import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Error.Selection ( unknownSelectionField )-import Data.Morpheus.Types.Internal.Validation.Validator- ( Context(..)- , InputContext(..)- , renderInputPrefix- , Target(..)- )-import Data.Morpheus.Types.Internal.AST- ( RESOLVED- , Ref(..)- , TypeRef(..)- , GQLError(..)- , GQLErrors- , Argument(..)- , ObjectEntry(..)- , Fragment(..)- , Fragments- , Variable(..)- , VariableDefinitions- , FieldDefinition(..)- , FieldsDefinition- , InputFieldsDefinition- , Schema- , Object- , Arguments- , getOperationName- )----class InternalError a where- internalError :: a -> GQLError----instance InternalError FieldDefinition where- internalError FieldDefinition - { fieldName- , fieldType = TypeRef { typeConName } - } = GQLError - { message - = "INTERNAL: Type \"" <> typeConName- <> "\" referenced by field \"" <> fieldName - <> "\" can't found in Schema "- , locations = []- }----class Unused c where- unused :: Context -> c -> GQLError---- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",-instance Unused (Variable s) where- unused - Context { operationName } - Variable{ variableName , variablePosition}- = GQLError - { message - = "Variable \"$" <> variableName - <> "\" is never used in operation \""- <> getOperationName operationName <> "\"."- , locations = [variablePosition] - }--instance Unused Fragment where- unused - _- Fragment { fragmentName , fragmentPosition }- = GQLError- { message - = "Fragment \"" <> fragmentName - <> "\" is never used."- , locations = [fragmentPosition]- }--class MissingRequired c ctx where - missingRequired :: Context -> ctx -> Ref -> c -> GQLError--instance MissingRequired (Arguments s) ctx where- missingRequired - Context { scopePosition , scopeSelectionName } - _- Ref { refName } _ - = GQLError - { message - = "Field \"" <> scopeSelectionName <> "\" argument \""- <> refName <> "\" is required but not provided."- , locations = [scopePosition]- }--instance MissingRequired (Object s) InputContext where- missingRequired - Context { scopePosition }- inputCTX- Ref { refName } - _ - = GQLError - { message- = renderInputPrefix inputCTX <> "Undefined Field \"" <> refName <> "\"."- , locations = [scopePosition]- }--instance MissingRequired (VariableDefinitions s) ctx where- missingRequired- Context { operationName }- _ - Ref { refName , refPosition } _ - = GQLError - { message - = "Variable \"" <> refName- <> "\" is not defined by operation \""- <> getOperationName operationName <> "\"."- , locations = [refPosition]- }---class Unknown c ctx where- type UnknownSelector c- unknown :: Context -> ctx -> c -> UnknownSelector c -> GQLErrors---- {...H} -> "Unknown fragment \"H\"."-instance Unknown Fragments ctx where- type UnknownSelector Fragments = Ref- unknown _ _ _ (Ref name pos) - = errorMessage pos- ("Unknown Fragment \"" <> name <> "\".")--instance Unknown Schema ctx where- type UnknownSelector Schema = Ref- unknown _ _ _ Ref { refName , refPosition }- = errorMessage refPosition ("Unknown type \"" <> refName <> "\".")--instance Unknown FieldDefinition ctx where- type UnknownSelector FieldDefinition = Argument RESOLVED- unknown _ _ FieldDefinition { fieldName } Argument { argumentName, argumentPosition }- = errorMessage argumentPosition - ("Unknown Argument \"" <> argumentName <> "\" on Field \"" <> fieldName <> "\".")--instance Unknown InputFieldsDefinition InputContext where- type UnknownSelector InputFieldsDefinition = ObjectEntry RESOLVED- unknown Context { scopePosition } ctx _ ObjectEntry { entryName } = - [- GQLError - { message = renderInputPrefix ctx <>"Unknown Field \"" <> entryName <> "\"."- , locations = [scopePosition]- }- ]--instance Unknown FieldsDefinition ctx where- type UnknownSelector FieldsDefinition = Ref- unknown Context { scopeTypeName } _ _ - = unknownSelectionField scopeTypeName--class KindViolation (t :: Target) ctx where- kindViolation :: c t -> ctx -> GQLError--instance KindViolation 'TARGET_OBJECT Fragment where- kindViolation _ Fragment { fragmentName, fragmentType, fragmentPosition } - = GQLError- { message - = "Fragment \"" <> fragmentName - <> "\" cannot condition on non composite type \"" - <> fragmentType <>"\"."- , locations = [fragmentPosition]- }--instance KindViolation 'TARGET_INPUT (Variable s) where- kindViolation _ Variable - { variableName - , variablePosition- , variableType = TypeRef { typeConName }- } - = GQLError - { message - = "Variable \"$" <> variableName - <> "\" cannot be non-input type \""- <> typeConName <>"\"."- , locations = [variablePosition]- }
− src/Data/Morpheus/Types/Internal/Validation/Validator.hs
@@ -1,226 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Data.Morpheus.Types.Internal.Validation.Validator- ( Validator(..)- , SelectionValidator- , InputValidator- , BaseValidator- , runValidator- , askSchema- , askContext- , askFragments- , Constraint(..)- , withScope- , withScopeType- , withScopePosition- , askScopeTypeName- , askScopePosition- , withInputScope- , inputMessagePrefix- , Context(..)- , InputSource(..)- , InputContext(..)- , SelectionContext(..)- , renderInputPrefix- , Target(..)- , Prop(..)- , Resolution- )- where--import Data.Semigroup ( (<>)- , Semigroup(..)- )-import Control.Monad.Trans.Reader ( ReaderT(..)- , ask- , withReaderT- )-import Data.Text ( intercalate )-import Control.Monad.Trans.Class ( MonadTrans(..) )----- MORPHEUS-import Data.Morpheus.Types.Internal.Operation- ( Failure(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )-import Data.Morpheus.Types.Internal.AST- ( Name- , Position- , Message- , GQLErrors- , GQLError(..)- , Fragments- , Schema- , FieldsDefinition(..)- , TypeDefinition(..)- , Argument(..)- , Variable(..)- , VariableDefinitions- , RESOLVED- , RAW- , VALID- )--data Prop =- Prop- { propName :: Name- , propTypeName :: Name- } deriving (Show)--type Path = [Prop]--renderPath :: Path -> Message-renderPath [] = ""-renderPath path = "in field \"" <> intercalate "." (fmap propName path) <> "\": "--renderInputPrefix :: InputContext -> Message-renderInputPrefix InputContext { inputPath , inputSource } = - renderSource inputSource <> renderPath inputPath--renderSource :: InputSource -> Message-renderSource (SourceArgument Argument { argumentName }) - = "Argument \"" <> argumentName <>"\" got invalid value. "-renderSource (SourceVariable Variable { variableName })- = "Variable \"$" <> variableName <>"\" got invalid value. "--data Context = Context - { schema :: Schema- , fragments :: Fragments- , scopePosition :: Position- , scopeTypeName :: Name- , operationName :: Maybe Name- , scopeSelectionName :: Name- } deriving (Show)--data InputContext - = InputContext - { inputSource :: InputSource- , inputPath :: [Prop]- } deriving (Show)--data InputSource- = SourceArgument (Argument RESOLVED)- | SourceVariable (Variable RAW)- deriving (Show)--newtype SelectionContext - = SelectionContext - { variables :: VariableDefinitions VALID- } deriving (Show)--data Target - = TARGET_OBJECT - | TARGET_INPUT--data Constraint (a :: Target) where- OBJECT :: Constraint 'TARGET_OBJECT- INPUT :: Constraint 'TARGET_INPUT--- UNION :: Constraint 'TARGET_UNION--type family Resolution (a :: Target)-type instance Resolution 'TARGET_OBJECT = (Name, FieldsDefinition)-type instance Resolution 'TARGET_INPUT = TypeDefinition---type instance Resolution 'TARGET_UNION = DataUnion- -withInputScope :: Prop -> InputValidator a -> InputValidator a-withInputScope prop = setContext update- where- update ctx@InputContext { inputPath = old } - = ctx { inputPath = old <> [prop] }---askContext :: Validator ctx ctx-askContext = snd <$> Validator ask--askSchema :: Validator ctx Schema-askSchema = schema . fst <$> Validator ask- -askFragments :: Validator ctx Fragments-askFragments = fragments . fst <$> Validator ask--askScopeTypeName :: Validator ctx Name-askScopeTypeName = scopeTypeName . fst <$> Validator ask--askScopePosition :: Validator ctx Position-askScopePosition = scopePosition . fst <$> Validator ask--setContext - :: (c' -> c) - -> Validator c a - -> Validator c' a-setContext f = Validator . withReaderT ( \(x,y) -> (x,f y)) . _runValidator--setGlobalContext - :: (Context -> Context) - -> Validator c a - -> Validator c a-setGlobalContext f = Validator . withReaderT ( \(x,y) -> (f x,y)) . _runValidator---withScope :: Name -> Position -> Validator ctx a -> Validator ctx a-withScope scopeTypeName scopePosition = setGlobalContext update- where- update ctx = ctx { scopeTypeName , scopePosition }---withScopePosition :: Position -> Validator ctx a -> Validator ctx a-withScopePosition scopePosition = setGlobalContext update- where- update ctx = ctx { scopePosition }--withScopeType :: Name -> Validator ctx a -> Validator ctx a-withScopeType scopeTypeName = setGlobalContext update- where- update ctx = ctx { scopeTypeName }--inputMessagePrefix :: InputValidator Message -inputMessagePrefix = renderInputPrefix <$> askContext---runValidator :: Validator ctx a -> Context -> ctx -> Eventless a-runValidator (Validator x) globalCTX ctx = runReaderT x (globalCTX,ctx) --newtype Validator ctx a - = Validator - {- _runValidator :: ReaderT - (Context, ctx) - Eventless- a- }- deriving - ( Functor- , Applicative- , Monad- )--type BaseValidator = Validator ()-type SelectionValidator = Validator SelectionContext-type InputValidator = Validator InputContext---- can be only used for internal errors-instance Failure Message (Validator ctx) where- failure inputMessage = do - position <- askScopePosition- failure - [- GQLError - { message = "INTERNAL: " <> inputMessage- , locations = [position]- }- ]--instance Failure GQLErrors (Validator ctx) where- failure = Validator . lift . failure
− src/Data/Morpheus/Types/Types.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE KindSignatures #-}--module Data.Morpheus.Types.Types- ( Undefined(..)- , Pair(..)- , MapKind(..)- , MapArgs(..)- , mapKindFromList- )-where--import GHC.Generics ( Generic )--data Undefined (m :: * -> *) = Undefined deriving (Show, Generic)--data Pair k v =- Pair- { key :: k- , value :: v- }- deriving (Generic)--newtype MapArgs k =- MapArgs- { oneOf :: Maybe [k]- }- deriving (Generic)--data MapKind k v m =- MapKind- { size :: Int- , pairs :: MapArgs k -> m [Pair k v]- }- deriving (Generic)--mapKindFromList :: (Eq k, Applicative m) => [(k, v)] -> MapKind k v m-mapKindFromList inputPairs = MapKind { size = length inputPairs- , pairs = resolvePairs- }- where- filterBy MapArgs { oneOf = Just list } =- filter ((`elem` list) . fst) inputPairs- filterBy _ = inputPairs- resolvePairs = pure . (map toGQLTuple . filterBy)- toGQLTuple (x, y) = Pair x y
− src/Data/Morpheus/Validation/Document/Validation.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Validation.Document.Validation- ( validatePartialDocument- )-where--import Data.Maybe------- Morpheus-import Data.Morpheus.Error.Document.Interface- ( ImplementsError(..)- , partialImplements- , unknownInterface- )-import Data.Morpheus.Rendering.RenderGQL- ( RenderGQL(..) )-import Data.Morpheus.Types.Internal.AST- ( Name- , FieldDefinition(..)- , TypeDefinition(..)- , FieldsDefinition(..)- , TypeContent(..)- , TypeRef(..)- , isWeaker- , lookupWith- )-import Data.Morpheus.Types.Internal.Operation- ( Selectable(..)- , Listable(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless- , Failure(..)- )--validatePartialDocument :: [TypeDefinition] -> Eventless [TypeDefinition]-validatePartialDocument lib = catMaybes <$> traverse validateType lib- where- validateType :: TypeDefinition -> Eventless (Maybe TypeDefinition)- validateType dt@TypeDefinition { typeName , typeContent = DataObject { objectImplements , objectFields} } = do - interface <- traverse getInterfaceByKey objectImplements- case concatMap (mustBeSubset objectFields) interface of- [] -> pure (Just dt) - errors -> failure $ partialImplements typeName errors- validateType TypeDefinition { typeContent = DataInterface {}} = pure Nothing- validateType x = pure (Just x)- mustBeSubset- :: FieldsDefinition -> (Name, FieldsDefinition) -> [(Name, Name, ImplementsError)]- mustBeSubset objFields (typeName, fields) = concatMap checkField (toList fields)- where- checkField :: FieldDefinition -> [(Name, Name, ImplementsError)]- checkField FieldDefinition { fieldName, fieldType = interfaceT@TypeRef { typeConName = interfaceTypeName, typeWrappers = interfaceWrappers } }- = selectOr err checkTypeEq fieldName objFields- where- err = [(typeName, fieldName, UndefinedField)]- checkTypeEq FieldDefinition { fieldType = objT@TypeRef { typeConName, typeWrappers } }- | typeConName == interfaceTypeName && not (isWeaker typeWrappers interfaceWrappers)- = []- | otherwise- = [ ( typeName , fieldName- , UnexpectedType { expectedType = render interfaceT- , foundType = render objT- }- )- ]- -------------------------------- getInterfaceByKey :: Name -> Eventless (Name, FieldsDefinition)- getInterfaceByKey interfaceName = case lookupWith typeName interfaceName lib of- Just TypeDefinition { typeContent = DataInterface { interfaceFields } } -> pure (interfaceName,interfaceFields)- _ -> failure $ unknownInterface interfaceName
− src/Data/Morpheus/Validation/Internal/Value.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Validation.Internal.Value- ( validateInput )-where--import Data.Semigroup ((<>))-import Data.Maybe (maybe)-import Data.Foldable (traverse_)-import Data.List ( elem )---- MORPHEUS--import Data.Morpheus.Error.Utils ( errorMessage )-import Data.Morpheus.Error.Variable ( incompatibleVariableType )-import Data.Morpheus.Error.Input ( typeViolation )-import Data.Morpheus.Types.Internal.AST- ( FieldDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , ScalarDefinition(..)- , TypeRef(..)- , TypeWrapper(..)- , DataEnumValue(..)- , Value(..)- , ValidValue- , Variable(..)- , Ref(..)- , Message- , Name- , ResolvedValue- , VALID- , VariableContent(..)- , TypeRef(..)- , isWeaker- , isNullableWrapper- , ObjectEntry(..)- , RESOLVED- , InputFieldsDefinition(..)- , Variable(..)- )-import Data.Morpheus.Types.Internal.AST.OrderedMap- ( unsafeFromValues )-import Data.Morpheus.Types.Internal.Operation- ( Failure(..) )-import Data.Morpheus.Types.Internal.Validation- ( InputValidator- , askInputFieldType- , constraintInputUnion- , askInputMember- , selectKnown- , selectWithDefaultValue- , askScopePosition- , withScopeType- , withInputScope- , inputMessagePrefix- , Prop(..)- )--castFailure :: TypeRef -> Maybe Message -> ResolvedValue -> InputValidator a-castFailure expected message value = do- pos <- askScopePosition- prefix <- inputMessagePrefix- failure- $ errorMessage pos - $ prefix <> typeViolation expected value <> maybe "" (" " <>) message--checkTypeEquality- :: (Name, [TypeWrapper])- -> Ref- -> Variable VALID- -> InputValidator ValidValue-checkTypeEquality (tyConName, tyWrappers) ref var@Variable { variableValue = ValidVariableValue value, variableType }- | typeConName variableType == tyConName && not- (isWeaker (typeWrappers variableType) tyWrappers)- = pure value- | otherwise- = failure $ incompatibleVariableType - ref- var- TypeRef - { typeConName = tyConName- , typeWrappers = tyWrappers- , typeArgs = Nothing- }---- Validate Variable Argument or all Possible input Values-validateInput- :: [TypeWrapper]- -> TypeDefinition- -> ObjectEntry RESOLVED- -> InputValidator ValidValue-validateInput tyWrappers TypeDefinition { typeContent = tyCont, typeName } =- withScopeType typeName - . validateWrapped tyWrappers tyCont- where- mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue- mismatchError wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing - -- VALIDATION- validateWrapped- :: [TypeWrapper]- -> TypeContent- -> ObjectEntry RESOLVED- -> InputValidator ValidValue- -- Validate Null. value = null ?- validateWrapped wrappers _ ObjectEntry { entryValue = ResolvedVariable ref variable} =- checkTypeEquality (typeName, wrappers) ref variable- validateWrapped wrappers _ ObjectEntry { entryValue = Null}- | isNullableWrapper wrappers = return Null- | otherwise = mismatchError wrappers Null- -- Validate LIST- validateWrapped (TypeMaybe : wrappers) _ value =- validateWrapped wrappers tyCont value- validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) =- List <$> traverse validateElement list- where- validateElement = validateWrapped wrappers tyCont . ObjectEntry key - {-- 2. VALIDATE TYPES, all wrappers are already Processed --}- {-- VALIDATE OBJECT--}- validateWrapped [] dt v = validate dt v- where- validate- :: TypeContent -> ObjectEntry RESOLVED -> InputValidator ValidValue- validate (DataInputObject parentFields) ObjectEntry { entryValue = Object fields} = do - traverse_ requiredFieldsDefined (unInputFieldsDefinition parentFields)- Object <$> traverse validateField fields- where- requiredFieldsDefined :: FieldDefinition -> InputValidator (ObjectEntry RESOLVED)- requiredFieldsDefined fieldDef@FieldDefinition { fieldName}- = selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields - validateField- :: ObjectEntry RESOLVED -> InputValidator (ObjectEntry VALID)- validateField entry@ObjectEntry { entryName } = do- inputField@FieldDefinition{ fieldType = TypeRef { typeConName , typeWrappers }} <- getField- inputTypeDef <- askInputFieldType inputField- withInputScope (Prop entryName typeConName) $ ObjectEntry entryName - <$> validateInput- typeWrappers- inputTypeDef- entry- where- getField = selectKnown entry parentFields- -- VALIDATE INPUT UNION- -- TODO: enhance input union Validation- validate (DataInputUnion inputUnion) ObjectEntry { entryValue = Object rawFields} =- case constraintInputUnion inputUnion rawFields of- Left message -> castFailure (TypeRef typeName Nothing []) (Just message) (Object rawFields) - Right (name, Nothing ) -> return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name)])- Right (name, Just value) -> do- inputDef <- askInputMember name- validValue <- validateInput- [TypeMaybe]- inputDef- (ObjectEntry name value)- return (Object $ unsafeFromValues [ObjectEntry "__typename" (Enum name), ObjectEntry name validValue])- {-- VALIDATE ENUM --}- validate (DataEnum tags) ObjectEntry { entryValue } =- validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue- {-- VALIDATE SCALAR --}- validate (DataScalar dataScalar) ObjectEntry { entryValue } = - validateScalar dataScalar entryValue (castFailure (TypeRef typeName Nothing []))- validate _ ObjectEntry { entryValue } = mismatchError [] entryValue- {-- 3. THROW ERROR: on invalid values --}- validateWrapped wrappers _ ObjectEntry { entryValue } = mismatchError wrappers entryValue--validateScalar- :: ScalarDefinition- -> ResolvedValue- -> (Maybe Message -> ResolvedValue -> InputValidator ValidValue)- -> InputValidator ValidValue-validateScalar ScalarDefinition { validateValue } value err = do- scalarValue <- toScalar value- case validateValue scalarValue of- Right _ -> return scalarValue- Left "" -> err Nothing value- Left message -> err (Just message) value- where- toScalar :: ResolvedValue -> InputValidator ValidValue- toScalar (Scalar x) = pure (Scalar x)- toScalar scValue = err Nothing scValue --validateEnum - :: (ResolvedValue -> InputValidator ValidValue) - -> [DataEnumValue] - -> ResolvedValue - -> InputValidator ValidValue-validateEnum err enumValues value@(Enum enumValue)- | enumValue `elem` tags = pure (Enum enumValue)- | otherwise = err value - where tags = map enumName enumValues-validateEnum err _ value = err value
− src/Data/Morpheus/Validation/Query/Arguments.hs
@@ -1,123 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}--module Data.Morpheus.Validation.Query.Arguments- ( validateArguments- )-where--import Data.Foldable (traverse_)-import Data.Morpheus.Types.Internal.AST- ( Argument(..)- , ArgumentsDefinition(..)- , Arguments- , ArgumentDefinition- , FieldDefinition(..)- , TypeRef(..)- , Value(..)- , RawValue- , ResolvedValue- , RESOLVED- , VALID- , ObjectEntry(..)- , RAW- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- , empty- )-import Data.Morpheus.Types.Internal.Validation- ( SelectionValidator- , InputSource(..)- , SelectionContext(..)- , selectKnown- , selectRequired- , selectWithDefaultValue- , askScopePosition- , withScopePosition- , askInputFieldType- , startInput- , askContext- )-import Data.Morpheus.Validation.Internal.Value- ( validateInput )---- only Resolves , doesnot checks the types-resolveObject :: RawValue -> SelectionValidator ResolvedValue-resolveObject = resolve- where- resolveEntry :: ObjectEntry RAW -> SelectionValidator (ObjectEntry RESOLVED)- resolveEntry (ObjectEntry name v) = ObjectEntry name <$> resolve v- ------------------------------------------------- resolve :: RawValue -> SelectionValidator ResolvedValue- resolve Null = pure Null- resolve (Scalar x ) = pure $ Scalar x- resolve (Enum x ) = pure $ Enum x- resolve (List x ) = List <$> traverse resolve x- resolve (Object obj) = Object <$> traverse resolveEntry obj- resolve (VariableValue ref) =- variables <$> askContext- >>= fmap (ResolvedVariable ref) - . selectRequired ref --resolveArgumentVariables- :: Arguments RAW- -> SelectionValidator (Arguments RESOLVED)-resolveArgumentVariables- = traverse resolveVariable- where- resolveVariable :: Argument RAW -> SelectionValidator (Argument RESOLVED)- resolveVariable (Argument key val position) = do - constValue <- resolveObject val- pure $ Argument key constValue position--validateArgument- :: Arguments RESOLVED- -> ArgumentDefinition- -> SelectionValidator (Argument VALID)-validateArgument - requestArgs - argumentDef@FieldDefinition - { fieldName - , fieldType = TypeRef { typeWrappers } - }- = do - argumentPosition <- askScopePosition- argument <- selectWithDefaultValue- Argument { argumentName = fieldName, argumentValue = Null, argumentPosition }- argumentDef- requestArgs - validateArgumentValue argument- where- -------------------------------------------------------------------------- validateArgumentValue :: Argument RESOLVED -> SelectionValidator (Argument VALID)- validateArgumentValue arg@Argument { argumentValue = value, .. } =- withScopePosition argumentPosition - $ startInput (SourceArgument arg) - $ do- datatype <- askInputFieldType argumentDef- argumentValue <- validateInput- typeWrappers - datatype - (ObjectEntry fieldName value)- pure Argument { argumentValue , .. }--validateArguments- :: FieldDefinition- -> Arguments RAW- -> SelectionValidator (Arguments VALID)-validateArguments- fieldDef@FieldDefinition { fieldArgs }- rawArgs- = do- args <- resolveArgumentVariables rawArgs- traverse_ checkUnknown (toList args)- traverse (validateArgument args) argsDef- where- argsDef = case fieldArgs of - (ArgumentsDefinition _ argsD) -> argsD- NoArguments -> empty- -------------------------------------------------- checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition- checkUnknown = (`selectKnown` fieldDef)
− src/Data/Morpheus/Validation/Query/Fragment.hs
@@ -1,139 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE FlexibleInstances #-}--module Data.Morpheus.Validation.Query.Fragment- ( validateFragments- , castFragmentType- , resolveSpread- )-where--import Data.Semigroup ( (<>) )-import Data.Foldable (traverse_) ---- MORPHEUS-import Data.Morpheus.Error.Fragment ( cannotBeSpreadOnType- , cannotSpreadWithinItself- )-import Data.Morpheus.Types.Internal.AST- ( Name- , Fragment(..)- , Fragments- , SelectionContent(..)- , Selection(..)- , Ref(..)- , Position- , SelectionSet- , RAW- )-import Data.Morpheus.Types.Internal.Operation- ( selectOr- , toList- , Failure(..)- )-import Data.Morpheus.Types.Internal.Validation- ( BaseValidator- , askSchema- , askFragments- , selectKnown- , constraint- , Constraint(..)- , Validator- , checkUnused- )--validateFragments :: SelectionSet RAW -> BaseValidator ()-validateFragments selectionSet - = fragmentsCycleChecking - *> checkUnusedFragments selectionSet- *> fragmentsConditionTypeChecking--checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()-checkUnusedFragments selectionSet = do- fragments <- askFragments- checkUnused - (usedFragments fragments (toList selectionSet)) - (toList fragments)--castFragmentType- :: Maybe Name -> Position -> [Name] -> Fragment -> Validator ctx Fragment-castFragmentType key position typeMembers fragment@Fragment { fragmentType }- | fragmentType `elem` typeMembers = pure fragment- | otherwise = failure $ cannotBeSpreadOnType key fragmentType position typeMembers--resolveSpread :: [Name] -> Ref -> Validator ctx Fragment-resolveSpread allowedTargets ref@Ref { refName, refPosition } - = askFragments- >>= selectKnown ref- >>= castFragmentType (Just refName) refPosition allowedTargets--usedFragments :: Fragments -> [Selection RAW] -> [Node]-usedFragments fragments = concatMap findAllUses- where- findAllUses :: Selection RAW -> [Node]- findAllUses Selection { selectionContent = SelectionField } = []- findAllUses Selection { selectionContent = SelectionSet selectionSet } =- concatMap findAllUses selectionSet- findAllUses (InlineFragment Fragment { fragmentSelection }) =- concatMap findAllUses fragmentSelection- findAllUses (Spread Ref { refName, refPosition }) =- [Ref refName refPosition] <> searchInFragment- where- searchInFragment = selectOr - [] - (concatMap findAllUses . fragmentSelection) - refName - fragments--fragmentsConditionTypeChecking :: BaseValidator ()-fragmentsConditionTypeChecking - = toList <$> askFragments- >>= traverse_ checkTypeExistence--checkTypeExistence :: Fragment -> BaseValidator ()-checkTypeExistence fr@Fragment { fragmentType, fragmentPosition }- = askSchema- >>= selectKnown (Ref fragmentType fragmentPosition) - >>= constraint OBJECT fr - >> pure ()--fragmentsCycleChecking :: BaseValidator ()-fragmentsCycleChecking = exploreSpreads >>= fragmentCycleChecking --exploreSpreads :: BaseValidator Graph-exploreSpreads = map exploreFragmentSpreads . toList <$> askFragments--exploreFragmentSpreads :: Fragment -> NodeEdges -exploreFragmentSpreads Fragment { fragmentName, fragmentSelection, fragmentPosition }- = ( Ref fragmentName fragmentPosition, concatMap scanForSpread fragmentSelection)--scanForSpread :: Selection RAW -> [Node]-scanForSpread Selection { selectionContent = SelectionField } = []-scanForSpread Selection { selectionContent = SelectionSet selectionSet } =- concatMap scanForSpread selectionSet-scanForSpread (InlineFragment Fragment { fragmentSelection }) =- concatMap scanForSpread fragmentSelection-scanForSpread (Spread Ref { refName, refPosition }) =- [Ref refName refPosition]--type Node = Ref--type NodeEdges = (Node, [Node])--type Graph = [NodeEdges]--fragmentCycleChecking :: Graph -> BaseValidator ()-fragmentCycleChecking lib = traverse_ checkFragment lib- where- checkFragment (fragmentID, _) = checkForCycle lib fragmentID [fragmentID]--checkForCycle :: Graph -> Node -> [Node] -> BaseValidator Graph-checkForCycle lib parentNode history = case lookup parentNode lib of- Just node -> concat <$> traverse checkNode node- Nothing -> pure []- where- checkNode x = if x `elem` history then cycleError x else recurse x- recurse node = checkForCycle lib node $ history ++ [node]- cycleError n = failure $ cannotSpreadWithinItself (n : history)
− src/Data/Morpheus/Validation/Query/Selection.hs
@@ -1,205 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.Morpheus.Validation.Query.Selection- ( validateOperation- )-where---import Data.Semigroup ( (<>) )---- MORPHEUS-import Data.Morpheus.Error.Selection ( hasNoSubfields- , subfieldsNotSelected- )-import Data.Morpheus.Types.Internal.AST- ( Selection(..)- , SelectionContent(..)- , Fragment(..)- , SelectionSet- , FieldDefinition(..)- , FieldsDefinition(..)- , TypeContent(..)- , TypeDefinition(..)- , Operation(..)- , Ref(..)- , Name- , RAW- , VALID- , Arguments- , isEntNode- , getOperationDataType- , GQLError(..)- , OperationType(..)- )-import Data.Morpheus.Types.Internal.AST.MergeSet- ( concatTraverse )-import Data.Morpheus.Types.Internal.Operation- ( empty- , singleton- , Failure(..)- , keyOf- , toList- )-import Data.Morpheus.Types.Internal.Validation- ( SelectionValidator- , askFieldType- , selectKnown- , withScope- , askSchema- )-import Data.Morpheus.Validation.Query.UnionSelection- (validateUnionSelection)-import Data.Morpheus.Validation.Query.Arguments- ( validateArguments )-import Data.Morpheus.Validation.Query.Fragment- ( castFragmentType- , resolveSpread- )--type TypeDef = (Name, FieldsDefinition)---getOperationObject- :: Operation a -> SelectionValidator (Name, FieldsDefinition)-getOperationObject operation = do- dt <- askSchema >>= getOperationDataType operation - case dt of- TypeDefinition { typeContent = DataObject { objectFields }, typeName } -> pure (typeName, objectFields)- TypeDefinition { typeName } ->- failure- $ "Type Mismatch: operation \""- <> typeName- <> "\" must be an Object"---selectionsWitoutTypename :: SelectionSet VALID -> [Selection VALID] -selectionsWitoutTypename = filter (("__typename" /=) . keyOf) . toList--singleTopLevelSelection :: Operation RAW -> SelectionSet VALID -> SelectionValidator ()-singleTopLevelSelection Operation { operationType = Subscription , operationName } selSet = - case selectionsWitoutTypename selSet of- (_:xs) | not (null xs) -> failure $ map (singleTopLevelSelectionError operationName) xs- _ -> pure ()-singleTopLevelSelection _ _ = pure () --singleTopLevelSelectionError :: Maybe Name -> Selection VALID -> GQLError-singleTopLevelSelectionError name Selection { selectionPosition } = GQLError - { message - = subscriptionName <> " must select " - <> "only one top level field."- , locations = [selectionPosition]- }- where- subscriptionName = maybe "Anonymous Subscription" (("Subscription \"" <>) . (<> "\"")) name--validateOperation- :: Operation RAW- -> SelectionValidator (Operation VALID)-validateOperation - rawOperation@Operation - { operationName- , operationType- , operationSelection- , operationPosition - } - = do- typeDef <- getOperationObject rawOperation- selection <- validateSelectionSet typeDef operationSelection- singleTopLevelSelection rawOperation selection- pure $ Operation - { operationName- , operationType- , operationArguments = empty- , operationSelection = selection- , operationPosition- }---validateSelectionSet- :: TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)-validateSelectionSet dataType@(typeName,fieldsDef) =- concatTraverse validateSelection - where- -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet- validateSelection :: Selection RAW -> SelectionValidator (SelectionSet VALID)- validateSelection - sel@Selection - { selectionName- , selectionArguments- , selectionContent- , selectionPosition - } - = withScope - typeName - currentSelectionRef- $ validateSelectionContent - selectionContent- where- currentSelectionRef = Ref selectionName selectionPosition- commonValidation :: SelectionValidator (TypeDefinition, Arguments VALID)- commonValidation = do- (fieldDef :: FieldDefinition) <- selectKnown (Ref selectionName selectionPosition) fieldsDef- -- validate field Argument ------ arguments <- validateArguments- fieldDef- selectionArguments- -- check field Type existence ------ (typeDef :: TypeDefinition) <- askFieldType fieldDef- pure (typeDef, arguments)- ------------------------------------------------------------------------------------ validateSelectionContent :: SelectionContent RAW -> SelectionValidator (SelectionSet VALID)- validateSelectionContent SelectionField - | null selectionArguments && selectionName == "__typename" - = pure $ singleton $ sel { selectionArguments = empty, selectionContent = SelectionField }- | otherwise = do- (datatype, validArgs) <- commonValidation- isLeaf datatype- pure $ singleton $ sel { selectionArguments = validArgs, selectionContent = SelectionField }- where- ------------------------------------------------------------- isLeaf :: TypeDefinition -> SelectionValidator ()- isLeaf TypeDefinition { typeName = typename, typeContent }- | isEntNode typeContent = pure ()- | otherwise = failure- $ subfieldsNotSelected selectionName typename selectionPosition- ----- SelectionSet- validateSelectionContent (SelectionSet rawSelectionSet)- = do- (TypeDefinition { typeName = name , typeContent}, validArgs) <- commonValidation- selContent <- withScope name currentSelectionRef $ validateByTypeContent name typeContent- pure $ singleton $ sel { selectionArguments = validArgs, selectionContent = selContent }- where- validateByTypeContent :: Name -> TypeContent -> SelectionValidator (SelectionContent VALID)- -- Validate UnionSelection - validateByTypeContent _ DataUnion { unionMembers } - = validateUnionSelection - validateSelectionSet- rawSelectionSet - unionMembers- -- Validate Regular selection set- validateByTypeContent typename DataObject { objectFields } - = SelectionSet - <$> validateSelectionSet - (typename, objectFields) - rawSelectionSet- validateByTypeContent typename _ - = failure - $ hasNoSubfields - (Ref selectionName selectionPosition) - typename- validateSelection (Spread ref) - = resolveSpread [typeName] ref - >>= validateFragment- validateSelection (InlineFragment fragment') - = castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment'- >>= validateFragment- --------------------------------------------------------------------------------- validateFragment Fragment { fragmentSelection } = validateSelectionSet dataType fragmentSelection
− src/Data/Morpheus/Validation/Query/UnionSelection.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE MultiParamTypeClasses #-}--module Data.Morpheus.Validation.Query.UnionSelection- ( validateUnionSelection- )-where---import Control.Monad ((>=>))---- MORPHEUS-import Data.Morpheus.Error.Selection ( unknownSelectionField )-import Data.Morpheus.Types.Internal.AST- ( Selection(..)- , SelectionContent(..)- , Fragment(..)- , SelectionSet- , FieldsDefinition(..)- , Name- , RAW- , VALID- , SelectionSet- , UnionTag(..)- , Ref(..)- , DataUnion- )-import qualified Data.Morpheus.Types.Internal.AST.MergeSet as MS- ( join )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..) - , selectOr- , empty- , singleton- , Failure(..)- )-import Data.Morpheus.Types.Internal.Validation- ( SelectionValidator- , askTypeMember- , askScopeTypeName- )-import Data.Morpheus.Validation.Query.Fragment- ( castFragmentType- , resolveSpread- )---type TypeDef = (Name, FieldsDefinition)---- returns all Fragments used in Union-exploreUnionFragments- :: [Name]- -> Selection RAW- -> SelectionValidator [Fragment]-exploreUnionFragments unionTags = splitFrag- where- packFragment fragment = [fragment]- splitFrag- :: Selection RAW -> SelectionValidator [Fragment]- splitFrag (Spread ref) = packFragment <$> resolveSpread unionTags ref - splitFrag Selection { selectionName = "__typename",selectionContent = SelectionField } = pure []- splitFrag Selection { selectionName, selectionPosition } = do- typeName <- askScopeTypeName- failure $ unknownSelectionField typeName (Ref selectionName selectionPosition)- splitFrag (InlineFragment fragment) = packFragment <$>- castFragmentType Nothing (fragmentPosition fragment) unionTags fragment---- sorts Fragment by contitional Types--- [--- ( Type for Tag User , [ Fragment for User] )--- ( Type for Tag Product , [ Fragment for Product] )--- ]-tagUnionFragments- :: [TypeDef] -> [Fragment] -> [(TypeDef, [Fragment])]-tagUnionFragments types fragments - = filter notEmpty - $ map categorizeType types- where- notEmpty = not . null . snd- categorizeType :: (Name, FieldsDefinition) -> (TypeDef, [Fragment])- categorizeType datatype = (datatype, filter matches fragments)- where matches fragment = fragmentType fragment == fst datatype---{-- - all Variable and Fragment references will be: resolved and validated- - unionTypes: will be clustered under type names- ...A on T1 {<SelectionA>}- ...B on T2 {<SelectionB>}- ...C on T2 {<SelectionC>}- will be become : [- UnionTag "T1" {<SelectionA>},- UnionTag "T2" {<SelectionB>,<SelectionC>}- ]- -}-validateCluster- :: (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID))- -> SelectionSet RAW- -> [(TypeDef, [Fragment])]- -> SelectionValidator (SelectionContent VALID)-validateCluster validator __typename = traverse _validateCluster >=> fmap UnionSelection . fromList- where- _validateCluster :: (TypeDef, [Fragment]) -> SelectionValidator UnionTag- _validateCluster (unionType, fragmets) = do- fragmentSelections <- MS.join (__typename:map fragmentSelection fragmets)- UnionTag (fst unionType) <$> validator unionType fragmentSelections--validateUnionSelection - :: (TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)) - -> SelectionSet RAW - -> DataUnion- -> SelectionValidator (SelectionContent VALID)-validateUnionSelection validate selectionSet members = do- let (__typename :: SelectionSet RAW) = selectOr empty singleton "__typename" selectionSet- -- get union Types defined in GraphQL schema -> (union Tag, union Selection set)- -- [("User", FieldsDefinition { ... }), ("Product", FieldsDefinition { ...- unionTypes <- traverse askTypeMember members- -- find all Fragments used in Selection- spreads <- concat <$> traverse (exploreUnionFragments members) (toList selectionSet)- let categories = tagUnionFragments unionTypes spreads- validateCluster validate __typename categories
− src/Data/Morpheus/Validation/Query/Validation.hs
@@ -1,74 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Validation.Query.Validation- ( validateRequest- )-where--import Data.Map ( fromList )-import Data.Morpheus.Types.Internal.AST- ( Operation(..)- , VALID- , Schema(..)- , GQLQuery(..)- , VALIDATION_MODE- )-import Data.Morpheus.Types.Internal.Validation- ( Context(..)- , runValidator- , SelectionContext(..)- )-import Data.Morpheus.Types.Internal.Resolving- ( Eventless )-import Data.Morpheus.Validation.Query.Fragment- ( validateFragments )-import Data.Morpheus.Validation.Query.Selection- ( validateOperation )-import Data.Morpheus.Validation.Query.Variable- ( resolveOperationVariables )---validateRequest- :: Schema - -> VALIDATION_MODE - -> GQLQuery - -> Eventless (Operation VALID)-validateRequest - schema - validationMode - GQLQuery - { fragments- , inputVariables, - operation = operation@Operation - { operationName- , operationSelection- , operationPosition - } - }- = do- variables <- runValidator validateHelpers ctx ()- runValidator - (validateOperation operation) - ctx - SelectionContext - { variables }- where - ctx = Context - { schema - , fragments- , scopeTypeName = "Root"- , scopeSelectionName = "Root"- , scopePosition = operationPosition- , operationName- }- validateHelpers = - validateFragments operationSelection *>- resolveOperationVariables- (fromList inputVariables)- validationMode- operation
− src/Data/Morpheus/Validation/Query/Variable.hs
@@ -1,169 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Validation.Query.Variable- ( resolveOperationVariables- )-where---import qualified Data.Map as M- ( lookup )-import Data.Maybe ( maybe )-import Data.Semigroup ( (<>) )----- MORPHEUS-import Data.Morpheus.Error.Variable ( uninitializedVariable)-import Data.Morpheus.Types.Internal.AST- ( DefaultValue- , Operation(..)- , Variable(..)- , VariableDefinitions- , Fragment(..)- , Argument(..)- , Selection(..)- , SelectionContent(..)- , SelectionSet- , Ref(..)- , TypeDefinition- , Variables- , Value(..)- , ValidValue- , RawValue- , ResolvedValue- , VALID- , RAW- , VariableContent(..)- , isNullable- , TypeRef(..)- , VALIDATION_MODE(..)- , ObjectEntry(..)- )-import Data.Morpheus.Types.Internal.Operation- ( Listable(..)- , Failure(..)- )-import Data.Morpheus.Types.Internal.Validation- ( BaseValidator- , askSchema- , askFragments- , selectKnown- , constraint- , Constraint(..)- , withScopePosition- , startInput- , InputSource(..)- , checkUnused- )-import Data.Morpheus.Validation.Internal.Value- ( validateInput )--class ExploreRefs a where- exploreRefs :: a -> [Ref]--instance ExploreRefs RawValue where- exploreRefs (VariableValue ref ) = [ref]- exploreRefs (Object fields) = concatMap (exploreRefs . entryValue) fields- exploreRefs (List ls ) = concatMap exploreRefs ls- exploreRefs _ = []--instance ExploreRefs (Argument RAW) where- exploreRefs = exploreRefs . argumentValue--mapSelection :: (Selection RAW -> BaseValidator [b]) -> SelectionSet RAW -> BaseValidator [b]-mapSelection f = fmap concat . traverse f--allVariableRefs :: [SelectionSet RAW] -> BaseValidator [Ref]-allVariableRefs = fmap concat . traverse (mapSelection searchRefs) - where- -- | search used variables in every arguments- searchRefs :: Selection RAW -> BaseValidator [Ref]- searchRefs Selection { selectionArguments, selectionContent = SelectionField }- = return $ concatMap exploreRefs selectionArguments- searchRefs Selection { selectionArguments, selectionContent = SelectionSet selSet }- = getArgs <$> mapSelection searchRefs selSet- where- getArgs :: [Ref] -> [Ref]- getArgs x = concatMap exploreRefs selectionArguments <> x- searchRefs (InlineFragment Fragment { fragmentSelection })- = mapSelection searchRefs fragmentSelection- searchRefs (Spread reference)- = askFragments- >>= selectKnown reference- >>= mapSelection searchRefs- . fragmentSelection--resolveOperationVariables- :: Variables- -> VALIDATION_MODE- -> Operation RAW- -> BaseValidator (VariableDefinitions VALID)-resolveOperationVariables - root - validationMode - Operation - { operationSelection- , operationArguments - }- = checkUnusedVariables *>- traverse (lookupAndValidateValueOnBody root validationMode) operationArguments- where- checkUnusedVariables :: BaseValidator ()- checkUnusedVariables = do- uses <- allVariableRefs [operationSelection]- checkUnused uses (toList operationArguments)--lookupAndValidateValueOnBody- :: Variables- -> VALIDATION_MODE- -> Variable RAW- -> BaseValidator (Variable VALID)-lookupAndValidateValueOnBody - bodyVariables - validationMode - var@Variable { - variableName,- variableType, - variablePosition, - variableValue = DefaultValue defaultValue - }- = withScopePosition variablePosition - $ toVariable- <$> ( askSchema- >>= selectKnown (Ref (typeConName variableType) variablePosition) - >>= constraint INPUT var - >>= checkType getVariable defaultValue- )- where- toVariable x = var { variableValue = ValidVariableValue x }- getVariable :: Maybe ResolvedValue- getVariable = M.lookup variableName bodyVariables- ------------------------------------------------------------------- -- checkType :: - checkType- :: Maybe ResolvedValue- -> DefaultValue- -> TypeDefinition- -> BaseValidator ValidValue- checkType (Just variable) Nothing varType = validator varType variable- checkType (Just variable) (Just defValue) varType =- validator varType defValue >> validator varType variable- checkType Nothing (Just defValue) varType = validator varType defValue- checkType Nothing Nothing varType- | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType)- = failure $ uninitializedVariable var- | otherwise- = returnNull- where- returnNull =- maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables)- ------------------------------------------------------------------------------------------------ validator :: TypeDefinition -> ResolvedValue -> BaseValidator ValidValue- validator varType varValue - = startInput (SourceVariable var) - $ validateInput- (typeWrappers variableType)- varType- (ObjectEntry variableName varValue)
test/Feature/Holistic/API.hs view
@@ -1,42 +1,43 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-} module Feature.Holistic.API- ( api- , rootResolver+ ( api,+ rootResolver, ) where -import Data.Morpheus ( interpreter )-import Data.Morpheus.Document ( importGQLDocument )-import Data.Morpheus.Kind ( SCALAR )-import Data.Morpheus.Types ( Event- , GQLRequest- , GQLResponse- , GQLRootResolver(..)- , GQLScalar(..)- , GQLType(..)- , ID(..)- , ScalarValue(..)- , failRes- , liftEither- , subscribe- )-import Data.Text ( Text )-import GHC.Generics ( Generic )-+import Data.Morpheus (interpreter)+import Data.Morpheus.Document (importGQLDocument)+import Data.Morpheus.Kind (SCALAR)+import Data.Morpheus.Types+ ( Event,+ GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLScalar (..),+ GQLType (..),+ ID (..),+ ScalarValue (..),+ liftEither,+ subscribe,+ )+import Data.Text (Text)+import GHC.Generics (Generic) -data TestScalar =- TestScalar Int- Int+data TestScalar+ = TestScalar+ Int+ Int deriving (Show, Generic) instance GQLType TestScalar where@@ -46,8 +47,8 @@ parseValue _ = pure (TestScalar 1 0) serialize (TestScalar x y) = Int (x * 100 + y) -data Channel =- Channel+data Channel+ = Channel deriving (Show, Eq) type EVENT = Event Channel ()@@ -57,34 +58,45 @@ alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either" - rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription-rootResolver = GQLRootResolver- { queryResolver = Query { user- , testUnion = Just . TestUnionUser <$> user- , fail1 = liftEither alwaysFail- , fail2 = failRes "fail with failRes"- }- , mutationResolver = Mutation { createUser = const user }- , subscriptionResolver = Subscription - { newUser = subscribe [Channel] (pure $ const user)- , newAddress = subscribe [Channel] (pure resolveAddress)+rootResolver =+ GQLRootResolver+ { queryResolver =+ Query+ { user,+ testUnion = Just . TestUnionUser <$> user,+ fail1 = liftEither alwaysFail,+ fail2 = fail "fail with MonadFail",+ person = pure Person {name = pure (Just "test Person Name")},+ type' = \TypeArgs {in' = TypeInput {data'}} -> pure data'+ },+ mutationResolver = Mutation {createUser = const user},+ subscriptionResolver =+ Subscription+ { newUser = subscribe [Channel] (pure $ const user),+ newAddress = subscribe [Channel] (pure resolveAddress)+ } }- }- where- user :: Applicative m => m (User m)- user = pure User { name = pure "testName"- , email = pure ""- , address = resolveAddress- , office = resolveAddress- , friend = pure Nothing- }- ----------------------------------------------------- - resolveAddress :: Applicative m => a -> m (Address m)- resolveAddress _ = pure Address { city = pure ""- , houseNumber = pure 0- , street = const $ pure Nothing- }+ where+ user :: Applicative m => m (User m)+ user =+ pure+ User+ { name = pure "testName",+ email = pure "",+ address = resolveAddress,+ office = resolveAddress,+ friend = pure Nothing+ }+ -----------------------------------------------------+ resolveAddress :: Applicative m => a -> m (Address m)+ resolveAddress _ =+ pure+ Address+ { city = pure "",+ houseNumber = pure 0,+ street = const $ pure Nothing+ } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/Holistic/arguments/undefinedArgument/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 3,- "column": 13+ "column": 5 } ] }
test/Feature/Holistic/cases.json view
@@ -116,6 +116,10 @@ "description": "returns on a query that pads all '!' chars with whitespace" }, {+ "path": "introspection/interface",+ "description": "interface must be visible in introspection"+ },+ { "path": "introspection/schemaTypes/__Type", "description": "benchmark __Type" },@@ -244,6 +248,10 @@ "description": "check if deprecated works with enumValue" }, {+ "path": "introspection/directives/default",+ "description": "default directives must be defined"+ },+ { "path": "introspection/deprecated/field", "description": "check if deprecated works with object fields" },@@ -266,5 +274,57 @@ { "path": "selection/subscription/singleTopLevelField/failAnonymous", "description": "fail if subscription selects more then one top level field. (for anonymous subscription)"+ },+ {+ "path": "selection/directives/default/resolve",+ "description": "test skip include resolving"+ },+ {+ "path": "selection/directives/default/requiredArgument",+ "description": "fail: if skip include does not have argument \"if\""+ },+ {+ "path": "selection/directives/default/wrongArgumentType",+ "description": "fail: if skip include has argument \"if\", but with wrong value"+ },+ {+ "path": "selection/directives/default/withVariable",+ "description": "api allowes use of variable inside directives"+ },+ {+ "path": "selection/directives/default/withMerge",+ "description": "@skip and @include are evaluated before selection is merged"+ },+ {+ "path": "selection/directives/default/variablesOnFragment",+ "description": "@skip and @include are evaluated before selection is merged"+ },+ {+ "path": "selection/directives/validation/invalidPlace/query",+ "description": "directive on invalid place must be rejected"+ },+ {+ "path": "selection/directives/validation/invalidPlace/mutation",+ "description": "directive on invalid place must be rejected"+ },+ {+ "path": "selection/directives/validation/invalidPlace/subscription",+ "description": "directive on invalid place must be rejected"+ },+ {+ "path": "selection/directives/validation/invalidPlace/field",+ "description": "directive on invalid place must be rejected"+ },+ {+ "path": "selection/directives/validation/invalidPlace/fragmentSpread",+ "description": "directive on invalid place must be rejected"+ },+ {+ "path": "selection/directives/validation/invalidPlace/inlineFragment",+ "description": "directive on invalid place must be rejected"+ },+ {+ "path": "reservedNames",+ "description": "morpheus should handle reserved names" } ]
test/Feature/Holistic/failure/resolveFailure/response.json view
@@ -5,7 +5,7 @@ "locations": [{ "line": 2, "column": 3 }] }, {- "message": "Failure on Resolving Field \"fail2\": fail with failRes",+ "message": "Failure on Resolving Field \"fail2\": fail with MonadFail", "locations": [{ "line": 3, "column": 3 }] } ]
test/Feature/Holistic/fragment/loopingFragment/response.json view
@@ -1,95 +1,45 @@ { "errors": [ {- "message": "Cannot spread fragment \"A\" within itself via A, A, C.",+ "message": "Cannot spread fragment \"A\" within itself via \"A\", \"A\", \"C\".", "locations": [- {- "line": 17,- "column": 3- },- {- "line": 7,- "column": 10- },- {- "line": 9,- "column": 3- }+ { "line": 17, "column": 3 },+ { "line": 7, "column": 10 },+ { "line": 9, "column": 3 } ] }, {- "message": "Cannot spread fragment \"C\" within itself via C, B, C, A.",+ "message": "Cannot spread fragment \"C\" within itself via \"C\", \"B\", \"C\", \"A\".", "locations": [- {- "line": 9,- "column": 3- },- {- "line": 12,- "column": 10- },- {- "line": 13,- "column": 3- },- {- "line": 17,- "column": 3- }+ { "line": 9, "column": 3 },+ { "line": 12, "column": 10 },+ { "line": 13, "column": 3 },+ { "line": 17, "column": 3 } ] }, {- "message": "Cannot spread fragment \"C\" within itself via C, C, A.",+ "message": "Cannot spread fragment \"C\" within itself via \"C\", \"C\", \"A\".", "locations": [- {- "line": 9,- "column": 3- },- {- "line": 16,- "column": 10- },- {- "line": 17,- "column": 3- }+ { "line": 9, "column": 3 },+ { "line": 16, "column": 10 },+ { "line": 17, "column": 3 } ] }, { "message": "Fragment \"A\" is never used.",- "locations": [- {- "line": 7,- "column": 10- }- ]+ "locations": [{ "line": 7, "column": 10 }] }, { "message": "Fragment \"B\" is never used.",- "locations": [- {- "line": 12,- "column": 10- }- ]+ "locations": [{ "line": 12, "column": 10 }] }, { "message": "Fragment \"C\" is never used.",- "locations": [- {- "line": 16,- "column": 10- }- ]+ "locations": [{ "line": 16, "column": 10 }] }, { "message": "Fragment \"D\" is never used.",- "locations": [- {- "line": 20,- "column": 10- }- ]+ "locations": [{ "line": 20, "column": 10 }] } ] }
+ test/Feature/Holistic/introspection/directives/default/query.gql view
@@ -0,0 +1,54 @@+# introspect directives+query Get__Type {+ __schema {+ directives {+ name+ description+ locations+ args {+ ...InputValue+ }+ }+ }+}++fragment InputValue on __InputValue {+ name+ type {+ ...TypeRef+ }+ defaultValue+}++fragment TypeRef on __Type {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ }+ }+ }+ }+ }+ }+ }+}
+ test/Feature/Holistic/introspection/directives/default/response.json view
@@ -0,0 +1,60 @@+{+ "data": {+ "__schema": {+ "directives": [+ {+ "name": "skip",+ "description": "Directs the executor to skip this field or fragment when the `if` argument is true.",+ "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],+ "args": [+ {+ "name": "if",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "SCALAR",+ "name": "Boolean",+ "ofType": null+ }+ },+ "defaultValue": null+ }+ ]+ },+ {+ "name": "include",+ "description": "Directs the executor to include this field or fragment only when the `if` argument is true.",+ "locations": ["FIELD", "FRAGMENT_SPREAD", "INLINE_FRAGMENT"],+ "args": [+ {+ "name": "if",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "SCALAR",+ "name": "Boolean",+ "ofType": null+ }+ },+ "defaultValue": null+ }+ ]+ },+ {+ "name": "deprecated",+ "description": "Marks an element of a GraphQL schema as no longer supported.",+ "locations": ["FIELD_DEFINITION", "ENUM_VALUE"],+ "args": [+ {+ "name": "reason",+ "type": { "kind": "SCALAR", "name": "String", "ofType": null },+ "defaultValue": null+ }+ ]+ }+ ]+ }+ }+}
+ test/Feature/Holistic/introspection/interface/query.gql view
@@ -0,0 +1,82 @@+query Get__Type {+ person {+ name+ }+ interface: __type(name: "Person") {+ ...FullType+ }+ user: __type(name: "User") {+ ...FullType+ }+}++fragment FullType on __Type {+ kind+ name+ fields(includeDeprecated: true) {+ name+ args {+ ...InputValue+ }+ type {+ ...TypeRef+ }+ isDeprecated+ deprecationReason+ }+ inputFields {+ ...InputValue+ }+ interfaces {+ ...TypeRef+ }+ enumValues(includeDeprecated: true) {+ name+ isDeprecated+ deprecationReason+ }+ possibleTypes {+ ...TypeRef+ }+}++fragment InputValue on __InputValue {+ name+ type {+ ...TypeRef+ }+ defaultValue+}++fragment TypeRef on __Type {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ ofType {+ kind+ name+ }+ }+ }+ }+ }+ }+ }+}
+ test/Feature/Holistic/introspection/interface/response.json view
@@ -0,0 +1,125 @@+{+ "data": {+ "person": { "name": "test Person Name" },+ "interface": {+ "kind": "INTERFACE",+ "name": "Person",+ "fields": [+ {+ "name": "name",+ "args": [],+ "type": { "kind": "SCALAR", "name": "String", "ofType": null },+ "isDeprecated": false,+ "deprecationReason": null+ }+ ],+ "inputFields": null,+ "interfaces": null,+ "enumValues": null,+ "possibleTypes": [{ "kind": "OBJECT", "name": "User", "ofType": null }]+ },+ "user": {+ "kind": "OBJECT",+ "name": "User",+ "fields": [+ {+ "name": "name",+ "args": [],+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+ },+ "isDeprecated": false,+ "deprecationReason": null+ },+ {+ "name": "email",+ "args": [],+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+ },+ "isDeprecated": false,+ "deprecationReason": null+ },+ {+ "name": "address",+ "args": [+ {+ "name": "coordinates",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": {+ "kind": "INPUT_OBJECT",+ "name": "Coordinates",+ "ofType": null+ }+ },+ "defaultValue": null+ },+ {+ "name": "comment",+ "type": { "kind": "SCALAR", "name": "String", "ofType": null },+ "defaultValue": null+ }+ ],+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": { "kind": "OBJECT", "name": "Address", "ofType": null }+ },+ "isDeprecated": false,+ "deprecationReason": null+ },+ {+ "name": "office",+ "args": [+ {+ "name": "zipCode",+ "type": {+ "kind": "LIST",+ "name": null,+ "ofType": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": { "kind": "SCALAR", "name": "Int", "ofType": null }+ }+ },+ "defaultValue": null+ },+ {+ "name": "cityID",+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": { "kind": "ENUM", "name": "TestEnum", "ofType": null }+ },+ "defaultValue": null+ }+ ],+ "type": {+ "kind": "NON_NULL",+ "name": null,+ "ofType": { "kind": "OBJECT", "name": "Address", "ofType": null }+ },+ "isDeprecated": false,+ "deprecationReason": null+ },+ {+ "name": "friend",+ "args": [],+ "type": { "kind": "OBJECT", "name": "User", "ofType": null },+ "isDeprecated": false,+ "deprecationReason": null+ }+ ],+ "inputFields": null,+ "interfaces": [{ "kind": "INTERFACE", "name": "Person", "ofType": null }],+ "enumValues": null,+ "possibleTypes": null+ }+ }+}
test/Feature/Holistic/parsing/complex/response.json view
@@ -2,66 +2,31 @@ "errors": [ { "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null,[[],[{\"uid\":\"1\"}]]].",- "locations": [- {- "line": 8,- "column": 23- }- ]+ "locations": [{ "line": 8, "column": 23 }] }, { "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [].",- "locations": [- {- "line": 11,- "column": 23- }- ]+ "locations": [{ "line": 11, "column": 23 }] }, { "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found \"HH\".",- "locations": [- {- "line": 15,- "column": 25- }- ]+ "locations": [{ "line": 15, "column": 25 }] }, { "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".",- "locations": [- {- "line": 15,- "column": 21- }- ]+ "locations": [{ "line": 15, "column": 21 }] }, { "message": "Cannot query field \"home\" on type \"User\".",- "locations": [- {- "line": 25,- "column": 5- }- ]+ "locations": [{ "line": 25, "column": 5 }] }, { "message": "Cannot query field \"myUnion\" on type \"User\".",- "locations": [- {- "line": 26,- "column": 18- }- ]+ "locations": [{ "line": 26, "column": 5 }] }, { "message": "Cannot query field \"myUnion\" on type \"User\".",- "locations": [- {- "line": 32,- "column": 18- }- ]+ "locations": [{ "line": 32, "column": 5 }] } ] }
test/Feature/Holistic/parsing/directive/operation/query.gql view
@@ -1,5 +1,5 @@-query Foo @someDirective (name: "testName" ) {- user {- name- }+query Foo @someDirective(name: "testName") @test2 {+ user {+ name+ } }
test/Feature/Holistic/parsing/directive/operation/response.json view
@@ -1,7 +1,12 @@ {- "data": {- "user": {- "name": "testName"+ "errors": [+ {+ "message": "Unknown Directive \"someDirective\".",+ "locations": [{ "line": 1, "column": 11 }]+ },+ {+ "message": "Unknown Directive \"test2\".",+ "locations": [{ "line": 1, "column": 44 }] }- }+ ] }
test/Feature/Holistic/parsing/directive/selection/query.gql view
@@ -1,6 +1,6 @@ query Foo {- user {- name @skip(name:"") @deprecated- email @someDir- }+ user {+ name @skip(if: false) @deprecated @do(id: 1)+ email @someDir+ } }
test/Feature/Holistic/parsing/directive/selection/response.json view
@@ -1,8 +1,16 @@ {- "data": {- "user": {- "name": "testName",- "email": ""+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on FIELD",+ "locations": [{ "line": 3, "column": 27 }]+ },+ {+ "message": "Unknown Directive \"do\".",+ "locations": [{ "line": 3, "column": 39 }]+ },+ {+ "message": "Unknown Directive \"someDir\".",+ "locations": [{ "line": 4, "column": 11 }] }- }+ ] }
test/Feature/Holistic/parsing/generousSpaces/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 4,- "column": 5+ "column": 2 } ] }
test/Feature/Holistic/parsing/invalidFields/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, body, digit, letter, or white space\n",+ "message": "offset=26:\nunexpected '<'\nexpecting '#', ',', '_', '}', Arguments, Directives, IgnoredTokens, Selection, SelectionContent, digit, letter, or white space\n", "locations": [{ "line": 1, "column": 27 }] } ]
test/Feature/Holistic/parsing/notNullSpacing/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 2,- "column": 6+ "column": 3 } ] }
+ test/Feature/Holistic/reservedNames/query.gql view
@@ -0,0 +1,18 @@+{+ type(in: { data: "some data" })++ query: __type(name: "Query") {+ fields {+ name+ args {+ name+ }+ }+ }++ input: __type(name: "TypeInput") {+ inputFields {+ name+ }+ }+}
+ test/Feature/Holistic/reservedNames/response.json view
@@ -0,0 +1,16 @@+{+ "data": {+ "type": "some data",+ "query": {+ "fields": [+ { "name": "user", "args": [] },+ { "name": "testUnion", "args": [] },+ { "name": "fail1", "args": [] },+ { "name": "fail2", "args": [] },+ { "name": "person", "args": [] },+ { "name": "type", "args": [{ "name": "in" }] }+ ]+ },+ "input": { "inputFields": [{ "name": "data" }] }+ }+}
test/Feature/Holistic/schema.gql view
@@ -68,6 +68,10 @@ """ union TestUnion = User | Address +interface Person {+ name: String+}+ """ User @@ -75,7 +79,7 @@ Test """-type User {+type User implements Person { """ field description: name """@@ -89,11 +93,17 @@ friend: User } +input TypeInput {+ data: String!+}+ type Query { user: User! testUnion: TestUnion fail1: String! fail2: Int!+ person: Person!+ type(in: TypeInput!): String! } type Mutation {
+ test/Feature/Holistic/selection/directives/default/requiredArgument/query.gql view
@@ -0,0 +1,6 @@+{+ user {+ name @include+ name2: name @skip+ }+}
+ test/Feature/Holistic/selection/directives/default/requiredArgument/response.json view
@@ -0,0 +1,12 @@+{+ "errors": [+ {+ "message": "Directive \"@include\" argument \"if\" is required but not provided.",+ "locations": [{ "line": 3, "column": 10 }]+ },+ {+ "message": "Directive \"@skip\" argument \"if\" is required but not provided.",+ "locations": [{ "line": 4, "column": 17 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/default/resolve/query.gql view
@@ -0,0 +1,17 @@+{+ user {+ no_directives: name++ include_false: name @include(if: false)+ include_true: name @include(if: true)++ skip_false: name @skip(if: false)+ skip_true: name @skip(if: true)++ skip_true_include_true: name @skip(if: true) @include(if: true)+ skip_true_include_false: name @skip(if: true) @include(if: false)++ skip_false_include_true: name @skip(if: false) @include(if: true)+ skip_false_include_false: name @skip(if: false) @include(if: false)+ }+}
+ test/Feature/Holistic/selection/directives/default/resolve/response.json view
@@ -0,0 +1,10 @@+{+ "data": {+ "user": {+ "no_directives": "testName",+ "include_true": "testName",+ "skip_false": "testName",+ "skip_false_include_true": "testName"+ }+ }+}
+ test/Feature/Holistic/selection/directives/default/resolve_and_merge/query.gql view
@@ -0,0 +1,17 @@+{+ user {+ no_directives: name++ include_false: name @include(if: false)+ include_true: name @include(if: true)++ skip_false: name @skip(if: false)+ skip_true: name @skip(if: true)++ skip_true_include_true: name @skip(if: true) @include(if: true)+ skip_true_include_false: name @skip(if: true) @include(if: false)++ skip_false_include_true: name @skip(if: false) @include(if: true)+ skip_false_include_false: name @skip(if: false) @include(if: false)+ }+}
+ test/Feature/Holistic/selection/directives/default/resolve_and_merge/response.json view
@@ -0,0 +1,10 @@+{+ "data": {+ "user": {+ "no_directives": "testName",+ "include_true": "testName",+ "skip_false": "testName",+ "skip_false_include_true": "testName"+ }+ }+}
+ test/Feature/Holistic/selection/directives/default/variablesOnFragment/query.gql view
@@ -0,0 +1,13 @@+query TestFragments($x: Boolean! = false, $y: Boolean! = false) {+ user {+ name+ ...UserName @skip(if: $x)+ ... on User @include(if: $y) {+ name2: name+ }+ }+}++fragment UserName on User {+ name1: name+}
+ test/Feature/Holistic/selection/directives/default/variablesOnFragment/response.json view
@@ -0,0 +1,1 @@+{ "data": { "user": { "name": "testName", "name1": "testName" } } }
+ test/Feature/Holistic/selection/directives/default/withMerge/query.gql view
@@ -0,0 +1,15 @@+query bla($x: Boolean! = false, $y: Boolean! = true) {+ user @skip(if: $x) {+ case1: name+ }+ user @include(if: $x) {+ case2: name+ }++ user2: user @skip(if: $y) {+ case1: name+ }+ user2: user @include(if: $y) {+ case2: name+ }+}
+ test/Feature/Holistic/selection/directives/default/withMerge/response.json view
@@ -0,0 +1,3 @@+{+ "data": { "user": { "case1": "testName" }, "user2": { "case2": "testName" } }+}
+ test/Feature/Holistic/selection/directives/default/withVariable/query.gql view
@@ -0,0 +1,15 @@+query bla($x: Boolean! = true, $y: Boolean! = false, $z: Boolean! = true) {+ user1: user {+ case1: name @skip(if: $x)+ case2: name @include(if: $x)+ }++ user2: user {+ case1: name @skip(if: $y)+ case2: name @include(if: $y)+ }++ user3: user @skip(if: $z) {+ case1: name+ }+}
+ test/Feature/Holistic/selection/directives/default/withVariable/response.json view
@@ -0,0 +1,3 @@+{+ "data": { "user1": { "case2": "testName" }, "user2": { "case1": "testName" } }+}
+ test/Feature/Holistic/selection/directives/default/wrongArgumentType/query.gql view
@@ -0,0 +1,12 @@+{+ user {+ testNull: name @include(if: null)+ testNoolean: name @include(if: true)+ testInt: name @include(if: 232)+ tetsFloat: name @include(if: 232.1324)+ testString: name @include(if: "some string")+ testEnum: name @include(if: SomeEnum)+ testObject: name @include(if: {})+ testList: name @include(if: [])+ }+}
+ test/Feature/Holistic/selection/directives/default/wrongArgumentType/response.json view
@@ -0,0 +1,32 @@+{+ "errors": [+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found null.",+ "locations": [{ "line": 3, "column": 29 }]+ },+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found 232.",+ "locations": [{ "line": 5, "column": 28 }]+ },+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found 232.1324.",+ "locations": [{ "line": 6, "column": 30 }]+ },+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found \"some string\".",+ "locations": [{ "line": 7, "column": 31 }]+ },+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found \"SomeEnum\".",+ "locations": [{ "line": 8, "column": 29 }]+ },+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found {}.",+ "locations": [{ "line": 9, "column": 31 }]+ },+ {+ "message": "Argument \"if\" got invalid value. Expected type \"Boolean!\" found [].",+ "locations": [{ "line": 10, "column": 29 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/field/query.gql view
@@ -0,0 +1,15 @@+query bla($x: Boolean! = false, $y: Boolean! = true) {+ user @skip(if: $x) @deprecated {+ case1: name+ }+ user @include(if: $x) @deprecated {+ case2: name+ }++ user2: user @skip(if: $y) @deprecated {+ case1: name+ }+ user2: user @include(if: $y) @deprecated {+ case2: name+ }+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/field/response.json view
@@ -0,0 +1,20 @@+{+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on FIELD",+ "locations": [{ "line": 2, "column": 22 }]+ },+ {+ "message": "Directive \"deprecated\" may not to be used on FIELD",+ "locations": [{ "line": 5, "column": 25 }]+ },+ {+ "message": "Directive \"deprecated\" may not to be used on FIELD",+ "locations": [{ "line": 9, "column": 29 }]+ },+ {+ "message": "Directive \"deprecated\" may not to be used on FIELD",+ "locations": [{ "line": 12, "column": 32 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/query.gql view
@@ -0,0 +1,9 @@+query {+ user {+ ...UserName @deprecated @include(if: false) @skip(if: true)+ }+}++fragment UserName on User {+ name+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/fragmentSpread/response.json view
@@ -0,0 +1,8 @@+{+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on FRAGMENT_SPREAD",+ "locations": [{ "line": 3, "column": 17 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/query.gql view
@@ -0,0 +1,7 @@+query {+ user {+ ... on User @deprecated @include(if: false) @skip(if: true) {+ name+ }+ }+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/inlineFragment/response.json view
@@ -0,0 +1,8 @@+{+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on INLINE_FRAGMENT",+ "locations": [{ "line": 3, "column": 17 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/query.gql view
@@ -0,0 +1,5 @@+mutation SomeMutation @deprecated @skip(if: true) @include(if: true) {+ createUser(userID: "test_id") {+ name+ }+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/mutation/response.json view
@@ -0,0 +1,16 @@+{+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on MUTATION",+ "locations": [{ "line": 1, "column": 23 }]+ },+ {+ "message": "Directive \"skip\" may not to be used on MUTATION",+ "locations": [{ "line": 1, "column": 35 }]+ },+ {+ "message": "Directive \"include\" may not to be used on MUTATION",+ "locations": [{ "line": 1, "column": 51 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/query/query.gql view
@@ -0,0 +1,5 @@+query SomeQUery @deprecated @skip(if: true) @include(if: true) {+ user {+ name+ }+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/query/response.json view
@@ -0,0 +1,16 @@+{+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on QUERY",+ "locations": [{ "line": 1, "column": 17 }]+ },+ {+ "message": "Directive \"skip\" may not to be used on QUERY",+ "locations": [{ "line": 1, "column": 29 }]+ },+ {+ "message": "Directive \"include\" may not to be used on QUERY",+ "locations": [{ "line": 1, "column": 45 }]+ }+ ]+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/query.gql view
@@ -0,0 +1,5 @@+subscription SomeSubscription @deprecated @skip(if: true) @include(if: true) {+ newUser {+ name+ }+}
+ test/Feature/Holistic/selection/directives/validation/invalidPlace/subscription/response.json view
@@ -0,0 +1,16 @@+{+ "errors": [+ {+ "message": "Directive \"deprecated\" may not to be used on SUBSCRIPTION",+ "locations": [{ "line": 1, "column": 31 }]+ },+ {+ "message": "Directive \"skip\" may not to be used on SUBSCRIPTION",+ "locations": [{ "line": 1, "column": 43 }]+ },+ {+ "message": "Directive \"include\" may not to be used on SUBSCRIPTION",+ "locations": [{ "line": 1, "column": 59 }]+ }+ ]+}
test/Feature/Holistic/selection/hasNoSubFields/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 3,- "column": 10+ "column": 5 } ] }
test/Feature/Holistic/selection/mergeConflict/alias/query.gql view
@@ -3,17 +3,15 @@ bla: email email bla: email- address(coordinates: {latitude:"", longitude: []}) {+ address(coordinates: { latitude: "", longitude: 1 }) { city- bla : city+ bla: city } } user {- address(coordinates: {latitude:"", longitude: []}) {- street+ address(coordinates: { latitude: "", longitude: 1 }) { bla: houseNumber }- city bla: email } }
test/Feature/Holistic/selection/mergeConflict/alias/response.json view
@@ -5,18 +5,18 @@ "locations": [ { "line": 2,- "column": 8+ "column": 3 }, { "line": 6,- "column": 56+ "column": 5 }, { "line": 8,- "column": 25+ "column": 7 }, {- "line": 14,+ "line": 13, "column": 7 } ]
test/Feature/Holistic/selection/mergeConflict/arguments/response.json view
@@ -5,19 +5,19 @@ "locations": [ { "line": 2,- "column": 8+ "column": 3 }, { "line": 6,- "column": 55+ "column": 5 }, { "line": 6,- "column": 55+ "column": 5 }, { "line": 12,- "column": 55+ "column": 5 } ] }
test/Feature/Holistic/selection/mergeConflict/union/response.json view
@@ -1,16 +1,11 @@ { "errors": [ {- "message": "\"name\" and \"email\" are different fields. Use different aliases on the fields to fetch both if this was intentional.",+ "message": "Fields \"testUnion\" conflict because \"name\" and \"email\" are different fields. Use different aliases on the fields to fetch both if this was intentional.", "locations": [- {- "line": 4,- "column": 7- },- {- "line": 14,- "column": 7- }+ { "line": 2, "column": 3 },+ { "line": 4, "column": 7 },+ { "line": 14, "column": 7 } ] } ]
test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 5,- "column": 14+ "column": 3 } ] }
test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json view
@@ -5,7 +5,7 @@ "locations": [ { "line": 5,- "column": 14+ "column": 3 } ] },@@ -14,7 +14,7 @@ "locations": [ { "line": 8,- "column": 24+ "column": 3 } ] }
test/Feature/Input/Enum/API.hs view
@@ -1,17 +1,18 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.Input.Enum.API- ( api- ) where+ ( api,+ )+where -import Data.Morpheus (interpreter)-import Data.Morpheus.Kind (ENUM)-import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..))-import GHC.Generics (Generic)+import Data.Morpheus (interpreter)+import Data.Morpheus.Kind (ENUM)+import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..))+import GHC.Generics (Generic) data TwoCon = LA@@ -37,7 +38,8 @@ -- types & args newtype TestArgs a = TestArgs { level :: a- } deriving (Generic, Show)+ }+ deriving (Generic, Show) instance GQLType Level where type KIND Level = ENUM@@ -54,17 +56,18 @@ -- resolver data Query m = Query- { test :: TestArgs Level -> m Level- , test2 :: TestArgs TwoCon -> m TwoCon- , test3 :: TestArgs ThreeCon -> m ThreeCon- } deriving (Generic, GQLType)+ { test :: TestArgs Level -> m Level,+ test2 :: TestArgs TwoCon -> m TwoCon,+ test3 :: TestArgs ThreeCon -> m ThreeCon+ }+ deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver- { queryResolver = Query {test = testRes, test2 = testRes, test3 = testRes}- , mutationResolver = Undefined- , subscriptionResolver = Undefined+ { queryResolver = Query {test = testRes, test2 = testRes, test3 = testRes},+ mutationResolver = Undefined,+ subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse
test/Feature/Input/Object/API.hs view
@@ -1,33 +1,35 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.Input.Object.API- ( api+ ( api, ) where -import Data.Morpheus ( interpreter )-import Data.Morpheus.Types ( GQLRequest- , GQLResponse- , GQLRootResolver(..)- , GQLType(..)- , Undefined(..)- )-import GHC.Generics ( Generic )-import Data.Morpheus.Kind ( INPUT )-import Data.Text ( Text- , pack- )-+import Data.Morpheus (interpreter)+import Data.Morpheus.Kind (INPUT)+import Data.Morpheus.Types+ ( GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLType (..),+ Undefined (..),+ )+import Data.Text+ ( Text,+ pack,+ )+import GHC.Generics (Generic) -data InputObject = InputObject {- field :: Text,- nullableField :: Maybe Int,- recursive :: Maybe InputObject-} deriving (Generic, Show)+data InputObject = InputObject+ { field :: Text,+ nullableField :: Maybe Int,+ recursive :: Maybe InputObject+ }+ deriving (Generic, Show) instance GQLType InputObject where type KIND InputObject = INPUT@@ -35,22 +37,26 @@ -- types & args newtype Arg a = Arg { value :: a- } deriving (Generic, Show)+ }+ deriving (Generic, Show) -- query testRes :: Show a => Applicative m => Arg a -> m Text-testRes Arg { value } = pure $ pack $ show value+testRes Arg {value} = pure $ pack $ show value -- resolver newtype Query m = Query- { input :: Arg InputObject -> m Text- } deriving (Generic, GQLType)+ { input :: Arg InputObject -> m Text+ }+ deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined-rootResolver = GQLRootResolver { queryResolver = Query { input = testRes }- , mutationResolver = Undefined- , subscriptionResolver = Undefined- }+rootResolver =+ GQLRootResolver+ { queryResolver = Query {input = testRes},+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/Input/Scalar/API.hs view
@@ -1,44 +1,48 @@ {-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.Input.Scalar.API- ( api+ ( api, ) where -import Data.Morpheus ( interpreter )-import Data.Morpheus.Types ( GQLRequest- , GQLResponse- , GQLRootResolver(..)- , GQLType(..)- , Undefined(..)- )-import GHC.Generics ( Generic )+import Data.Morpheus (interpreter)+import Data.Morpheus.Types+ ( GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLType,+ Undefined (..),+ )+import GHC.Generics (Generic) -- types & args newtype Arg a = Arg { value :: a- } deriving (Generic, Show)+ }+ deriving (Generic, Show) -- query testRes :: Applicative m => Arg a -> m a-testRes Arg { value } = pure value+testRes Arg {value} = pure value -- resolver data Query m = Query- { testFloat :: Arg Float -> m Float- , testInt :: Arg Int -> m Int- } deriving (Generic, GQLType)+ { testFloat :: Arg Float -> m Float,+ testInt :: Arg Int -> m Int+ }+ deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined-rootResolver = GQLRootResolver- { queryResolver = Query { testFloat = testRes, testInt = testRes }- , mutationResolver = Undefined- , subscriptionResolver = Undefined- }+rootResolver =+ GQLRootResolver+ { queryResolver = Query {testFloat = testRes, testInt = testRes},+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/InputType/API.hs view
@@ -1,54 +1,63 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.InputType.API- ( api+ ( api, ) where -import Data.Morpheus ( interpreter )-import Data.Morpheus.Types ( GQLRequest- , GQLResponse- , GQLRootResolver(..)- , GQLType(..)- , IORes- , Undefined(..)- )-import Data.Text ( Text )-import GHC.Generics ( Generic )+import Data.Morpheus (interpreter)+import Data.Morpheus.Types+ ( GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLType (..),+ ResolverQ,+ Undefined (..),+ )+import Data.Text (Text)+import GHC.Generics (Generic) data F1Args = F1Args- { arg1 :: Text- , arg2 :: Maybe Int- } deriving (Generic)+ { arg1 :: Text,+ arg2 :: Maybe Int+ }+ deriving (Generic, GQLType) data F2Args = F2Args- { argList :: [Text]- , argNestedList :: [Maybe [[Int]]]- } deriving (Generic)+ { argList :: [Text],+ argNestedList :: [Maybe [[Int]]]+ }+ deriving (Generic, GQLType) data A = A- { a1 :: F1Args -> IORes () Text- , a2 :: F2Args -> IORes () Int- } deriving (Generic, GQLType)+ { a1 :: F1Args -> ResolverQ () IO Text,+ a2 :: F2Args -> ResolverQ () IO Int+ }+ deriving (Generic, GQLType) newtype Query (m :: * -> *) = Query { q1 :: A- } deriving (Generic, GQLType)+ }+ deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined-rootResolver = GQLRootResolver- { queryResolver = Query- { q1 = A { a1 = const $ return "a1Test"- , a2 = const $ return 1- }- }- , mutationResolver = Undefined- , subscriptionResolver = Undefined- }+rootResolver =+ GQLRootResolver+ { queryResolver =+ Query+ { q1 =+ A+ { a1 = const $ return "a1Test",+ a2 = const $ return 1+ }+ },+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/Schema/A2.hs view
@@ -1,14 +1,16 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeFamilies #-} module Feature.Schema.A2- ( A(..)- ) where+ ( A (..),+ )+where -import Data.Morpheus.Types (GQLType)-import GHC.Generics (Generic)+import Data.Morpheus.Types (GQLType)+import GHC.Generics (Generic) newtype A = A { bla :: Int- } deriving (Generic, GQLType)+ }+ deriving (Generic, GQLType)
test/Feature/Schema/API.hs view
@@ -1,35 +1,38 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.Schema.API- ( api- ) where+ ( api,+ )+where -import Data.Morpheus (interpreter)-import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..))-import Data.Text (Text)-import qualified Feature.Schema.A2 as A2 (A (..))-import GHC.Generics (Generic)+import Data.Morpheus (interpreter)+import Data.Morpheus.Types (GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), Undefined (..))+import Data.Text (Text)+import qualified Feature.Schema.A2 as A2 (A (..))+import GHC.Generics (Generic) data A = A- { aText :: Text- , aInt :: Int- } deriving (Generic, GQLType)+ { aText :: Text,+ aInt :: Int+ }+ deriving (Generic, GQLType) -data Query (m :: * -> * ) = Query- { a1 :: A- , a2 :: A2.A- } deriving (Generic, GQLType)+data Query (m :: * -> *) = Query+ { a1 :: A,+ a2 :: A2.A+ }+ deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO () Query Undefined Undefined rootResolver = GQLRootResolver- { queryResolver = Query {a1 = A "" 0, a2 = A2.A 0}- , mutationResolver = Undefined- , subscriptionResolver = Undefined+ { queryResolver = Query {a1 = A "" 0, a2 = A2.A 0},+ mutationResolver = Undefined,+ subscriptionResolver = Undefined } api :: GQLRequest -> IO GQLResponse
test/Feature/TypeInference/API.hs view
@@ -1,105 +1,111 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.TypeInference.API- ( api+ ( api, ) where -import Data.Morpheus ( interpreter )-import Data.Morpheus.Kind ( INPUT )-import Data.Morpheus.Types ( GQLRequest- , GQLResponse- , GQLRootResolver(..)- , GQLType(..)- , Undefined(..)- )-import Data.Text ( Text- , pack- )-import GHC.Generics ( Generic )+import Data.Morpheus (interpreter)+import Data.Morpheus.Kind (INPUT)+import Data.Morpheus.Types+ ( GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLType (..),+ Undefined (..),+ )+import Data.Text+ ( Text,+ pack,+ )+import GHC.Generics (Generic) data Power = Thunderbolts | Shapeshift | Hurricanes- deriving (Generic,GQLType)+ deriving (Generic, GQLType) -data Deity (m :: * -> *) = Deity {- name :: Text ,- power :: Power-} deriving(Generic,GQLType)+data Deity (m :: * -> *) = Deity+ { name :: Text,+ power :: Power+ }+ deriving (Generic, GQLType) deityRes :: Deity m-deityRes = Deity { name = "Morpheus", power = Shapeshift }+deityRes = Deity {name = "Morpheus", power = Shapeshift} -data Hydra = Hydra {- name :: Text,- age :: Int-} deriving (Show,Generic)+data Hydra = Hydra+ { name :: Text,+ age :: Int+ }+ deriving (Show, Generic) instance GQLType Hydra where type KIND Hydra = INPUT -data Monster =- MonsterHydra Hydra- | Cerberus { name :: Text }+data Monster+ = MonsterHydra Hydra+ | Cerberus {name :: Text} | UnidentifiedMonster deriving (Show, Generic) instance GQLType Monster where type KIND Monster = INPUT -data Character (m :: * -> *) =- CharacterDeity (Deity m) -- Only <tycon name><type ref name> should generate direct link- -- RECORDS- | Creature { creatureName :: Text, creatureAge :: Int }- | BoxedDeity { boxedDeity :: Deity m}- | ScalarRecord { scalarText :: Text }- --- Types - | CharacterInt Int -- all scalars mus be boxed- -- Types+data Character (m :: * -> *)+ = CharacterDeity (Deity m) -- Only <tycon name><type ref name> should generate direct link+ -- RECORDS+ | Creature {creatureName :: Text, creatureAge :: Int}+ | BoxedDeity {boxedDeity :: Deity m}+ | ScalarRecord {scalarText :: Text}+ | --- Types+ CharacterInt Int -- all scalars mus be boxed+ -- Types | SomeDeity (Deity m) | SomeMutli Int Text- --- ENUMS- | Zeus- | Cronus deriving (Generic, GQLType)-+ | --- ENUMS+ Zeus+ | Cronus+ deriving (Generic, GQLType) -newtype MonsterArgs = MonsterArgs {- monster :: Monster-} deriving (Generic)+newtype MonsterArgs = MonsterArgs+ { monster :: Monster+ }+ deriving (Generic) data Query (m :: * -> *) = Query { deity :: Deity m, character :: [Character m], showMonster :: MonsterArgs -> m Text- } deriving (Generic, GQLType)--rootResolver :: GQLRootResolver IO () Query Undefined Undefined-rootResolver = GQLRootResolver- { queryResolver = Query { deity = deityRes, character, showMonster }- , mutationResolver = Undefined- , subscriptionResolver = Undefined }- where- showMonster MonsterArgs { monster } = pure (pack $ show monster)- character :: [Character m]- character =- [ CharacterDeity deityRes- , Creature { creatureName = "Lamia", creatureAge = 205 }- , BoxedDeity { boxedDeity = deityRes }- , ScalarRecord { scalarText = "Some Text" }- ---- , SomeDeity deityRes- , CharacterInt 12- , SomeMutli 21 "some text"- , Zeus- , Cronus- ]+ deriving (Generic, GQLType) +rootResolver :: GQLRootResolver IO () Query Undefined Undefined+rootResolver =+ GQLRootResolver+ { queryResolver = Query {deity = deityRes, character, showMonster},+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ }+ where+ showMonster MonsterArgs {monster} = pure (pack $ show monster)+ character :: [Character m]+ character =+ [ CharacterDeity deityRes,+ Creature {creatureName = "Lamia", creatureAge = 205},+ BoxedDeity {boxedDeity = deityRes},+ ScalarRecord {scalarText = "Some Text"},+ ---+ SomeDeity deityRes,+ CharacterInt 12,+ SomeMutli 21 "some text",+ Zeus,+ Cronus+ ] api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/UnionType/API.hs view
@@ -1,39 +1,43 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.UnionType.API- ( api+ ( api, ) where -import Data.Morpheus ( interpreter )-import Data.Morpheus.Types ( GQLRequest- , GQLResponse- , GQLRootResolver(..)- , GQLType(..)- , IORes- , Undefined(..)- )-import Data.Text ( Text )-import GHC.Generics ( Generic )+import Data.Morpheus (interpreter)+import Data.Morpheus.Types+ ( GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLType (..),+ ResolverQ,+ Undefined (..),+ )+import Data.Text (Text)+import GHC.Generics (Generic) data A = A- { aText :: Text- , aInt :: Int- } deriving (Generic, GQLType)+ { aText :: Text,+ aInt :: Int+ }+ deriving (Generic, GQLType) data B = B- { bText :: Text- , bInt :: Int- } deriving (Generic, GQLType)+ { bText :: Text,+ bInt :: Int+ }+ deriving (Generic, GQLType) data C = C- { cText :: Text- , cInt :: Int- } deriving (Generic, GQLType)+ { cText :: Text,+ cInt :: Int+ }+ deriving (Generic, GQLType) data Sum = SumA A@@ -41,22 +45,26 @@ deriving (Generic, GQLType) data Query m = Query- { union :: () -> m [Sum]- , fc :: C- } deriving (Generic, GQLType)+ { union :: () -> m [Sum],+ fc :: C+ }+ deriving (Generic, GQLType) -resolveUnion :: () -> IORes () [Sum]+resolveUnion :: () -> ResolverQ () IO [Sum] resolveUnion _ =- return [SumA A { aText = "at", aInt = 1 }, SumB B { bText = "bt", bInt = 2 }]+ return [SumA A {aText = "at", aInt = 1}, SumB B {bText = "bt", bInt = 2}] rootResolver :: GQLRootResolver IO () Query Undefined Undefined-rootResolver = GQLRootResolver- { queryResolver = Query { union = resolveUnion- , fc = C { cText = "", cInt = 3 }- }- , mutationResolver = Undefined- , subscriptionResolver = Undefined- }+rootResolver =+ GQLRootResolver+ { queryResolver =+ Query+ { union = resolveUnion,+ fc = C {cText = "", cInt = 3}+ },+ mutationResolver = Undefined,+ subscriptionResolver = Undefined+ } api :: GQLRequest -> IO GQLResponse api = interpreter rootResolver
test/Feature/UnionType/cannotBeSpreadOnType/response.json view
@@ -1,7 +1,7 @@ { "errors": [ {- "message": "Fragment \"FC\" cannot be spread here as objects of type \"A, B\" can never be of type \"C\".",+ "message": "Fragment \"FC\" cannot be spread here as objects of type \"A\", \"B\" can never be of type \"C\".", "locations": [ { "line": 3,
test/Feature/UnionType/inlineFragment/cannotBeSpreadOnType/response.json view
@@ -1,13 +1,8 @@ { "errors": [ {- "message": "Fragment cannot be spread here as objects of type \"A, B\" can never be of type \"C\".",- "locations": [- {- "line": 3,- "column": 5- }- ]+ "message": "Fragment cannot be spread here as objects of type \"A\", \"B\" can never be of type \"C\".",+ "locations": [{ "line": 3, "column": 5 }] } ] }
test/Feature/WrappedTypeName/API.hs view
@@ -1,63 +1,82 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-} module Feature.WrappedTypeName.API- ( api- ) where+ ( api,+ )+where -import Data.Morpheus (interpreter)-import Data.Morpheus.Types (Event, GQLRequest, GQLResponse, GQLRootResolver (..), GQLType (..), IORes,- constRes, subscribe)-import Data.Text (Text)-import GHC.Generics (Generic)+import Data.Morpheus (interpreter)+import Data.Morpheus.Types+ ( ComposedSubField,+ Event,+ GQLRequest,+ GQLResponse,+ GQLRootResolver (..),+ GQLType (..),+ constRes,+ subscribe,+ )+import Data.Text (Text)+import GHC.Generics (Generic) data Wrapped a b = Wrapped- { fieldA :: a- , fieldB :: b- } deriving (Generic, GQLType)+ { fieldA :: a,+ fieldB :: b+ }+ deriving (Generic, GQLType) data WA m = WA- { aText :: () -> m Text- , aInt :: Int- } deriving (Generic,GQLType)+ { aText :: () -> m Text,+ aInt :: Int+ }+ deriving (Generic, GQLType) +type Wrapped1 = Wrapped Int Int++type Wrapped2 = Wrapped (Wrapped Text Int) Text+ data Query m = Query- { a1 :: WA m- , a2 :: Maybe (Wrapped Int Int)- , a3 :: Maybe (Wrapped (Wrapped Text Int) Text)- } deriving (Generic, GQLType)+ { a1 :: WA m,+ a2 :: Maybe Wrapped1,+ a3 :: Maybe Wrapped2+ }+ deriving (Generic, GQLType) data Mutation m = Mutation- { mut1 :: Maybe (WA m)- , mut2 :: Maybe (Wrapped Int Int)- , mut3 :: Maybe (Wrapped (Wrapped Text Int) Text)- } deriving (Generic, GQLType)+ { mut1 :: Maybe (WA m),+ mut2 :: Maybe Wrapped1,+ mut3 :: Maybe Wrapped2+ }+ deriving (Generic, GQLType) -data Channel =- Channel+data Channel+ = Channel deriving (Show, Eq) -type EVENT = Event Channel ()+type EVENT = Event Channel () data Subscription (m :: * -> *) = Subscription- { sub1 :: m (Maybe (WA (IORes EVENT)))- , sub2 :: m (Maybe (Wrapped Int Int))- , sub3 :: m (Maybe (Wrapped (Wrapped Text Int) Text))- } deriving (Generic, GQLType)+ { sub1 :: ComposedSubField m Maybe WA,+ sub2 :: m (Maybe Wrapped1),+ sub3 :: m (Maybe Wrapped2)+ }+ deriving (Generic, GQLType) rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver- { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing}- , mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing}- , subscriptionResolver = Subscription- { sub1 = subscribe [Channel] (pure $ constRes Nothing)- , sub2 = subscribe [Channel] (pure $ constRes Nothing)- , sub3 = subscribe [Channel] (pure $ constRes Nothing)- }+ { queryResolver = Query {a1 = WA {aText = const $ pure "test1", aInt = 0}, a2 = Nothing, a3 = Nothing},+ mutationResolver = Mutation {mut1 = Nothing, mut2 = Nothing, mut3 = Nothing},+ subscriptionResolver =+ Subscription+ { sub1 = subscribe [Channel] (pure $ constRes Nothing),+ sub2 = subscribe [Channel] (pure $ constRes Nothing),+ sub3 = subscribe [Channel] (pure $ constRes Nothing)+ } } api :: GQLRequest -> IO GQLResponse
test/Lib.hs view
@@ -1,18 +1,19 @@ {-# LANGUAGE OverloadedStrings #-} module Lib- ( getGQLBody- , getResponseBody- , getCases- , maybeVariables- ) where+ ( getGQLBody,+ getResponseBody,+ getCases,+ maybeVariables,+ )+where -import Control.Applicative ((<|>))-import Data.Aeson (FromJSON, Value (..), decode)-import qualified Data.ByteString.Lazy as L (readFile)-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Maybe (fromMaybe)-import Data.Text (Text, unpack)+import Control.Applicative ((<|>))+import Data.Aeson (FromJSON, Value (..), decode)+import qualified Data.ByteString.Lazy as L (readFile)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Maybe (fromMaybe)+import Data.Text (Text, unpack) path :: Text -> String path name = "test/" ++ unpack name
test/Rendering/Schema.hs view
@@ -1,29 +1,36 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-} module Rendering.Schema- ( schemaProxy- ) where+ ( schemaProxy,+ )+where -import Data.Morpheus.Document (importGQLDocumentWithNamespace)-import Data.Morpheus.Kind (SCALAR)-import Data.Morpheus.Types (GQLRootResolver (..), GQLScalar (..), GQLType (..), ID (..), ScalarValue (..),- Undefined (..))-import Data.Proxy (Proxy (..))-import Data.Text (Text)-import GHC.Generics (Generic)+import Data.Morpheus.Document (importGQLDocumentWithNamespace)+import Data.Morpheus.Kind (SCALAR)+import Data.Morpheus.Types+ ( GQLRootResolver (..),+ GQLScalar (..),+ GQLType (..),+ ID (..),+ ScalarValue (..),+ Undefined (..),+ )+import Data.Proxy (Proxy (..))+import Data.Text (Text)+import GHC.Generics (Generic) -data TestScalar =- TestScalar+data TestScalar+ = TestScalar deriving (Show, Generic) instance GQLType TestScalar where@@ -35,5 +42,5 @@ importGQLDocumentWithNamespace "test/Rendering/schema.gql" -schemaProxy :: Proxy (GQLRootResolver IO () Query Undefined Undefined)-schemaProxy = Proxy @(GQLRootResolver IO () Query Undefined Undefined)+schemaProxy :: Proxy (GQLRootResolver IO () Query Undefined Undefined)+schemaProxy = Proxy @(GQLRootResolver IO () Query Undefined Undefined)
test/Rendering/TestSchemaRendering.hs view
@@ -1,14 +1,14 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module Rendering.TestSchemaRendering- ( testSchemaRendering- ) where+ ( testSchemaRendering,+ )+where -import Data.Morpheus.Document (toGraphQLDocument)-import Rendering.Schema (schemaProxy)-import Test.Tasty (TestTree)-import Test.Tasty.HUnit (assertEqual, testCase)+import Data.Morpheus.Document (toGraphQLDocument)+import Rendering.Schema (schemaProxy)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertEqual, testCase) -- TODO: better Test testSchemaRendering :: TestTree@@ -16,4 +16,4 @@ where schema = toGraphQLDocument schemaProxy expected =- "enum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\ntype Query { \n user: User!\n testUnion: TestUnion\n}\n\nunion TestUnion =\n User\n | Address\n\nscalar TestScalar"+ "enum TestEnum { \n EnumA\n EnumB\n EnumC\n}\n\ntype Address { \n street: [[[[String!]!]!]]\n}\n\ninput Coordinates { \n latitude: TestScalar!\n longitude: Int!\n}\n\ntype User { \n type: String!\n address(coordinates: Coordinates!, type: String): Int!\n friend(id: ID!, cityID: TestEnum): User!\n}\n\ntype Query { \n user: User!\n testUnion: TestUnion\n}\n\nunion TestUnion =\n User\n | Address\n\nscalar TestScalar"
test/Spec.hs view
@@ -1,57 +1,70 @@ {-# LANGUAGE OverloadedStrings #-} module Main- ( main+ ( main, ) where -import qualified Feature.Holistic.API as Holistic- ( api )-import qualified Feature.Input.Enum.API as InputEnum- ( api )-import qualified Feature.Input.Scalar.API as InputScalar- ( api )-import qualified Feature.Input.Object.API as InputObject- ( api )-import qualified Feature.InputType.API as InputType- ( api )-import qualified Feature.Schema.API as Schema- ( api )-import qualified Feature.UnionType.API as UnionType- ( api )-import qualified Feature.WrappedTypeName.API as TypeName- ( api )-import qualified Feature.TypeInference.API as Inference- ( api )-import Rendering.TestSchemaRendering ( testSchemaRendering )-import Test.Tasty ( defaultMain- , testGroup- )-import TestFeature ( testFeature )+import qualified Feature.Holistic.API as Holistic+ ( api,+ )+import qualified Feature.Input.Enum.API as InputEnum+ ( api,+ )+import qualified Feature.Input.Object.API as InputObject+ ( api,+ )+import qualified Feature.Input.Scalar.API as InputScalar+ ( api,+ )+import qualified Feature.InputType.API as InputType+ ( api,+ )+import qualified Feature.Schema.API as Schema+ ( api,+ )+import qualified Feature.TypeInference.API as Inference+ ( api,+ )+import qualified Feature.UnionType.API as UnionType+ ( api,+ )+import qualified Feature.WrappedTypeName.API as TypeName+ ( api,+ )+import Rendering.TestSchemaRendering (testSchemaRendering)+import Subscription.Test (testSubsriptions)+import Test.Tasty+ ( defaultMain,+ testGroup,+ )+import TestFeature (testFeature) main :: IO () main = do- ioTests <- testFeature Holistic.api "Feature/Holistic"- unionTest <- testFeature UnionType.api "Feature/UnionType"- inputTest <- testFeature InputType.api "Feature/InputType"- schemaTest <- testFeature Schema.api "Feature/Schema"- typeName <- testFeature TypeName.api "Feature/WrappedTypeName"- inputEnum <- testFeature InputEnum.api "Feature/Input/Enum"+ ioTests <- testFeature Holistic.api "Feature/Holistic"+ unionTest <- testFeature UnionType.api "Feature/UnionType"+ inputTest <- testFeature InputType.api "Feature/InputType"+ schemaTest <- testFeature Schema.api "Feature/Schema"+ typeName <- testFeature TypeName.api "Feature/WrappedTypeName"+ inputEnum <- testFeature InputEnum.api "Feature/Input/Enum" inputScalar <- testFeature InputScalar.api "Feature/Input/Scalar" inputObject <- testFeature InputObject.api "Feature/Input/Object"- inference <- testFeature Inference.api "Feature/TypeInference"+ inference <- testFeature Inference.api "Feature/TypeInference"+ subscription <- testSubsriptions defaultMain- (testGroup- "Morpheus Graphql Tests"- [ ioTests- , unionTest- , inputTest- , schemaTest- , typeName- , inputEnum- , inputScalar- , inputObject- , testSchemaRendering- , inference- ]+ ( testGroup+ "Morpheus Graphql Tests"+ [ ioTests,+ unionTest,+ inputTest,+ schemaTest,+ typeName,+ inputEnum,+ inputScalar,+ inputObject,+ testSchemaRendering,+ inference,+ subscription+ ] )
+ test/Subscription/API.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}++module Subscription.API (api, EVENT, Channel (..), Info (..)) where++import Data.Morpheus (interpreter)+import Data.Morpheus.Document (importGQLDocument)+import Data.Morpheus.Types+ ( Event (..),+ GQLRootResolver (..),+ Input,+ Stream,+ subscribe,+ )+import Data.Text (Text)+import Subscription.Utils (SubM)++data Channel+ = DEITY+ | HUMAN+ deriving (Show, Eq)++importGQLDocument "test/Subscription/schema.gql"++type EVENT = Event Channel Info++character :: Applicative m => m (Character m)+character =+ pure+ Character+ { name = pure "testName",+ age = pure 1+ }++characterSub :: Applicative m => EVENT -> m (Character m)+characterSub (Event _ Info {name, age}) =+ pure+ Character+ { name = pure name,+ age = pure age+ }++rootResolver :: GQLRootResolver (SubM EVENT) EVENT Query Mutation Subscription+rootResolver =+ GQLRootResolver+ { queryResolver =+ Query+ { queryField = pure ""+ },+ mutationResolver =+ Mutation+ { createDeity = const character,+ createHuman = const character+ },+ subscriptionResolver =+ Subscription+ { newDeity = subscribe [DEITY] (pure characterSub),+ newHuman = subscribe [HUMAN] (pure characterSub)+ }+ }++api :: Input api -> Stream api EVENT (SubM EVENT)+api = interpreter rootResolver
+ test/Subscription/Case/ApolloRequest.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Subscription.Case.ApolloRequest+ ( testApolloRequest,+ SubM,+ )+where++import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Morpheus.Types+ ( Input,+ Stream,+ )+import Data.Morpheus.Types.Internal.Subscription+ ( GQLChannel (..),+ WS,+ )+import Subscription.Utils+ ( SimulationState (..),+ SubM,+ apolloInit,+ apolloStart,+ apolloStop,+ inputsAreConsumed,+ storeIsEmpty,+ storeSubscriptions,+ stored,+ storedSingle,+ testResponse,+ testSimulation,+ )+import Test.Tasty+ ( TestTree,+ testGroup,+ )++testUnknownType ::+ ( Eq (StreamChannel e),+ GQLChannel e+ ) =>+ (Input WS -> Stream WS e (SubM e)) ->+ IO TestTree+testUnknownType =+ testSimulation+ test+ ["{ \"type\":\"bla\" }"]+ where+ test _ SimulationState {inputs, outputs, store} =+ testGroup+ "unknown request type"+ [ inputsAreConsumed inputs,+ testResponse+ ["Unknown Request type \"bla\"."]+ outputs,+ storeIsEmpty store+ ]++testConnectionInit ::+ ( Eq (StreamChannel e),+ GQLChannel e+ ) =>+ (Input WS -> Stream WS e (SubM e)) ->+ IO TestTree+testConnectionInit = testSimulation test [apolloInit]+ where+ test input SimulationState {inputs, outputs, store} =+ testGroup+ "connection init"+ [ inputsAreConsumed inputs,+ testResponse+ []+ outputs,+ stored input store,+ storedSingle store+ ]++startSub :: ByteString -> ByteString+startSub = apolloStart "subscription MySubscription { newDeity { name }}"++testSubscriptionStart ::+ ( Eq (StreamChannel e),+ GQLChannel e+ ) =>+ (Input WS -> Stream WS e (SubM e)) ->+ IO TestTree+testSubscriptionStart =+ testSimulation+ test+ [ apolloInit,+ startSub "1",+ startSub "5"+ ]+ where+ test input SimulationState {inputs, outputs, store} =+ testGroup+ "subscription start"+ [ inputsAreConsumed inputs,+ testResponse+ []+ outputs,+ storeSubscriptions+ input+ ["1", "5"]+ store+ ]++testSubscriptionStop ::+ ( Eq (StreamChannel e),+ GQLChannel e+ ) =>+ (Input WS -> Stream WS e (SubM e)) ->+ IO TestTree+testSubscriptionStop =+ testSimulation+ test+ [ apolloInit,+ startSub "1",+ startSub "5",+ apolloStop "1"+ ]+ where+ test input SimulationState {inputs, outputs, store} =+ testGroup+ "stop subscription"+ [ inputsAreConsumed inputs,+ testResponse+ []+ outputs,+ storeSubscriptions+ input+ ["5"]+ store+ ]++testApolloRequest ::+ ( Eq (StreamChannel e),+ GQLChannel e+ ) =>+ (Input WS -> Stream WS e (SubM e)) ->+ IO TestTree+testApolloRequest api = do+ unknownType <- testUnknownType api+ connection_init <- testConnectionInit api+ start <- testSubscriptionStart api+ stop <- testSubscriptionStop api+ return $ testGroup "ApolloRequest" [unknownType, connection_init, start, stop]
+ test/Subscription/Case/Publishing.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}++module Subscription.Case.Publishing+ ( testPublishing,+ )+where++import Data.ByteString.Lazy.Char8+ ( ByteString,+ )+import Data.Morpheus.Types+ ( Event (..),+ Input,+ )+import Data.Morpheus.Types.Internal.Subscription+ ( WS,+ connect,+ empty,+ )+import Subscription.API+ ( Channel (..),+ EVENT,+ Info (..),+ api,+ )+import Subscription.Utils+ ( SimulationState (..),+ apolloInit,+ apolloRes,+ apolloStart,+ apolloStop,+ inputsAreConsumed,+ simulate,+ simulatePublish,+ storeSubscriptions,+ testResponse,+ )+import Test.Tasty+ ( TestTree,+ testGroup,+ )++startNewDeity :: ByteString -> ByteString+startNewDeity = apolloStart "subscription MySubscription { newDeity { name , age }}"++startNewHuman :: ByteString -> ByteString+startNewHuman = apolloStart "subscription MySubscription { newHuman { name , age }}"++simulateSubscriptions :: IO (Input WS, SimulationState EVENT)+simulateSubscriptions = do+ input <- connect+ state <-+ simulate+ api+ input+ ( SimulationState+ [ apolloInit,+ startNewDeity "1",+ startNewDeity "2",+ startNewDeity "3",+ startNewHuman "4",+ apolloStop "1"+ ]+ []+ empty+ )+ pure (input, state)++triggerSubsciption ::+ IO TestTree+triggerSubsciption = do+ (input, state) <- simulateSubscriptions+ SimulationState {inputs, outputs, store} <-+ simulatePublish (Event [DEITY] Info {name = "Zeus", age = 1200}) state+ >>= simulatePublish (Event [HUMAN] Info {name = "Hercules", age = 18})+ pure $+ testGroup+ "publish event"+ [ inputsAreConsumed inputs,+ testResponse+ -- triggers subscriptions by channels+ [ apolloRes+ "2"+ "{\"newDeity\":{\"name\":\"Zeus\",\"age\":1200}}",+ apolloRes+ "3"+ "{\"newDeity\":{\"name\":\"Zeus\",\"age\":1200}}",+ apolloRes+ "4"+ "{\"newHuman\":{\"name\":\"Hercules\",\"age\":18}}"+ ]+ outputs,+ storeSubscriptions+ input+ ["2", "3", "4"]+ store+ ]++testPublishing :: IO TestTree+testPublishing = do+ trigger <- triggerSubsciption+ return $ testGroup "Publishing" [trigger]
+ test/Subscription/Test.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE OverloadedStrings #-}++module Subscription.Test (testSubsriptions) where++import qualified Subscription.API as TS+import Subscription.Case.ApolloRequest (testApolloRequest)+import Subscription.Case.Publishing (testPublishing)+import Test.Tasty (TestTree, testGroup)++testSubsriptions :: IO TestTree+testSubsriptions = do+ subscription <- testApolloRequest TS.api+ publishing <- testPublishing+ return $ testGroup "Subscription" [subscription, publishing]
+ test/Subscription/Utils.hs view
@@ -0,0 +1,217 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module Subscription.Utils+ ( SimulationState (..),+ simulate,+ expectedResponse,+ SubM,+ testResponse,+ inputsAreConsumed,+ storeIsEmpty,+ storedSingle,+ stored,+ storeSubscriptions,+ simulatePublish,+ apolloStart,+ apolloStop,+ apolloRes,+ apolloInit,+ testSimulation,+ )+where++import Control.Monad.State.Lazy+ ( StateT,+ runStateT,+ state,+ )+import Data.ByteString.Lazy.Char8+ ( ByteString,+ )+import Data.List+ ( sort,+ )+import Data.Maybe+ ( isJust,+ )+import Data.Morpheus.Types+ ( Input,+ Stream,+ )+import Data.Morpheus.Types.Internal.Subscription+ ( ClientConnectionStore,+ GQLChannel (..),+ Input (..),+ Scope (..),+ SessionID,+ WS,+ connect,+ connectionSessionIds,+ empty,+ publish,+ runStreamWS,+ toList,+ )+import Data.Semigroup+ ( (<>),+ )+import Test.Tasty+ ( TestTree,+ )+import Test.Tasty.HUnit+ ( assertEqual,+ assertFailure,+ testCase,+ )++data SimulationState e = SimulationState+ { inputs :: [ByteString],+ outputs :: [ByteString],+ store :: ClientConnectionStore e (SubM e)+ }++type Store e = ClientConnectionStore e (SubM e)++type SubM e = StateT (SimulationState e) IO++addOutput :: ByteString -> SimulationState e -> ((), SimulationState e)+addOutput x (SimulationState i xs st) = ((), SimulationState i (xs <> [x]) st)++updateStore :: (Store e -> Store e) -> SimulationState e -> ((), SimulationState e)+updateStore up (SimulationState i o st) = ((), SimulationState i o (up st))++readInput :: SimulationState e -> (ByteString, SimulationState e)+readInput (SimulationState (i : ins) o s) = (i, SimulationState ins o s)+readInput (SimulationState [] o s) = ("<Error>", SimulationState [] o s)++wsApp ::+ (Input WS -> Stream WS e (SubM e)) ->+ Input WS ->+ SubM e ()+wsApp api input =+ runStreamWS+ ScopeWS+ { update = state . updateStore,+ listener = state readInput,+ callback = state . addOutput+ }+ (api input)++simulatePublish ::+ (GQLChannel e, Eq (StreamChannel e)) =>+ e ->+ SimulationState e ->+ IO (SimulationState e)+simulatePublish event s = snd <$> runStateT (publish event (store s)) s++simulate ::+ (Input WS -> Stream WS e (SubM e)) ->+ Input WS ->+ SimulationState e ->+ IO (SimulationState e)+simulate _ _ s@SimulationState {inputs = []} = pure s+simulate api input s = snd <$> runStateT (wsApp api input) s >>= simulate api input++testSimulation ::+ (Input WS -> SimulationState e -> TestTree) ->+ [ByteString] ->+ (Input WS -> Stream WS e (SubM e)) ->+ IO TestTree+testSimulation test simInputs api = do+ input <- connect+ s <- simulate api input (SimulationState simInputs [] empty)+ pure $ test input s++expectedResponse :: [ByteString] -> [ByteString] -> IO ()+expectedResponse expected value+ | expected == value = return ()+ | otherwise =+ assertFailure $ "expected: \n " <> show expected <> " \n but got: \n " <> show value++testResponse :: [ByteString] -> [ByteString] -> TestTree+testResponse expected =+ testCase+ "expected response"+ . expectedResponse+ expected++inputsAreConsumed :: [ByteString] -> TestTree+inputsAreConsumed =+ testCase "inputs are consumed"+ . assertEqual+ "input stream should be consumed"+ []++storeIsEmpty :: Store e -> TestTree+storeIsEmpty cStore+ | null (toList cStore) =+ testCase "connectionStore: is empty" $ return ()+ | otherwise =+ testCase "connectionStore: is empty"+ $ assertFailure+ $ " must be empty but "+ <> show+ cStore++storedSingle :: Store e -> TestTree+storedSingle cStore+ | length (toList cStore) == 1 =+ testCase "stored single connection" $ return ()+ | otherwise =+ testCase "stored single connection"+ $ assertFailure+ $ "connectionStore must store single connection"+ <> show+ cStore++stored :: Input WS -> Store e -> TestTree+stored (Init uuid) cStore+ | isJust (lookup uuid (toList cStore)) =+ testCase "stored connection" $ return ()+ | otherwise =+ testCase "stored connection"+ $ assertFailure+ $ " must store connection \"" <> show uuid <> "\" but stored: "+ <> show+ cStore++storeSubscriptions ::+ Input WS ->+ [SessionID] ->+ Store e ->+ TestTree+storeSubscriptions+ (Init uuid)+ sids+ cStore =+ checkSession (lookup uuid (toList cStore))+ where+ checkSession (Just conn)+ | sort sids == sort (connectionSessionIds conn) =+ testCase "stored subscriptions" $ return ()+ | otherwise =+ testCase "stored subscriptions"+ $ assertFailure+ $ " must store subscriptions with id \"" <> show sids <> "\" but stored: "+ <> show+ (connectionSessionIds conn)+ checkSession _ =+ testCase "stored connection"+ $ assertFailure+ $ " must store connection \"" <> show uuid <> "\" but: "+ <> show+ cStore++apolloStart :: ByteString -> ByteString -> ByteString+apolloStart query sid = "{\"id\":\"" <> sid <> "\",\"type\":\"start\",\"payload\":{\"variables\":{},\"operationName\":\"MySubscription\",\"query\":\"" <> query <> "\"}}"++apolloStop :: ByteString -> ByteString+apolloStop x = "{\"id\":\"" <> x <> "\",\"type\":\"stop\"}"++apolloRes :: ByteString -> ByteString -> ByteString+apolloRes sid value = "{\"id\":\"" <> sid <> "\",\"type\":\"data\",\"payload\":{\"data\":" <> value <> "}}"++apolloInit :: ByteString+apolloInit = "{ \"type\":\"connection_init\" }"
+ test/Subscription/schema.gql view
@@ -0,0 +1,25 @@+input Info + { name: String!+ , age: Int!+ }++type Character {+ name: String!+ age: Int!+}++type Query {+ queryField: String!+}++type Mutation {+ createDeity+ ( input: Info! ): Character!+ createHuman+ ( input: Info! ): Character!+}++type Subscription {+ newDeity: Character!+ newHuman: Character!+}
test/TestFeature.hs view
@@ -1,44 +1,38 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} module TestFeature- ( testFeature- ) where--import qualified Data.Text.Lazy as LT (toStrict)-import Data.Text.Lazy.Encoding (decodeUtf8)+ ( testFeature,+ )+where -import Data.Aeson (FromJSON, Value, decode, encode)-import Data.ByteString.Lazy.Char8 (ByteString)+import Data.Aeson (Value, decode, encode)+import Data.ByteString.Lazy.Char8 (ByteString) import qualified Data.ByteString.Lazy.Char8 as LB (unpack)-import Data.Morpheus.Types (GQLRequest (..), GQLResponse (..))-import Data.Semigroup ((<>))-import Data.Text (Text, unpack)-import qualified Data.Text as T (concat)-import GHC.Generics-import Lib (getCases, getGQLBody, getResponseBody, maybeVariables)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase)+import Data.Morpheus.Types (GQLRequest (..), GQLResponse (..))+import Data.Semigroup ((<>))+import Data.Text (unpack)+import qualified Data.Text.Lazy as LT (toStrict)+import Data.Text.Lazy.Encoding (decodeUtf8)+import Lib (getGQLBody, getResponseBody, maybeVariables)+import Test.Tasty (TestTree)+import Test.Tasty.HUnit (assertFailure, testCase)+import Types+ ( Case (..),+ Name,+ testWith,+ ) packGQLRequest :: ByteString -> Maybe Value -> GQLRequest-packGQLRequest queryBS variables = GQLRequest - { operationName = Nothing- , query = LT.toStrict $ decodeUtf8 queryBS- , variables- }--data Case = Case- { path :: Text- , description :: String- } deriving (Generic, FromJSON)+packGQLRequest queryBS variables =+ GQLRequest+ { operationName = Nothing,+ query = LT.toStrict $ decodeUtf8 queryBS,+ variables+ } -testFeature :: (GQLRequest -> IO GQLResponse) -> Text -> IO TestTree-testFeature api dir = do- cases' <- getCases (unpack dir)- test' <- sequence $ testByFiles api <$> map (\x -> x {path = T.concat [dir, "/", path x]}) cases'- return $ testGroup (unpack dir) test'+testFeature :: (GQLRequest -> IO GQLResponse) -> Name -> IO TestTree+testFeature api = testWith (testByFiles api) testByFiles :: (GQLRequest -> IO GQLResponse) -> Case -> IO TestTree testByFiles testApi Case {path, description} = do@@ -49,7 +43,8 @@ case decode actualResponse of Nothing -> assertFailure "Bad Response" Just response -> return $ testCase (unpack path ++ " | " ++ description) $ customTest expectedResponse response- where customTest expected value- | expected == value = return ()- | otherwise =- assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse+ where+ customTest expected value+ | expected == value = return ()+ | otherwise =+ assertFailure $ LB.unpack $ "expected: \n " <> encode expected <> " \n but got: \n " <> actualResponse
+ test/Types.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}++module Types+ ( Case (..),+ Name,+ testWith,+ )+where++import Data.Aeson (FromJSON)+import Data.Text (Text, unpack)+import qualified Data.Text as T (concat)+import GHC.Generics+import Lib (getCases)+import Test.Tasty (TestTree, testGroup)++type Name = Text++data Case = Case+ { path :: Text,+ description :: String+ }+ deriving (Generic, FromJSON)++testWith :: (Case -> IO TestTree) -> Name -> IO TestTree+testWith f dir = do+ cases <- getCases (unpack dir)+ test <- sequence $ f <$> map (\x -> x {path = T.concat [dir, "/", path x]}) cases+ return $ testGroup (unpack dir) test