morpheus-graphql 0.10.0 → 0.11.0

raw patch · 156 files changed

+6118/−3762 lines, 156 filesdep +unliftio-corePVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio-core

API changes (from Hackage documentation)

- Data.Morpheus.Server: gqlSocketApp :: RootResCon IO e que mut sub => GQLRootResolver IO e que mut sub -> GQLState IO e -> ServerApp

- Data.Morpheus.Server: gqlSocketMonadIOApp :: (RootResCon m e que mut sub, MonadIO m) => GQLRootResolver m e que mut sub -> GQLState m e -> (m () -> IO ()) -> ServerApp

- Data.Morpheus.Server: initGQLState :: IO (GQLState m e)

- Data.Morpheus.Server: type GQLState m e = MVar (ClientDB m e)

- Data.Morpheus.Types.Internal.AST: DataField :: Key -> [(Key, DataArgument)] -> Maybe Name -> TypeRef -> Maybe Meta -> DataField

- Data.Morpheus.Types.Internal.AST: DataType :: Key -> DataFingerprint -> Maybe Meta -> DataTypeContent -> DataType

- Data.Morpheus.Types.Internal.AST: DataValidator :: (ValidValue -> Either Key ValidValue) -> DataValidator

- Data.Morpheus.Types.Internal.AST: [fieldArgsType] :: DataField -> Maybe Name

- Data.Morpheus.Types.Internal.AST: [fragments] :: GQLQuery -> FragmentLib

- Data.Morpheus.Types.Internal.AST: [inputVariables] :: GQLQuery -> [(Key, ResolvedValue)]

- Data.Morpheus.Types.Internal.AST: [operation] :: GQLQuery -> RawOperation

- Data.Morpheus.Types.Internal.AST: checkForUnknownKeys :: Failure e m => [Ref] -> [Name] -> ([Ref] -> e) -> m [Ref]

- Data.Morpheus.Types.Internal.AST: checkNameCollision :: (Failure e m, Ord a) => [a] -> ([a] -> e) -> m [a]

- Data.Morpheus.Types.Internal.AST: class DataLookup l a

- Data.Morpheus.Types.Internal.AST: coerceDataObject :: Failure error m => error -> DataType -> m (Name, DataObject)

- Data.Morpheus.Types.Internal.AST: data DataField

- Data.Morpheus.Types.Internal.AST: data DataType

- Data.Morpheus.Types.Internal.AST: data DataTypeContent

- Data.Morpheus.Types.Internal.AST: getOperationObject :: Operation a -> Schema -> Validation (Name, DataObject)

- Data.Morpheus.Types.Internal.AST: lookupDataUnion :: (Monad m, Failure e m) => e -> Key -> Schema -> m DataUnion

- Data.Morpheus.Types.Internal.AST: lookupField :: Failure error m => Key -> [(Key, field)] -> error -> m field

- Data.Morpheus.Types.Internal.AST: lookupFieldAsSelectionSet :: (Monad m, Failure GQLErrors m) => Position -> Key -> Schema -> DataField -> m (Name, DataObject)

- Data.Morpheus.Types.Internal.AST: lookupInputType :: Failure e m => Key -> Schema -> e -> m DataType

- Data.Morpheus.Types.Internal.AST: lookupResult :: (DataLookup l a, Failure e m, Monad m) => e -> Name -> l -> m a

- Data.Morpheus.Types.Internal.AST: lookupSelectionField :: Failure GQLErrors Validation => Position -> Name -> Name -> DataObject -> Validation DataField

- Data.Morpheus.Types.Internal.AST: lookupUnionTypes :: (Monad m, Failure GQLErrors m) => Position -> Key -> Schema -> DataField -> m [(Name, DataObject)]

- Data.Morpheus.Types.Internal.AST: newtype DataValidator

- Data.Morpheus.Types.Internal.AST: type Collection a = [(Key, a)]

- Data.Morpheus.Types.Internal.AST: type DataArgument = DataField

- Data.Morpheus.Types.Internal.AST: type DataArguments = [(Key, DataArgument)]

- Data.Morpheus.Types.Internal.AST: type DataObject = [(Key, DataField)]

- Data.Morpheus.Types.Internal.AST: type DataScalar = DataValidator

- Data.Morpheus.Types.Internal.AST: type FragmentLib = [(Key, Fragment)]

- Data.Morpheus.Types.Internal.AST: type RawArgument = Argument RAW

- Data.Morpheus.Types.Internal.AST: type RawArguments = Arguments RAW

- Data.Morpheus.Types.Internal.AST: type RawOperation = Operation RAW

- Data.Morpheus.Types.Internal.AST: type RawSelection = Selection RAW

- Data.Morpheus.Types.Internal.AST: type RawSelectionRec = SelectionContent RAW

- Data.Morpheus.Types.Internal.AST: type RawSelectionSet = Collection RawSelection

- Data.Morpheus.Types.Internal.AST: type ValidArgument = Argument VALID

- Data.Morpheus.Types.Internal.AST: type ValidArguments = Collection ValidArgument

- Data.Morpheus.Types.Internal.AST: type ValidOperation = Operation VALID

- Data.Morpheus.Types.Internal.AST: type ValidSelection = Selection VALID

- Data.Morpheus.Types.Internal.AST: type ValidSelectionRec = SelectionContent VALID

- Data.Morpheus.Types.Internal.AST: type ValidSelectionSet = Collection ValidSelection

- Data.Morpheus.Types.Internal.AST: type ValidVariables = Collection (Variable VALID)

- Data.Morpheus.Types.Internal.AST: unpackInputUnion :: [(Name, Bool)] -> Object stage -> Either Message (Name, Maybe (Value stage))

+ Data.Morpheus.Server: httpPubApp :: (MonadIO m, MapAPI a) => (Input HTTP -> Stream HTTP e m) -> (e -> m ()) -> a -> m a

+ Data.Morpheus.Server: webSocketsApp :: (MonadIO m, MonadUnliftIO m, Eq (StreamChannel e), GQLChannel e) => (Input WS -> Stream WS e m) -> m (ServerApp, e -> m ())

+ Data.Morpheus.Types: data Input (api :: API)

+ Data.Morpheus.Types: data Stream (api :: API) e (m :: * -> *)

+ Data.Morpheus.Types.Internal.AST: ArgumentsDefinition :: Maybe Name -> OrderedMap ArgumentDefinition -> ArgumentsDefinition

+ 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: GQLError :: Message -> [Position] -> GQLError

+ Data.Morpheus.Types.Internal.AST: InputFieldsDefinition :: OrderedMap FieldDefinition -> InputFieldsDefinition

+ Data.Morpheus.Types.Internal.AST: NoArguments :: ArgumentsDefinition

+ Data.Morpheus.Types.Internal.AST: ObjectEntry :: Name -> Value s -> ObjectEntry

+ Data.Morpheus.Types.Internal.AST: ScalarDefinition :: (ValidValue -> Either Key ValidValue) -> ScalarDefinition

+ Data.Morpheus.Types.Internal.AST: TypeDefinition :: Key -> DataFingerprint -> Maybe Meta -> TypeContent -> TypeDefinition

+ Data.Morpheus.Types.Internal.AST: UnionTag :: Name -> SelectionSet VALID -> UnionTag

+ 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: [argumentName] :: Argument -> Name

+ Data.Morpheus.Types.Internal.AST: [argumentsTypename] :: ArgumentsDefinition -> Maybe Name

+ Data.Morpheus.Types.Internal.AST: [arguments] :: ArgumentsDefinition -> OrderedMap ArgumentDefinition

+ Data.Morpheus.Types.Internal.AST: [entryName] :: ObjectEntry -> Name

+ Data.Morpheus.Types.Internal.AST: [entryValue] :: ObjectEntry -> Value s

+ Data.Morpheus.Types.Internal.AST: [fragmentName] :: Fragment -> Name

+ Data.Morpheus.Types.Internal.AST: [locations] :: GQLError -> [Position]

+ Data.Morpheus.Types.Internal.AST: [message] :: GQLError -> Message

+ Data.Morpheus.Types.Internal.AST: [unFieldsDefinition] :: FieldsDefinition -> OrderedMap FieldDefinition

+ Data.Morpheus.Types.Internal.AST: [unInputFieldsDefinition] :: InputFieldsDefinition -> OrderedMap FieldDefinition

+ Data.Morpheus.Types.Internal.AST: [unionTagName] :: UnionTag -> Name

+ Data.Morpheus.Types.Internal.AST: [unionTagSelection] :: UnionTag -> SelectionSet VALID

+ Data.Morpheus.Types.Internal.AST: [variableName] :: Variable -> Name

+ Data.Morpheus.Types.Internal.AST: __inputname :: Name

+ Data.Morpheus.Types.Internal.AST: data ArgumentsDefinition

+ Data.Morpheus.Types.Internal.AST: data FieldDefinition

+ Data.Morpheus.Types.Internal.AST: data GQLError

+ Data.Morpheus.Types.Internal.AST: data ObjectEntry (s :: Stage)

+ Data.Morpheus.Types.Internal.AST: data OrderedMap a

+ Data.Morpheus.Types.Internal.AST: data TypeContent

+ Data.Morpheus.Types.Internal.AST: data TypeDefinition

+ Data.Morpheus.Types.Internal.AST: data UnionTag

+ Data.Morpheus.Types.Internal.AST: hasArguments :: ArgumentsDefinition -> Bool

+ Data.Morpheus.Types.Internal.AST: hsTypeName :: Key -> Key

+ Data.Morpheus.Types.Internal.AST: isInputDataType :: TypeDefinition -> Bool

+ 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: splitDuplicates :: Eq a => [a] -> ([a], [a])

+ Data.Morpheus.Types.Internal.AST: toHSFieldDefinition :: FieldDefinition -> FieldDefinition

+ Data.Morpheus.Types.Internal.AST: type ArgumentDefinition = FieldDefinition

+ Data.Morpheus.Types.Internal.AST: type Fragments = OrderedMap Fragment

+ Data.Morpheus.Types.Internal.AST: type GQLErrors = [GQLError]

+ Data.Morpheus.Types.Internal.AST: type Named a = (Name, a)

+ Data.Morpheus.Types.Internal.AST: type TypeLib = HashMap Key TypeDefinition

+ 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: class Interpreter k m e

+ Data.Morpheus: class Interpreter e m a b

- Data.Morpheus: interpreter :: (Interpreter k m e, Monad m) => RootResCon m e query mut sub => GQLRootResolver m e query mut sub -> k

+ Data.Morpheus: interpreter :: (Interpreter e m a b, Monad m) => RootResCon m e query mut sub => GQLRootResolver m e query mut sub -> a -> b

- Data.Morpheus.Client: defineQuery :: IO (Validation Schema) -> (GQLQuery, String) -> Q [Dec]

+ Data.Morpheus.Client: defineQuery :: IO (Eventless Schema) -> (GQLQuery, String) -> Q [Dec]

- Data.Morpheus.Document: parseFullGQLDocument :: ByteString -> Validation Schema

+ Data.Morpheus.Document: parseFullGQLDocument :: ByteString -> Eventless Schema

- Data.Morpheus.Types.Internal.AST: Argument :: Value valid -> Position -> Argument

+ Data.Morpheus.Types.Internal.AST: Argument :: Name -> Value valid -> Position -> Argument

- Data.Morpheus.Types.Internal.AST: ConsD :: Name -> [DataField] -> ConsD

+ Data.Morpheus.Types.Internal.AST: ConsD :: Name -> [FieldDefinition] -> ConsD

- Data.Morpheus.Types.Internal.AST: DataEnum :: DataEnum -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataEnum :: DataEnum -> TypeContent

- Data.Morpheus.Types.Internal.AST: DataInputObject :: DataObject -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataInputObject :: InputFieldsDefinition -> TypeContent

- Data.Morpheus.Types.Internal.AST: DataInputUnion :: [(Key, Bool)] -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataInputUnion :: [(Key, Bool)] -> TypeContent

- Data.Morpheus.Types.Internal.AST: DataInterface :: DataObject -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataInterface :: FieldsDefinition -> TypeContent

- Data.Morpheus.Types.Internal.AST: DataObject :: [Name] -> DataObject -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataObject :: [Name] -> FieldsDefinition -> TypeContent

- Data.Morpheus.Types.Internal.AST: DataScalar :: DataScalar -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataScalar :: ScalarDefinition -> TypeContent

- Data.Morpheus.Types.Internal.AST: DataUnion :: DataUnion -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: DataUnion :: DataUnion -> TypeContent

- Data.Morpheus.Types.Internal.AST: Directive :: Name -> [(Name, ValidValue)] -> Directive

+ Data.Morpheus.Types.Internal.AST: Directive :: Name -> OrderedMap (Argument VALID) -> Directive

- Data.Morpheus.Types.Internal.AST: Fragment :: Key -> Position -> RawSelectionSet -> Fragment

+ Data.Morpheus.Types.Internal.AST: Fragment :: Name -> Name -> Position -> SelectionSet RAW -> Fragment

- Data.Morpheus.Types.Internal.AST: GQLQuery :: FragmentLib -> RawOperation -> [(Key, ResolvedValue)] -> GQLQuery

+ Data.Morpheus.Types.Internal.AST: GQLQuery :: Fragments -> Operation RAW -> [(Key, ResolvedValue)] -> GQLQuery

- Data.Morpheus.Types.Internal.AST: GQLTypeD :: TypeD -> DataTypeKind -> [TypeD] -> (Name, DataType) -> GQLTypeD

+ Data.Morpheus.Types.Internal.AST: GQLTypeD :: TypeD -> DataTypeKind -> [TypeD] -> TypeDefinition -> GQLTypeD

- Data.Morpheus.Types.Internal.AST: Operation :: Maybe Key -> OperationType -> Collection (Variable stage) -> SelectionSet stage -> Position -> Operation

+ Data.Morpheus.Types.Internal.AST: Operation :: Maybe Key -> OperationType -> VariableDefinitions s -> SelectionSet s -> Position -> Operation

- Data.Morpheus.Types.Internal.AST: Schema :: HashMap Name DataType -> (Name, DataType) -> Maybe (Name, DataType) -> Maybe (Name, DataType) -> Schema

+ Data.Morpheus.Types.Internal.AST: Schema :: TypeLib -> TypeDefinition -> Maybe TypeDefinition -> Maybe TypeDefinition -> Schema

- Data.Morpheus.Types.Internal.AST: Variable :: TypeRef -> Position -> VariableContent (VAR stage) -> Variable

+ Data.Morpheus.Types.Internal.AST: Variable :: Name -> TypeRef -> Position -> VariableContent (VAR stage) -> Variable

- Data.Morpheus.Types.Internal.AST: [Enum] :: Name -> Value a

+ Data.Morpheus.Types.Internal.AST: [Enum] :: Name -> Value stage

- Data.Morpheus.Types.Internal.AST: [List] :: [Value a] -> Value a

+ Data.Morpheus.Types.Internal.AST: [List] :: [Value stage] -> Value stage

- Data.Morpheus.Types.Internal.AST: [Null] :: Value a

+ Data.Morpheus.Types.Internal.AST: [Null] :: Value stage

- Data.Morpheus.Types.Internal.AST: [Object] :: Object a -> Value a

+ Data.Morpheus.Types.Internal.AST: [Object] :: Object stage -> Value stage

- Data.Morpheus.Types.Internal.AST: [Scalar] :: ScalarValue -> Value a

+ Data.Morpheus.Types.Internal.AST: [Scalar] :: ScalarValue -> Value stage

- Data.Morpheus.Types.Internal.AST: [SelectionField] :: SelectionContent valid

+ Data.Morpheus.Types.Internal.AST: [SelectionField] :: SelectionContent s

- Data.Morpheus.Types.Internal.AST: [SelectionSet] :: SelectionSet valid -> SelectionContent valid

+ Data.Morpheus.Types.Internal.AST: [SelectionSet] :: SelectionSet s -> SelectionContent s

- Data.Morpheus.Types.Internal.AST: [Selection] :: {selectionArguments :: Arguments valid, selectionPosition :: Position, selectionAlias :: Maybe Key, selectionContent :: SelectionContent valid} -> Selection valid

+ 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: [cFields] :: ConsD -> [DataField]

+ Data.Morpheus.Types.Internal.AST: [cFields] :: ConsD -> [FieldDefinition]

- Data.Morpheus.Types.Internal.AST: [dataScalar] :: DataTypeContent -> DataScalar

+ Data.Morpheus.Types.Internal.AST: [dataScalar] :: TypeContent -> ScalarDefinition

- Data.Morpheus.Types.Internal.AST: [directiveArgs] :: Directive -> [(Name, ValidValue)]

+ Data.Morpheus.Types.Internal.AST: [directiveArgs] :: Directive -> OrderedMap (Argument VALID)

- Data.Morpheus.Types.Internal.AST: [enumMembers] :: DataTypeContent -> DataEnum

+ Data.Morpheus.Types.Internal.AST: [enumMembers] :: TypeContent -> DataEnum

- Data.Morpheus.Types.Internal.AST: [fieldArgs] :: DataField -> [(Key, DataArgument)]

+ Data.Morpheus.Types.Internal.AST: [fieldArgs] :: FieldDefinition -> ArgumentsDefinition

- Data.Morpheus.Types.Internal.AST: [fieldMeta] :: DataField -> Maybe Meta

+ Data.Morpheus.Types.Internal.AST: [fieldMeta] :: FieldDefinition -> Maybe Meta

- Data.Morpheus.Types.Internal.AST: [fieldName] :: DataField -> Key

+ Data.Morpheus.Types.Internal.AST: [fieldName] :: FieldDefinition -> Key

- Data.Morpheus.Types.Internal.AST: [fieldType] :: DataField -> TypeRef

+ Data.Morpheus.Types.Internal.AST: [fieldType] :: FieldDefinition -> TypeRef

- Data.Morpheus.Types.Internal.AST: [fragmentSelection] :: Fragment -> RawSelectionSet

+ Data.Morpheus.Types.Internal.AST: [fragmentSelection] :: Fragment -> SelectionSet RAW

- Data.Morpheus.Types.Internal.AST: [fragmentType] :: Fragment -> Key

+ Data.Morpheus.Types.Internal.AST: [fragmentType] :: Fragment -> Name

- Data.Morpheus.Types.Internal.AST: [inputObjectFields] :: DataTypeContent -> DataObject

+ Data.Morpheus.Types.Internal.AST: [inputObjectFields] :: TypeContent -> InputFieldsDefinition

- Data.Morpheus.Types.Internal.AST: [inputUnionMembers] :: DataTypeContent -> [(Key, Bool)]

+ Data.Morpheus.Types.Internal.AST: [inputUnionMembers] :: TypeContent -> [(Key, Bool)]

- Data.Morpheus.Types.Internal.AST: [interfaceFields] :: DataTypeContent -> DataObject

+ Data.Morpheus.Types.Internal.AST: [interfaceFields] :: TypeContent -> FieldsDefinition

- Data.Morpheus.Types.Internal.AST: [mutation] :: Schema -> Maybe (Name, DataType)

+ Data.Morpheus.Types.Internal.AST: [mutation] :: Schema -> Maybe TypeDefinition

- Data.Morpheus.Types.Internal.AST: [objectFields] :: DataTypeContent -> DataObject

+ Data.Morpheus.Types.Internal.AST: [objectFields] :: TypeContent -> FieldsDefinition

- Data.Morpheus.Types.Internal.AST: [objectImplements] :: DataTypeContent -> [Name]

+ Data.Morpheus.Types.Internal.AST: [objectImplements] :: TypeContent -> [Name]

- Data.Morpheus.Types.Internal.AST: [operationArguments] :: Operation -> Collection (Variable stage)

+ Data.Morpheus.Types.Internal.AST: [operationArguments] :: Operation -> VariableDefinitions s

- Data.Morpheus.Types.Internal.AST: [operationSelection] :: Operation -> SelectionSet stage

+ Data.Morpheus.Types.Internal.AST: [operationSelection] :: Operation -> SelectionSet s

- Data.Morpheus.Types.Internal.AST: [query] :: Schema -> (Name, DataType)

+ Data.Morpheus.Types.Internal.AST: [query] :: Schema -> TypeDefinition

- Data.Morpheus.Types.Internal.AST: [subscription] :: Schema -> Maybe (Name, DataType)

+ Data.Morpheus.Types.Internal.AST: [subscription] :: Schema -> Maybe TypeDefinition

- Data.Morpheus.Types.Internal.AST: [typeContent] :: DataType -> DataTypeContent

+ Data.Morpheus.Types.Internal.AST: [typeContent] :: TypeDefinition -> TypeContent

- Data.Morpheus.Types.Internal.AST: [typeFingerprint] :: DataType -> DataFingerprint

+ Data.Morpheus.Types.Internal.AST: [typeFingerprint] :: TypeDefinition -> DataFingerprint

- Data.Morpheus.Types.Internal.AST: [typeMeta] :: DataType -> Maybe Meta

+ Data.Morpheus.Types.Internal.AST: [typeMeta] :: TypeDefinition -> Maybe Meta

- Data.Morpheus.Types.Internal.AST: [typeName] :: DataType -> Key

+ Data.Morpheus.Types.Internal.AST: [typeName] :: TypeDefinition -> Key

- Data.Morpheus.Types.Internal.AST: [typeOriginal] :: GQLTypeD -> (Name, DataType)

+ Data.Morpheus.Types.Internal.AST: [typeOriginal] :: GQLTypeD -> TypeDefinition

- Data.Morpheus.Types.Internal.AST: [types] :: Schema -> HashMap Name DataType

+ Data.Morpheus.Types.Internal.AST: [types] :: Schema -> TypeLib

- Data.Morpheus.Types.Internal.AST: [unionMembers] :: DataTypeContent -> DataUnion

+ Data.Morpheus.Types.Internal.AST: [unionMembers] :: TypeContent -> DataUnion

- Data.Morpheus.Types.Internal.AST: [validateValue] :: DataValidator -> ValidValue -> Either Key ValidValue

+ Data.Morpheus.Types.Internal.AST: [validateValue] :: ScalarDefinition -> ValidValue -> Either Key ValidValue

- Data.Morpheus.Types.Internal.AST: allDataTypes :: Schema -> [(Key, DataType)]

+ Data.Morpheus.Types.Internal.AST: allDataTypes :: Schema -> [TypeDefinition]

- Data.Morpheus.Types.Internal.AST: createArgument :: Key -> ([TypeWrapper], Key) -> (Key, DataField)

+ Data.Morpheus.Types.Internal.AST: createArgument :: Key -> ([TypeWrapper], Key) -> FieldDefinition

- Data.Morpheus.Types.Internal.AST: createDataTypeLib :: [(Key, DataType)] -> Validation Schema

+ Data.Morpheus.Types.Internal.AST: createDataTypeLib :: Failure Message m => [TypeDefinition] -> m Schema

- Data.Morpheus.Types.Internal.AST: createEnumType :: Key -> [Key] -> (Key, DataType)

+ Data.Morpheus.Types.Internal.AST: createEnumType :: Name -> [Key] -> TypeDefinition

- Data.Morpheus.Types.Internal.AST: createEnumValue :: Key -> DataEnumValue

+ Data.Morpheus.Types.Internal.AST: createEnumValue :: Name -> DataEnumValue

- Data.Morpheus.Types.Internal.AST: createField :: DataArguments -> Key -> ([TypeWrapper], Key) -> DataField

+ Data.Morpheus.Types.Internal.AST: createField :: ArgumentsDefinition -> Key -> ([TypeWrapper], Key) -> FieldDefinition

- Data.Morpheus.Types.Internal.AST: createInputUnionFields :: Key -> [Key] -> [(Key, DataField)]

+ Data.Morpheus.Types.Internal.AST: createInputUnionFields :: Key -> [Key] -> [FieldDefinition]

- Data.Morpheus.Types.Internal.AST: createScalarType :: Key -> (Key, DataType)

+ Data.Morpheus.Types.Internal.AST: createScalarType :: Name -> TypeDefinition

- Data.Morpheus.Types.Internal.AST: createType :: Key -> DataTypeContent -> DataType

+ Data.Morpheus.Types.Internal.AST: createType :: Key -> TypeContent -> TypeDefinition

- Data.Morpheus.Types.Internal.AST: createUnionType :: Key -> [Key] -> (Key, DataType)

+ Data.Morpheus.Types.Internal.AST: createUnionType :: Key -> [Key] -> TypeDefinition

- Data.Morpheus.Types.Internal.AST: data Operation (stage :: Stage)

+ Data.Morpheus.Types.Internal.AST: data Operation (s :: Stage)

- Data.Morpheus.Types.Internal.AST: data Selection (valid :: Stage)

+ Data.Morpheus.Types.Internal.AST: data Selection (s :: Stage)

- Data.Morpheus.Types.Internal.AST: data SelectionContent (valid :: Stage)

+ Data.Morpheus.Types.Internal.AST: data SelectionContent (s :: Stage)

- Data.Morpheus.Types.Internal.AST: data Value (valid :: Stage)

+ Data.Morpheus.Types.Internal.AST: data Value (stage :: Stage)

- Data.Morpheus.Types.Internal.AST: defineType :: (Key, DataType) -> Schema -> Schema

+ Data.Morpheus.Types.Internal.AST: defineType :: TypeDefinition -> Schema -> Schema

- Data.Morpheus.Types.Internal.AST: fieldVisibility :: (Key, DataField) -> Bool

+ Data.Morpheus.Types.Internal.AST: fieldVisibility :: FieldDefinition -> Bool

- Data.Morpheus.Types.Internal.AST: getOperationDataType :: Operation a -> Schema -> Validation DataType

+ Data.Morpheus.Types.Internal.AST: getOperationDataType :: Failure GQLErrors m => Operation a -> Schema -> m TypeDefinition

- Data.Morpheus.Types.Internal.AST: initTypeLib :: (Key, DataType) -> Schema

+ Data.Morpheus.Types.Internal.AST: initTypeLib :: TypeDefinition -> Schema

- Data.Morpheus.Types.Internal.AST: insertType :: (Key, DataType) -> TypeUpdater

+ Data.Morpheus.Types.Internal.AST: insertType :: TypeDefinition -> TypeUpdater

- Data.Morpheus.Types.Internal.AST: isEntNode :: DataTypeContent -> Bool

+ Data.Morpheus.Types.Internal.AST: isEntNode :: TypeContent -> Bool

- Data.Morpheus.Types.Internal.AST: isFieldNullable :: DataField -> Bool

+ Data.Morpheus.Types.Internal.AST: isFieldNullable :: FieldDefinition -> Bool

- Data.Morpheus.Types.Internal.AST: kindOf :: DataType -> DataTypeKind

+ Data.Morpheus.Types.Internal.AST: kindOf :: TypeDefinition -> DataTypeKind

- Data.Morpheus.Types.Internal.AST: lookupDataType :: Key -> Schema -> Maybe DataType

+ Data.Morpheus.Types.Internal.AST: lookupDataType :: Key -> Schema -> Maybe TypeDefinition

- Data.Morpheus.Types.Internal.AST: toListField :: DataField -> DataField

+ Data.Morpheus.Types.Internal.AST: toListField :: FieldDefinition -> FieldDefinition

- Data.Morpheus.Types.Internal.AST: toNullableField :: DataField -> DataField

+ Data.Morpheus.Types.Internal.AST: toNullableField :: FieldDefinition -> FieldDefinition

- Data.Morpheus.Types.Internal.AST: type Arguments a = Collection (Argument a)

+ Data.Morpheus.Types.Internal.AST: type Arguments s = OrderedMap (Argument s)

- Data.Morpheus.Types.Internal.AST: type Object a = Collection (Value a)

+ Data.Morpheus.Types.Internal.AST: type Object a = OrderedMap (ObjectEntry a)

- Data.Morpheus.Types.Internal.AST: type SelectionSet a = Collection (Selection a)

+ Data.Morpheus.Types.Internal.AST: type SelectionSet s = MergeSet (Selection s)

- Data.Morpheus.Types.Internal.AST: type VariableDefinitions = Collection (Variable RAW)

+ Data.Morpheus.Types.Internal.AST: type VariableDefinitions s = OrderedMap (Variable s)

Files

README.md +75/−12
changelog.md +73/−23
morpheus-graphql.cabal +44/−14
src/Data/Morpheus/Client.hs +2/−2
src/Data/Morpheus/Document.hs +10/−9
src/Data/Morpheus/Error/Arguments.hs +0/−62
src/Data/Morpheus/Error/Client/Client.hs +11/−7
src/Data/Morpheus/Error/Document/Interface.hs +2/−3
src/Data/Morpheus/Error/Fragment.hs +9/−38
src/Data/Morpheus/Error/Input.hs +29/−67
src/Data/Morpheus/Error/Internal.hs +11/−26
src/Data/Morpheus/Error/Mutation.hs +0/−16
src/Data/Morpheus/Error/NameCollision.hs +12/−0
src/Data/Morpheus/Error/Operation.hs +21/−0
src/Data/Morpheus/Error/Schema.hs +1/−1
src/Data/Morpheus/Error/Selection.hs +13/−38
src/Data/Morpheus/Error/Subscription.hs +0/−16
src/Data/Morpheus/Error/Utils.hs +7/−18
src/Data/Morpheus/Error/Variable.hs +23/−63
src/Data/Morpheus/Execution/Client/Aeson.hs +31/−19
src/Data/Morpheus/Execution/Client/Build.hs +7/−8
src/Data/Morpheus/Execution/Client/Compile.hs +2/−2
src/Data/Morpheus/Execution/Client/Fetch.hs +1/−0
src/Data/Morpheus/Execution/Client/Selection.hs +81/−89
src/Data/Morpheus/Execution/Document/Compile.hs +3/−3
src/Data/Morpheus/Execution/Document/Convert.hs +71/−90
src/Data/Morpheus/Execution/Document/Declare.hs +10/−8
src/Data/Morpheus/Execution/Document/Decode.hs +2/−2
src/Data/Morpheus/Execution/Document/Encode.hs +13/−4
src/Data/Morpheus/Execution/Document/GQLType.hs +30/−29
src/Data/Morpheus/Execution/Document/Introspect.hs +35/−44
src/Data/Morpheus/Execution/Internal/Declare.hs +29/−13
src/Data/Morpheus/Execution/Internal/Decode.hs +30/−22
src/Data/Morpheus/Execution/Server/Decode.hs +23/−20
src/Data/Morpheus/Execution/Server/Encode.hs +120/−100
src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs +2/−2
src/Data/Morpheus/Execution/Server/Interpreter.hs +18/−91
src/Data/Morpheus/Execution/Server/Introspect.hs +100/−114
src/Data/Morpheus/Execution/Server/Resolve.hs +36/−94
src/Data/Morpheus/Execution/Server/Subscription.hs +0/−105
src/Data/Morpheus/Parsing/Document/Parser.hs +0/−37
src/Data/Morpheus/Parsing/Document/TypeSystem.hs +82/−89
src/Data/Morpheus/Parsing/Internal/Arguments.hs +62/−0
src/Data/Morpheus/Parsing/Internal/Internal.hs +33/−15
src/Data/Morpheus/Parsing/Internal/Pattern.hs +37/−37
src/Data/Morpheus/Parsing/Internal/Terms.hs +27/−8
src/Data/Morpheus/Parsing/Internal/Value.hs +15/−10
src/Data/Morpheus/Parsing/JSONSchema/Parse.hs +24/−21
src/Data/Morpheus/Parsing/Request/Arguments.hs +0/−45
src/Data/Morpheus/Parsing/Request/Operation.hs +16/−30
src/Data/Morpheus/Parsing/Request/Parser.hs +12/−19
src/Data/Morpheus/Parsing/Request/Selection.hs +29/−50
src/Data/Morpheus/Rendering/RenderGQL.hs +58/−48
src/Data/Morpheus/Rendering/RenderIntrospection.hs +39/−34
src/Data/Morpheus/Schema/SchemaAPI.hs +7/−7
src/Data/Morpheus/Server.hs +86/−98
src/Data/Morpheus/Types.hs +6/−0
src/Data/Morpheus/Types/GQLScalar.hs +3/−3
src/Data/Morpheus/Types/GQLType.hs +1/−1
src/Data/Morpheus/Types/ID.hs +7/−0
src/Data/Morpheus/Types/IO.hs +60/−7
src/Data/Morpheus/Types/Internal/AST.hs +53/−95
src/Data/Morpheus/Types/Internal/AST/Base.hs +205/−37
src/Data/Morpheus/Types/Internal/AST/Data.hs +396/−433
src/Data/Morpheus/Types/Internal/AST/MergeSet.hs +106/−0
src/Data/Morpheus/Types/Internal/AST/OrderedMap.hs +111/−0
src/Data/Morpheus/Types/Internal/AST/Selection.hs +175/−107
src/Data/Morpheus/Types/Internal/AST/Value.hs +73/−23
src/Data/Morpheus/Types/Internal/Apollo.hs +0/−92
src/Data/Morpheus/Types/Internal/Operation.hs +100/−0
src/Data/Morpheus/Types/Internal/Resolving.hs +8/−10
src/Data/Morpheus/Types/Internal/Resolving/Core.hs +46/−60
src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs +278/−148
src/Data/Morpheus/Types/Internal/Subscription.hs +131/−0
src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs +144/−0
src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs +162/−0
src/Data/Morpheus/Types/Internal/Subscription/Stream.hs +235/−0
src/Data/Morpheus/Types/Internal/Validation.hs +354/−0
src/Data/Morpheus/Types/Internal/Validation/Error.hs +201/−0
src/Data/Morpheus/Types/Internal/Validation/Validator.hs +226/−0
src/Data/Morpheus/Types/Internal/WebSocket.hs +0/−47
src/Data/Morpheus/Validation/Document/Validation.hs +32/−33
src/Data/Morpheus/Validation/Internal/Value.hs +120/−127
src/Data/Morpheus/Validation/Query/Arguments.hs +87/−125
src/Data/Morpheus/Validation/Query/Fragment.hs +90/−78
src/Data/Morpheus/Validation/Query/Selection.hs +163/−192
src/Data/Morpheus/Validation/Query/UnionSelection.hs +127/−0
src/Data/Morpheus/Validation/Query/Validation.hs +51/−30
src/Data/Morpheus/Validation/Query/Variable.hs +86/−96
test/Feature/Holistic/API.hs +8/−7
test/Feature/Holistic/arguments/nameConflict/response.json +1/−1
test/Feature/Holistic/arguments/undefinedArgument/response.json +1/−1
test/Feature/Holistic/arguments/unknownArguments/query.gql +1/−1
test/Feature/Holistic/arguments/unknownArguments/response.json +2/−2
test/Feature/Holistic/cases.json +36/−4
test/Feature/Holistic/fragment/conditionTypeViolation/query.gql +8/−0
test/Feature/Holistic/fragment/conditionTypeViolation/response.json +13/−0
test/Feature/Holistic/fragment/loopingFragment/response.json +86/−3
test/Feature/Holistic/fragment/unknownConditionType/query.gql +8/−0
test/Feature/Holistic/fragment/unknownConditionType/response.json +13/−0
test/Feature/Holistic/parsing/complex/response.json +46/−11
test/Feature/Holistic/parsing/directive/notOnArgument/response.json +1/−1
test/Feature/Holistic/parsing/duplicatedFields/response.json +4/−10
test/Feature/Holistic/parsing/extraCommas/query.gql +7/−7
test/Feature/Holistic/parsing/extraCommas/response.json +5/−29
test/Feature/Holistic/parsing/inputListValues/query.gql +19/−0
test/Feature/Holistic/parsing/inputListValues/response.json +14/−0
test/Feature/Holistic/parsing/inputListValues/variables.json +5/−0
test/Feature/Holistic/schema.gql +1/−0
test/Feature/Holistic/selection/AliasNameConflict/query.gql +0/−8
test/Feature/Holistic/selection/AliasNameConflict/response.json +0/−22
test/Feature/Holistic/selection/mergeConflict/alias/query.gql +19/−0
test/Feature/Holistic/selection/mergeConflict/alias/response.json +25/−0
test/Feature/Holistic/selection/mergeConflict/arguments/query.gql +19/−0
test/Feature/Holistic/selection/mergeConflict/arguments/response.json +25/−0
test/Feature/Holistic/selection/mergeConflict/union/query.gql +20/−0
test/Feature/Holistic/selection/mergeConflict/union/response.json +17/−0
test/Feature/Holistic/selection/mergeSelection/query.gql +32/−0
test/Feature/Holistic/selection/mergeSelection/response.json +15/−0
test/Feature/Holistic/selection/mergeUnionSelection/query.gql +19/−0
test/Feature/Holistic/selection/mergeUnionSelection/response.json +12/−0
test/Feature/Holistic/selection/nameConflict/query.gql +0/−7
test/Feature/Holistic/selection/nameConflict/response.json +0/−22
test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql +8/−0
test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json +13/−0
test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql +11/−0
test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json +22/−0
test/Feature/Input/Enum/decodeInvalidValue/query.gql +1/−1
test/Feature/Input/Enum/decodeInvalidValue/response.json +2/−2
test/Feature/Input/Object/API.hs +2/−1
test/Feature/Input/Object/nullableUndefinedField/response.json +1/−1
test/Feature/Input/Object/resolveObject/query.gql +1/−1
test/Feature/Input/Object/resolveObject/response.json +2/−2
test/Feature/Input/Object/resolveVariable/response.json +2/−2
test/Feature/Input/Object/undefinedField/query.gql +2/−1
test/Feature/Input/Object/undefinedField/response.json +23/−4
test/Feature/Input/Object/unexpectedValue/query.gql +3/−0
test/Feature/Input/Object/unexpectedValue/response.json +46/−8
test/Feature/Input/Object/unknownField/query.gql +3/−2
test/Feature/Input/Object/unknownField/response.json +16/−2
test/Feature/InputType/cases.json +8/−0
test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json +1/−1
test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json +1/−1
test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json +1/−1
test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json +1/−1
test/Feature/InputType/variables/nameCollision/query.gql +5/−0
test/Feature/InputType/variables/nameCollision/response.json +13/−0
test/Feature/InputType/variables/nameCollision/variables.json +5/−0
test/Feature/InputType/variables/nonInputTypeViolation/query.gql +5/−0
test/Feature/InputType/variables/nonInputTypeViolation/response.json +13/−0
test/Feature/TypeInference/API.hs +9/−10
test/Feature/TypeInference/introspection/complexInput/response.json +16/−4
test/Feature/TypeInference/resolving/complexUnion/response.json +40/−9
test/Feature/TypeInference/resolving/input/query.gql +3/−3
test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json +1/−1
test/TestFeature.hs +5/−2

README.md view

@@ -29,7 +29,7 @@ resolver: lts-14.8  extra-deps:-  - morpheus-graphql-0.10.0+  - morpheus-graphql-0.11.0 ```  As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`@@ -53,7 +53,7 @@   Description for name   """   name: String!-  power: String String! @deprecated(reason: "some reason for")+  power: String @deprecated(reason: "some reason for") } ``` @@ -76,7 +76,7 @@  import           Data.Morpheus              (interpreter) import           Data.Morpheus.Document     (importGQLDocumentWithNamespace)-import           Data.Morpheus.Types        (GQLRootResolver (..), IORes)+import           Data.Morpheus.Types        (GQLRootResolver (..), IORes, Undefined(..)) import           Data.Text                  (Text)  importGQLDocumentWithNamespace "schema.gql"@@ -253,12 +253,12 @@  ```gql union Character =-    Deity # unwrapped union: becouse Character + Deity = CharacterDeity+    Deity # unwrapped union: because "Character" <> "Deity" == "CharacterDeity"   | Creature-  | SomeDeity # wrapped union: becouse Character + Deity != SomeDeity+  | SomeDeity # wrapped union: because "Character" <> "Deity" /= SomeDeity   | CharacterInt   | SomeMutli-  | CharacterEnumObject # object wrapped for enums+  | CharacterEnumObject # no-argument constructors all wrapped into an enum  type Creature {   creatureName: String!@@ -289,10 +289,60 @@ } ``` -- namespaced Unions: `CharacterDeity` where `Character` is TypeConstructor and `Deity` referenced object (not scalar) type: will be generate regular graphql Union-  -- for all other unions will be generated new object type. for types without record syntaxt, fields will be automatally indexed.+By default, union members will be generated with wrapper objects.+There is one exception to this: if a constructor of a type is the type name concatinated with the name of the contained type, it will be referenced directly.+That is, given: +```haskell+data Song = { songName :: Text, songDuration :: Float } deriving (Generic, GQLType)++data Skit = { skitName :: Text, skitDuration :: Float } deriving (Generic, GQLType)++data WrappedNode+  = WrappedSong Song+  | WrappedSkit Skit+  deriving (Generic, GQLType)++data NonWrapped+  = NonWrappedSong Song+  | NonWrappedSkit Skit+  deriving (Generic, GQLType)++```++You will get the following schema:+++```gql++# has wrapper types+union WrappedNode = WrappedSong | WrappedSkit++# is a direct union+union NonWrapped = Song | Skit++type WrappedSong {+  _0: Song!+}++type WrappedSKit {+  _0: Skit!+}++type Song {+  songDuration: Float!+  songName: String!+}++type Skit {+  skitDuration: Float!+  skitName: String!+}++```++- for all other unions will be generated new object type. for types without record syntax, fields will be automatally indexed.+ - all empty constructors in union will be summed in type `<tyConName>Enum` (e.g `CharacterEnum`), this enum will be wrapped in `CharacterEnumObject` and added to union members.  ### Scalar types@@ -361,7 +411,7 @@  ### Mutations -In addition to queries, Morpheus also supports mutations. The behave just like regular queries and are defined similarly:+In addition to queries, Morpheus also supports mutations. They behave just like regular queries and are defined similarly:  ```haskell newtype Mutation m = Mutation@@ -386,7 +436,7 @@  ### Subscriptions -im morpheus subscription and mutation communicating with Events,+In morpheus subscription and mutation communicate with Events, `Event` consists with user defined `Channel` and `Content`.  Every subscription has its own Channel by which it will be triggered@@ -467,7 +517,14 @@ type Deity {   name: String!   worships: Deity+  power: Power! }++enum Power {+  Lightning+  Teleportation+  Omniscience+} ```  will validate query and Generate:@@ -484,6 +541,7 @@ data DeityDeity = DeityDeity {   name: Text,   worships: Maybe DeityWorshipsDeity+  power: Power }  -- from: {deity{worships@@ -491,6 +549,11 @@   name: Text, } +data Power =+    PowerLightning+  | PowerTeleportation+  | PowerOmniscience+ data GetHeroArgs = GetHeroArgs {   getHeroArgsCharacter: Character }@@ -513,7 +576,7 @@         jsonRes = <GraphQL APi> ``` -in this case, `jsonRes` is resolves a request into a response in some monad `m`.+in this case, `jsonRes` resolves a request into a response in some monad `m`.  A `fetch` resolver implementation against [a real API](https://swapi.graph.cool) may look like the following:

changelog.md view

@@ -1,5 +1,55 @@ # Changelog +## 0.11.0 - 01.05.2020++### Breaking Changes++- Client generated enum data constructors are now prefixed with with the type name to avoid name conflicts.+- for Variant selection inputUnion uses `inputname` insead of `__typename`++- in `Data.Morpheus.Server`  +  - `gqlSocketApp` and `gqlSocketMonadIOApp` are replaced with `webSocketsApp`+  - removed `initGQLState`, `GQLState`++- for better control of subscriptions+  - replaced instance  `interpreter gqlRoot state` with+    `interpreter gqlRoot`.+  - added: `Input`, `Stream`, `httpPubApp`+  +  from now on you can define API that can be+  used in websockets as well as in http servers++  ```hs+  api :: Input api -> Stream api EVENT IO+  api = interpreter gqlRoot+  +  server :: IO ()+  server = do+    (wsApp, publish) <- webSocketsApp api+    let httpApp = httpPubApp api publish+    ...+    runBoth wsApp httpApp+  ```+  +  where `publish :: e -> m ()`++  websockets and http app do not have to be on the same server. +  e.g. you can pass events between servers with webhooks.++- subscription can select only one top level field (based on the GraphQL specification).++### New features++- Instead of rejecting conflicting selections, they are merged (based on the GraphQL specification).+- Support for input lists separated by newlines. thanks @charlescrain+- conflicting variable , fragment ... validation+- issue #411: Aeson `FromJSON` `ToJSON` instances for `ID`++### minor++- changes to internal types+- fixed validation of apollo websockets requests  + ## 0.10.0 - 07.01.2020  ### Breaking Changes@@ -23,7 +73,7 @@   resolveNewUser = subscribe [USER] $ do     pure $ \(Event _ content) -> lift (getDBUserByContent content)   ```-  + ### New features  - exposed `publish` for mutation resolvers, now you can write@@ -49,9 +99,9 @@ - `type SubField` will convert your subscription monad to query monad.   `SubField (Resolver Subscription Event IO) User` will generate same as   `Resolver Subscription Event IO (User ((Resolver QUERY Event IO)))`-  +   now if you want define subscription as follows-  +   ```hs   data Subscription m = Subscription {     newUser :: SubField m User@@ -60,7 +110,7 @@  - `unsafeInternalContext` to get resolver context, use only if it really necessary.   the code depending on it may break even on minor version changes.-  +   ```hs   resolveUser :: ResolveQ EVENT IO User   resolveUser = do@@ -68,10 +118,10 @@     lift (getDBUser currentSelection)   ``` -### Minor+### minor -- MonadIO instance for resolvers. Thanks @dandoh-- Example using STM, authentication, monad transformers. Thanks @dandoh+- monadio instance for resolvers. thanks @dandoh+- example using stm, authentication, monad transformers. thanks @dandoh - added dependency `mtl`  ## [0.9.1] - 02.01.2020@@ -91,9 +141,9 @@ - auto inferece of external types in gql document (#343)    th will generate field `m (Type m)` if type has an argument-  +   e.g for this types and DSL-  +   ```hs   data Type1 = Type1 { ... }   type Type2 m = SomeType m@@ -102,11 +152,11 @@    ```gql   type Query {-    field1 : Type1!-    field2 : Type2!-    field3 : Type3!+    field1: Type1!+    field2: Type2!+    field3: Type3!   }-  ```  +  ```    morpheus generates @@ -119,7 +169,7 @@   ```    now you can combine multiple gql documents:-  +   ```hs   importDocumentWithNamespace `coreTypes.gql`   importDocumentWithNamespace `operations.gql`@@ -139,7 +189,7 @@   }   ``` -- template haskell generates `m type`  insead of `() -> m type` for fields without argument (#334)+- template haskell generates `m type` insead of `() -> m type` for fields without argument (#334)    ```hs   data Diety m = Deity {@@ -162,10 +212,10 @@   - use `INPUT` instead of `INPUT_OBJECT`   - use `deriving(GQLType)` insead of `OBJECT` or `UNION` -- only namespaced Unions  generate regular graphql Union, other attempts will be wrapped inside an object with constructor name :+- only namespaced Unions generate regular graphql Union, other attempts will be wrapped inside an object with constructor name :    e.g:-  +   ```hs   data Character =     CharacterDeity Deity@@ -177,11 +227,11 @@   will generate    ```gql-    union CHaracter = Deity | SomeDeity+  union CHaracter = Deity | SomeDeity -    type SomeDeity {-      _0: Deity-    }+  type SomeDeity {+    _0: Deity+  }   ```  ### Added@@ -322,7 +372,7 @@  - on filed resolver was displayed. unexhausted case exception of graphql error - support of signed numbers (e.g `-4`)-- support of round floats (e.g `1.000`) +- support of round floats (e.g `1.000`) - validation checks undefined fields on inputObject - variables are supported inside input values @@ -502,7 +552,7 @@    ```gql   mutation {-     name+    name   }   ```

morpheus-graphql.cabal view

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: acb4d101970b68e1e9b3790252120726595167c2154a4861772462f29501c7bb+-- hash: e10665dda7dcb75f84d447086dcbd786a36aea915278bd6bbf4285a01cf9d21a  name:           morpheus-graphql-version:        0.10.0+version:        0.11.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -28,10 +28,12 @@     test/Feature/Holistic/arguments/unknownArguments/query.gql     test/Feature/Holistic/failure/resolveFailure/query.gql     test/Feature/Holistic/fragment/cannotBeSpreadOnType/query.gql+    test/Feature/Holistic/fragment/conditionTypeViolation/query.gql     test/Feature/Holistic/fragment/inlineFragment/query.gql     test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/query.gql     test/Feature/Holistic/fragment/loopingFragment/query.gql     test/Feature/Holistic/fragment/nameCollision/query.gql+    test/Feature/Holistic/fragment/unknownConditionType/query.gql     test/Feature/Holistic/fragment/unknownTargetType/query.gql     test/Feature/Holistic/fragment/unusedFragment/query.gql     test/Feature/Holistic/introspection/defaultTypes/Boolean/query.gql@@ -69,6 +71,7 @@     test/Feature/Holistic/parsing/duplicatedFields/query.gql     test/Feature/Holistic/parsing/extraCommas/query.gql     test/Feature/Holistic/parsing/generousSpaces/query.gql+    test/Feature/Holistic/parsing/inputListValues/query.gql     test/Feature/Holistic/parsing/invalidFields/query.gql     test/Feature/Holistic/parsing/invalidNotNullOperator/query.gql     test/Feature/Holistic/parsing/missingCloseBrace/query.gql@@ -77,12 +80,17 @@     test/Feature/Holistic/parsing/singleLineComments/query.gql     test/Feature/Holistic/schema.gql     test/Feature/Holistic/selection/__typename/query.gql-    test/Feature/Holistic/selection/AliasNameConflict/query.gql     test/Feature/Holistic/selection/AliasResolve/query.gql     test/Feature/Holistic/selection/AliasUnknownField/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+    test/Feature/Holistic/selection/mergeConflict/union/query.gql+    test/Feature/Holistic/selection/mergeSelection/query.gql+    test/Feature/Holistic/selection/mergeUnionSelection/query.gql     test/Feature/Holistic/selection/mustHaveSubFields/query.gql-    test/Feature/Holistic/selection/nameConflict/query.gql+    test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql+    test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql     test/Feature/Holistic/selection/unknownField/query.gql     test/Feature/Input/Enum/decode2Con/query.gql     test/Feature/Input/Enum/decode3Con/query.gql@@ -112,7 +120,9 @@     test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/query.gql     test/Feature/InputType/variables/invalidValue/invalidListVariable/query.gql     test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/query.gql+    test/Feature/InputType/variables/nameCollision/query.gql     test/Feature/InputType/variables/nestedListNullableListReceivedNull/query.gql+    test/Feature/InputType/variables/nonInputTypeViolation/query.gql     test/Feature/InputType/variables/undefinedVariable/query.gql     test/Feature/InputType/variables/unknownType/query.gql     test/Feature/InputType/variables/unusedVariable/unusedVariables/query.gql@@ -153,10 +163,12 @@     test/Feature/Holistic/cases.json     test/Feature/Holistic/failure/resolveFailure/response.json     test/Feature/Holistic/fragment/cannotBeSpreadOnType/response.json+    test/Feature/Holistic/fragment/conditionTypeViolation/response.json     test/Feature/Holistic/fragment/inlineFragment/response.json     test/Feature/Holistic/fragment/inlineFragmentTypeMismatch/response.json     test/Feature/Holistic/fragment/loopingFragment/response.json     test/Feature/Holistic/fragment/nameCollision/response.json+    test/Feature/Holistic/fragment/unknownConditionType/response.json     test/Feature/Holistic/fragment/unknownTargetType/response.json     test/Feature/Holistic/fragment/unusedFragment/response.json     test/Feature/Holistic/introspection/defaultTypes/Boolean/response.json@@ -194,6 +206,8 @@     test/Feature/Holistic/parsing/duplicatedFields/response.json     test/Feature/Holistic/parsing/extraCommas/response.json     test/Feature/Holistic/parsing/generousSpaces/response.json+    test/Feature/Holistic/parsing/inputListValues/response.json+    test/Feature/Holistic/parsing/inputListValues/variables.json     test/Feature/Holistic/parsing/invalidFields/response.json     test/Feature/Holistic/parsing/invalidNotNullOperator/response.json     test/Feature/Holistic/parsing/missingCloseBrace/response.json@@ -202,12 +216,17 @@     test/Feature/Holistic/parsing/numbers/response.json     test/Feature/Holistic/parsing/singleLineComments/response.json     test/Feature/Holistic/selection/__typename/response.json-    test/Feature/Holistic/selection/AliasNameConflict/response.json     test/Feature/Holistic/selection/AliasResolve/response.json     test/Feature/Holistic/selection/AliasUnknownField/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+    test/Feature/Holistic/selection/mergeConflict/union/response.json+    test/Feature/Holistic/selection/mergeSelection/response.json+    test/Feature/Holistic/selection/mergeUnionSelection/response.json     test/Feature/Holistic/selection/mustHaveSubFields/response.json-    test/Feature/Holistic/selection/nameConflict/response.json+    test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json+    test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json     test/Feature/Holistic/selection/unknownField/response.json     test/Feature/Input/Enum/cases.json     test/Feature/Input/Enum/decode2Con/response.json@@ -250,8 +269,11 @@     test/Feature/InputType/variables/invalidValue/invalidListVariable/variables.json     test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json     test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/variables.json+    test/Feature/InputType/variables/nameCollision/response.json+    test/Feature/InputType/variables/nameCollision/variables.json     test/Feature/InputType/variables/nestedListNullableListReceivedNull/response.json     test/Feature/InputType/variables/nestedListNullableListReceivedNull/variables.json+    test/Feature/InputType/variables/nonInputTypeViolation/response.json     test/Feature/InputType/variables/undefinedVariable/response.json     test/Feature/InputType/variables/unknownType/response.json     test/Feature/InputType/variables/unusedVariable/unusedVariables/response.json@@ -308,16 +330,15 @@       Data.Morpheus.Client       Data.Morpheus.Types.Internal.AST   other-modules:-      Data.Morpheus.Error.Arguments       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.Mutation+      Data.Morpheus.Error.NameCollision+      Data.Morpheus.Error.Operation       Data.Morpheus.Error.Schema       Data.Morpheus.Error.Selection-      Data.Morpheus.Error.Subscription       Data.Morpheus.Error.Utils       Data.Morpheus.Error.Variable       Data.Morpheus.Execution.Client.Aeson@@ -341,16 +362,14 @@       Data.Morpheus.Execution.Server.Interpreter       Data.Morpheus.Execution.Server.Introspect       Data.Morpheus.Execution.Server.Resolve-      Data.Morpheus.Execution.Server.Subscription-      Data.Morpheus.Parsing.Document.Parser       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.Arguments       Data.Morpheus.Parsing.Request.Operation       Data.Morpheus.Parsing.Request.Parser       Data.Morpheus.Parsing.Request.Selection@@ -362,16 +381,24 @@       Data.Morpheus.Types.GQLScalar       Data.Morpheus.Types.GQLType       Data.Morpheus.Types.ID-      Data.Morpheus.Types.Internal.Apollo       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+      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.WebSocket+      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@@ -379,6 +406,7 @@       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@@ -397,6 +425,7 @@     , 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     , unordered-containers >=0.2.8.0 && <0.3     , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13@@ -440,6 +469,7 @@     , 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     , unordered-containers >=0.2.8.0 && <0.3     , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13

src/Data/Morpheus/Client.hs view

@@ -29,7 +29,7 @@ import           Data.Morpheus.Parsing.JSONSchema.Parse                                                 ( decodeIntrospection ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Eventless ) import           Data.Morpheus.Types.Internal.AST                                                 ( GQLQuery                                                 , Schema@@ -59,7 +59,7 @@ defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec] defineByDocument doc = defineQuery (schemaByDocument doc) -schemaByDocument :: IO ByteString -> IO (Validation Schema)+schemaByDocument :: IO ByteString -> IO (Eventless Schema) schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL  defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec]

src/Data/Morpheus/Document.hs view

@@ -31,11 +31,12 @@                                                 ( RootResCon                                                 , fullSchema                                                 )-import           Data.Morpheus.Parsing.Document.Parser-                                                ( parseTypes )-+import           Data.Morpheus.Parsing.Document.TypeSystem+                                                ( parseSchema +                                                ) import           Data.Morpheus.Rendering.RenderGQL-                                                ( renderGraphQLDocument )+                                                ( renderGraphQLDocument +                                                ) import           Data.Morpheus.Schema.SchemaAPI ( defaultTypes ) import           Data.Morpheus.Types            ( GQLRootResolver ) import           Data.Morpheus.Types.Internal.AST@@ -43,7 +44,7 @@                                                 , createDataTypeLib                                                 ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+                                                ( Eventless                                                 , Result(..)                                                 ) import           Data.Morpheus.Validation.Document.Validation@@ -56,14 +57,14 @@   Success { result } -> Right result  -parseDocument :: Text -> Validation Schema+parseDocument :: Text -> Eventless Schema parseDocument doc =-  parseTypes doc >>= validatePartialDocument >>= createDataTypeLib+  parseSchema doc >>= validatePartialDocument >>= createDataTypeLib -parseGraphQLDocument :: ByteString -> Validation Schema+parseGraphQLDocument :: ByteString -> Eventless Schema parseGraphQLDocument x = parseDocument (LT.toStrict $ decodeUtf8 x) -parseFullGQLDocument :: ByteString -> Validation Schema+parseFullGQLDocument :: ByteString -> Eventless Schema parseFullGQLDocument = parseGraphQLDocument >=> defaultTypes  -- | Generates schema.gql file from 'GQLRootResolver'

− src/Data/Morpheus/Error/Arguments.hs

@@ -1,62 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Arguments-  ( undefinedArgument-  , unknownArguments-  , argumentGotInvalidValue-  , argumentNameCollision-  )-where--import           Data.Morpheus.Error.Utils      ( errorMessage )-import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Ref(..)-                                                , Position-                                                )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)-                                                , GQLErrors-                                                )-import           Data.Text                      ( Text )-import qualified Data.Text                     as T-                                                ( concat )--{--  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\"."--}-argumentGotInvalidValue :: Text -> Text -> Position -> GQLErrors-argumentGotInvalidValue key' inputMessage' position' = errorMessage position'-                                                                    text- where-  text = T.concat ["Argument ", key', " got invalid value ;", inputMessage']--unknownArguments :: Text -> [Ref] -> GQLErrors-unknownArguments fieldName = map keyToError- where-  keyToError (Ref argName pos) =-    GQLError { message = toMessage argName, locations = [pos] }-  toMessage argName = T.concat-    ["Unknown Argument \"", argName, "\" on Field \"", fieldName, "\"."]--argumentNameCollision :: [Ref] -> GQLErrors-argumentNameCollision = map keyToError- where-  keyToError (Ref argName pos) =-    GQLError { message = toMessage argName, locations = [pos] }-  toMessage argName =-    T.concat ["There can Be only One Argument Named \"", argName, "\""]--undefinedArgument :: Ref -> GQLErrors-undefinedArgument (Ref key' position') = errorMessage position' text-  where text = T.concat ["Required Argument: \"", key', "\" was not Defined"]

src/Data/Morpheus/Error/Client/Client.hs view

@@ -9,21 +9,25 @@   ) 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.Resolving.Core-                                                ( GQLErrors ) import           Data.Morpheus.Types.Internal.AST.Base                                                 ( Ref(..)                                                 , Description                                                 , Name-                                                )-import           Language.Haskell.TH            ( Q-                                                , reportWarning+                                                , GQLErrors                                                 )-import           Data.Semigroup                 ( (<>) ) + renderGQLErrors :: GQLErrors -> String renderGQLErrors = unpack . encode @@ -49,7 +53,7 @@  gqlWarnings :: GQLErrors -> Q () gqlWarnings []       = pure ()-gqlWarnings warnings = mapM_ handleWarning warnings+gqlWarnings warnings = traverse_ handleWarning warnings  where   handleWarning warning =     reportWarning ("Morpheus GraphQL Warning: " <> (unpack . encode) warning)

src/Data/Morpheus/Error/Document/Interface.hs view

@@ -10,9 +10,8 @@  import           Data.Morpheus.Error.Utils      ( globalErrorMessage ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Key )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)+                                                ( Key+                                                , GQLError(..)                                                 , GQLErrors                                                 ) import           Data.Semigroup                 ( (<>) )

src/Data/Morpheus/Error/Fragment.hs view

@@ -1,12 +1,8 @@-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Error.Fragment   ( cannotSpreadWithinItself-  , unusedFragment-  , unknownFragment   , cannotBeSpreadOnType-  , fragmentNameCollision   ) where @@ -21,9 +17,7 @@ import           Data.Morpheus.Types.Internal.AST.Base                                                 ( Ref(..)                                                 , Position-                                                )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)+                                                , GQLError(..)                                                 , GQLErrors                                                 ) @@ -38,46 +32,23 @@     fragment H on D {...}  ->  "Unknown type \"D\"."     {...H} -> "Unknown fragment \"H\"." -}-fragmentNameCollision :: [Ref] -> GQLErrors-fragmentNameCollision = map toError- where-  toError Ref { refName, refPosition } = GQLError-    { message   = "There can be only one fragment named \"" <> refName <> "\"."-    , locations = [refPosition]-    } -unusedFragment :: [Ref] -> GQLErrors-unusedFragment = map toError- where-  toError Ref { refName, refPosition } = GQLError-    { message   = "Fragment \"" <> refName <> "\" is never used."-    , locations = [refPosition]-    }- cannotSpreadWithinItself :: [Ref] -> GQLErrors-cannotSpreadWithinItself fragments =-  [GQLError { message = text, locations = map refPosition fragments }]+cannotSpreadWithinItself fragments = [GQLError { message = text, locations = map refPosition fragments }]  where-  text = T.concat-    [ "Cannot spread fragment \""-    , refName $ head fragments-    , "\" within itself via "-    , T.intercalate ", " (map refName fragments)-    , "."-    ]---- {...H} -> "Unknown fragment \"H\"."-unknownFragment :: Text -> Position -> GQLErrors-unknownFragment key' position' = errorMessage position' text-  where text = T.concat ["Unknown Fragment \"", key', "\"."]+  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-  message+  msg  where-  message =+  msg =     "Fragment "       <> getName key       <> "cannot be spread here as objects of type \""

src/Data/Morpheus/Error/Input.hs view

@@ -1,81 +1,43 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}  module Data.Morpheus.Error.Input-  ( inputErrorMessage-  , InputError(..)-  , Prop(..)-  , InputValidation+  ( typeViolation    ) where +import           Data.Semigroup                 ( (<>) ) import           Data.Aeson                     ( encode ) import           Data.ByteString.Lazy.Char8     ( unpack )-import           Data.Morpheus.Types.Internal.AST.Value-                                                ( ResolvedValue )-import           Data.Text                      ( Text )-import qualified Data.Text                     as T-                                                ( concat-                                                , intercalate-                                                , pack+import           Data.Text                      ( pack )++-- MORPHEUS+import           Data.Morpheus.Types.Internal.AST +                                                ( Message+                                                , ResolvedValue+                                                , TypeRef(..)                                                  )+import           Data.Morpheus.Rendering.RenderGQL+                                                ( RenderGQL(..) )  -import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLErrors )--type InputValidation a = Either InputError a--data InputError-  = UnexpectedType [Prop] Text ResolvedValue (Maybe Text)-  | UndefinedField [Prop] Text-  | UnknownField [Prop] Text-  | GlobalInputError GQLErrors+typeViolation :: TypeRef -> ResolvedValue -> Message+typeViolation expected found = "Expected type \""+  <> render expected+  <> "\" found "+  <> pack (unpack $ encode found)+  <> "." -data Prop =-  Prop-    { propKey  :: Text-    , propType :: Text+{-+  ARGUMENTS:+    type Experience {+        experience ( lang: LANGUAGE ) : String ,+        date: String     } -inputErrorMessage :: InputError -> Either GQLErrors Text-inputErrorMessage (UnexpectedType path type' value errorMessage) =-  Right $ expectedTypeAFoundB path type' value errorMessage-inputErrorMessage (UndefinedField path' field') =-  Right $ undefinedField path' field'-inputErrorMessage (UnknownField path' field') =-  Right $ unknownField path' field'-inputErrorMessage (GlobalInputError err) = Left err--pathToText :: [Prop] -> Text-pathToText []    = ""-pathToText path' = T.concat ["on ", T.intercalate "." $ fmap propKey path']--expectedTypeAFoundB :: [Prop] -> Text -> ResolvedValue -> Maybe Text -> Text-expectedTypeAFoundB path' expected found Nothing = T.concat-  [ pathToText path'-  , " Expected type \""-  , expected-  , "\" found "-  , T.pack (unpack $ encode found)-  , "."-  ]-expectedTypeAFoundB path' expected found (Just errorMessage) = T.concat-  [ pathToText path'-  , " Expected type \""-  , expected-  , "\" found "-  , T.pack (unpack $ encode found)-  , "; "-  , errorMessage-  , "."-  ]--undefinedField :: [Prop] -> Text -> Text-undefinedField path' field' =-  T.concat [pathToText path', " Undefined Field \"", field', "\"."]--unknownField :: [Prop] -> Text -> Text-unknownField path' field' =-  T.concat [pathToText path', " Unknown Field \"", field', "\"."]+  - 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 view

@@ -2,51 +2,36 @@  module Data.Morpheus.Error.Internal   ( internalTypeMismatch-  , internalArgumentError-  , internalUnknownTypeMessage   , internalError   , internalResolvingError   ) where -import           Data.Text                      ( Text )-import qualified Data.Text                     as T-                                                ( concat-                                                , pack-                                                )+import           Data.Text                      ( pack ) import           Data.Semigroup                 ( (<>) )  -- MORPHEUS import           Data.Morpheus.Error.Utils      ( globalErrorMessage ) import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( Validation-                                                , GQLErrors+                                                ( 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 :: Text -> Validation b+internalError :: Message -> Eventless a internalError x = failure $ globalErrorMessage $ "INTERNAL ERROR: " <> x --- if type did not not found, but was defined by Schema-internalResolvingError :: Text -> GQLErrors-internalResolvingError = globalErrorMessage . ("INTERNAL RESOLVING ERROR:" <>)----- if type did not not found, but was defined by Schema-internalUnknownTypeMessage :: Text -> GQLErrors-internalUnknownTypeMessage x = globalErrorMessage-  $ T.concat ["type did not not found, but was defined by Schema", x]---- if arguments is already validated but has not found required argument-internalArgumentError :: Text -> Validation b-internalArgumentError x = internalError $ "Argument " <> x+internalResolvingError :: Message -> GQLErrors+internalResolvingError = globalErrorMessage . ("INTERNAL ERROR:" <>)  -- if value is already validated but value has different type-internalTypeMismatch :: Text -> ValidValue -> Validation b+internalTypeMismatch :: Message -> ValidValue -> Eventless a internalTypeMismatch text jsType =-  internalError $ "Type mismatch " <> text <> T.pack (show jsType)+  internalError $ "Type mismatch " <> text <> pack (show jsType)

− src/Data/Morpheus/Error/Mutation.hs

@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Mutation-  ( mutationIsNotDefined-  )-where--import           Data.Morpheus.Error.Utils      ( errorMessage )-import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Position )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLErrors )--mutationIsNotDefined :: Position -> GQLErrors-mutationIsNotDefined position' =-  errorMessage position' "Schema is not configured for mutations."

+ src/Data/Morpheus/Error/NameCollision.hs view

@@ -0,0 +1,12 @@+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 view

@@ -0,0 +1,21 @@+{-# 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 view

@@ -7,7 +7,7 @@ where  import           Data.Morpheus.Error.Utils      ( globalErrorMessage )-import           Data.Morpheus.Types.Internal.Resolving.Core+import           Data.Morpheus.Types.Internal.AST.Base                                                 ( GQLErrors ) import           Data.Semigroup                 ( (<>) ) import           Data.Text                      ( Text )

src/Data/Morpheus/Error/Selection.hs view

@@ -1,9 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns    #-}  module Data.Morpheus.Error.Selection-  ( cannotQueryField+  ( unknownSelectionField   , subfieldsNotSelected-  , duplicateQuerySelections   , hasNoSubfields   ) where@@ -11,52 +11,27 @@ import           Data.Semigroup                 ( (<>) ) import           Data.Morpheus.Error.Utils      ( errorMessage ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Ref(..)-                                                , Position-                                                )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)+                                                ( Position                                                 , GQLErrors+                                                , Ref(..)+                                                , Name                                                 ) import           Data.Text                      ( Text )-import qualified Data.Text                     as T-                                                ( concat ) - -- GQL: "Field \"default\" must not have a selection since type \"String!\" has no subfields."-hasNoSubfields :: Text -> Text -> Position -> GQLErrors-hasNoSubfields key typeName position = errorMessage position text- where-  text = T.concat-    [ "Field \""-    , key-    , "\" must not have a selection since type \""-    , typeName-    , "\" has no subfields."-    ]--cannotQueryField :: Text -> Text -> Position -> GQLErrors-cannotQueryField key typeName position = errorMessage position text+hasNoSubfields :: Ref -> Name -> GQLErrors+hasNoSubfields (Ref selectionName position) typeName  = errorMessage position text  where-  text =-    T.concat ["Cannot query field \"", key, "\" on type \"", typeName, "\"."]+  text = "Field \"" <> selectionName <> "\" must not have a selection since type \"" <> typeName <> "\" has no subfields." -duplicateQuerySelections :: Text -> [Ref] -> GQLErrors-duplicateQuerySelections parentType = map keyToError+unknownSelectionField :: Name -> Ref -> GQLErrors+unknownSelectionField typeName Ref { refName , refPosition } = errorMessage refPosition text  where-  keyToError (Ref key' pos) =-    GQLError { message = toMessage key', locations = [pos] }-  toMessage key' = T.concat-    ["duplicate selection of key \"", key', "\" on type \"", parentType, "\"."]+  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 = T.concat-    [ "Field \""-    , key-    , "\" of type \""-    , typeName-    , "\" must have a selection of subfields"-    ]+  text = "Field \"" <> key <> "\" of type \""+    <> typeName <> "\" must have a selection of subfields"

− src/Data/Morpheus/Error/Subscription.hs

@@ -1,16 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Error.Subscription-  ( subscriptionIsNotDefined-  )-where--import           Data.Morpheus.Error.Utils      ( errorMessage )-import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Position )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLErrors )--subscriptionIsNotDefined :: Position -> GQLErrors-subscriptionIsNotDefined position' =-  errorMessage position' "Schema is not configured for subscriptions."

src/Data/Morpheus/Error/Utils.hs view

@@ -1,41 +1,30 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE OverloadedStrings          #-}  module Data.Morpheus.Error.Utils   ( errorMessage   , globalErrorMessage   , badRequestError-  , toLocation   ) where +import           Data.Semigroup                         ((<>)) import           Data.ByteString.Lazy.Char8     ( ByteString                                                 , pack                                                 ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Position )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)-                                                , GQLErrors+                                                ( Position(..)                                                 , GQLError(..)-                                                , Position(..)+                                                , GQLErrors                                                 ) import           Data.Text                      ( Text )-import           Text.Megaparsec                ( SourcePos(SourcePos)-                                                , sourceColumn-                                                , sourceLine-                                                , unPos-                                                ) + errorMessage :: Position -> Text -> GQLErrors errorMessage position message = [GQLError { message, locations = [position] }]  globalErrorMessage :: Text -> GQLErrors globalErrorMessage message = [GQLError { message, locations = [] }] -toLocation :: SourcePos -> Position-toLocation SourcePos { sourceLine, sourceColumn } =-  Position { line = unPos sourceLine, column = unPos sourceColumn }- badRequestError :: String -> ByteString-badRequestError aesonError' =-  pack $ "Bad Request. Could not decode Request body: " ++ aesonError'+badRequestError = ("Bad Request. Could not decode Request body: " <>) . pack

src/Data/Morpheus/Error/Variable.hs view

@@ -1,84 +1,44 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NamedFieldPuns    #-}  module Data.Morpheus.Error.Variable-  ( undefinedVariable-  , unknownType-  , variableGotInvalidValue-  , uninitializedVariable-  , unusedVariables+  ( uninitializedVariable   , incompatibleVariableType   ) where  import           Data.Morpheus.Error.Utils      ( errorMessage )-import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Ref(..)-                                                , Position-                                                )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)-                                                , GQLErrors+import           Data.Morpheus.Types.Internal.AST+                                                ( GQLErrors+                                                , Ref(..)+                                                , Variable(..)+                                                , TypeRef                                                 ) import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( Text )-import qualified Data.Text                     as T-                                                ( concat )+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 :: Text -> Text -> Text -> Position -> GQLErrors-incompatibleVariableType variableName variableType argType argPosition =+incompatibleVariableType :: Ref -> Variable s -> TypeRef -> GQLErrors+incompatibleVariableType +  (Ref variableName argPosition) +  Variable { variableType } +  argumentType  =   errorMessage argPosition text  where   text =     "Variable \"$"       <> variableName       <> "\" of type \""-      <> variableType+      <> render variableType       <> "\" used in position expecting type \""-      <> argType+      <> render argumentType       <> "\"." --- query M ( $v : String ) { a } -> "Variable \"$bla\" is never used in operation \"MyMutation\".",-unusedVariables :: Text -> [Ref] -> GQLErrors-unusedVariables operator' = map keyToError- where-  keyToError (Ref key' position') =-    GQLError { message = text key', locations = [position'] }-  text key' = T.concat-    ["Variable \"$", key', "\" is never used in operation \"", operator', "\"."]---- type mismatch--- { "v": 1  }        "Variable \"$v\" got invalid value 1; Expected type LANGUAGE."-variableGotInvalidValue :: Text -> Text -> Position -> GQLErrors-variableGotInvalidValue name' inputMessage' position' = errorMessage-  position'-  text- where-  text =-    T.concat ["Variable \"$", name', "\" got invalid value; ", inputMessage']--unknownType :: Text -> Position -> GQLErrors-unknownType type' position' = errorMessage position' text-  where text = T.concat ["Unknown type \"", type', "\"."]--undefinedVariable :: Text -> Position -> Text -> GQLErrors-undefinedVariable operation' position' key' = errorMessage position' text- where-  text = T.concat-    [ "Variable \""-    , key'-    , "\" is not defined by operation \""-    , operation'-    , "\"."-    ]--uninitializedVariable :: Position -> Text -> Text -> GQLErrors-uninitializedVariable position' type' key' = errorMessage position' text- where-  text = T.concat-    [ "Variable \"$"-    , key'-    , "\" of required type \""-    , type'-    , "!\" was not provided."-    ]+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 view

@@ -20,7 +20,10 @@ import qualified Data.HashMap.Lazy             as H                                                 ( lookup ) import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( unpack )+import           Data.Text                      ( append+                                                , Text+                                                , unpack+                                                ) import           Language.Haskell.TH  import           Data.Morpheus.Execution.Internal.Utils@@ -28,8 +31,10 @@  -- -- MORPHEUS+import           Data.Morpheus.Execution.Internal.Declare+                                                ( isEnum ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)+                                                ( FieldDefinition(..)                                                 , isFieldNullable                                                 , ConsD(..)                                                 , TypeD(..)@@ -43,15 +48,15 @@  -- FromJSON deriveFromJSON :: TypeD -> Q Dec-deriveFromJSON TypeD { tCons = [] } =-  fail "Type Should Have at least one Constructor"+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 aesonEnum tCons+  | isEnum tCons = defineFromJSON name (aesonFromJSONEnumBody tName) tCons   | otherwise    = defineFromJSON name (aesonUnionObject tNamespace) typeD   where name = nameSpaceType tNamespace tName @@ -65,16 +70,16 @@ aesonObjectBody namespace ConsD { cName, cFields } = handleFields cFields  where   consName = mkName $ unpack $ nameSpaceType namespace cName-  -------------------------------------------  handleFields []     = fail "No Empty Object"+  ----------------------------------------------------------+  handleFields []     = fail $ "Type \""<>unpack cName <>"\" is Empty Object"   handleFields fields = startExp fields-  ----------------------------------------------------------------------------------+  ----------------------------------------------------------    where-    defField field@DataField { fieldName }+    defField field@FieldDefinition { fieldName }       | isFieldNullable field = [|o .:? fName|]       | otherwise             = [|o .: fName|]       where fName = unpack fieldName-        -------------------------------------------------------------------+    --------------------------------------------------------     startExp fNames = uInfixE (conE consName)                               (varE '(<$>))                               (applyFields fNames)@@ -109,19 +114,15 @@   -----------------------------------------   method = instanceFunD 'parseJSON [] (parseJ cFields) -isEnum :: [ConsD] -> Bool-isEnum = not . isEmpty . filter (isEmpty . cFields)-  where isEmpty = (0 ==) . length--aesonEnum :: [ConsD] -> ExpQ-aesonEnum cons = lamCaseE handlers+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 cName)+      body    = normalB $ appE (varE 'pure) (conE $ mkName $ unpack $ append tName cName)  elseCaseEXP :: MatchQ elseCaseEXP = match (varP varName) body []@@ -134,6 +135,16 @@              (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 = [] } =@@ -152,8 +163,9 @@     varNames = map fieldName cFields deriveToJSON TypeD { tName, tCons }   | isEnum tCons-  = pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) []+  = let methods = [funD 'toJSON clauses]+        clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []]+     in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) methods   |-    -- enum: uses default aeson instance derivation methods     otherwise   = fail "Input Unions are not yet supported"

src/Data/Morpheus/Execution/Client/Build.hs view

@@ -28,7 +28,9 @@ import           Data.Morpheus.Execution.Client.Fetch                                                 ( deriveFetch ) import           Data.Morpheus.Execution.Internal.Declare-                                                ( declareType )+                                                ( declareType +                                                , Scope(..)+                                                )  import           Data.Morpheus.Types.Internal.AST                                                 ( GQLQuery(..)@@ -40,20 +42,17 @@                                                 , TypeD(..)                                                 ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+                                                ( Eventless                                                 , Result(..)                                                 ) ---defineQuery :: IO (Validation Schema) -> (GQLQuery, String) -> Q [Dec]+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@@ -72,12 +71,12 @@ defineQueryD ClientQuery { queryTypes = [] } = return []  declareOutputType :: TypeD -> Q [Dec]-declareOutputType typeD = pure [declareType False Nothing [''Show] typeD]+declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD]  declareInputType :: TypeD -> Q [Dec] declareInputType typeD = do   toJSONDec <- deriveToJSON typeD-  pure $ declareType True Nothing [''Show] typeD : toJSONDec+  pure $ declareType CLIENT True Nothing [''Show] typeD : toJSONDec  withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec] withToJSON f datatype = do

src/Data/Morpheus/Execution/Client/Compile.hs view

@@ -37,7 +37,7 @@                                                 , VALIDATION_MODE(..)                                                 ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+                                                ( Eventless                                                 , Result(..)                                                 ) import           Data.Morpheus.Validation.Query.Validation@@ -54,7 +54,7 @@                        , variables     = Nothing                        } -validateWith :: Schema -> (GQLQuery, String) -> Validation ClientQuery+validateWith :: Schema -> (GQLQuery, String) -> Eventless ClientQuery validateWith schema (rawRequest@GQLQuery { operation }, queryText) = do   validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest   (queryArgsType, queryTypes) <- operationTypes

src/Data/Morpheus/Execution/Client/Fetch.hs view

@@ -38,6 +38,7 @@                                                 , JSONResponse(..)                                                 ) + fixVars :: A.Value -> Maybe A.Value fixVars x | x == A.emptyArray = Nothing           | otherwise         = Just x

src/Data/Morpheus/Execution/Client/Selection.hs view

@@ -10,7 +10,6 @@   ) where -import           Data.Maybe                     ( fromMaybe ) import           Data.Semigroup                 ( (<>) ) import           Data.Text                      ( Text                                                 , pack@@ -24,48 +23,50 @@                                                 ( nameSpaceType ) import           Data.Morpheus.Types.Internal.AST                                                 ( Operation(..)-                                                , ValidOperation+                                                , Key+                                                , Name+                                                , RAW+                                                , VALID                                                 , Variable(..)                                                 , VariableDefinitions-                                                , getOperationName-                                                , getOperationDataType                                                 , Selection(..)                                                 , SelectionContent(..)-                                                , ValidSelectionSet-                                                , ValidSelection+                                                , SelectionSet                                                 , Ref(..)-                                                , DataField(..)-                                                , DataTypeContent(..)-                                                , DataType(..)+                                                , FieldDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)                                                 , DataTypeKind(..)                                                 , Schema(..)-                                                , Key                                                 , TypeRef(..)                                                 , DataEnumValue(..)-                                                , DataLookup(..)                                                 , ConsD(..)                                                 , ClientType(..)                                                 , TypeD(..)+                                                , ArgumentsDefinition(..)+                                                , getOperationName+                                                , getOperationDataType                                                 , lookupDeprecated                                                 , lookupDeprecatedReason-                                                , RAW-                                                , Name+                                                , typeFromScalar+                                                , removeDuplicates+                                                , Position+                                                , GQLErrors+                                                , UnionTag(..)                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                ( Listable(..)+                                                , selectBy+                                                , keyOf+                                                ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( GQLErrors-                                                , Validation+                                                ( Eventless                                                 , Failure(..)                                                 , Result(..)-                                                , Position                                                 , LibUpdater                                                 , resolveUpdates                                                 )-import           Data.Set                       ( fromList-                                                , toList-                                                ) -removeDuplicates :: [Text] -> [Text]-removeDuplicates = toList . fromList  compileError :: Text -> GQLErrors compileError x =@@ -73,9 +74,9 @@  operationTypes   :: Schema-  -> VariableDefinitions-  -> ValidOperation-  -> Validation (Maybe TypeD, [ClientType])+  -> VariableDefinitions RAW+  -> Operation VALID+  -> Eventless (Maybe TypeD, [ClientType]) operationTypes lib variables = genOperation  where   genOperation operation@Operation { operationName, operationSelection } = do@@ -85,7 +86,7 @@                                          datatype                                          operationSelection     inputTypeRequests <- resolveUpdates []-      $ map (scanInputTypes lib . typeConName . variableType . snd) variables+      $ map (scanInputTypes lib . typeConName . variableType) (toList variables)     inputTypesAndEnums <- buildListedTypes (inputTypeRequests <> enums)     pure       ( rootArguments (getOperationName operationName <> "Args")@@ -105,15 +106,14 @@     rootArgumentsType = TypeD       { tName      = argsName       , tNamespace = []-      , tCons = [ConsD { cName = argsName, cFields = map fieldD variables }]+      , tCons = [ConsD { cName = argsName, cFields = map fieldD (toList variables) }]       , tMeta      = Nothing       }      where-      fieldD :: (Text, Variable RAW) -> DataField-      fieldD (key, Variable { variableType }) = DataField-        { fieldName     = key-        , fieldArgs     = []-        , fieldArgsType = Nothing+      fieldD :: Variable RAW -> FieldDefinition+      fieldD Variable { variableName, variableType } = FieldDefinition+        { fieldName     = variableName+        , fieldArgs     = NoArguments         , fieldType     = variableType         , fieldMeta     = Nothing         }@@ -122,9 +122,9 @@   genRecordType     :: [Name]     -> Name-    -> DataType-    -> ValidSelectionSet-    -> Validation ([ClientType], [Name])+    -> TypeDefinition+    -> SelectionSet VALID+    -> Eventless ([ClientType], [Name])   genRecordType path tName dataType recordSelSet = do     (con, subTypes, requests) <- genConsD tName dataType recordSelSet     pure@@ -142,41 +142,45 @@    where     genConsD       :: Name-      -> DataType-      -> ValidSelectionSet-      -> Validation (ConsD, [ClientType], [Text])+      -> TypeDefinition+      -> SelectionSet VALID+      -> Eventless (ConsD, [ClientType], [Text])     genConsD cName datatype selSet = do-      (cFields, subTypes, requests) <- unzip3 <$> traverse genField selSet+      (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet)       pure (ConsD { cName, cFields }, concat subTypes, concat requests)      where       genField-        :: (Text, ValidSelection)-        -> Validation (DataField, [ClientType], [Text])-      genField (fName, sel@Selection { selectionAlias, selectionPosition }) =+        :: Selection VALID+        -> Eventless (FieldDefinition, [ClientType], [Text])+      genField +          sel@Selection +          { selectionName+          , selectionPosition+          } =         do           (fieldDataType, fieldType) <- lookupFieldType lib                                                         fieldPath                                                         datatype                                                         selectionPosition-                                                        fName+                                                        selectionName           (subTypes, requests) <- subTypesBySelection fieldDataType sel           pure-            ( DataField { fieldName-                        , fieldArgs     = []-                        , fieldArgsType = Nothing-                        , fieldType-                        , fieldMeta     = Nothing-                        }+            ( FieldDefinition +                { fieldName+                , fieldType+                , fieldArgs  = NoArguments+                , fieldMeta  = Nothing+                }             , subTypes             , requests             )        where         fieldPath = path <> [fieldName]         --------------------------------        fieldName = fromMaybe fName selectionAlias+        fieldName = keyOf sel         ------------------------------------------         subTypesBySelection-          :: DataType -> ValidSelection -> Validation ([ClientType], [Text])+          :: TypeDefinition -> Selection VALID -> Eventless ([ClientType], [Text])         subTypesBySelection dType Selection { selectionContent = SelectionField }           = leafType dType           --withLeaf buildLeaf dType@@ -186,7 +190,7 @@         subTypesBySelection dType Selection { selectionContent = UnionSelection unionSelections }           = do             (tCons, subTypes, requests) <--              unzip3 <$> mapM getUnionType unionSelections+              unzip3 <$> traverse getUnionType (toList unionSelections)             pure               ( ClientType                   { clientType = TypeD { tNamespace = fieldPath@@ -200,7 +204,7 @@               , concat requests               )          where-          getUnionType (selectedTyName, selectionVariant) = do+          getUnionType (UnionTag selectedTyName selectionVariant) = do             conDatatype <- getType lib selectedTyName             genConsD selectedTyName conDatatype selectionVariant @@ -208,25 +212,24 @@ scanInputTypes lib name collected | name `elem` collected = pure collected                                   | otherwise = getType lib name >>= scanInpType  where-  scanInpType DataType { typeContent, typeName } = scanType typeContent+  scanInpType TypeDefinition { typeContent, typeName } = scanType typeContent    where     scanType (DataInputObject fields) = resolveUpdates-      (name : collected)-      (map toInputTypeD fields)+      (name : collected) (map toInputTypeD $ toList fields)      where-      toInputTypeD :: (Text, DataField) -> LibUpdater [Key]-      toInputTypeD (_, DataField { fieldType = TypeRef { typeConName } }) =+      toInputTypeD :: FieldDefinition -> LibUpdater [Key]+      toInputTypeD FieldDefinition { fieldType = TypeRef { typeConName } } =         scanInputTypes lib typeConName     scanType (DataEnum _) = pure (collected <> [typeName])     scanType _            = pure collected -buildInputType :: Schema -> Text -> Validation [ClientType]+buildInputType :: Schema -> Text -> Eventless [ClientType] buildInputType lib name = getType lib name >>= generateTypes  where-  generateTypes DataType { typeName, typeContent } = subTypes typeContent+  generateTypes TypeDefinition { typeName, typeContent } = subTypes typeContent    where     subTypes (DataInputObject inputFields) = do-      fields <- traverse toFieldD inputFields+      fields <- traverse toFieldD (toList inputFields)       pure         [ ClientType             { clientType = TypeD@@ -242,10 +245,10 @@             }         ]      where-      toFieldD :: (Text, DataField) -> Validation DataField-      toFieldD (_, field@DataField { fieldType }) = do+      toFieldD :: FieldDefinition -> Eventless FieldDefinition+      toFieldD field@FieldDefinition { fieldType } = do         typeConName <- typeFrom [] <$> getType lib (typeConName fieldType)-        pure $ field { fieldType = fieldType { typeConName } }+        pure $ field { fieldType = fieldType { typeConName  }  }     subTypes (DataEnum enumTags) = pure       [ ClientType           { clientType = TypeD { tName      = typeName@@ -261,23 +264,24 @@         ConsD { cName = enumName, cFields = [] }     subTypes _ = pure [] - lookupFieldType   :: Schema   -> [Key]-  -> DataType+  -> TypeDefinition   -> Position   -> Text-  -> Validation (DataType, TypeRef)-lookupFieldType lib path DataType { typeContent = DataObject { objectFields }, typeName } refPosition key-  = case lookup key objectFields of-    Just DataField { fieldType = alias@TypeRef { typeConName }, fieldMeta } ->+  -> 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 :: Validation ()+      checkDeprecated :: Eventless ()       checkDeprecated = case fieldMeta >>= lookupDeprecated of         Just deprecation -> Success { result = (), warnings, events = [] }          where@@ -285,35 +289,23 @@                                      Ref { refName = key, refPosition }                                      (lookupDeprecatedReason deprecation)         Nothing -> pure ()-    -------------------    Nothing ->-      failure-        (compileError $ "cant find field \"" <> pack (show objectFields) <> "\"") lookupFieldType _ _ dt _ _ =   failure (compileError $ "Type should be output Object \"" <> pack (show dt))  -leafType :: DataType -> Validation ([ClientType], [Text])-leafType DataType { typeName, typeContent } = fromKind typeContent+leafType :: TypeDefinition -> Eventless ([ClientType], [Text])+leafType TypeDefinition { typeName, typeContent } = fromKind typeContent  where-  fromKind :: DataTypeContent -> Validation ([ClientType], [Text])+  fromKind :: TypeContent -> Eventless ([ClientType], [Text])   fromKind DataEnum{} = pure ([], [typeName])   fromKind DataScalar{} = pure ([], [])   fromKind _ = failure $ compileError "Invalid schema Expected scalar" -getType :: Schema -> Text -> Validation DataType-getType lib typename = lookupResult (compileError typename) typename lib --typeFromScalar :: Name -> Name-typeFromScalar "Boolean" = "Bool"-typeFromScalar "Int"     = "Int"-typeFromScalar "Float"   = "Float"-typeFromScalar "String"  = "Text"-typeFromScalar "ID"      = "ID"-typeFromScalar _         = "ScalarValue"+getType :: Schema -> Text -> Eventless TypeDefinition+getType lib typename = selectBy (compileError typename) typename lib  -typeFrom :: [Name] -> DataType -> Name-typeFrom path DataType { typeName, typeContent } = __typeFrom typeContent+typeFrom :: [Name] -> TypeDefinition -> Name+typeFrom path TypeDefinition { typeName, typeContent } = __typeFrom typeContent  where   __typeFrom DataScalar{} = typeFromScalar typeName   __typeFrom DataObject{} = nameSpaceType path typeName

src/Data/Morpheus/Execution/Document/Compile.hs view

@@ -22,8 +22,8 @@                                                 ( toTHDefinitions ) import           Data.Morpheus.Execution.Document.Declare                                                 ( declareTypes )-import           Data.Morpheus.Parsing.Document.Parser-                                                ( parseTypes )+import           Data.Morpheus.Parsing.Document.TypeSystem+                                                ( parseSchema ) import           Data.Morpheus.Validation.Document.Validation import           Data.Morpheus.Types.Internal.Resolving                                                 ( Result(..) )@@ -52,7 +52,7 @@ compileDocument :: Bool -> String -> Q [Dec] compileDocument namespace documentTXT =   case-      parseTypes (T.pack documentTXT)+      parseSchema (T.pack documentTXT)       >>= validatePartialDocument     of       Failure errors -> fail (renderGQLErrors errors)

src/Data/Morpheus/Execution/Document/Convert.hs view

@@ -3,7 +3,8 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-}-{-# LANGUAGE TemplateHaskell     #-}+-- {-# LANGUAGE TemplateHaskell     #-}+{-# LANGUAGE RecordWildCards     #-}  module Data.Morpheus.Execution.Document.Convert   ( toTHDefinitions@@ -19,84 +20,101 @@ import           Data.Morpheus.Execution.Internal.Utils                                                 ( capital ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)-                                                , DataTypeContent(..)-                                                , DataType(..)-                                                , DataTypeKind(..)-                                                , OperationType(..)+                                                ( FieldDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)                                                 , TypeRef(..)                                                 , DataEnumValue(..)-                                                , sysTypes                                                 , ConsD(..)                                                 , GQLTypeD(..)                                                 , TypeD(..)                                                 , Key-                                                , DataObject+                                                , InputFieldsDefinition(..)+                                                , ArgumentsDefinition(..)+                                                , hasArguments+                                                , lookupWith+                                                , toHSFieldDefinition+                                                , hsTypeName+                                                , kindOf                                                 )-+import           Data.Morpheus.Types.Internal.Operation +                                                (Listable(..))  m_ :: Key m_ = "m" -getTypeArgs :: Key -> [(Key, DataType)] -> Q (Maybe Key)+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 <$> lookup key lib of+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 -          | length (infoTyVars x) > 0 = Just m_ -          | otherwise = Nothing-+  | null (infoTyVars x) = Nothing+  | otherwise = Just m_  -kindToTyArgs :: DataTypeContent -> Maybe Key+kindToTyArgs :: TypeContent -> Maybe Key kindToTyArgs DataObject{} = Just m_ kindToTyArgs DataUnion{}  = Just m_ kindToTyArgs _             = Nothing -toTHDefinitions :: Bool -> [(Key, DataType)] -> Q [GQLTypeD]+toTHDefinitions :: Bool -> [TypeDefinition] -> Q [GQLTypeD] toTHDefinitions namespace lib = traverse renderTHType lib  where-  renderTHType :: (Key, DataType) -> Q GQLTypeD-  renderTHType (tyConName, x) = generateType x+  renderTHType :: TypeDefinition -> Q GQLTypeD+  renderTHType x = generateType x    where     genArgsTypeName :: Key -> Key-    genArgsTypeName fieldName | namespace = hsTypeName tyConName <> argTName+    genArgsTypeName fieldName | namespace = hsTypeName (typeName x) <> argTName                               | otherwise = argTName       where argTName = capital fieldName <> "Args"     ----------------------------------------------------------------------------------------------    genResField :: (Key, DataField) -> Q DataField-    genResField (_, field@DataField { fieldName, fieldArgs, fieldType = typeRef@TypeRef { typeConName } })+    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 }-                , fieldArgsType-              }+        pure $ field +          { fieldType = typeRef { typeConName = hsTypeName typeConName, typeArgs }+          , fieldArgs = fieldArguments+          }      where-      fieldArgsType-        | null fieldArgs = Nothing-        | otherwise = Just (genArgsTypeName fieldName)+      fieldArguments+        | hasArguments fieldArgs = fieldArgs { argumentsTypename = Just $ genArgsTypeName fieldName }+        | otherwise = fieldArgs     ---------------------------------------------    generateType :: DataType -> Q GQLTypeD-    generateType dt@DataType { typeName, typeContent, typeMeta } = genType+    generateType :: TypeDefinition -> Q GQLTypeD+    generateType typeOriginal@TypeDefinition { typeName, typeContent, typeMeta } = genType       typeContent      where-      genType :: DataTypeContent -> Q GQLTypeD+      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                                }-        , typeKindD    = KindEnum         , typeArgD     = []-        , typeOriginal = (typeName, dt)+        , ..         }        where         enumOption DataEnumValue { enumName } =@@ -105,63 +123,35 @@       genType DataInputUnion {} = fail "Input Unions not Supported"       genType DataInterface {} = fail "interfaces must be eliminated in Validation"       genType (DataInputObject fields) = pure GQLTypeD-        { typeD        =-          TypeD-            { tName      = hsTypeName typeName-            , tNamespace = []-            , tCons      = [ ConsD { cName   = hsTypeName typeName-                                   , cFields = genInputFields fields-                                   }-                           ]-            , tMeta      = typeMeta-            }-        , typeKindD    = KindInputObject-        , typeArgD     = []-        , typeOriginal = (typeName, dt)+        { typeD       = buildType $ buildObjectCons $ genInputFields fields+        , typeArgD    = []+        , ..         }       genType DataObject {objectFields} = do-        typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) objectFields-        cFields  <- traverse genResField objectFields+        typeArgD <- concat <$> traverse (genArgumentType genArgsTypeName) (toList objectFields)+        objCons  <- buildObjectCons <$> traverse genResField (toList objectFields)         pure GQLTypeD-          { typeD        = TypeD-                             { tName      = hsTypeName typeName-                             , tNamespace = []-                             , tCons = [ ConsD { cName = hsTypeName typeName-                                               , cFields -                                               }-                                       ]-                             , tMeta      = typeMeta-                             }-          , typeKindD    = if typeName == "Subscription"-                             then KindObject (Just Subscription)-                             else KindObject Nothing+          { typeD    = buildType objCons           , typeArgD-          , typeOriginal = (typeName, dt)+          , ..           }-      genType (DataUnion members) = do-        let tCons = map unionCon members+      genType (DataUnion members) =          pure GQLTypeD-          { typeD        = TypeD { tName      = typeName-                                 , tNamespace = []-                                 , tCons-                                 , tMeta      = typeMeta-                                 }-          , typeKindD    = KindUnion+          { typeD        = buildType (map unionCon members)           , typeArgD     = []-          , typeOriginal = (typeName, dt)+          , ..           }        where         unionCon memberName = ConsD           { cName-          , cFields = [ DataField+          , cFields = [ FieldDefinition                           { fieldName     = "un" <> cName                           , fieldType     = TypeRef { typeConName  = utName                                                     , typeArgs     = Just m_                                                     , typeWrappers = []                                                     }                           , fieldMeta     = Nothing-                          , fieldArgs     = []-                          , fieldArgsType = Nothing+                          , fieldArgs     = NoArguments                           }                       ]           }@@ -170,21 +160,14 @@           utName = hsTypeName memberName  --hsTypeName :: Key -> Key-hsTypeName "String"                    = "Text"-hsTypeName "Boolean"                   = "Bool"-hsTypeName name | name `elem` sysTypes = "S" <> name-hsTypeName name                        = name--genArgumentType :: (Key -> Key) -> (Key, DataField) -> Q [TypeD]-genArgumentType _ (_, DataField { fieldArgs = [] }) = pure []-genArgumentType namespaceWith (fieldName, DataField { fieldArgs }) = pure+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 = genInputFields fieldArgs+                             , cFields = genArguments fieldArgs                              }                      ]       , tMeta      = Nothing@@ -192,10 +175,8 @@   ]   where tName = namespaceWith (hsTypeName fieldName) +genArguments :: ArgumentsDefinition -> [FieldDefinition]+genArguments = genInputFields . InputFieldsDefinition . arguments -genInputFields :: DataObject -> [DataField]-genInputFields = map (genField . snd)- where-  genField :: DataField -> DataField-  genField field@DataField { fieldType = tyRef@TypeRef { typeConName } } =-    field { fieldType = tyRef { typeConName = hsTypeName typeConName } }+genInputFields :: InputFieldsDefinition -> [FieldDefinition]+genInputFields = map toHSFieldDefinition . toList

src/Data/Morpheus/Execution/Document/Declare.hs view

@@ -23,7 +23,9 @@                                                 , instanceIntrospect                                                 ) import           Data.Morpheus.Execution.Internal.Declare-                                                ( declareType )+                                                ( declareType+                                                , Scope(..)+                                                ) import           Data.Morpheus.Types.Internal.AST                                                 ( isInput                                                 , isObject@@ -36,11 +38,11 @@ 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+    mainType        <- declareMainType+    argTypes        <- declareArgTypes+    gqlInstances    <- deriveGQLInstances+    typeClasses     <- deriveGQLType gqlType+    introspectEnum  <- instanceIntrospect typeOriginal     pure $ mainType <> typeClasses <> argTypes <> gqlInstances <> introspectEnum  where   deriveGQLInstances = concat <$> sequence gqlInstances@@ -60,11 +62,11 @@    where     deriveArgsRep args = deriveObjectRep (args, Nothing)     -----------------------------------------------------    argsTypeDecs = map (declareType namespace Nothing []) typeArgD+    argsTypeDecs = map (declareType SERVER namespace Nothing []) typeArgD       --------------------------------------------------   declareMainType = declareT    where     declareT =-      pure [declareType namespace (Just typeKindD) derivingClasses typeD]+      pure [declareType SERVER namespace (Just typeKindD) derivingClasses typeD]     derivingClasses | isInput typeKindD = [''Show]                     | otherwise         = []

src/Data/Morpheus/Execution/Document/Decode.hs view

@@ -31,9 +31,9 @@ import           Data.Morpheus.Types.Internal.TH                                                 ( instanceHeadT ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Eventless ) -(.:) :: Decode a => ValidValue -> Text -> Validation a+(.:) :: Decode a => ValidValue -> Text -> Eventless a value .: selectorName = withObject (decodeFieldWith decode selectorName) value  deriveDecode :: TypeD -> Q [Dec]

src/Data/Morpheus/Execution/Document/Encode.hs view

@@ -21,7 +21,7 @@                                                 ) import           Data.Morpheus.Types.GQLType    ( TRUE ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)+                                                ( FieldDefinition(..)                                                 , QUERY                                                 , SUBSCRIPTION                                                 , isSubscription@@ -34,7 +34,8 @@                                                 ( Resolver                                                 , MapStrategy(..)                                                 , LiftOperation-                                                , DataResolver(..)+                                                , Deriving(..)+                                                , ObjectDeriving(..)                                                 ) import           Data.Morpheus.Types.Internal.TH                                                 ( applyT@@ -79,7 +80,8 @@     | isSubscription typeKindD     = [applyT ''MapStrategy $ map conT [''QUERY, ''SUBSCRIPTION]]     | otherwise-    = [ iLiftOp fo_+    = [ iLiftOp po_+      , iLiftOp fo_       , typeT ''MapStrategy [fo_, po_]       , iTypeable fo_       , iTypeable po_@@ -107,7 +109,14 @@   methods = [funD 'exploreResolvers [clause argsE (normalB body) []]]    where     argsE = [varP (mkName "_"), destructRecord tName varNames]-    body  = appE (conE 'ObjectRes) (listE $ map (decodeVar . unpack) 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

src/Data/Morpheus/Execution/Document/GQLType.hs view

@@ -44,48 +44,49 @@                                                 ) import           Data.Typeable                  ( Typeable ) -genTypeName :: Key -> Key-genTypeName = pack . __genTypeName . unpack- where-  __genTypeName ('S' : name) | isSchemaTypeName (pack name) = name-  __genTypeName name = name- deriveGQLType :: GQLTypeD -> Q [Dec] deriveGQLType GQLTypeD { typeD = TypeD { tName, tMeta }, typeKindD } =   pure <$> instanceD (cxt constrains) iHead (functions <> typeFamilies)  where   functions = map     instanceProxyFunD-    [('__typeName, [|genTypeName tName|]), ('description, descriptionValue)]+    [('__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 = [deriveCUSTOM, deriveKind]-               | otherwise          = [deriveKind]+   where conTypeable name = typeT ''Typeable [name]+  -------------------------------------------------+  typeFamilies | isObject typeKindD = [deriveKIND, deriveCUSTOM]+               | otherwise          = [deriveKIND]    where-    deriveCUSTOM = do-      typeN <- headSig-      pure $ typeInstanceDec ''CUSTOM typeN (ConT ''TRUE)-    ----------------------------------------------------------------    deriveKind = do+    deriveCUSTOM = deriveInstance ''CUSTOM ''TRUE+    deriveKIND = deriveInstance ''KIND (kindName typeKindD)+    -------------------------------------------------------+    deriveInstance :: Name -> Name -> Q Dec+    deriveInstance insName tyName = do       typeN <- headSig-      pure $ typeInstanceDec ''KIND typeN (ConT $ toKIND typeKindD)-    ----------------------------------    toKIND KindScalar      = ''SCALAR-    toKIND KindEnum        = ''ENUM-    toKIND (KindObject _)  = ''OUTPUT-    toKIND KindUnion       = ''OUTPUT-    toKIND KindInputObject = ''INPUT-    toKIND KindList        = ''WRAPPER-    toKIND KindNonNull     = ''WRAPPER-    toKIND KindInputUnion  = ''INPUT+      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 view

@@ -1,7 +1,9 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE QuasiQuotes        #-}+{-# LANGUAGE TemplateHaskell    #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE RecordWildCards    #-}  module Data.Morpheus.Execution.Document.Introspect   ( deriveObjectRep , instanceIntrospect@@ -17,34 +19,34 @@ 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 (..), Key, DataType(..), DataTypeContent(..), DataField (..),insertType,DataTypeKind(..), TypeRef (..))+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 :: (Key,DataType) -> Q [Dec]--- FIXME: dirty fix for introspection-instanceIntrospect ("__DirectiveLocation",_) = pure []-instanceIntrospect ("__TypeKind",_) = pure []-instanceIntrospect (name, DataType {-      typeContent = DataEnum enumType,-      typeName-      , typeMeta-      , typeFingerprint-    }) = pure <$> instanceD (cxt []) iHead [defineIntrospect]+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 name []+    iHead = instanceHeadT ''Introspect typeName []     defineIntrospect = instanceProxyFunD ('introspect,body)       where-        body =[| insertType (name,DataType {-          typeName-          ,typeMeta-          , typeFingerprint-          ,typeContent = DataEnum enumType-        }) |]+        body =[| insertType TypeDefinition { typeContent = DataEnum enumType, .. } |] instanceIntrospect _ = pure [] --- [((Text, DataField), TypeUpdater)]+-- [(FieldDefinition, TypeUpdater)] deriveObjectRep :: (TypeD, Maybe DataTypeKind) -> Q [Dec] deriveObjectRep (TypeD {tName, tCons = [ConsD {cFields}]}, tKind) =   pure <$> instanceD (cxt constrains) iHead methods@@ -59,18 +61,18 @@     methods = [instanceFunD 'introspectRep ["_proxy1", "_proxy2"] body]       where         body -          | tKind == Just KindInputObject || null tKind  = [| (DataInputObject  $(buildFields cFields), concat $(buildTypes cFields))|]-          | otherwise  =  [| (DataObject [] $(buildFields cFields), concat $(buildTypes cFields))|]+          | tKind == Just KindInputObject || null tKind  = [| (DataInputObject $ unsafeFromInputFields $(buildFields cFields), concat $(buildTypes cFields))|]+          | otherwise  =  [| (DataObject [] $ unsafeFromFields $(buildFields cFields), concat $(buildTypes cFields))|] deriveObjectRep _ = pure []     -buildTypes :: [DataField] -> ExpQ+buildTypes :: [FieldDefinition] -> ExpQ buildTypes = listE . concatMap introspectField   where-    introspectField DataField {fieldType, fieldArgsType} =-      [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgsType+    introspectField FieldDefinition {fieldType, fieldArgs } =+      [|[introspect $(proxyT fieldType)]|] : inputTypes fieldArgs       where-        inputTypes (Just argsTypeName)-          | argsTypeName /= "()" = [[|snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]]+        inputTypes ArgumentsDefinition { argumentsTypename = Just argsTypeName }+          | argsTypeName /= "()" = [[| snd $ introspectObjectFields (Proxy :: Proxy TRUE) (argsTypeName, InputType,$(proxyT tAlias))|]]           where             tAlias = TypeRef {typeConName = argsTypeName, typeWrappers = [], typeArgs = Nothing}         inputTypes _ = []@@ -87,18 +89,7 @@     genSig (Just m) = appT (conTX typeConName) (varTX m)     genSig _        = conTX typeConName -buildFields :: [DataField] -> ExpQ+buildFields :: [FieldDefinition] -> ExpQ buildFields = listE . map buildField   where-    buildField DataField {fieldName, fieldArgs, fieldType = alias@TypeRef {typeArgs, typeWrappers}, fieldMeta} =-      [|( fieldName-        , DataField-            { fieldName-            , fieldArgs = fArgs-            , fieldArgsType = Nothing-            , fieldType = TypeRef {typeConName = __typeName $(proxyT alias), typeArgs = aArgs, typeWrappers}-            , fieldMeta-            })|]-      where-        fArgs = map (\(k, v) -> (unpack k, v)) fieldArgs-        aArgs = unpack <$> typeArgs+    buildField f@FieldDefinition {fieldType } = [| f { fieldType = fieldType {typeConName = __typeName $(proxyT fieldType) } } |]

src/Data/Morpheus/Execution/Internal/Declare.hs view

@@ -6,14 +6,18 @@ {-# 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@@ -24,7 +28,7 @@                                                 , nameSpaceWith                                                 ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)+                                                ( FieldDefinition(..)                                                 , DataTypeKind(..)                                                 , DataTypeKind(..)                                                 , TypeRef(..)@@ -35,6 +39,7 @@                                                 , TypeD(..)                                                 , Key                                                 , isOutputObject+                                                , ArgumentsDefinition(..)                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( UnSubResolver )@@ -65,10 +70,13 @@ tyConArgs kindD | isOutputObject kindD || kindD == KindUnion = [m_]                 | otherwise = [] +data Scope = CLIENT | SERVER+  deriving Eq+ -- declareType-declareType :: Bool -> Maybe DataTypeKind -> [Name] -> TypeD -> Dec-declareType namespace kindD derivingList TypeD { tName, tCons, tNamespace } =-  DataD [] (genName tName) tVars Nothing (map cons tCons)+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@@ -76,26 +84,34 @@     where declareTyVar = map (PlainTV . mkName . unpack)   defBang = Bang NoSourceUnpackedness NoSourceStrictness   derive className = DerivClause Nothing [ConT className]-  cons ConsD { cName, cFields } = RecC (genName cName)-                                       (map declareField cFields)+  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 DataField { fieldName, fieldArgsType, fieldType } =+    declareField FieldDefinition { fieldName, fieldArgs, fieldType } =       (fName, defBang, fiType)      where       fName | namespace = mkName $ unpack (nameSpaceWith tName fieldName)             | otherwise = mkName (unpack fieldName)-      fiType = genFieldT fieldArgsType+      fiType = genFieldT fieldArgs        where         monadVar = VarT $ mkName $ unpack m_         ----------------------------        genFieldT Nothing-          | (isOutputObject <$> kindD) == Just True = AppT monadVar result-          | otherwise                             = result-        genFieldT (Just argsTypeName) = AppT+        genFieldT ArgumentsDefinition {  argumentsTypename = Just argsTypename } = AppT           (AppT arrowType argType)           (AppT monadVar result)          where-          argType   = ConT $ mkName (unpack argsTypeName)+          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 view

@@ -1,6 +1,7 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell   #-}+{-# LANGUAGE NamedFieldPuns       #-}+{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE TemplateHaskell      #-}+{-# LANGUAGE ScopedTypeVariables  #-}  module Data.Morpheus.Execution.Internal.Decode   ( withObject@@ -26,17 +27,24 @@                                                 internalTypeMismatch                                                 ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)+                                                ( FieldDefinition(..)                                                 , Key                                                 , ConsD(..)                                                  , ValidObject                                                 , Value(..)                                                 , ValidValue                                                 , Message+                                                , ObjectEntry(..)                                                 ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation, Failure(..) )-+                                                ( Eventless +                                                , Failure(..) +                                                )+import           Data.Morpheus.Types.Internal.Operation+                                                ( selectBy+                                                , selectOr+                                                , empty+                                                )  decodeObjectExpQ :: ExpQ -> ConsD -> ExpQ decodeObjectExpQ fieldDecoder ConsD { cName, cFields } = handleFields cFields@@ -49,12 +57,12 @@     applyFields [x     ] = defField x     applyFields (x : xs) = uInfixE (defField x) (varE '(<*>)) (applyFields xs)     -------------------------------------------------------------------------    defField DataField { fieldName } = uInfixE (varE (mkName "o"))+    defField FieldDefinition { fieldName } = uInfixE (varE (mkName "o"))                                                fieldDecoder                                                [|fName|]       where fName = unpack fieldName -withObject :: (ValidObject -> Validation a) -> ValidValue -> Validation a+withObject :: (ValidObject -> Eventless a) -> ValidValue -> Eventless a withObject f (Object object) = f object withObject _ isType          = internalTypeMismatch "Object" isType @@ -62,23 +70,23 @@ withMaybe _      Null = pure Nothing withMaybe decode x    = Just <$> decode x -withList :: (ValidValue -> Validation a) -> ValidValue -> Validation [a]-withList decode (List li) = mapM decode li+withList :: (ValidValue -> Eventless a) -> ValidValue -> Eventless [a]+withList decode (List li) = traverse decode li withList _      isType    = internalTypeMismatch "List" isType -withEnum :: (Key -> Validation a) -> ValidValue -> Validation a+withEnum :: (Key -> Eventless a) -> ValidValue -> Eventless a withEnum decode (Enum value) = decode value withEnum _      isType       = internalTypeMismatch "Enum" isType -withUnion :: (Key -> ValidObject -> ValidObject -> Validation a) -> ValidObject -> Validation a-withUnion decoder unions = case lookup "__typename" unions of-  Just (Enum key) -> case lookup key unions of-    Nothing -> withObject (decoder key unions) (Object [])-    Just value -> withObject (decoder key unions) value-  Just _  -> failure ("__typename must be Enum" :: Message)-  Nothing -> failure ("__typename not found on Input Union" :: Message)+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 -> Validation a) -> Key -> ValidObject -> Validation a-decodeFieldWith decoder name object = case lookup name object of-  Nothing    -> decoder Null-  Just value -> decoder value+decodeFieldWith :: (ValidValue -> Eventless a) -> Key -> ValidObject -> Eventless a+decodeFieldWith decoder = selectOr (decoder Null) (decoder . entryValue)

src/Data/Morpheus/Execution/Server/Decode.hs view

@@ -48,29 +48,31 @@ import           Data.Morpheus.Types.Internal.AST                                                 ( Name                                                 , Argument(..)-                                                , ValidArguments-                                                , ValidArgument+                                                , ObjectEntry(..)                                                 , ValidObject                                                 , Value(..)                                                 , ValidValue+                                                , Arguments+                                                , VALID                                                 ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+                                                ( Eventless                                                 , Failure(..)                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                ( Listable(..)+                                                )   -- GENERIC-decodeArguments :: DecodeType a => ValidArguments -> Validation a-decodeArguments = decodeType . Object . map toObject- where-  toObject :: (Name, ValidArgument) -> (Name, ValidValue)-  toObject (x, Argument { argumentValue }) = (x, argumentValue)-+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 -> Validation a+  decode :: ValidValue -> Eventless a  instance {-# OVERLAPPABLE #-} DecodeKind (KIND a) a => Decode a where   decode = decodeKind (Proxy @(KIND a))@@ -83,7 +85,7 @@  -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: GQL_KIND) a where-  decodeKind :: Proxy kind -> ValidValue -> Validation a+  decodeKind :: Proxy kind -> ValidValue -> Eventless a  -- SCALAR instance (GQLScalar a) => DecodeKind SCALAR a where@@ -105,7 +107,7 @@   class DecodeType a where-  decodeType :: ValidValue -> Validation a+  decodeType :: ValidValue -> Eventless a  instance {-# OVERLAPPABLE #-} (Generic a, DecodeRep (Rep a))=> DecodeType a where   decodeType = fmap to . decodeRep . (, Cont D_CONS "")@@ -118,11 +120,11 @@ --     deriving (Generic, GQLType)  decideUnion-  :: ([Name], value -> Validation (f1 a))-  -> ([Name], value -> Validation (f2 a))+  :: ([Name], value -> Eventless (f1 a))+  -> ([Name], value -> Eventless (f2 a))   -> Name   -> value-  -> Validation ((:+:) f1 f2 a)+  -> Eventless ((:+:) f1 f2 a) decideUnion (left, f1) (right, f2) name value   | name `elem` left   = L1 <$> f1 value@@ -153,16 +155,17 @@ -- class DecodeRep f where   tags :: Proxy f -> Name -> Info-  decodeRep :: (ValidValue,Cont) -> Validation (f a)+  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 -> Validation Name-getEnumTag [("enum", Enum value)] = pure value-getEnumTag _                      = internalError "bad union enum object"+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)@@ -210,7 +213,7 @@  class DecodeFields f where   refType :: Proxy f -> Maybe Name-  decodeFields :: (ValidValue,Cont) -> Validation (f a)+  decodeFields :: (ValidValue,Cont) -> Eventless (f a)  instance (DecodeFields f, DecodeFields g) => DecodeFields (f :*: g) where   refType _ = Nothing

src/Data/Morpheus/Execution/Server/Encode.hs view

@@ -10,21 +10,19 @@ {-# LANGUAGE TypeFamilies          #-} {-# LANGUAGE TypeOperators         #-} {-# LANGUAGE UndecidableInstances  #-}+{-# LANGUAGE GADTs                 #-}  module Data.Morpheus.Execution.Server.Encode   ( EncodeCon   , Encode(..)-  , encodeQuery-  , encodeSubscription-  , encodeMutation   , ExploreResolvers(..)+  , deriveModel   ) where  import           Data.Map                       ( Map ) import qualified Data.Map                      as M                                                 ( toList )-import           Data.Maybe                     ( fromMaybe ) import           Data.Proxy                     ( Proxy(..) ) import           Data.Semigroup                 ( (<>) ) import           Data.Set                       ( Set )@@ -38,8 +36,6 @@                                                 ( DecodeType                                                 , decodeArguments                                                 )-import           Data.Morpheus.Execution.Server.Generics.EnumRep-                                                ( EnumRep(..) ) import           Data.Morpheus.Kind             ( ENUM                                                 , GQL_KIND                                                 , ResContext(..)@@ -55,43 +51,43 @@ import           Data.Morpheus.Types.GQLType    ( GQLType(..) ) import           Data.Morpheus.Types.Internal.AST                                                 ( Name-                                                , Operation(..)-                                                , MUTATION-                                                , OperationType+                                                , OperationType(..)                                                 , QUERY                                                 , SUBSCRIPTION-                                                , GQLValue(..)-                                                , ValidValue+                                                , MUTATION+                                                , Message                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                (Merge(..)) import           Data.Morpheus.Types.Internal.Resolving                                                 ( MapStrategy(..)                                                 , LiftOperation                                                 , Resolver-                                                , unsafeBind                                                 , toResolver-                                                , DataResolver(..)-                                                , resolveObject-                                                , resolve__typename+                                                , Deriving(..)                                                 , FieldRes-                                                , ResponseStream-                                                , runResolver-                                                , runDataResolver-                                                , Context(..)+                                                , GQLRootResolver(..)+                                                , ResolverModel(..)+                                                , unsafeBind+                                                , failure+                                                , ObjectDeriving(..)+                                                , Eventless+                                                , liftStateless                                                 )  class Encode resolver o e (m :: * -> *) where-  encode :: resolver -> Resolver o e m ValidValue+  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 gqlNull) encode+  encode = maybe (pure DerivingNull) encode  -- LIST [] instance (Monad m, Encode a o e m, LiftOperation o) => Encode [a] o e m where-  encode = fmap gqlList . (traverse encode)+  encode = fmap DerivingList . traverse encode  --  Tuple  (a,b) instance Encode (Pair k v) o e m => Encode (k, v) o e m where@@ -107,46 +103,68 @@     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, MapStrategy fo o, Encode b fo e m) => Encode (a -> Resolver fo e m b) o e m where- encode resolver = mapStrategy $ (toResolver decodeArguments resolver) `unsafeBind` encode +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 fo, MapStrategy fo o, Encode b fo e m) => Encode (Resolver fo e m b) o e m where-  encode = mapStrategy . (`unsafeBind` encode)+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 ValidValue+  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 . gqlScalar . serialize . unVContext+  encodeKind = pure . DerivingScalar . serialize . unVContext  -- ENUM-instance (Generic a, EnumRep (Rep a), Monad m) => EncodeKind ENUM a o e m where-  encodeKind = pure . gqlString . encodeRep . from . unVContext+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, GQLType a,ExploreResolvers (CUSTOM a) a o e m) => EncodeKind OUTPUT a o e m where-  encodeKind (VContext value) = runDataResolver (__typeName (Proxy @a)) (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-  -> DataResolver o e m-convertNode ResNode { resKind = REP_OBJECT, resFields } =-  ObjectRes $ map toFieldRes resFields+  -> 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 [] = EnumRes resTypeName+  encodeUnion [] = DerivingEnum resDatatypeName resTypeName   -- Type References --------------------------------------------------------------   encodeUnion [FieldNode { fieldTypeName, fieldResolver, isFieldObject }]     | isFieldObject && resTypeName == resDatatypeName <> fieldTypeName-    = UnionRef (fieldTypeName, fieldResolver)-  -- RECORDS -----------------------------------------------------------------------------  encodeUnion fields = UnionRes-    (resTypeName, resolve__typename resTypeName : map toFieldRes resolvers)+    = DerivingUnion fieldTypeName fieldResolver+  -- Inline Union Types ----------------------------------------------------------------------------+  encodeUnion fields +      = DerivingUnion+        resTypeName+        $ pure+        $ DerivingObject +        $ ObjectDeriving +            resTypeName +            (map toFieldRes resolvers)    where     resolvers | isResRecord = fields               | otherwise   = setFieldNames fields@@ -154,75 +172,79 @@ -- Types & Constrains ------------------------------------------------------- type GQL_RES a = (Generic a, GQLType a) -type EncodeOperation e m a = a -> Context -> ResponseStream e m ValidValue- type EncodeCon o e m a = (GQL_RES a, ExploreResolvers (CUSTOM a) a o e m) --objectResolvers-  :: forall custom a o e m-   . ExploreResolvers custom a o e m-  => Proxy custom-  -> a-  -> DataResolver o e m-objectResolvers isCustom value = case exploreResolvers isCustom value of-  ObjectRes resFields -> ObjectRes resFields-  _                   -> InvalidRes "resolver must be an object"-- --- GENERICS ------------------------------------------------ class ExploreResolvers (custom :: Bool) a (o :: OperationType) e (m :: * -> *) where-  exploreResolvers :: Proxy custom -> a -> DataResolver o e m+  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 = convertNode-    $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)+  exploreResolvers _ value = +    pure +      $ convertNode+      $ typeResolvers (ResContext :: ResContext OUTPUT o e m value) (from value)  ----- HELPERS -----------------------------encodeQuery-  :: forall m event query (schema :: (* -> *) -> *)-   . ( Monad m-     , EncodeCon QUERY event m (schema (Resolver QUERY event m))-     , EncodeCon QUERY event m query+objectResolvers+  :: forall a o e m+   . ( ExploreResolvers (CUSTOM a) a o e m+     , Monad m+     , LiftOperation o      )-  => schema (Resolver QUERY event m)-  -> EncodeOperation event m query-encodeQuery schema = encodeOperationWith-  (Proxy @QUERY)-  (Just $ objectResolvers-    (Proxy :: Proxy (CUSTOM (schema (Resolver QUERY event m))))-    schema-  )--encodeMutation-  :: forall event m mut-   . (Monad m, EncodeCon MUTATION event m mut)-  => EncodeOperation event m mut-encodeMutation = encodeOperationWith (Proxy @MUTATION) Nothing+  => 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) -encodeSubscription-  :: forall m event mut-   . (Monad m, EncodeCon SUBSCRIPTION event m mut)-  => EncodeOperation event m mut-encodeSubscription = encodeOperationWith (Proxy @SUBSCRIPTION) Nothing+type Con o e m a +  = ExploreResolvers +      (CUSTOM +        (a (Resolver o e m))+      ) +      (a (Resolver o e m)) +      o +      e +      m -encodeOperationWith-  :: forall (o :: OperationType) e m a-   . (Monad m, EncodeCon o e m a, LiftOperation o)-  => Proxy o-  -> Maybe (DataResolver o e m)-  -> EncodeOperation e m a-encodeOperationWith _ externalRes rootResolver ctx@Context { operation = Operation { operationSelection } } =-  runResolver (resolveObject operationSelection (rootDataRes <> extDataRes)) ctx- where-  rootDataRes = objectResolvers (Proxy :: Proxy (CUSTOM a)) rootResolver-  extDataRes  = fromMaybe (ObjectRes []) externalRes+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 @@ -235,9 +257,9 @@   }  data FieldNode o e m = FieldNode {-    fieldTypeName :: Name,-    fieldSelName :: Name,-    fieldResolver  :: Resolver o e m ValidValue,+    fieldTypeName  :: Name,+    fieldSelName   :: Name,+    fieldResolver  :: Resolver o e m (Deriving o e m),     isFieldObject  :: Bool   } @@ -251,11 +273,9 @@  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)-    }-+    { resDatatypeName = pack $ datatypeName (undefined :: M1 D d f a) } -      --- UNION OR OBJECT +--- 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 }

src/Data/Morpheus/Execution/Server/Generics/EnumRep.hs view

@@ -19,11 +19,11 @@ -- MORPHEUS import           Data.Morpheus.Error.Internal   ( internalError ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Eventless )  class EnumRep f where   encodeRep :: f a -> Text-  decodeEnum :: Text -> Validation (f a)+  decodeEnum :: Text -> Eventless (f a)   enumTags :: Proxy f -> [Text]  instance (Datatype c, EnumRep f) => EnumRep (M1 D c f) where

src/Data/Morpheus/Execution/Server/Interpreter.hs view

@@ -8,41 +8,24 @@   ) where -import           Data.Aeson                     ( encode )-import           Data.ByteString                ( ByteString )-import qualified Data.ByteString.Lazy.Char8    as LB-                                                ( ByteString-                                                , fromStrict-                                                , toStrict-                                                )-import           Data.Text                      ( Text )-import qualified Data.Text.Lazy                as LT-                                                ( Text-                                                , fromStrict-                                                , toStrict-                                                )-import           Data.Text.Lazy.Encoding        ( decodeUtf8-                                                , encodeUtf8-                                                )-import           Control.Monad.IO.Class         ( MonadIO() )  -- MORPHEUS+import           Data.Morpheus.Types.Internal.Subscription+                                                ( Stream+                                                , Input+                                                , toOutStream+                                                ) import           Data.Morpheus.Execution.Server.Resolve                                                 ( RootResCon-                                                , byteStringIO-                                                , statefulResolver-                                                , statelessResolver-                                                , streamResolver                                                 , coreResolver+                                                , statelessResolver                                                 )-import           Data.Morpheus.Execution.Server.Subscription-                                                ( GQLState ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( GQLRootResolver(..)-                                                , ResponseStream                                                 ) import           Data.Morpheus.Types.IO         ( GQLRequest                                                 , GQLResponse+                                                , MapAPI(..)                                                 )  -- | main query processor and resolver@@ -62,76 +45,20 @@ --       -- or --       k :: GQLRequest -> IO GQLResponse --     @-class Interpreter k m e  where+class Interpreter e m a b where   interpreter ::        Monad m-    => (RootResCon m e query mut sub) =>-         GQLRootResolver m e query mut sub -> k--{--  simple HTTP stateless Interpreter without side effects--}-type StateLess m a = a -> m a+    => (RootResCon m e query mut sub) +        => GQLRootResolver m e query mut sub+        -> a+        -> b -instance Interpreter (GQLRequest -> m GQLResponse) m e   where+instance Interpreter e m GQLRequest (m GQLResponse) where   interpreter = statelessResolver -instance Interpreter (StateLess m LB.ByteString) m e  where-  interpreter root = byteStringIO (statelessResolver root)--instance Interpreter (StateLess m LT.Text) m e  where-  interpreter root request =-    decodeUtf8 <$> interpreter root (encodeUtf8 request)--instance Interpreter (StateLess m ByteString) m e  where-  interpreter root request =-    LB.toStrict <$> interpreter root (LB.fromStrict request)--instance Interpreter (StateLess m Text) m e  where-  interpreter root request =-    LT.toStrict <$> interpreter root (LT.fromStrict request)--{--   HTTP Interpreter with state and side effects, every mutation will-   trigger subscriptions in  shared `GQLState`--}-type WSPub m e a = GQLState m e -> a -> m a--instance MonadIO m => Interpreter (WSPub m e LB.ByteString) m e where-  interpreter root state = statefulResolver state (coreResolver root)--instance MonadIO m => Interpreter (WSPub m e  LT.Text) m e where-  interpreter root state request =-    decodeUtf8 <$> interpreter root state (encodeUtf8 request)--instance MonadIO m => Interpreter (WSPub m e  ByteString) m e where-  interpreter root state request =-    LB.toStrict <$> interpreter root state (LB.fromStrict request)--instance MonadIO m => Interpreter (WSPub m e  Text) m e  where-  interpreter root state request =-    LT.toStrict <$> interpreter root state (LT.fromStrict request)--{--   WebSocket Interpreter without state and side effects, mutations and subscription will return Actions-   that will be executed in WebSocket server--}-type WSSub m e a = a -> ResponseStream e m a--instance Interpreter (GQLRequest -> ResponseStream e m LB.ByteString) m e where-  interpreter root request = encode <$> streamResolver root request--instance Interpreter (WSSub m e  LB.ByteString) m e where-  interpreter root = byteStringIO (streamResolver root)--instance Interpreter (WSSub m e  LT.Text)  m e where-  interpreter root request =-    decodeUtf8 <$> interpreter root (encodeUtf8 request)--instance Interpreter (WSSub m e ByteString) m e where-  interpreter root request =-    LB.toStrict <$> interpreter root (LB.fromStrict request)+instance Interpreter e m (Input api)  (Stream api e m) where+  interpreter root = toOutStream (coreResolver root) -instance Interpreter (WSSub m e Text)  m e where-  interpreter root request =-    LT.toStrict <$> interpreter root (LT.fromStrict request)+instance ( MapAPI a ) => +  Interpreter e m a (m a)  where+    interpreter root = mapAPI (interpreter root)

src/Data/Morpheus/Execution/Server/Introspect.hs view

@@ -1,19 +1,20 @@-{-# 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 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@@ -61,11 +62,11 @@                                                 ) import           Data.Morpheus.Types.Internal.AST                                                 ( Name-                                                , DataArguments+                                                , ArgumentsDefinition(..)                                                 , Meta(..)-                                                , DataField(..)-                                                , DataTypeContent(..)-                                                , DataType(..)+                                                , FieldDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)                                                 , Key                                                 , createAlias                                                 , defineType@@ -76,10 +77,16 @@                                                 , TypeUpdater                                                 , DataFingerprint(..)                                                 , DataUnion-                                                , DataObject+                                                , FieldsDefinition(..)+                                                , InputFieldsDefinition(..)                                                 , TypeRef(..)+                                                , Message+                                                , unsafeFromFields                                                 )-+import           Data.Morpheus.Types.Internal.Operation+                                                ( Empty(..)+                                                , Singleton(..)+                                                )  type IntroCon a = (GQLType a, IntrospectRep (CUSTOM a) a) @@ -89,12 +96,12 @@   isObject :: proxy a -> Bool   default isObject :: GQLType a => proxy a -> Bool   isObject _ = isObjectKind (Proxy @a)-  field :: proxy a -> Text -> DataField+  field :: proxy a -> Text -> FieldDefinition   introspect :: proxy a -> TypeUpdater   -----------------------------------------------   default field :: GQLType a =>-    proxy a -> Text -> DataField-  field _ = buildField (Proxy @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)@@ -135,7 +142,7 @@   field _ name = fieldObj { fieldArgs }    where     fieldObj  = field (Proxy @b) name-    fieldArgs = fst $ introspectObjectFields+    fieldArgs = ArgumentsDefinition Nothing $ unFieldsDefinition $ fst  $ introspectObjectFields       (Proxy :: Proxy 'False)       (__typeName (Proxy @b), OutputType, Proxy @a)   introspect _ typeLib = resolveUpdates typeLib@@ -191,46 +198,44 @@  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)-  -> ([(Name, DataField)], [TypeUpdater])+  -> (FieldsDefinition, [TypeUpdater]) introspectObjectFields p1 (name, scope, proxy) = withObject   (introspectRep p1 (proxy, scope, "", DataFingerprint "" []))  where   withObject (DataObject     {objectFields}, ts) = (objectFields, ts)-  withObject (DataInputObject x, ts) = (x, ts)-  withObject _ =-    ( []-    , [ const-          $  failure-          $  globalErrorMessage-          $  "invalid schema: "-          <> name-          <> " should have only one nonempty constructor"-      ]-    )+  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) -> (DataTypeContent, [TypeUpdater])+  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 -> DataArguments -> Text -> DataField-buildField proxy fieldArgs fieldName = DataField-  { fieldName-  , fieldArgs-  , fieldArgsType = Nothing-  , fieldType     = createAlias $ __typeName proxy+buildField :: GQLType a => Proxy a -> ArgumentsDefinition -> Text -> FieldDefinition+buildField proxy fieldArgs fieldName = FieldDefinition+  { fieldType     = createAlias $ __typeName proxy   , fieldMeta     = Nothing+  , ..   } -buildType :: GQLType a => DataTypeContent -> Proxy a -> DataType-buildType typeContent proxy = DataType+buildType :: GQLType a => TypeContent -> Proxy a -> TypeDefinition+buildType typeContent proxy = TypeDefinition   { typeName        = __typeName proxy   , typeFingerprint = __typeFingerprint proxy   , typeMeta        = Just Meta { metaDescription = description proxy@@ -241,23 +246,23 @@  updateLib   :: GQLType a-  => (Proxy a -> DataType)+  => (Proxy a -> TypeDefinition)   -> [TypeUpdater]   -> Proxy a   -> TypeUpdater-updateLib typeBuilder stack proxy lib' =-  case isTypeDefined (__typeName proxy) lib' of+updateLib typeBuilder stack proxy lib =+  case isTypeDefined (__typeName proxy) lib of     Nothing -> resolveUpdates-      (defineType (__typeName proxy, typeBuilder proxy) lib')+      (defineType (typeBuilder proxy) lib)       stack-    Just fingerprint' | fingerprint' == __typeFingerprint proxy -> return lib'+    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 {+data ConsRep = ConsRep {   consName :: Key,   consIsRecord :: Bool,   consFields :: [FieldRep]@@ -265,7 +270,7 @@  data FieldRep = FieldRep {   fieldTypeName :: Name,-  fieldData :: (Name, DataField),+  fieldData :: FieldDefinition,   fieldTypeUpdater :: TypeUpdater,   fieldIsObject :: Bool }@@ -273,17 +278,14 @@ data ResRep = ResRep {   enumCons :: [Name],   unionRef :: [Name],-  unionRecordRep :: [ConsRep]+  unionRecordRep :: [ConsRep ] }  isEmpty :: ConsRep -> Bool isEmpty ConsRep { consFields = [] } = True isEmpty _                           = False -isUnionRecord :: ConsRep -> Bool-isUnionRecord ConsRep { consIsRecord } = consIsRecord--isUnionRef :: Name -> ConsRep -> Bool+isUnionRef :: Name -> ConsRep  -> Bool isUnionRef baseName ConsRep { consName, consFields = [FieldRep { fieldIsObject = True, fieldTypeName }] }   = consName == baseName <> fieldTypeName isUnionRef _ _ = False@@ -293,9 +295,7 @@   { consFields = zipWith setFieldName ([0 ..] :: [Int]) consFields   }  where-  setFieldName i fieldR@FieldRep { fieldData = (_, fieldD) } = fieldR-    { fieldData = (fieldName, fieldD { fieldName })-    }+  setFieldName i fieldR@FieldRep { fieldData = fieldD } = fieldR { fieldData = fieldD { fieldName } }     where fieldName = "_" <> pack (show i)  analyseRep :: Name -> [ConsRep] -> ResRep@@ -307,7 +307,7 @@  where   (enumRep       , left1             ) = partition isEmpty cons   (unionRefRep   , left2             ) = partition (isUnionRef baseName) left1-  (unionRecordRep, anyonimousUnionRep) = partition isUnionRecord left2+  (unionRecordRep, anyonimousUnionRep) = partition consIsRecord left2  derivingDataContent   :: forall a@@ -315,7 +315,7 @@   => Proxy a   -> (Name, DataFingerprint)   -> TypeScope-  -> (DataTypeContent, [TypeUpdater])+  -> (TypeContent, [TypeUpdater]) derivingDataContent _ (baseName, baseFingerprint) scope =   builder $ typeRep $ Proxy @(Rep a)  where@@ -328,7 +328,7 @@   buildInputUnion-  :: (Name, DataFingerprint) -> [ConsRep] -> (DataTypeContent, [TypeUpdater])+  :: (Name, DataFingerprint) -> [ConsRep ] -> (TypeContent, [TypeUpdater]) buildInputUnion (baseName, baseFingerprint) cons = datatype   (analyseRep baseName cons)  where@@ -340,15 +340,15 @@     typeMembers =       map (, True) (unionRef <> unionMembers) <> map (, False) enumCons     (unionMembers, unionTypes) =-      buildUnions DataInputObject baseFingerprint unionRecordRep+      buildUnions (DataInputObject . toInput) baseFingerprint unionRecordRep   types = map fieldTypeUpdater $ concatMap consFields cons  buildUnionType   :: (Name, DataFingerprint)-  -> (DataUnion -> DataTypeContent)-  -> (DataObject -> DataTypeContent)+  -> (DataUnion -> TypeContent)+  -> (FieldsDefinition -> TypeContent)   -> [ConsRep]-  -> (DataTypeContent, [TypeUpdater])+  -> (TypeContent, [TypeUpdater]) buildUnionType (baseName, baseFingerprint) wrapUnion wrapObject cons = datatype   (analyseRep baseName cons)  where@@ -365,48 +365,41 @@   types = map fieldTypeUpdater $ concatMap consFields cons  -buildObject :: TypeScope -> [FieldRep] -> (DataTypeContent, [TypeUpdater])-buildObject isOutput consFields = (wrap fields, types)+buildObject :: TypeScope -> [FieldRep] -> (TypeContent, [TypeUpdater])+buildObject isOutput consFields = (wrapWith fields, types)  where   (fields, types) = buildDataObject consFields-  wrap | isOutput == OutputType = DataObject []-       | otherwise              = DataInputObject+  wrapWith | isOutput == OutputType = DataObject [] +           | otherwise              = DataInputObject . toInput  -buildDataObject :: [FieldRep] -> (DataObject, [TypeUpdater])+buildDataObject :: [FieldRep] -> (FieldsDefinition , [TypeUpdater]) buildDataObject consFields = (fields, types)  where-  fields = map fieldData consFields+  fields = unsafeFromFields $ map fieldData consFields   types  = map fieldTypeUpdater consFields  buildUnions-  :: (DataObject -> DataTypeContent)+  :: (FieldsDefinition -> TypeContent)   -> DataFingerprint   -> [ConsRep]   -> ([Name], [TypeUpdater]) buildUnions wrapObject baseFingerprint cons = (members, map buildURecType cons)  where   buildURecType consRep = pure . defineType-    (consName consRep, buildUnionRecord wrapObject baseFingerprint consRep)+      (buildUnionRecord wrapObject baseFingerprint consRep)   members = map consName cons  buildUnionRecord-  :: (DataObject -> DataTypeContent) -> DataFingerprint -> ConsRep -> DataType-buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } =-  DataType { typeName        = consName-           , typeFingerprint-           , typeMeta        = Nothing-           , typeContent     = wrapObject $ genFields consFields-           }-- where-  genFields [FieldRep { fieldData = ("", fData) }] =-    [("value", fData { fieldName = "value" })]-  genFields fields = map uRecField fields-  uRecField FieldRep { fieldData = (fName, fData) } = (fName, fData)-+  :: (FieldsDefinition -> TypeContent) -> DataFingerprint -> ConsRep -> TypeDefinition+buildUnionRecord wrapObject typeFingerprint ConsRep { consName, consFields } = TypeDefinition +    { typeName        = consName+    , typeFingerprint+    , typeMeta        = Nothing+    , typeContent     = wrapObject $ unsafeFromFields $ map fieldData consFields+    }  buildUnionEnum-  :: (DataObject -> DataTypeContent)+  :: (FieldsDefinition -> TypeContent)   -> Name   -> DataFingerprint   -> [Name]@@ -432,39 +425,32 @@  buildEnum :: Name -> DataFingerprint -> [Name] -> TypeUpdater buildEnum typeName typeFingerprint tags = pure . defineType-  ( typeName-  , DataType { typeName-             , typeFingerprint-             , typeMeta        = Nothing-             , typeContent     = DataEnum $ map createEnumValue tags-             }-  )+  TypeDefinition +    { typeMeta        = Nothing+    , typeContent     = DataEnum $ map createEnumValue tags+    , ..+    }  buildEnumObject-  :: (DataObject -> DataTypeContent)+  :: (FieldsDefinition -> TypeContent)   -> Name   -> DataFingerprint   -> Name   -> TypeUpdater buildEnumObject wrapObject typeName typeFingerprint enumTypeName =   pure . defineType-    ( typeName-    , DataType+    TypeDefinition       { typeName       , typeFingerprint       , typeMeta        = Nothing-      , typeContent     = wrapObject-                            [ ( "enum"-                              , DataField { fieldName     = "enum"-                                          , fieldArgs     = []-                                          , fieldArgsType = Nothing-                                          , fieldType = createAlias enumTypeName-                                          , fieldMeta     = Nothing-                                          }-                              )-                            ]+      , typeContent     = wrapObject $ singleton +          FieldDefinition +            { fieldName  = "enum"+            , fieldArgs  = NoArguments+            , fieldType  = createAlias enumTypeName+            , fieldMeta  = Nothing+            }       }-    )  data TypeScope = InputType | OutputType deriving (Show,Eq,Ord) @@ -497,7 +483,7 @@ instance (Selector s, Introspect a) => ConRep (M1 S s (Rec0 a)) where   conRep _ =     [ FieldRep { fieldTypeName    = typeConName $ fieldType fieldData-               , fieldData        = (name, fieldData)+               , fieldData        = fieldData                , fieldTypeUpdater = introspect (Proxy @a)                , fieldIsObject    = isObject (Proxy @a)                }

src/Data/Morpheus/Execution/Server/Resolve.hs view

@@ -7,48 +7,32 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-} + module Data.Morpheus.Execution.Server.Resolve   ( statelessResolver-  , byteStringIO-  , streamResolver-  , statefulResolver   , RootResCon   , fullSchema   , coreResolver+  , EventCon   ) where -import           Data.Aeson                     ( encode )-import           Data.Aeson.Internal            ( formatError-                                                , ifromJSON-                                                )-import           Data.Aeson.Parser              ( eitherDecodeWith-                                                , jsonNoDup-                                                )-import qualified Data.ByteString.Lazy.Char8    as L+ import           Data.Functor.Identity          ( Identity(..) ) import           Data.Proxy                     ( Proxy(..) )  -- MORPHEUS-import           Data.Morpheus.Error.Utils      ( badRequestError ) import           Data.Morpheus.Execution.Server.Encode                                                 ( EncodeCon-                                                , encodeMutation-                                                , encodeQuery-                                                , encodeSubscription+                                                , deriveModel                                                 ) import           Data.Morpheus.Execution.Server.Introspect                                                 ( IntroCon                                                 , introspectObjectFields                                                 , TypeScope(..)                                                 )-import           Data.Morpheus.Execution.Server.Subscription-                                                ( GQLState-                                                , publishEvent-                                                ) import           Data.Morpheus.Parsing.Request.Parser                                                 ( parseGQL )---import           Data.Morpheus.Schema.Schema                         (Root) import           Data.Morpheus.Schema.SchemaAPI ( defaultTypes                                                 , hiddenRootFields                                                 , schemaAPI@@ -57,34 +41,35 @@ import           Data.Morpheus.Types.Internal.AST                                                 ( Operation(..)                                                 , DataFingerprint(..)-                                                , DataTypeContent(..)+                                                , TypeContent(..)                                                 , Schema(..)-                                                , DataType(..)+                                                , TypeDefinition(..)                                                 , MUTATION-                                                , OperationType(..)                                                 , QUERY                                                 , SUBSCRIPTION                                                 , initTypeLib                                                 , ValidValue                                                 , Name-                                                , DataField                                                 , VALIDATION_MODE(..)                                                 , Selection(..)                                                 , SelectionContent(..)+                                                , FieldsDefinition(..)                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                ( Merge(..)+                                                , empty+                                                ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( GQLRootResolver(..)                                                 , Resolver                                                 , GQLChannel(..)-                                                , ResponseEvent(..)                                                 , ResponseStream-                                                , Validation+                                                , Eventless                                                 , cleanEvents                                                 , ResultT(..)-                                                , unpackEvents-                                                , Failure(..)                                                 , resolveUpdates                                                 , Context(..)+                                                , runResolverModel                                                 ) import           Data.Morpheus.Types.IO         ( GQLRequest(..)                                                 , GQLResponse(..)@@ -93,8 +78,8 @@ import           Data.Morpheus.Validation.Query.Validation                                                 ( validateRequest ) import           Data.Typeable                  ( Typeable )-import           Control.Monad.IO.Class         ( MonadIO() ) + type EventCon event   = (Eq (StreamChannel event), Typeable event, GQLChannel event) @@ -117,18 +102,6 @@         (subscription (Resolver SUBSCRIPTION event m))     ) -decodeNoDup :: Failure String m => L.ByteString -> m GQLRequest-decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of-  Left  (path, x) -> failure $ formatError path x-  Right value     -> pure value---byteStringIO-  :: Monad m => (GQLRequest -> m GQLResponse) -> L.ByteString -> m L.ByteString-byteStringIO resolver request = case decodeNoDup request of-  Left  aesonError' -> return $ badRequestError aesonError'-  Right req         -> encode <$> resolver req- statelessResolver   :: (Monad m, RootResCon m event query mut sub)   => GQLRootResolver m event query mut sub@@ -137,24 +110,14 @@ statelessResolver root req =   renderResponse <$> runResultT (coreResolver root req) -streamResolver-  :: forall event m query mut sub-   . (Monad m, RootResCon m event query mut sub)-  => GQLRootResolver m event query mut sub-  -> GQLRequest-  -> ResponseStream event m GQLResponse-streamResolver root req =-  ResultT $ pure . 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@GQLRootResolver { queryResolver, mutationResolver, subscriptionResolver } request-  = validRequest >>= execOperator+coreResolver root request+  = validRequest >>=  execOperator  where   validRequest     :: Monad m => ResponseStream event m Context@@ -164,47 +127,28 @@     pure $ Context {         schema       , operation-      , currentSelection = (-        "Root"-        , Selection {-          selectionArguments = []-          , selectionPosition = (operationPosition operation)+      , currentTypeName = "Root"+      , currentSelection = Selection+          { selectionName = "Root"+          , selectionArguments = empty+          , selectionPosition = operationPosition operation           , selectionAlias = Nothing           , selectionContent = SelectionSet (operationSelection operation)-        } -    )+        }   }   -----------------------------------------------------------  execOperator ctx@Context {schema ,operation = Operation{ operationType} } = execOperationBy operationType ctx-    where-      execOperationBy Query = encodeQuery (schemaAPI schema) queryResolver-      execOperationBy Mutation = encodeMutation mutationResolver-      execOperationBy Subscription = encodeSubscription subscriptionResolver-    -statefulResolver-  :: (EventCon event, MonadIO m)-  => GQLState m event-  -> (GQLRequest -> ResponseStream event m ValidValue)-  -> L.ByteString-  -> m L.ByteString-statefulResolver state streamApi requestText = do-  res <- runResultT (decodeNoDup requestText >>= streamApi)-  mapM_ execute (unpackEvents res)-  pure $ encode $ renderResponse res- where-  execute (Publish events) = publishEvent state events-  execute Subscribe{}       = pure ()+  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)-  -> Validation Schema+  -> Eventless Schema fullSchema _ = querySchema >>= mutationSchema >>= subscriptionSchema  where-  querySchema = resolveUpdates-    (initTypeLib (operatorType (hiddenRootFields ++ fields) "Query"))-    (defaultTypes : types)+  querySchema = do+    fs <- hiddenRootFields <:> fields+    resolveUpdates (initTypeLib (operatorType fs "Query")) (defaultTypes : types)    where     (fields, types) = introspectObjectFields       (Proxy @(CUSTOM (query (Resolver QUERY event m))))@@ -231,16 +175,14 @@       , OutputType       , Proxy @(subscription (Resolver SUBSCRIPTION event m))       )-  maybeOperator :: [(Name, DataField)] -> Name -> Maybe (Name, DataType)-  maybeOperator []     = const Nothing+  maybeOperator :: FieldsDefinition -> Name -> Maybe TypeDefinition+  maybeOperator (FieldsDefinition x) | null x     = const Nothing   maybeOperator fields = Just . operatorType fields   --------------------------------------------------  operatorType :: [(Name, DataField)] -> Name -> (Name, DataType)-  operatorType fields typeName =-    ( typeName-    , DataType { typeContent     = DataObject [] fields-               , typeName-               , typeFingerprint = DataFingerprint typeName []-               , typeMeta        = Nothing-               }-    )+  operatorType :: FieldsDefinition -> Name -> TypeDefinition+  operatorType fields typeName = TypeDefinition +      { typeContent     = DataObject [] fields+        , typeName+        , typeFingerprint = DataFingerprint typeName []+        , typeMeta        = Nothing+      }

− src/Data/Morpheus/Execution/Server/Subscription.hs

@@ -1,105 +0,0 @@-{-# LANGUAGE NamedFieldPuns , FlexibleContexts #-}--module Data.Morpheus.Execution.Server.Subscription-  ( ClientDB-  , GQLState-  , initGQLState-  , connectClient-  , disconnectClient-  , startSubscription-  , endSubscription-  , publishEvent-  )-where--import           Control.Monad.IO.Class         ( MonadIO(liftIO) )-import           Control.Concurrent             ( MVar-                                                , modifyMVar-                                                , modifyMVar_-                                                , newMVar-                                                , readMVar-                                                )-import           Data.Foldable                  ( traverse_ )-import           Data.List                      ( intersect )-import           Data.UUID.V4                   ( nextRandom )-import           Network.WebSockets             ( Connection-                                                , sendTextData-                                                )-import           Data.HashMap.Lazy              ( empty-                                                , insert-                                                , delete-                                                , adjust-                                                , toList-                                                )---- MORPHEUS-import           Data.Morpheus.Types.Internal.Apollo-                                                ( toApolloResponse )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( Event(..)-                                                , GQLChannel(..)-                                                , SubEvent-                                                )-import           Data.Morpheus.Types.Internal.WebSocket-                                                ( ClientID-                                                , GQLClient(..)-                                                , ClientDB-                                                , GQLState-                                                , SesionID-                                                )---- | initializes empty GraphQL state-initGQLState :: IO (GQLState m e)-initGQLState = newMVar empty- -connectClient :: MonadIO m => Connection -> GQLState m e -> IO (GQLClient m e)-connectClient clientConnection gqlState = do-  clientID <- nextRandom-  let client = GQLClient { clientID , clientConnection, clientSessions = empty }-  modifyMVar_ gqlState (pure . insert clientID client)-  return client--disconnectClient :: GQLClient m e -> GQLState m e -> IO (ClientDB m e)-disconnectClient GQLClient { clientID } state = modifyMVar state removeUser- where-  removeUser db = let s' = delete clientID db in return (s', s')--updateClientByID-  :: MonadIO m =>-     ClientID-  -> (GQLClient m e -> GQLClient m e)-  -> MVar (ClientDB m e)-  -> m ()-updateClientByID key f state = liftIO $ modifyMVar_ state (return . adjust f key)--publishEvent-  :: (Eq (StreamChannel e), GQLChannel e, MonadIO m) => GQLState m e -> e -> m ()-publishEvent gqlState event = liftIO (readMVar gqlState) >>= traverse_ sendMessage - where-  sendMessage GQLClient { clientSessions, clientConnection } -    | null clientSessions  = return ()-    | otherwise = mapM_ send (filterByChannels clientSessions)-   where-    send (sid, Event { content = subscriptionRes }) = do-      res <- subscriptionRes event-      let apolloRes = toApolloResponse sid res-      liftIO $ sendTextData clientConnection apolloRes-    ----------------------------    filterByChannels = filter-      ( not-      . null-      . intersect (streamChannels event)-      . channels-      . snd-      ) . toList--endSubscription :: MonadIO m => ClientID -> SesionID -> GQLState m e -> m ()-endSubscription cid sid = updateClientByID cid stopSubscription- where-  stopSubscription client = client { clientSessions = delete sid (clientSessions client) }--startSubscription :: MonadIO m => ClientID -> SubEvent m e -> SesionID -> GQLState m e -> m ()-startSubscription cid subscriptions sid = updateClientByID cid startSubscription- where-  startSubscription client = client-    { clientSessions = insert sid subscriptions (clientSessions client) }

− src/Data/Morpheus/Parsing/Document/Parser.hs

@@ -1,37 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Parsing.Document.Parser-  ( parseTypes-  )-where--import           Data.Text                      ( Text )-import           Text.Megaparsec                ( eof-                                                , label-                                                , manyTill-                                                , runParser-                                                )---- MORPHEUS-import           Data.Morpheus.Parsing.Document.TypeSystem-                                                ( parseDataType )-import           Data.Morpheus.Parsing.Internal.Internal-                                                ( processErrorBundle )-import           Data.Morpheus.Parsing.Internal.Terms-                                                ( spaceAndComments )-import           Data.Morpheus.Types.Internal.AST-                                                ( DataType )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation-                                                , Failure(..)-                                                )--parseTypes :: Text -> Validation [(Text, DataType)]-parseTypes doc = case parseDoc of-  Right root       -> pure root-  Left  parseError -> failure (processErrorBundle parseError)- where-  parseDoc = runParser request "<input>" doc-  request  = label "DocumentTypes" $ do-    spaceAndComments-    manyTill parseDataType eof

src/Data/Morpheus/Parsing/Document/TypeSystem.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Parsing.Document.TypeSystem-  ( parseDataType+  ( parseSchema   ) where @@ -10,17 +10,21 @@ import           Text.Megaparsec                ( label                                                 , sepBy1                                                 , (<|>)+                                                , eof+                                                , manyTill                                                 )  -- MORPHEUS import           Data.Morpheus.Parsing.Internal.Internal-                                                ( Parser )+                                                ( Parser+                                                , processParser+                                                ) import           Data.Morpheus.Parsing.Internal.Pattern                                                 ( fieldsDefinition-                                                , inputValueDefinition                                                 , optionalDirectives                                                 , typDeclaration                                                 , enumValueDefinition+                                                , inputFieldsDefinition                                                 ) import           Data.Morpheus.Parsing.Internal.Terms                                                 ( keyword@@ -29,36 +33,36 @@                                                 , parseName                                                 , pipeLiteral                                                 , sepByAnd-                                                , setOf+                                                , collection+                                                , spaceAndComments                                                 ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField-                                                , DataFingerprint(..)-                                                , DataTypeContent(..)-                                                , DataType(..)-                                                , DataValidator(..)-                                                , Key+                                                ( 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 Text -> Parser (Text, DataType)+scalarTypeDefinition :: Maybe Description -> Parser TypeDefinition scalarTypeDefinition metaDescription = label "ScalarTypeDefinition" $ do   typeName       <- typDeclaration "scalar"   metaDirectives <- optionalDirectives-  pure-    ( typeName-    , DataType { typeName-               , typeMeta        = Just Meta { metaDescription, metaDirectives }-               , typeFingerprint = DataFingerprint typeName []-               , typeContent     = DataScalar $ DataValidator pure-               }-    )+  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 --@@ -75,24 +79,21 @@ --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---objectTypeDefinition :: Maybe Text -> Parser (Text, DataType)+objectTypeDefinition :: Maybe Description -> Parser TypeDefinition objectTypeDefinition metaDescription = label "ObjectTypeDefinition" $ do   typeName         <- typDeclaration "type"   objectImplements <- optionalImplementsInterfaces   metaDirectives   <- optionalDirectives   objectFields     <- fieldsDefinition-  ---------------------------  pure-    ( typeName-    , DataType-      { typeName-      , typeMeta          = Just Meta { metaDescription, metaDirectives }-      , typeFingerprint   = DataFingerprint typeName []-      , typeContent       = DataObject { objectImplements, objectFields }-      }-    )+  -- build object+  pure TypeDefinition+    { typeName+    , typeMeta          = Just Meta { metaDescription, metaDirectives }+    , typeFingerprint   = DataFingerprint typeName []+    , typeContent       = DataObject { objectImplements, objectFields }+    } -optionalImplementsInterfaces :: Parser [Text]+optionalImplementsInterfaces :: Parser [Name] optionalImplementsInterfaces = implements <|> pure []  where   implements =@@ -103,20 +104,18 @@ --  InterfaceTypeDefinition --    Description(opt) interface Name Directives(Const)(opt) FieldsDefinition(opt) ---interfaceTypeDefinition :: Maybe Text -> Parser (Text, DataType)+interfaceTypeDefinition :: Maybe Description -> Parser TypeDefinition interfaceTypeDefinition metaDescription = label "InterfaceTypeDefinition" $ do   typeName  <- typDeclaration "interface"   metaDirectives <- optionalDirectives   fields         <- fieldsDefinition-  pure-    ( typeName-    , DataType { typeName-               , typeMeta        = Just Meta { metaDescription, metaDirectives }-               , typeFingerprint = DataFingerprint typeName []-               , typeContent     = DataInterface fields-               }-    )-+  -- 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 --@@ -127,19 +126,18 @@ --    = |(opt) NamedType --      UnionMemberTypes | NamedType ---unionTypeDefinition :: Maybe Text -> Parser (Text, DataType)+unionTypeDefinition :: Maybe Description -> Parser TypeDefinition unionTypeDefinition metaDescription = label "UnionTypeDefinition" $ do   typeName       <- typDeclaration "union"   metaDirectives <- optionalDirectives   memberTypes    <- unionMemberTypes-  pure-    ( typeName-    , DataType { typeName-               , typeMeta        = Just Meta { metaDescription, metaDirectives }-               , typeFingerprint = DataFingerprint typeName []-               , typeContent     = DataUnion memberTypes-               }-    )+  -- 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@@ -153,20 +151,18 @@ --  EnumValueDefinition --    Description(opt) EnumValue Directives(Const)(opt) ---enumTypeDefinition :: Maybe Text -> Parser (Text, DataType)+enumTypeDefinition :: Maybe Description -> Parser TypeDefinition enumTypeDefinition metaDescription = label "EnumTypeDefinition" $ do   typeName              <- typDeclaration "enum"   metaDirectives        <- optionalDirectives-  enumValuesDefinitions <- setOf enumValueDefinition-  pure-    ( typeName-    , DataType { typeName-               , typeMeta        = Just Meta { metaDescription, metaDirectives }-               , typeFingerprint = DataFingerprint typeName []-               , typeContent     = DataEnum enumValuesDefinitions-               }-    )-+  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 --@@ -176,37 +172,34 @@ --   InputFieldsDefinition: --     { InputValueDefinition(list) } ---inputObjectTypeDefinition :: Maybe Text -> Parser (Text, DataType)+inputObjectTypeDefinition :: Maybe Description -> Parser TypeDefinition inputObjectTypeDefinition metaDescription =   label "InputObjectTypeDefinition" $ do     typeName       <- typDeclaration "input"     metaDirectives <- optionalDirectives     fields         <- inputFieldsDefinition-    pure-      ( typeName-      , DataType { typeName-                 , typeMeta = Just Meta { metaDescription, metaDirectives }-                 , typeFingerprint = DataFingerprint typeName []-                 , typeContent     = DataInputObject fields-                 }-      )- where-  inputFieldsDefinition :: Parser [(Key, DataField)]-  inputFieldsDefinition =-    label "InputFieldsDefinition" $ setOf inputValueDefinition---parseFinalDataType :: Maybe Text -> Parser (Text, DataType)-parseFinalDataType description =-  label "TypeDefinition"-     $  inputObjectTypeDefinition description-    <|> unionTypeDefinition description-    <|> enumTypeDefinition description-    <|> scalarTypeDefinition description-    <|> objectTypeDefinition description-    <|> interfaceTypeDefinition description+    -- build input+    pure TypeDefinition +      { typeName+      , typeContent     = DataInputObject fields+      , typeFingerprint = DataFingerprint typeName []+      , typeMeta = Just Meta { metaDescription, metaDirectives }+      } -parseDataType :: Parser (Text, DataType)-parseDataType = label "TypeDefinition" $ do+parseDataType :: Parser TypeDefinition+parseDataType = label "TypeDefinition" $ do     description <- optDescription-  parseFinalDataType description+  -- 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 view

@@ -0,0 +1,62 @@+{-# 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 view

@@ -1,30 +1,32 @@-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NamedFieldPuns             #-}  module Data.Morpheus.Parsing.Internal.Internal   ( Parser   , Position-  , processErrorBundle   , getLocation+  , processParser   ) where  import qualified Data.List.NonEmpty            as NonEmpty-import           Data.Morpheus.Error.Utils      ( toLocation ) import           Data.Morpheus.Types.Internal.AST-                                                ( Position )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( GQLError(..)+                                                ( Position(..)+                                                , GQLError(..)                                                 , GQLErrors                                                 )+import           Data.Morpheus.Types.Internal.Resolving+                                                ( Eventless+                                                , failure+                                                , Result(..)+                                                ) import           Data.Text                      ( Text                                                 , pack                                                 )-import           Data.Void                      ( Void ) import           Text.Megaparsec                ( ParseError                                                 , ParseErrorBundle                                                   ( ParseErrorBundle                                                   )-                                                , Parsec+                                                , ParsecT                                                 , SourcePos                                                 , attachSourcePos                                                 , bundleErrors@@ -32,24 +34,40 @@                                                 , errorOffset                                                 , getSourcePos                                                 , parseErrorPretty+                                                , runParserT+                                                , SourcePos(..)+                                                , unPos                                                 )-+import           Data.Void                      (Void)  getLocation :: Parser Position getLocation = fmap toLocation getSourcePos -type Parser = Parsec Void Text+toLocation :: SourcePos -> Position+toLocation SourcePos { sourceLine, sourceColumn } =+  Position { line = unPos sourceLine, column = unPos sourceColumn } -processErrorBundle :: ParseErrorBundle Text Void -> GQLErrors-processErrorBundle = fmap parseErrorToGQLError . bundleToErrors+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 Void, SourcePos) -> GQLError+  parseErrorToGQLError :: (ParseError Text MyError, SourcePos) -> GQLError   parseErrorToGQLError (err, position) = GQLError     { message   = pack (parseErrorPretty err)-    , locations = [toLocation position]+      , locations = [toLocation position]     }   bundleToErrors-    :: ParseErrorBundle Text Void -> [(ParseError Text Void, SourcePos)]+    :: ErrorBundle -> [(ParseError Text MyError, SourcePos)]   bundleToErrors ParseErrorBundle { bundleErrors, bundlePosState } =     NonEmpty.toList $ fst $ attachSourcePos errorOffset                                             bundleErrors

src/Data/Morpheus/Parsing/Internal/Pattern.hs view

@@ -6,12 +6,13 @@     , typDeclaration     , optionalDirectives     , enumValueDefinition+    , inputFieldsDefinition     ) where - import           Text.Megaparsec                ( label                                                 , many+                                                , (<|>)                                                 )  -- MORPHEUS@@ -22,26 +23,26 @@                                                 , litAssignment                                                 , operator                                                 , optDescription-                                                , parseAssignment-                                                , parseMaybeTuple                                                 , parseName                                                 , parseType                                                 , setOf+                                                , uniqTuple                                                 )+import           Data.Morpheus.Parsing.Internal.Arguments+                                                ( parseArgumentsOpt ) import           Data.Morpheus.Parsing.Internal.Value-                                                ( parseDefaultValue-                                                , parseValue-                                                )+                                                ( parseDefaultValue ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)+                                                ( FieldDefinition(..)                                                 , Directive(..)-                                                , Key                                                 , Meta(..)                                                 , DataEnumValue(..)                                                 , Name+                                                , ArgumentsDefinition(..)+                                                , FieldsDefinition(..)+                                                , InputFieldsDefinition(..)                                                 ) - --  EnumValueDefinition: https://graphql.github.io/graphql-spec/June2018/#EnumValueDefinition -- --  EnumValueDefinition@@ -62,7 +63,7 @@ -- InputValueDefinition --   Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) ---inputValueDefinition :: Parser (Key, DataField)+inputValueDefinition :: Parser FieldDefinition inputValueDefinition = label "InputValueDefinition" $ do     metaDescription <- optDescription     fieldName       <- parseName@@ -70,39 +71,35 @@     fieldType      <- parseType     _              <- parseDefaultValue     metaDirectives <- optionalDirectives-    pure-        ( fieldName-        , DataField { fieldArgs     = []-                    , fieldArgsType = Nothing-                    , fieldName-                    , fieldType-                    , fieldMeta = Just Meta { metaDescription, metaDirectives }-                    }-        )+    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 [(Key, DataField)]-argumentsDefinition =-    label "ArgumentsDefinition" $ parseMaybeTuple inputValueDefinition-+argumentsDefinition :: Parser ArgumentsDefinition+argumentsDefinition = label "ArgumentsDefinition" +     $  uniqTuple inputValueDefinition+    <|> pure NoArguments  --  FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition -- --  FieldsDefinition : --    { FieldDefinition(list) } ---fieldsDefinition :: Parser [(Key, DataField)]+fieldsDefinition :: Parser FieldsDefinition fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition - --  FieldDefinition --    Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---fieldDefinition :: Parser (Key, DataField)+fieldDefinition :: Parser FieldDefinition fieldDefinition = label "FieldDefinition" $ do     metaDescription <- optDescription     fieldName       <- parseName@@ -110,15 +107,19 @@     litAssignment -- ':'     fieldType      <- parseType     metaDirectives <- optionalDirectives-    pure-        ( fieldName-        , DataField { fieldName-                    , fieldArgs-                    , fieldArgsType = Nothing-                    , fieldType-                    , fieldMeta = Just Meta { metaDescription, metaDirectives }-                    }-        )+    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 --@@ -137,9 +138,8 @@ directive = label "Directive" $ do     operator '@'     directiveName <- parseName-    directiveArgs <- parseMaybeTuple (parseAssignment parseName parseValue)+    directiveArgs <- parseArgumentsOpt     pure Directive { directiveName, directiveArgs }-  -- typDeclaration : Not in spec ,start part of type definitions --

src/Data/Morpheus/Parsing/Internal/Terms.hs view

@@ -10,11 +10,13 @@   , spaceAndComments1   , pipeLiteral   -------------+  , collection   , setOf+  , uniqTuple+  , uniqTupleOpt   , parseTypeCondition   , spreadLiteral   , parseNonNull-  , parseMaybeTuple   , parseAssignment   , parseWrappedType   , litEquals@@ -27,10 +29,12 @@   , keyword   , operator   , optDescription+  , optionalList   , parseNegativeSign   ) where +import           Control.Monad                  ((>=>)) import           Data.Functor                   ( ($>) ) import           Data.Text                      ( Text                                                 , pack@@ -61,6 +65,10 @@                                                 )  -- MORPHEUS+import           Data.Morpheus.Types.Internal.Operation+                                                ( Listable(..)+                                                , KeyOf+                                                ) import           Data.Morpheus.Parsing.Internal.Internal                                                 ( Parser                                                 , Position@@ -96,9 +104,11 @@ operator x = char x *> spaceAndComments  -- LITERALS-setLiteral :: Parser [a] -> Parser [a]-setLiteral =-  between (char '{' *> spaceAndComments) (char '}' *> spaceAndComments)+braces :: Parser [a] -> Parser [a]+braces =+  between +    (char '{' *> spaceAndComments) +    (char '}' *> spaceAndComments)  pipeLiteral :: Parser () pipeLiteral = char '|' *> spaceAndComments@@ -185,17 +195,20 @@ sepByAnd entry = entry `sepBy` (char '&' *> spaceAndComments)  ------------------------------setOf :: Parser a -> Parser [a]-setOf entry = setLiteral (entry `sepEndBy` many (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 -parseMaybeTuple :: Parser a -> Parser [a]-parseMaybeTuple parser = parseTuple parser <|> pure []+optionalList :: Parser [a] -> Parser [a] +optionalList x = x <|> pure []  parseTuple :: Parser a -> Parser [a] parseTuple parser = label "Tuple" $ between@@ -203,6 +216,12 @@   (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

src/Data/Morpheus/Parsing/Internal/Value.hs view

@@ -1,5 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies      #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE NamedFieldPuns     #-}  module Data.Morpheus.Parsing.Internal.Value   ( parseValue@@ -32,11 +33,11 @@ import           Data.Morpheus.Parsing.Internal.Terms                                                 ( litEquals                                                 , parseAssignment-                                                , setOf                                                 , spaceAndComments                                                 , token                                                 , parseNegativeSign                                                 , variable+                                                , setOf                                                 ) import           Data.Morpheus.Types.Internal.AST                                                 ( ScalarValue(..)@@ -44,9 +45,10 @@                                                 , RawValue                                                 , ValidValue                                                 , decodeScientific-                                                , Name                                                 , Value(..)                                                 , ResolvedValue+                                                , OrderedMap+                                                , ObjectEntry(..)                                                 )  valueNull :: Parser (Value a)@@ -87,16 +89,19 @@   (char '"')   (many escaped) - listValue :: Parser a -> Parser [a]-listValue parser = label "listValue" $ between+listValue parser = label "ListValue" $ between   (char '[' *> spaceAndComments)   (char ']' *> spaceAndComments)-  (parser `sepBy` (char ',' *> spaceAndComments))+  (parser `sepBy` (many (char ',') *> spaceAndComments)) -objectValue :: Show a => Parser a -> Parser [(Name, a)]-objectValue parser = label "objectValue" $ setOf entry-  where entry = parseAssignment token parser+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 =

src/Data/Morpheus/Parsing/JSONSchema/Parse.hs view

@@ -3,6 +3,7 @@ {-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeOperators         #-}+{-# LANGUAGE ScopedTypeVariables   #-}  module Data.Morpheus.Parsing.JSONSchema.Parse   ( decodeIntrospection@@ -24,11 +25,10 @@ import qualified Data.Morpheus.Types.Internal.AST as AST                                                 ( Schema) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField-                                                , DataType(..)-                                                , DataTypeContent(..)+                                                ( FieldDefinition+                                                , TypeDefinition(..)+                                                , TypeContent(..)                                                 , DataTypeWrapper(..)-                                                , Key                                                 , TypeWrapper                                                 , createArgument                                                 , createDataTypeLib@@ -38,16 +38,19 @@                                                 , createType                                                 , createUnionType                                                 , toHSWrappers+                                                , ArgumentsDefinition(..)                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                ( Listable(..)) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Eventless ) import           Data.Morpheus.Types.IO         ( JSONResponse(..) ) import           Data.Semigroup                 ( (<>) ) import           Data.Text                      ( Text                                                 , pack                                                 ) -decodeIntrospection :: ByteString -> Validation AST.Schema+decodeIntrospection :: ByteString -> Eventless AST.Schema decodeIntrospection jsonDoc = case jsonSchema of   Left errors -> internalError $ pack errors   Right JSONResponse { responseData = Just Introspection { __schema = Schema { types } } }@@ -58,9 +61,9 @@   jsonSchema = eitherDecode jsonDoc  class ParseJSONSchema a b where-  parse :: a -> Validation b+  parse :: a -> Eventless b -instance ParseJSONSchema Type [(Key,DataType)] where+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 } =@@ -71,34 +74,34 @@       Just uni -> pure [createUnionType typeName uni]   parse Type { name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields }     = do-      fields <- traverse parse iFields-      pure [(typeName, createType typeName $ DataInputObject fields)]+      (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 <- traverse parse oFields-      pure [(typeName, createType typeName $ DataObject [] fields)]+      (fields :: [FieldDefinition]) <- traverse parse oFields+      fs <- fromList fields+      pure [createType typeName $ DataObject [] fs]    parse _ = pure [] -instance ParseJSONSchema Field (Key,DataField) where+instance ParseJSONSchema Field FieldDefinition where   parse Field { fieldName, fieldArgs, fieldType } = do     fType <- fieldTypeFromJSON fieldType-    args  <- traverse genArg fieldArgs-    pure (fieldName, createField args fieldName fType)+    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 (Key,DataField) where-  parse InputValue { inputName, inputType } = do-    fieldType <- fieldTypeFromJSON inputType-    pure (inputName, createField [] inputName fieldType)+instance ParseJSONSchema InputValue FieldDefinition where+  parse InputValue { inputName, inputType } = createField NoArguments inputName <$> fieldTypeFromJSON inputType -fieldTypeFromJSON :: Type -> Validation ([TypeWrapper], Text)+fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], Text) fieldTypeFromJSON = fmap toHs . fieldTypeRec []  where   toHs (w, t) = (toHSWrappers w, t)   fieldTypeRec-    :: [DataTypeWrapper] -> Type -> Validation ([DataTypeWrapper], Text)+    :: [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 } =

− src/Data/Morpheus/Parsing/Request/Arguments.hs

@@ -1,45 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Parsing.Request.Arguments-  ( maybeArguments-  )-where--import           Text.Megaparsec                ( label)---- MORPHEUS-import           Data.Morpheus.Parsing.Internal.Internal-                                                ( Parser-                                                , getLocation-                                                )-import           Data.Morpheus.Parsing.Internal.Terms-                                                ( parseAssignment-                                                , parseMaybeTuple-                                                , token-                                                )-import           Data.Morpheus.Parsing.Internal.Value-                                                ( parseRawValue )-import           Data.Morpheus.Types.Internal.AST-                                                ( Argument(..)-                                                , RawArgument-                                                , RawArguments-                                                )----- Arguments : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Arguments------ Arguments[Const]--- ( Argument[Const](list) )------ Argument[Const]---  Name : Value[Const]--- TODO: move variable to Value-valueArgument :: Parser RawArgument-valueArgument = label "Argument" $ do-  argumentPosition <- getLocation-  argumentValue    <- parseRawValue-  pure $ Argument { argumentValue, argumentPosition }--maybeArguments :: Parser RawArguments-maybeArguments =-  label "Arguments" $ parseMaybeTuple (parseAssignment token valueArgument)

src/Data/Morpheus/Parsing/Request/Operation.hs view

@@ -1,5 +1,5 @@-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE RecordWildCards    #-}  module Data.Morpheus.Parsing.Request.Operation   ( parseOperation@@ -7,7 +7,6 @@ where  import           Data.Functor                   ( ($>) )-import           Data.Text                      ( Text ) import           Text.Megaparsec                ( label                                                 , optional                                                 , (<?>)@@ -25,7 +24,7 @@                                                 ( optionalDirectives ) import           Data.Morpheus.Parsing.Internal.Terms                                                 ( operator-                                                , parseMaybeTuple+                                                , uniqTupleOpt                                                 , parseName                                                 , parseType                                                 , spaceAndComments1@@ -35,9 +34,10 @@                                                 ( parseDefaultValue ) import           Data.Morpheus.Parsing.Request.Selection                                                 ( parseSelectionSet )+import           Data.Morpheus.Types.Internal.Operation +                                                (empty) import           Data.Morpheus.Types.Internal.AST                                                 ( Operation(..)-                                                , RawOperation                                                 , Variable(..)                                                 , OperationType(..)                                                 , Ref(..)@@ -51,19 +51,13 @@ --  VariableDefinition --    Variable : Type DefaultValue(opt) ---variableDefinition :: Parser (Text, Variable RAW)+variableDefinition :: Parser (Variable RAW) variableDefinition = label "VariableDefinition" $ do-  (Ref name variablePosition) <- variable+  (Ref variableName variablePosition) <- variable   operator ':'   variableType <- parseType-  defaultValue <- parseDefaultValue-  pure-    ( name-    , Variable { variableType-               , variablePosition-               , variableValue    = DefaultValue defaultValue-               }-    )+  variableValue <- DefaultValue <$> parseDefaultValue+  pure Variable{..}  -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations --@@ -72,23 +66,16 @@ -- --   OperationType: one of --     query, mutation,    subscription-parseOperationDefinition :: Parser RawOperation+parseOperationDefinition :: Parser (Operation RAW) parseOperationDefinition = label "OperationDefinition" $ do   operationPosition  <- getLocation   operationType      <- parseOperationType   operationName      <- optional parseName-  operationArguments <- parseMaybeTuple variableDefinition+  operationArguments <- uniqTupleOpt variableDefinition   -- TODO: handle directives   _directives        <- optionalDirectives   operationSelection <- parseSelectionSet-  pure-    (Operation { operationName-               , operationType-               , operationArguments-               , operationSelection-               , operationPosition-               }-    )+  pure Operation {..}  parseOperationType :: Parser OperationType parseOperationType = label "OperationType" $ do@@ -99,19 +86,18 @@   spaceAndComments1   return kind -parseAnonymousQuery :: Parser RawOperation+parseAnonymousQuery :: Parser (Operation RAW) parseAnonymousQuery = label "AnonymousQuery" $ do   operationPosition  <- getLocation   operationSelection <- parseSelectionSet   pure       (Operation { operationName      = Nothing                  , operationType      = Query-                 , operationArguments = []-                 , operationSelection-                 , operationPosition+                 , operationArguments = empty+                 , ..                  }       )     <?> "can't parse AnonymousQuery" -parseOperation :: Parser RawOperation+parseOperation :: Parser (Operation RAW) parseOperation = parseAnonymousQuery <|> parseOperationDefinition

src/Data/Morpheus/Parsing/Request/Parser.hs view

@@ -3,6 +3,7 @@  module Data.Morpheus.Parsing.Request.Parser   ( parseGQL+  , processParser   ) where @@ -10,19 +11,16 @@                                                 ( Value(..) ) import           Data.HashMap.Lazy              ( toList ) import           Data.Text                      ( Text )-import           Data.Void                      ( Void )-import           Text.Megaparsec                ( ParseErrorBundle-                                                , eof+import           Text.Megaparsec                ( eof                                                 , label                                                 , manyTill-                                                , runParser                                                 )  -- -- MORPHEUS import           Data.Morpheus.Parsing.Internal.Internal                                                 ( Parser-                                                , processErrorBundle+                                                , processParser                                                 ) import           Data.Morpheus.Parsing.Internal.Terms                                                 ( spaceAndComments )@@ -31,32 +29,27 @@ import           Data.Morpheus.Parsing.Request.Selection                                                 ( parseFragmentDefinition ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation-                                                , Failure(..)-                                                )+                                                ( Eventless ) import           Data.Morpheus.Types.Internal.AST                                                 ( replaceValue                                                 , GQLQuery(..)                                                 , ResolvedValue                                                 ) import           Data.Morpheus.Types.IO         ( GQLRequest(..) )-+import           Data.Morpheus.Types.Internal.Operation+                                                (fromList) -parseGQLSyntax :: Text -> Either (ParseErrorBundle Text Void) GQLQuery-parseGQLSyntax = runParser request "<input>"- where-  request :: Parser GQLQuery-  request = label "GQLQuery" $ do+request :: Parser GQLQuery+request = label "GQLQuery" $ do     spaceAndComments     operation <- parseOperation-    fragments <- manyTill parseFragmentDefinition eof+    fragments <- manyTill parseFragmentDefinition eof >>= fromList     pure GQLQuery { operation, fragments, inputVariables = [] } -parseGQL :: GQLRequest -> Validation GQLQuery-parseGQL GQLRequest { query, variables } = case parseGQLSyntax query of-  Right root       -> pure $ root { inputVariables = toVariableMap variables }-  Left  parseError -> failure $ processErrorBundle parseError+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)

src/Data/Morpheus/Parsing/Request/Selection.hs view

@@ -1,5 +1,5 @@-{-# LANGUAGE NamedFieldPuns    #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}  module Data.Morpheus.Parsing.Request.Selection   ( parseSelectionSet@@ -7,7 +7,6 @@   ) where -import           Data.Text                      ( Text ) import           Text.Megaparsec                ( label                                                 , try                                                 , (<|>)@@ -30,16 +29,18 @@                                                 , spreadLiteral                                                 , token                                                 )-import           Data.Morpheus.Parsing.Request.Arguments+import           Data.Morpheus.Parsing.Internal.Arguments                                                 ( maybeArguments ) import           Data.Morpheus.Types.Internal.AST                                                 ( Selection(..)                                                 , SelectionContent(..)                                                 , Ref(..)                                                 , Fragment(..)-                                                , RawArguments-                                                , RawSelection-                                                , RawSelectionSet+                                                , Arguments+                                                , RAW+                                                , SelectionSet+                                                , Name+                                                , Position                                                 )  @@ -53,7 +54,7 @@ --   FragmentSpread --   InlineFragment ---parseSelectionSet :: Parser RawSelectionSet+parseSelectionSet :: Parser (SelectionSet RAW) parseSelectionSet = label "SelectionSet" $ setOf parseSelection  where   parseSelection =@@ -67,39 +68,22 @@ -- Field -- Alias(opt) Name Arguments(opt) Directives(opt) SelectionSet(opt) ---parseSelectionField :: Parser (Text, RawSelection)+parseSelectionField :: Parser (Selection RAW) parseSelectionField = label "SelectionField" $ do-  position    <- getLocation-  aliasName   <- parseAlias-  name        <- parseName-  arguments   <- maybeArguments+  selectionPosition   <- getLocation+  selectionAlias      <- parseAlias+  selectionName       <- parseName+  selectionArguments  <- maybeArguments   -- TODO: handle Directives-  _directives <- optionalDirectives-  value       <--    selSet aliasName arguments <|> buildField aliasName arguments position-  return (name, value)+  _directives   <- optionalDirectives+  selSet selectionName selectionAlias selectionArguments <|> pure Selection { selectionContent   = SelectionField, ..}  where-    -----------------------------------------  buildField selectionAlias selectionArguments selectionPosition = pure-    (Selection { selectionAlias-               , selectionArguments-               , selectionContent   = SelectionField-               , selectionPosition-               }-    )   ------------------------------------------  selSet :: Maybe Text -> RawArguments -> Parser RawSelection-  selSet selectionAlias selectionArguments = label "body" $ do+  selSet :: Name -> Maybe Name -> Arguments RAW -> Parser (Selection RAW)+  selSet selectionName selectionAlias selectionArguments = label "body" $ do     selectionPosition <- getLocation     selectionSet      <- parseSelectionSet-    return-      (Selection { selectionAlias-                 , selectionArguments-                 , selectionContent   = SelectionSet selectionSet-                 , selectionPosition-                 }-      )-+    pure Selection { selectionContent   = SelectionSet selectionSet, ..}  -- -- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments@@ -110,45 +94,40 @@ --  FragmentSpread --    ...FragmentName Directives(opt) ---spread :: Parser (Text, RawSelection)+spread :: Parser (Selection RAW) spread = label "FragmentSpread" $ do   refPosition <- spreadLiteral   refName     <- token   -- TODO: handle Directives   _directives <- optionalDirectives-  return (refName, Spread $ Ref { refName, refPosition })+  pure $ Spread Ref { .. }  -- FragmentDefinition : https://graphql.github.io/graphql-spec/June2018/#FragmentDefinition -- --  FragmentDefinition: --   fragment FragmentName TypeCondition Directives(opt) SelectionSet ---parseFragmentDefinition :: Parser (Text, Fragment)+parseFragmentDefinition :: Parser Fragment parseFragmentDefinition = label "FragmentDefinition" $ do   keyword "fragment"   fragmentPosition  <- getLocation-  name              <- parseName-  fragmentType      <- parseTypeCondition-  -- TODO: handle Directives-  _directives       <- optionalDirectives-  fragmentSelection <- parseSelectionSet-  pure (name, Fragment { fragmentType, fragmentSelection, fragmentPosition })+  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 (Text, RawSelection)+inlineFragment :: Parser (Selection RAW) inlineFragment = label "InlineFragment" $ do   fragmentPosition  <- spreadLiteral-  -- TODO: optional+  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-    ( "INLINE_FRAGMENT"-    , InlineFragment-      $ Fragment { fragmentType, fragmentSelection, fragmentPosition }-    )+  pure $ Fragment { .. }

src/Data/Morpheus/Rendering/RenderGQL.hs view

@@ -1,11 +1,12 @@-{-# LANGUAGE DefaultSignatures    #-} {-# LANGUAGE FlexibleInstances    #-} {-# LANGUAGE NamedFieldPuns       #-} {-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE GADTs                #-}  module Data.Morpheus.Rendering.RenderGQL   ( RenderGQL(..)   , renderGraphQLDocument+  , renderWrapped   ) where @@ -20,9 +21,10 @@  -- MORPHEUS import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)-                                                , DataTypeContent(..)-                                                , DataType(..)+                                                ( FieldDefinition(..)+                                                , InputFieldsDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)                                                 , Schema                                                 , DataTypeWrapper(..)                                                 , Key@@ -35,68 +37,76 @@                                                 , 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 . fst) (allDataTypes lib)+  visibleTypes = filter (not . isDefaultTypeName . typeName) (allDataTypes lib)  class RenderGQL a where   render :: a -> Key-  renderWrapped :: a -> [TypeWrapper] -> Key-  default renderWrapped :: a -> [TypeWrapper] -> Key-  renderWrapped x wrappers = showGQLWrapper (toGQLWrapper wrappers)-    where-      showGQLWrapper []               = render x-      showGQLWrapper (ListType:xs)    = "[" <> showGQLWrapper xs <> "]"-      showGQLWrapper (NonNullType:xs) = showGQLWrapper xs <> "!" +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 -instance RenderGQL Key where-  render = id -instance RenderGQL TypeRef where-  render TypeRef { typeConName, typeWrappers } =-    renderWrapped typeConName typeWrappers+ignoreHidden :: [FieldDefinition] -> [FieldDefinition]+ignoreHidden = filter fieldVisibility -instance RenderGQL DataType where-  render = typeName+-- 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 (Key, DataType) where-  render (name, DataType { typeContent }) = __render typeContent-   where-    __render DataInterface { interfaceFields } = "interface " <> name <> render interfaceFields-    __render DataScalar{}    = "scalar " <> name-    __render (DataEnum tags) = "enum " <> name <> renderObject render tags-    __render (DataUnion members) =-      "union "-        <> name-        <> " =\n    "-        <> intercalate ("\n" <> renderIndent <> "| ") members-    __render (DataInputObject fields ) = "input " <> name <> render fields-    __render (DataInputUnion  members) = "input " <> name <> render fields-      where fields = createInputUnionFields name (map fst members)-    __render (DataObject {objectFields}) = "type " <> name <> render objectFields+instance RenderGQL TypeRef where+  render TypeRef { typeConName, typeWrappers } = renderWrapped typeConName typeWrappers --- OBJECT-instance RenderGQL [(Text, DataField)] where-  render = renderObject renderField . ignoreHidden-   where-    renderField :: (Text, DataField) -> Text-    renderField (key, DataField { fieldType, fieldArgs }) =-      convertToJSONName key <> renderArgs fieldArgs <> ": " <> render fieldType-     where-      renderArgs []   = ""-      renderArgs list = "(" <> intercalate ", " (map renderField list) <> ")"-    ------------------------------------------------------------    ignoreHidden :: [(Text, DataField)] -> [(Text, DataField)]-    ignoreHidden = filter fieldVisibility+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 = "  "

src/Data/Morpheus/Rendering/RenderIntrospection.hs view

@@ -2,7 +2,7 @@ {-# LANGUAGE NamedFieldPuns        #-} {-# LANGUAGE OverloadedStrings     #-} {-# LANGUAGE TypeOperators         #-}-{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleContexts  , FlexibleInstances    #-}  module Data.Morpheus.Rendering.RenderIntrospection   ( render@@ -20,9 +20,9 @@ import           Data.Morpheus.Schema.TypeKind  ( TypeKind(..) ) import           Data.Morpheus.Types.Internal.AST                                                 ( DataInputUnion-                                                , DataField(..)-                                                , DataTypeContent(..)-                                                , DataType(..)+                                                , FieldDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)                                                 , DataTypeKind(..)                                                 , Schema                                                 , DataTypeWrapper(..)@@ -39,7 +39,11 @@                                                 , DataInputUnion                                                 , lookupDeprecatedReason                                                 , convertToJSONName+                                                , ArgumentsDefinition(..)                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                ( Listable(..)+                                                ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( Failure(..) ) @@ -49,27 +53,27 @@ type Result m a = Schema -> m a  class RenderSchema a b where-  render :: (Monad m, Failure Text m) => (Text, a) -> Schema -> m (b m)+  render :: (Monad m, Failure Text m) => a -> Schema -> m (b m) -instance RenderSchema DataType S__Type where-  render (name, DataType { typeMeta, typeContent }) = __render typeContent+instance RenderSchema TypeDefinition S__Type where+  render TypeDefinition { typeName , typeMeta, typeContent } = __render typeContent    where     __render-      :: (Monad m, Failure Text m) => DataTypeContent -> Schema -> m (S__Type m)+      :: (Monad m, Failure Text m) => TypeContent -> Schema -> m (S__Type m)     __render DataScalar{} =-      constRes $ createLeafType SCALAR name typeMeta Nothing+      constRes $ createLeafType SCALAR typeName typeMeta Nothing     __render (DataEnum enums) = constRes-      $ createLeafType ENUM name typeMeta (Just $ map createEnumValue enums)+      $ createLeafType ENUM typeName typeMeta (Just $ map createEnumValue enums)     __render (DataInputObject fields) = \lib ->-      createInputObject name typeMeta-        <$> traverse (`renderinputValue` lib) fields-    __render (DataObject {objectFields}) = \lib ->-      createObjectType name (typeMeta >>= metaDescription)-        <$> (Just <$> traverse (`render` lib) (filter fieldVisibility objectFields))+      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 (name, typeMeta, union)+      constRes $ typeFromUnion (typeName, typeMeta, union)     __render (DataInputUnion members) =-      renderInputUnion (name, typeMeta, members)+      renderInputUnion (typeName, typeMeta, members)  createEnumValue :: Monad m => DataEnumValue -> S__EnumValue m createEnumValue DataEnumValue { enumName, enumMeta } = S__EnumValue@@ -80,17 +84,20 @@   }   where deprecated = enumMeta >>= lookupDeprecated -instance RenderSchema DataField S__Field where-  render (name, field@DataField { fieldType = TypeRef { typeConName }, fieldArgs, fieldMeta }) lib+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-      args <- traverse (`renderinputValue` lib) fieldArgs       pure S__Field-        { s__FieldName              = pure (convertToJSONName name)+        { s__FieldName              = pure (convertToJSONName fieldName)         , s__FieldDescription       = pure (fieldMeta >>= metaDescription)-        , s__FieldArgs              = pure args+        , s__FieldArgs              = renderArguments fieldArgs lib          , s__FieldType'             =-          pure (wrap field $ createType kind typeConName Nothing $ Just [])+          pure (applyTypeWrapper field $ createType kind typeConName Nothing $ Just [])         , s__FieldIsDeprecated      = pure (isJust deprecated)         , s__FieldDeprecationReason = pure                                         (deprecated >>= lookupDeprecatedReason)@@ -107,8 +114,8 @@ renderTypeKind KindList        = LIST renderTypeKind KindNonNull     = NON_NULL -wrap :: Monad m => DataField -> S__Type m -> S__Type m-wrap DataField { fieldType = TypeRef { typeWrappers } } typ =+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@@ -122,18 +129,16 @@  renderinputValue   :: (Monad m, Failure Text m)-  => (Text, DataField)+  => FieldDefinition   -> Result m (S__InputValue m)-renderinputValue (key, input) =-  fmap (createInputValueWith key (fieldMeta input))-    . createInputObjectType input+renderinputValue input = fmap (createInputValueWith (fieldName input) (fieldMeta input)) . createInputObjectType input  createInputObjectType-  :: (Monad m, Failure Text m) => DataField -> Result m (S__Type m)-createInputObjectType field@DataField { fieldType = TypeRef { typeConName } } lib+  :: (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 $ wrap field $ createType kind typeConName Nothing $ Just []+    pure $ applyTypeWrapper field $ createType kind typeConName Nothing $ Just []   renderInputUnion@@ -145,8 +150,8 @@     createField     (createInputUnionFields key $ map fst $ filter snd fields)  where-  createField (name, field) =-    createInputValueWith name Nothing <$> createInputObjectType field lib+  createField field =+    createInputValueWith (fieldName field) Nothing <$> createInputObjectType field lib  createLeafType   :: Monad m

src/Data/Morpheus/Schema/SchemaAPI.hs view

@@ -33,12 +33,12 @@ import           Data.Morpheus.Types.GQLType    ( CUSTOM ) import           Data.Morpheus.Types.ID         ( ID ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)-                                                , Schema(..)+                                                ( Schema(..)                                                 , QUERY-                                                , DataType+                                                , TypeDefinition(..)                                                 , allDataTypes                                                 , lookupDataType+                                                , FieldsDefinition                                                 ) import           Data.Morpheus.Types.Internal.Resolving                                                 ( Resolver@@ -51,8 +51,8 @@ convertTypes lib = traverse (`render` lib) (allDataTypes lib)  buildSchemaLinkType-  :: Monad m => (Text, DataType) -> S__Type (Resolver QUERY e m)-buildSchemaLinkType (key', _) = createObjectType key' Nothing $ Just []+  :: Monad m => TypeDefinition -> S__Type (Resolver QUERY e m)+buildSchemaLinkType TypeDefinition { typeName } = createObjectType typeName Nothing $ Just []  findType   :: Monad m@@ -61,7 +61,7 @@   -> Resolver QUERY e m (Maybe (S__Type (Resolver QUERY e m))) findType name lib = renderT (lookupDataType name lib)  where-  renderT (Just datatype) = Just <$> render (name, datatype) lib+  renderT (Just datatype) = Just <$> render datatype lib   renderT Nothing         = pure Nothing  initSchema@@ -76,7 +76,7 @@   , s__SchemaDirectives       = pure []   } -hiddenRootFields :: [(Text, DataField)]+hiddenRootFields :: FieldsDefinition hiddenRootFields = fst $ introspectObjectFields   (Proxy :: Proxy (CUSTOM (Root Maybe)))   ("Root", OutputType, Proxy @(Root Maybe))

src/Data/Morpheus/Server.hs view

@@ -1,113 +1,101 @@-{-# LANGUAGE ConstraintKinds     #-}-{-# LANGUAGE FlexibleContexts    #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE RankNTypes          #-}-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds        #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE RankNTypes             #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE CPP                    #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE MultiParamTypeClasses  #-}+{-# LANGUAGE GADTs                  #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE DataKinds             #-}  -- |  GraphQL Wai Server Applications module Data.Morpheus.Server-  ( gqlSocketApp-  , gqlSocketMonadIOApp-  , initGQLState-  , GQLState+  ( webSocketsApp+  , httpPubApp   ) where -import           Control.Exception              ( finally )-import           Control.Monad                  ( forever )-import           Control.Monad.IO.Class         ( MonadIO(liftIO) )-import           Data.Text                      ( Text )-import           Network.WebSockets             ( ServerApp-                                                , acceptRequestWith-                                                , forkPingThread-                                                , pendingRequest-                                                , receiveData++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  -- MORPHEUS-import           Data.Morpheus.Execution.Server.Resolve-                                                ( RootResCon-                                                , coreResolver-                                                )-import           Data.Morpheus.Types.Internal.Apollo-                                                ( SubAction(..)-                                                , acceptApolloSubProtocol-                                                , apolloFormat-                                                , toApolloResponse-                                                )-import           Data.Morpheus.Execution.Server.Subscription-                                                ( GQLState-                                                , connectClient-                                                , disconnectClient-                                                , initGQLState-                                                , publishEvent-                                                , startSubscription-                                                , endSubscription-                                                )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( GQLRootResolver(..)-                                                , GQLChannel(..)-                                                , ResponseEvent(..)-                                                , ResponseStream-                                                , runResultT-                                                , Result(..)+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.Internal.WebSocket-                                                ( GQLClient(..) )-import           Data.Morpheus.Types.IO         ( GQLResponse(..) )-import           Data.Morpheus.Types.Internal.AST-                                                ( ValidValue ) -handleSubscription-  :: (Eq (StreamChannel e), GQLChannel e, MonadIO m)-  => GQLClient m e-  -> GQLState m e-  -> Text-  -> ResponseStream e m ValidValue-  -> m ()-handleSubscription GQLClient { clientConnection, clientID } state sessionId stream-  = do-    response <- runResultT stream-    case response of-      Success { events } -> mapM_ execute events-      Failure errors     -> liftIO $ sendTextData-        clientConnection-        (toApolloResponse sessionId $ Errors errors)- where-  execute (Publish   pub) = publishEvent state pub-  execute (Subscribe sub) = startSubscription clientID sub sessionId state +-- support old version of Websockets+pingThread :: Connection -> IO () -> IO ()+#if MIN_VERSION_websockets(0,12,6)+pingThread connection = WS.withPingThread connection 30 (return ())+#else+pingThread connection = (WS.forkPingThread connection 30 >>)+#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+  }++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-gqlSocketMonadIOApp-  :: (RootResCon m e que mut sub, MonadIO m)-  => GQLRootResolver m e que mut sub-  -> GQLState m e-  -> (m () -> IO ())-  -> ServerApp-gqlSocketMonadIOApp gqlRoot state f pending = do-  connection <- acceptRequestWith pending-    $ acceptApolloSubProtocol (pendingRequest pending)-  forkPingThread connection 30-  client <- connectClient connection state-  finally (f $ queryHandler client) (disconnectClient client state)- where-  queryHandler client = forever handleRequest-   where-    handleRequest = do-      d <- liftIO $ receiveData (clientConnection client)-      resolveMessage (apolloFormat d)+webSocketsApp+  ::  ( MonadIO m +      , MonadUnliftIO m+      , (Eq (StreamChannel e)) +      , (GQLChannel e) +      )+  => (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-      resolveMessage (SubError x) = liftIO $ print x-      resolveMessage (AddSub sessionId request) =-        handleSubscription client state sessionId (coreResolver gqlRoot request)-      resolveMessage (RemoveSub sessionId) =-        endSubscription (clientID client) sessionId state---- | Same as above but specific to IO-gqlSocketApp-  :: (RootResCon IO e que mut sub)-  => GQLRootResolver IO e que mut sub-  -> GQLState IO e-  -> ServerApp-gqlSocketApp gqlRoot state = gqlSocketMonadIOApp gqlRoot state id+      wsApp store pending = do+        connection <- acceptApolloRequest pending+        let scope = defaultWSScope store connection+        pingThread +          connection +          $ runIO (connectionThread api scope)

src/Data/Morpheus/Types.hs view

@@ -36,6 +36,8 @@   , subscribe   , unsafeInternalContext   , SubField+  , Input+  , Stream   ) where @@ -76,6 +78,10 @@                                                 , GQLResponse(..)                                                 ) import           Data.Morpheus.Types.Types      ( Undefined(..) )+import           Data.Morpheus.Types.Internal.Subscription  +                                                ( Stream+                                                , Input+                                                )  type Res = Resolver QUERY type MutRes = Resolver MUTATION

src/Data/Morpheus/Types/GQLScalar.hs view

@@ -10,7 +10,7 @@ where  import           Data.Morpheus.Types.Internal.AST.Data-                                                ( DataValidator(..) )+                                                ( ScalarDefinition(..) ) import           Data.Morpheus.Types.Internal.AST                                                 ( ScalarValue(..)                                                 , ValidValue@@ -42,8 +42,8 @@   parseValue :: ScalarValue -> Either Text a   -- | serialization of haskell type into scalar value   serialize :: a -> ScalarValue-  scalarValidator :: Proxy a -> DataValidator-  scalarValidator _ = DataValidator {validateValue = validator}+  scalarValidator :: Proxy a -> ScalarDefinition+  scalarValidator _ = ScalarDefinition {validateValue = validator}     where       validator value = do         scalarValue' <- toScalar value

src/Data/Morpheus/Types/GQLType.hs view

@@ -38,7 +38,7 @@                                                 , Pair                                                 , Undefined(..)                                                 )-import           Data.Morpheus.Types.Internal.AST.Data+import           Data.Morpheus.Types.Internal.AST                                                 ( DataFingerprint(..)                                                 , QUERY                                                 )

src/Data/Morpheus/Types/ID.hs view

@@ -7,6 +7,7 @@   ) 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) )@@ -26,6 +27,12 @@  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)

src/Data/Morpheus/Types/IO.hs view

@@ -2,40 +2,90 @@ {-# 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.Types.Internal.AST.Base-                                                ( Key )+import           Data.Morpheus.Error.Utils      ( badRequestError )+import           Data.Morpheus.Types.Internal.AST+                                                ( Key +                                                , GQLError(..)+                                                , ValidValue+                                                ) import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( GQLError(..)-                                                , Result(..)+                                                ( Result(..)+                                                , Failure(..)                                                 )-import           Data.Morpheus.Types.Internal.AST.Value-                                                ( ValidValue )  -renderResponse :: Result e GQLError con ValidValue -> GQLResponse+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 @@ -69,5 +119,8 @@   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 view

@@ -1,12 +1,14 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DeriveLift           #-}-{-# LANGUAGE OverloadedStrings    #-}+{-# LANGUAGE FlexibleContexts       #-}+{-# LANGUAGE DeriveLift             #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE NamedFieldPuns         #-}  module Data.Morpheus.Types.Internal.AST   (     -- BASE     Key-  , Collection   , Ref(..)   , Position(..)   , Message@@ -34,58 +36,58 @@   , ValidObject   , ResolvedObject   , ResolvedValue-  , unpackInputUnion-+  , Named+  , splitDuplicates+  , removeDuplicates   -- Selection   , Argument(..)   , Arguments   , SelectionSet   , SelectionContent(..)-  , ValidSelection   , Selection(..)-  , RawSelection-  , FragmentLib-  , RawArguments-  , RawSelectionSet+  , Fragments   , Fragment(..)-  , RawArgument-  , ValidSelectionSet-  , ValidArgument-  , ValidArguments-  , RawSelectionRec-  , ValidSelectionRec   , isOutputType   -- OPERATION   , Operation(..)   , Variable(..)-  , ValidOperation-  , RawOperation   , VariableDefinitions-  , ValidVariables   , DefaultValue   , getOperationName   , getOperationDataType-  , getOperationObject--   -- DSL-  , DataScalar+  , ScalarDefinition(..)   , DataEnum-  , DataObject-  , DataArgument+  , FieldsDefinition(..)+  , ArgumentDefinition   , DataUnion-  , DataArguments-  , DataField(..)-  , DataTypeContent(..)-  , DataType(..)+  , ArgumentsDefinition(..)+  , FieldDefinition(..)+  , InputFieldsDefinition(..)+  , TypeContent(..)+  , TypeDefinition(..)   , Schema(..)   , DataTypeWrapper(..)-  , DataValidator(..)   , DataTypeKind(..)   , DataFingerprint(..)   , TypeWrapper(..)   , TypeRef(..)   , DataEnumValue(..)+  , OperationType(..)+  , QUERY+  , MUTATION+  , SUBSCRIPTION+  , Meta(..)+  , Directive(..)+  , TypeUpdater+  , TypeD(..)+  , ConsD(..)+  , ClientQuery(..)+  , GQLTypeD(..)+  , ClientType(..)+  , DataInputUnion+  , VariableContent(..)+  , TypeLib   , isTypeDefined   , initTypeLib   , defineType@@ -107,18 +109,7 @@   , isDefaultTypeName   , isSchemaTypeName   , isPrimitiveTypeName-  , OperationType(..)-  , QUERY-  , MUTATION-  , SUBSCRIPTION   , isEntNode-  , lookupInputType-  , coerceDataObject-  , lookupDataUnion-  , lookupField-  , lookupUnionTypes-  , lookupSelectionField-  , lookupFieldAsSelectionSet   , createField   , createArgument   , createDataTypeLib@@ -129,79 +120,46 @@   , createAlias   , createInputUnionFields   , fieldVisibility-  , Meta(..)-  , Directive(..)   , createEnumValue   , insertType-  , TypeUpdater   , lookupDeprecated   , lookupDeprecatedReason-  , TypeD(..)-  , ConsD(..)-  , ClientQuery(..)-  , GQLTypeD(..)-  , ClientType(..)-  , DataInputUnion-  , VariableContent(..)-  , checkForUnknownKeys-  , checkNameCollision-  , DataLookup(..)+  , 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 )-import           Data.Semigroup                 ( (<>) )  -- Morpheus-import           Data.Morpheus.Types.Internal.AST.Data--import           Data.Morpheus.Types.Internal.AST.Selection- import           Data.Morpheus.Types.Internal.AST.Base- import           Data.Morpheus.Types.Internal.AST.Value--import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( Failure(..) )+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      :: FragmentLib-  , operation      :: RawOperation+  { fragments      :: Fragments+  , operation      :: Operation RAW   , inputVariables :: [(Key, ResolvedValue)]   } deriving (Show,Lift)--unpackInputUnion-  :: [(Name, Bool)]-  -> Object stage-  -> Either Message (Name, Maybe (Value stage))-unpackInputUnion tags [("__typename", enum)] = do-  tyName <- isPosibeUnion tags enum-  pure (tyName, Nothing)-unpackInputUnion tags [("__typename", enum), (name, value)] = do-  tyName <- isPosibeUnion tags enum-  inputtypeName tyName name value-unpackInputUnion tags [(name, value), ("__typename", enum)] = do-  tyName <- isPosibeUnion tags enum-  inputtypeName tyName name value-unpackInputUnion _ _ = failure-  ("valid input union should contain __typename and actual value" :: Message)--isPosibeUnion :: [(Name, Bool)] -> Value stage -> Either Message Name-isPosibeUnion tags (Enum name) = case lookup name tags of-  Nothing -> failure (name <> " is not posible union type" :: Message)-  _       -> pure name-isPosibeUnion _ _ = failure ("__typename must be Enum" :: Message)---inputtypeName-  :: Name -> Name -> Value stage -> Either Message (Name, Maybe (Value stage))-inputtypeName name fName fieldValue-  | fName == name = pure (name, Just fieldValue)-  | otherwise = failure ("field \"" <> name <> "\" was not provided" :: Message)

src/Data/Morpheus/Types/Internal/AST/Base.hs view

@@ -1,17 +1,19 @@-{-# LANGUAGE DeriveAnyClass  #-}-{-# LANGUAGE DeriveGeneric   #-}-{-# LANGUAGE DeriveLift      #-}-{-# LANGUAGE NamedFieldPuns  #-}-{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE DeriveAnyClass             #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE DeriveLift                 #-}+{-# LANGUAGE NamedFieldPuns             #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE MultiParamTypeClasses      #-}  module Data.Morpheus.Types.Internal.AST.Base   ( Key-  , Collection   , Ref(..)   , Position(..)   , Message-  , anonymousRef   , Name+  , Named   , Description   , VALID   , RAW@@ -19,43 +21,97 @@   , Stage(..)   , RESOLVED   , TypeRef(..)-  , removeDuplicates-  , elementOfKeys   , 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              ( )-import qualified Data.Set                      as S+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 -type Collection a = [(Key, a)]+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 Stage = RAW | RESOLVED | VALID+data GQLError = GQLError+  { message      :: Message+  , locations :: [Position]+  } deriving ( Show, Generic, FromJSON, ToJSON) -type RAW = 'RAW+type GQLErrors = [GQLError] -type RESOLVED = 'RESOLVED +type RAW = 'RAW+type RESOLVED = 'RESOLVED type VALID = 'VALID -data Position = Position-  { line   :: Int-  , column :: Int-  } deriving (Show, Generic, FromJSON, ToJSON, Lift)+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@@ -63,10 +119,7 @@ data Ref = Ref   { refName     :: Key   , refPosition :: Position-  } deriving (Show,Lift)--instance Eq Ref where-  (Ref id1 _) == (Ref id2 _) = id1 == id2+  } deriving (Show,Lift, Eq)  instance Ord Ref where   compare (Ref x _) (Ref y _) = compare x y@@ -74,27 +127,142 @@ 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) -data TypeRef = TypeRef-  { typeConName    :: Name-  , typeArgs     :: Maybe Name-  , typeWrappers :: [TypeWrapper]-  } 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 -data VALIDATION_MODE-  = WITHOUT_VARIABLES-  | FULL_VALIDATION-  deriving (Eq, Show)+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] -removeDuplicates :: Ord a => [a] -> [a]-removeDuplicates = S.toList . S.fromList+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]                   = [] -elementOfKeys :: [Name] -> Ref -> Bool-elementOfKeys keys Ref { refName } = refName `elem` keys+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 view

@@ -1,65 +1,42 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveLift            #-}-{-# LANGUAGE FlexibleInstances     #-}-{-# LANGUAGE GADTs                 #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns        #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE PolyKinds             #-}-{-# LANGUAGE RankNTypes            #-}+{-# 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-  ( DataScalar+  ( Arguments+  , ScalarDefinition(..)   , DataEnum-  , DataObject-  , DataArgument+  , FieldsDefinition(..)+  , ArgumentDefinition   , DataUnion-  , DataArguments-  , DataField(..)-  , DataTypeContent(..)-  , DataType(..)+  , ArgumentsDefinition(..)+  , FieldDefinition(..)+  , InputFieldsDefinition(..)+  , TypeContent(..)+  , TypeDefinition(..)   , Schema(..)-  , DataTypeWrapper(..)-  , DataValidator(..)-  , DataTypeKind(..)-  , DataFingerprint(..)-  , TypeWrapper(..)-  , TypeRef(..)   , DataEnumValue(..)-  , isTypeDefined-  , initTypeLib-  , defineType-  , isFieldNullable+  , TypeLib+  , Meta(..)+  , Directive(..)+  , TypeUpdater+  , TypeD(..)+  , ConsD(..)+  , ClientQuery(..)+  , GQLTypeD(..)+  , ClientType(..)+  , DataInputUnion+  , Argument(..)   , allDataTypes-  , lookupDataType-  , kindOf-  , toNullableField-  , toListField-  , isObject-  , isInput-  , toHSWrappers-  , isNullable-  , toGQLWrapper-  , isWeaker-  , isSubscription-  , isOutputObject-  , sysTypes-  , isDefaultTypeName-  , isSchemaTypeName-  , isPrimitiveTypeName-  , OperationType(..)-  , QUERY-  , MUTATION-  , SUBSCRIPTION-  , isEntNode-  , lookupInputType-  , coerceDataObject-  , lookupDataUnion-  , lookupField-  , lookupUnionTypes-  , lookupSelectionField-  , lookupFieldAsSelectionSet   , createField   , createArgument   , createDataTypeLib@@ -69,62 +46,77 @@   , createUnionType   , createAlias   , createInputUnionFields-  , fieldVisibility-  , Meta(..)-  , Directive(..)   , createEnumValue+  , defineType+  , isTypeDefined+  , initTypeLib+  , isFieldNullable   , insertType-  , TypeUpdater+  , fieldVisibility+  , kindOf+  , toNullableField+  , toListField+  , toHSFieldDefinition+  , isEntNode+  , lookupDataType   , lookupDeprecated   , lookupDeprecatedReason-  , TypeD(..)-  , ConsD(..)-  , ClientQuery(..)-  , GQLTypeD(..)-  , ClientType(..)-  , DataInputUnion-  , isNullableWrapper-  , isOutputType-  , checkForUnknownKeys-  , checkNameCollision-  , DataLookup(..)+  , lookupWith+  , hasArguments+  , unsafeFromFields+  , isInputDataType+  , unsafeFromInputFields+  , __inputname   ) where  import           Data.HashMap.Lazy              ( HashMap-                                                , empty-                                                , fromList-                                                , insert-                                                , toList                                                 , union+                                                , elems                                                 ) import qualified Data.HashMap.Lazy             as HM-                                                ( lookup )-import           Data.Semigroup                 ( (<>) )-import           Language.Haskell.TH.Syntax     ( Lift )+import           Data.Semigroup                 ( Semigroup(..), (<>) )+import           Language.Haskell.TH.Syntax     ( Lift(..) ) import           Instances.TH.Lift              ( )-import           Data.List                      ( find , (\\))+import           Data.List                      ( find)  -- MORPHEUS-import           Data.Morpheus.Error.Internal   ( internalError )-import           Data.Morpheus.Error.Selection  ( cannotQueryField-                                                , hasNoSubfields+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(..)-                                                , Ref(..)-                                                , elementOfKeys-                                                , removeDuplicates+                                                , 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-                                                ( Validation-                                                , Failure(..)-                                                , GQLErrors+                                                ( Failure(..)                                                 , LibUpdater                                                 , resolveUpdates                                                 )@@ -135,147 +127,43 @@                                                 ) import           Data.Morpheus.Error.Schema     ( nameCollisionError ) -type QUERY = 'Query-type MUTATION = 'Mutation-type SUBSCRIPTION = 'Subscription -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"])---checkNameCollision :: (Failure e m, Ord a) => [a] -> ([a] -> e) -> m [a]-checkNameCollision enhancedKeys errorGenerator =-  case enhancedKeys \\ removeDuplicates enhancedKeys of-    []         -> pure enhancedKeys-    duplicates -> failure $ errorGenerator duplicates--checkForUnknownKeys :: Failure e m => [Ref] -> [Name] -> ([Ref] -> e) -> m [Ref]-checkForUnknownKeys enhancedKeys' keys' errorGenerator' =-  case filter (not . elementOfKeys keys') enhancedKeys' of-    []           -> pure enhancedKeys'-    unknownKeys' -> failure $ errorGenerator' unknownKeys'  ---sysTypes :: [Key]-sysTypes =-  [ "__Schema"-  , "__Type"-  , "__Directive"-  , "__TypeKind"-  , "__Field"-  , "__DirectiveLocation"-  , "__InputValue"-  , "__EnumValue"-  ]--data OperationType-  = Query-  | Subscription-  | Mutation-  deriving (Show, Eq, 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--data DataTypeKind-  = KindScalar-  | KindObject (Maybe OperationType)-  | KindUnion-  | KindEnum-  | KindInputObject-  | KindList-  | KindNonNull-  | KindInputUnion-  deriving (Eq, Show, Lift)+type DataEnum = [DataEnumValue]+type DataUnion = [Key]+type DataInputUnion = [(Key, Bool)] -isFieldNullable :: DataField -> Bool-isFieldNullable = isNullable . fieldType+-- scalar+------------------------------------------------------------------+newtype ScalarDefinition = ScalarDefinition+  { validateValue :: ValidValue -> Either Key ValidValue } -isNullable :: TypeRef -> Bool-isNullable TypeRef { typeWrappers = typeWrappers } = isNullableWrapper typeWrappers+instance Show ScalarDefinition where+  show _ = "ScalarDefinition" -isNullableWrapper :: [TypeWrapper] -> Bool-isNullableWrapper (TypeMaybe : _ ) = True-isNullableWrapper _               = False+data Argument (valid :: Stage) = Argument +  { argumentName     :: Name+  , argumentValue    :: Value valid+  , argumentPosition :: Position+  } deriving ( Show, Eq, Lift )  -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]                   = []--data DataFingerprint = DataFingerprint Name [String] deriving (Show, Eq, Ord, Lift)--newtype DataValidator = DataValidator-  { validateValue :: ValidValue -> Either Key ValidValue-  }--instance Show DataValidator where-  show _ = "DataValidator"+instance KeyOf (Argument stage) where+  keyOf = argumentName  -type DataScalar = DataValidator-type DataEnum = [DataEnumValue]-type DataObject = [(Key, DataField)]-type DataArgument = DataField-type DataUnion = [Key]-type DataInputUnion = [(Key, Bool)]-type DataArguments = [(Key, DataArgument)]+instance NameCollision (Argument s) where +  nameCollision _ Argument { argumentName, argumentPosition } +    = GQLError +      { message = "There can Be only One Argument Named \"" <> argumentName <> "\"",+        locations = [argumentPosition] +      } -data DataTypeWrapper-  = ListType-  | NonNullType-  deriving (Show, Lift)+type Arguments s = OrderedMap (Argument s) +-- directive+------------------------------------------------------------------ data Directive = Directive {   directiveName :: Name,-  directiveArgs :: [(Name, ValidValue)]-} deriving (Show,Lift)---- META-data Meta = Meta {-    metaDescription:: Maybe Description,-    metaDirectives  :: [Directive]+  directiveArgs :: OrderedMap (Argument VALID) } deriving (Show,Lift)  lookupDeprecated :: Meta -> Maybe Directive@@ -286,132 +174,133 @@  lookupDeprecatedReason :: Directive -> Maybe Key lookupDeprecatedReason Directive { directiveArgs } =-  maybeString . snd <$> find isReason directiveArgs+  selectOr Nothing (Just . maybeString) "reason" directiveArgs   where-  maybeString :: ValidValue -> Name-  maybeString (Scalar (String x)) = x+  maybeString :: Argument VALID -> Name+  maybeString Argument { argumentValue = (Scalar (String x)) } = x   maybeString _                   = "can't read deprecated Reason Value"-  isReason ("reason", _) = True-  isReason _             = False +-- 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) ----------------------------------------------------------------------------------------------------data DataField = DataField-  { fieldName     :: Key-  , fieldArgs     :: [(Key, DataArgument)]-  , fieldArgsType :: Maybe Name-  , fieldType     :: TypeRef-  , fieldMeta     :: 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 -fieldVisibility :: (Key, DataField) -> Bool-fieldVisibility ("__typename", _) = False-fieldVisibility ("__schema"  , _) = False-fieldVisibility ("__type"    , _) = False-fieldVisibility _                 = True+data Schema = Schema+  { types        :: TypeLib+  , query        :: TypeDefinition+  , mutation     :: Maybe TypeDefinition+  , subscription :: Maybe TypeDefinition+  } deriving (Show) -createField :: DataArguments -> Key -> ([TypeWrapper], Key) -> DataField-createField fieldArgs fieldName (typeWrappers, typeConName) = DataField-  { fieldArgs-  , fieldArgsType = Nothing-  , fieldName-  , fieldType     = TypeRef { typeConName, typeWrappers, typeArgs = Nothing }-  , fieldMeta     = Nothing-  }+type TypeLib = HashMap Key TypeDefinition -createArgument :: Key -> ([TypeWrapper], Key) -> (Key, DataField)-createArgument fieldName x = (fieldName, createField [] fieldName x)+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+                            } -toNullableField :: DataField -> DataField-toNullableField dataField-  | isNullable (fieldType dataField) = dataField-  | otherwise = dataField { fieldType = nullable (fieldType dataField) }- where-  nullable alias@TypeRef { typeWrappers } =-    alias { typeWrappers = TypeMaybe : typeWrappers } -toListField :: DataField -> DataField-toListField dataField = dataField { fieldType = listW (fieldType dataField) }- where-  listW alias@TypeRef { typeWrappers } =-    alias { typeWrappers = TypeList : typeWrappers }+allDataTypes :: Schema -> [TypeDefinition]+allDataTypes  = elems . typeRegister -lookupField :: Failure error m => Key -> [(Key, field)] -> error -> m field-lookupField key fields gqlError = case lookup key fields of-  Nothing    -> failure gqlError-  Just field -> pure field+typeRegister :: Schema -> TypeLib+typeRegister Schema { types, query, mutation, subscription } =+  types `union` HM.fromList+    (concatMap fromOperation [Just query, mutation, subscription]) -lookupSelectionField-  :: Failure GQLErrors Validation-  => Position-  -> Name-  -> Name-  -> DataObject-  -> Validation DataField-lookupSelectionField position fieldName typeName fields = lookupField-  fieldName-  fields-  gqlError-  where gqlError = cannotQueryField fieldName typeName position+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}  --- DATA TYPE----------------------------------------------------------------------------------------------------data DataType = DataType+-- 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       :: DataTypeContent+  , typeMeta        :: Maybe Meta+  , typeContent     :: TypeContent   } deriving (Show) -data DataTypeContent-  = DataScalar      { dataScalar        :: DataScalar   }-  | DataEnum        { enumMembers       :: DataEnum     }-  | DataInputObject { inputObjectFields :: DataObject   }+data TypeContent+  = DataScalar      { dataScalar        :: ScalarDefinition      +                    }+  | DataEnum        { enumMembers       :: DataEnum              +                    }+  | DataInputObject { inputObjectFields :: InputFieldsDefinition +                    }   | DataObject      { objectImplements  :: [Name],-                      objectFields      :: DataObject   }-  | DataUnion       { unionMembers      :: DataUnion    }-  | DataInputUnion  { inputUnionMembers :: [(Key,Bool)] }-  | DataInterface   { interfaceFields   :: DataObject   }+                      objectFields      :: FieldsDefinition      +                    }+  | DataUnion       { unionMembers      :: DataUnion    +                    }+  | DataInputUnion  { inputUnionMembers :: [(Key,Bool)] +                    }+  | DataInterface   { interfaceFields   :: FieldsDefinition    +                    }   deriving (Show) -createType :: Key -> DataTypeContent -> DataType-createType typeName typeContent = DataType+createType :: Key -> TypeContent -> TypeDefinition+createType typeName typeContent = TypeDefinition   { typeName   , typeMeta        = Nothing   , typeFingerprint = DataFingerprint typeName []   , typeContent   } -createScalarType :: Key -> (Key, DataType)-createScalarType typeName =-  (typeName, createType typeName $ DataScalar (DataValidator pure))+createScalarType :: Name -> TypeDefinition+createScalarType typeName = createType typeName $ DataScalar (ScalarDefinition pure) -createEnumType :: Key -> [Key] -> (Key, DataType)-createEnumType typeName typeData =-  (typeName, createType typeName $ DataEnum enumValues)+createEnumType :: Name -> [Key] -> TypeDefinition+createEnumType typeName typeData = createType typeName (DataEnum enumValues)   where enumValues = map createEnumValue typeData -createEnumValue :: Key -> DataEnumValue+createEnumValue :: Name -> DataEnumValue createEnumValue enumName = DataEnumValue { enumName, enumMeta = Nothing } -createUnionType :: Key -> [Key] -> (Key, DataType)-createUnionType typeName typeData =-  (typeName, createType typeName $ DataUnion typeData)+createUnionType :: Key -> [Key] -> TypeDefinition+createUnionType typeName typeData = createType typeName (DataUnion typeData) -isEntNode :: DataTypeContent -> Bool+isEntNode :: TypeContent -> Bool isEntNode DataScalar{}  = True isEntNode DataEnum{} = True isEntNode _ = False -isInputDataType :: DataType -> Bool-isInputDataType DataType { typeContent } = __isInput typeContent+isInputDataType :: TypeDefinition -> Bool+isInputDataType TypeDefinition { typeContent } = __isInput typeContent  where   __isInput DataScalar{}      = True   __isInput DataEnum{}        = True@@ -419,156 +308,240 @@   __isInput DataInputUnion{}  = True   __isInput _                 = False -coerceDataObject :: Failure error m => error -> DataType -> m (Name,DataObject)-coerceDataObject _ DataType { typeContent = DataObject { objectFields } , typeName } = pure (typeName, objectFields)-coerceDataObject gqlError _ = failure gqlError--coerceDataUnion :: Failure error m => error -> DataType -> m DataUnion-coerceDataUnion _ DataType { typeContent = DataUnion members } = pure members-coerceDataUnion gqlError _ = failure gqlError--kindOf :: DataType -> DataTypeKind-kindOf DataType { typeContent } = __kind typeContent+kindOf :: TypeDefinition -> DataTypeKind+kindOf TypeDefinition { typeName, typeContent } = __kind typeContent  where   __kind DataScalar      {} = KindScalar   __kind DataEnum        {} = KindEnum   __kind DataInputObject {} = KindInputObject-  __kind DataObject      {} = KindObject Nothing+  __kind DataObject      {} = KindObject (toOperationType typeName)   __kind DataUnion       {} = KindUnion   __kind DataInputUnion  {} = KindInputUnion+  -- TODO:+  -- __kind DataInterface   {} = KindInterface ------ Type Register----------------------------------------------------------------------------------------------------data Schema = Schema-  { types        :: HashMap Name DataType-  , query        :: (Name,DataType)-  , mutation     :: Maybe (Name,DataType)-  , subscription :: Maybe (Name,DataType)-  } deriving (Show)+fromOperation :: Maybe TypeDefinition -> [(Name, TypeDefinition)]+fromOperation (Just datatype) = [(typeName datatype,datatype)]+fromOperation Nothing = [] -type TypeRegister = HashMap Key DataType+lookupDataType :: Key -> Schema -> Maybe TypeDefinition+lookupDataType name  = HM.lookup name . typeRegister -initTypeLib :: (Key, DataType) -> Schema-initTypeLib query = Schema { types        = empty-                             , query        = query-                             , mutation     = Nothing-                             , subscription = Nothing-                            }+isTypeDefined :: Key -> Schema -> Maybe DataFingerprint+isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib -allDataTypes :: Schema -> [(Key, DataType)]-allDataTypes  = toList . typeRegister+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) } -typeRegister :: Schema -> TypeRegister-typeRegister Schema { types, query, mutation, subscription } =-  types `union` fromList-    (concatMap fromOperation [Just query, mutation, subscription])+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 -fromOperation :: Maybe (Key, DataType) -> [(Key, DataType)]-fromOperation (Just (key, datatype)) = [(key, datatype)]-fromOperation Nothing = []+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)  -class DataLookup l a where -  lookupResult :: (Failure e m, Monad m) => e -> Name -> l -> m a +-- 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) }+-- -instance DataLookup Schema DataType where -  lookupResult err name lib = case lookupDataType name lib of-      Nothing -> failure err-      Just x  -> pure x+newtype FieldsDefinition = FieldsDefinition + { unFieldsDefinition :: OrderedMap FieldDefinition } +  deriving (Show, Empty) -instance DataLookup Schema (Name,DataObject) where -  lookupResult validationError name lib =-     lookupResult validationError name lib >>= coerceDataObject validationError+unsafeFromFields :: [FieldDefinition] -> FieldsDefinition +unsafeFromFields = FieldsDefinition . unsafeFromValues -lookupDataUnion-  :: (Monad m, Failure e m) => e -> Key -> Schema -> m DataUnion-lookupDataUnion validationError name lib =-  lookupResult validationError name lib >>= coerceDataUnion validationError+instance Merge FieldsDefinition where+  merge path (FieldsDefinition x)  (FieldsDefinition y) = FieldsDefinition <$> merge path x y -lookupDataType :: Key -> Schema -> Maybe DataType-lookupDataType name  = HM.lookup name . typeRegister+instance Selectable FieldsDefinition FieldDefinition where+  selectOr fb f name (FieldsDefinition lib) = selectOr fb f name lib -lookupUnionTypes-  :: (Monad m, Failure GQLErrors m)-  => Position-  -> Key-  -> Schema-  -> DataField-  -> m [(Name,DataObject)]-lookupUnionTypes position key lib DataField { fieldType = TypeRef { typeConName = typeName } }-  = lookupDataUnion gqlError typeName lib-    >>= mapM (flip (lookupResult gqlError) lib)-  where gqlError = hasNoSubfields key typeName position+instance Singleton  FieldsDefinition FieldDefinition  where +  singleton  = FieldsDefinition . singleton  -lookupFieldAsSelectionSet-  :: (Monad m, Failure GQLErrors m)-  => Position-  -> Key-  -> Schema-  -> DataField-  -> m (Name,DataObject)-lookupFieldAsSelectionSet position key lib DataField { fieldType = TypeRef { typeConName } }-  = lookupResult gqlError typeConName lib-  where gqlError = hasNoSubfields key typeConName position+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) -lookupInputType :: Failure e m => Key -> Schema -> e -> m DataType-lookupInputType name lib errors = case lookupDataType name lib of-  Just x | isInputDataType x -> pure x-  _                          -> failure errors+instance KeyOf FieldDefinition where +  keyOf = fieldName -isTypeDefined :: Key -> Schema -> Maybe DataFingerprint-isTypeDefined name lib = typeFingerprint <$> lookupDataType name lib+instance Selectable FieldDefinition ArgumentDefinition where+  selectOr fb f key FieldDefinition { fieldArgs }  = selectOr fb f key fieldArgs  -defineType :: (Key, DataType) -> Schema -> Schema-defineType (key, datatype@DataType { typeName, typeContent = DataInputUnion enumKeys, typeFingerprint }) lib-  = lib { types = insert name unionTags (insert key datatype (types lib)) }+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-  name      = typeName <> "Tags"-  unionTags = DataType-    { typeName        = name-    , typeFingerprint-    , typeMeta        = Nothing-    , typeContent     = DataEnum $ map (createEnumValue . fst) enumKeys+  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     }-defineType (key, datatype) lib =-  lib { types = insert key datatype (types lib) }+  | NoArguments+  deriving (Show, Lift) +type ArgumentDefinition = FieldDefinition  --- lookups and removes DataType from hashmap -popByKey :: Name -> [(Key, DataType)] -> (Maybe (Name,DataType), [(Key, DataType)])-popByKey key lib = case lookup key lib of-    Just dt@DataType { typeContent = DataObject {} } ->-      (Just (key, dt), filter ((/= key) . fst) lib)-    _ -> (Nothing, lib)   +instance Selectable ArgumentsDefinition ArgumentDefinition where+  selectOr fb _ _    NoArguments                  = fb+  selectOr fb f key (ArgumentsDefinition _ args)  = selectOr fb f key args  -createDataTypeLib :: [(Key, DataType)] -> Validation Schema-createDataTypeLib types = case popByKey "Query" types of-  (Nothing   ,_    ) -> internalError "Query Not Defined"-  (Just query, lib1) -> do-    let (mutation, lib2) = popByKey "Mutation" lib1-    let (subscription, lib3) = popByKey "Subscription" lib2-    pure $ (foldr defineType (initTypeLib query) lib3) {mutation, subscription}+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 -createInputUnionFields :: Key -> [Key] -> [(Key, DataField)]+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 =-    ( "__typename"-    , DataField { fieldName     = "__typename"-                , fieldArgs     = []-                , fieldArgsType = Nothing-                , fieldType     = createAlias (name <> "Tags")-                , fieldMeta     = Nothing-                }-    )-  unionField memberName =-    ( memberName-    , DataField-      { fieldArgs     = []-      , fieldArgsType = Nothing+  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]@@ -576,27 +549,17 @@                                   }       , fieldMeta     = Nothing       }-    )+--+-- OTHER+--------------------------------------------------------------------------------------------------  createAlias :: Key -> TypeRef createAlias typeConName =   TypeRef { typeConName, typeWrappers = [], typeArgs = Nothing } - type TypeUpdater = LibUpdater Schema -insertType :: (Key, DataType) -> TypeUpdater-insertType nextType@(name, datatype) lib = case isTypeDefined name lib of-  Nothing -> resolveUpdates (defineType nextType lib) []-  Just fingerprint | fingerprint == typeFingerprint datatype -> return lib-                   |-      -- throw error if 2 different types has same name-                     otherwise -> failure $ nameCollisionError name-- -- TEMPLATE HASKELL DATA TYPES---- CLIENT                                                 data ClientQuery = ClientQuery   { queryText     :: String   , queryTypes    :: [ClientType]@@ -613,7 +576,7 @@   { typeD     :: TypeD   , typeKindD :: DataTypeKind   , typeArgD  :: [TypeD]-  , typeOriginal:: (Name,DataType)+  , typeOriginal:: TypeDefinition   } deriving (Show)  data TypeD = TypeD@@ -625,5 +588,5 @@  data ConsD = ConsD   { cName   :: Name-  , cFields :: [DataField]+  , cFields :: [FieldDefinition]   } deriving (Show)

+ src/Data/Morpheus/Types/Internal/AST/MergeSet.hs view

@@ -0,0 +1,106 @@+{-# 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 view

@@ -0,0 +1,111 @@+{-# 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 view

@@ -1,179 +1,247 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE NamedFieldPuns     #-} {-# LANGUAGE DeriveLift         #-}-{-# LANGUAGE KindSignatures     #-} {-# LANGUAGE DataKinds          #-} {-# LANGUAGE GADTs              #-} {-# LANGUAGE OverloadedStrings  #-} {-# LANGUAGE FlexibleInstances  #-}-+{-# LANGUAGE TypeFamilies       #-}+{-# LANGUAGE FlexibleContexts   #-}  module Data.Morpheus.Types.Internal.AST.Selection-  ( Argument(..)-  , Arguments-  , SelectionSet+  ( Selection(..)   , SelectionContent(..)-  , ValidSelection-  , Selection(..)-  , RawSelection-  , FragmentLib-  , RawArguments-  , RawSelectionSet+  , SelectionSet+  , UnionTag(..)+  , UnionSelection   , Fragment(..)-  , RawArgument-  , ValidSelectionSet-  , ValidArgument-  , ValidArguments-  , RawSelectionRec-  , ValidSelectionRec+  , Fragments   , Operation(..)   , Variable(..)-  , ValidOperation-  , RawOperation   , VariableDefinitions-  , ValidVariables   , DefaultValue   , getOperationName   , getOperationDataType-  , getOperationObject   ) where  -import           Data.Maybe                     ( fromMaybe )+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.Mutation   ( mutationIsNotDefined )-import           Data.Morpheus.Error.Subscription-                                                ( subscriptionIsNotDefined )+import           Data.Morpheus.Error.Operation  ( mutationIsNotDefined +                                                , subscriptionIsNotDefined+                                                ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Collection-                                                , Key+                                                ( Key                                                 , Position                                                 , Ref(..)                                                 , Name                                                 , VALID                                                 , RAW                                                 , Stage-                                                )-import           Data.Morpheus.Types.Internal.Resolving.Core-                                                ( Validation-                                                , Failure(..)+                                                , OperationType(..)+                                                , GQLError(..)+                                                , GQLErrors+                                                , Message                                                 ) import           Data.Morpheus.Types.Internal.AST.Data-                                                ( OperationType(..)-                                                , Schema(..)-                                                , DataType(..)-                                                , DataTypeContent(..)-                                                , DataObject+                                                ( Schema(..)+                                                , TypeDefinition(..)+                                                , Arguments                                                 ) import           Data.Morpheus.Types.Internal.AST.Value-                                                ( Value-                                                , Variable(..)+                                                ( 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-  { fragmentType      :: Key+  { fragmentName      :: Name+  , fragmentType      :: Name   , fragmentPosition  :: Position-  , fragmentSelection :: RawSelectionSet-  } deriving (Show,Lift)+  , fragmentSelection :: SelectionSet RAW+  } deriving ( Show, Eq, Lift) -type FragmentLib = [(Key, Fragment)]+-- ERRORs+instance NameCollision Fragment where+  nameCollision _ Fragment { fragmentName , fragmentPosition } = GQLError+    { message   = "There can be only one fragment named \"" <> fragmentName <> "\"."+    , locations = [fragmentPosition]+    } -data Argument (valid :: Stage) = Argument {-    argumentValue    :: Value valid-  , argumentPosition :: Position-  } deriving (Show,Lift)+instance KeyOf Fragment where +  keyOf = fragmentName -type RawArgument = Argument RAW+type Fragments = OrderedMap Fragment -type ValidArgument = Argument VALID+data SelectionContent (s :: Stage) where+  SelectionField :: SelectionContent s+  SelectionSet   :: SelectionSet s -> SelectionContent s+  UnionSelection :: UnionSelection -> SelectionContent VALID -type Arguments a = Collection (Argument a)+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+      }+    ] -type RawArguments = Arguments RAW+deriving instance Show (SelectionContent a)+deriving instance Eq   (SelectionContent a)+deriving instance Lift (SelectionContent a) -type ValidArguments = Collection ValidArgument+data UnionTag = UnionTag {+  unionTagName :: Name,+  unionTagSelection :: SelectionSet VALID+} deriving (Show, Eq, Lift) -data SelectionContent (valid :: Stage) where-  SelectionField ::SelectionContent valid-  SelectionSet   ::SelectionSet valid -> SelectionContent valid-  UnionSelection ::UnionSelection -> SelectionContent VALID -deriving instance Show (SelectionContent a)-deriving instance Lift (SelectionContent a)+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 -type RawSelectionRec = SelectionContent RAW-type ValidSelectionRec = SelectionContent VALID-type UnionSelection = Collection (SelectionSet VALID)-type SelectionSet a = Collection (Selection a)-type RawSelectionSet = Collection RawSelection-type ValidSelectionSet = Collection ValidSelection+instance Merge UnionTag where +  merge path (UnionTag oldTag oldSel) (UnionTag _ currentSel) +    = UnionTag oldTag <$> merge path oldSel currentSel +instance KeyOf UnionTag where+  keyOf = unionTagName -data Selection (valid:: Stage) where-    Selection ::{-      selectionArguments :: Arguments valid-    , selectionPosition  :: Position-    , selectionAlias     :: Maybe Key-    , selectionContent   :: SelectionContent valid-    } -> Selection valid-    InlineFragment ::Fragment -> Selection RAW-    Spread ::Ref -> Selection RAW+type UnionSelection = MergeSet UnionTag -deriving instance Show (Selection a)-deriving instance Lift (Selection a)+type SelectionSet s = MergeSet  (Selection s) -type RawSelection = Selection RAW-type ValidSelection = Selection VALID+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 -type DefaultValue = Maybe ResolvedValue+instance KeyOf (Selection s) where+  keyOf Selection { selectionName , selectionAlias } = fromMaybe selectionName selectionAlias+  keyOf InlineFragment {} = ""+  keyOf Spread {} = "" -type VariableDefinitions = Collection (Variable RAW)+useDufferentAliases :: Message+useDufferentAliases +  =   "Use different aliases on the "+  <>  "fields to fetch both if this was intentional." -type ValidVariables = Collection (Variable VALID)+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) -data Operation (stage:: Stage) = Operation+type DefaultValue = Maybe ResolvedValue++data Operation (s:: Stage) = Operation   { operationName      :: Maybe Key   , operationType      :: OperationType-  , operationArguments :: Collection (Variable stage)-  , operationSelection :: SelectionSet stage+  , operationArguments :: VariableDefinitions s+  , operationSelection :: SelectionSet s   , operationPosition  :: Position   } deriving (Show,Lift) -type RawOperation = Operation RAW--type ValidOperation = Operation VALID-- getOperationName :: Maybe Key -> Key getOperationName = fromMaybe "AnonymousOperation" -getOperationObject-  :: Operation a -> Schema -> Validation (Name, DataObject)-getOperationObject op lib = do-  dt <- getOperationDataType op lib-  case dt of-    DataType { typeContent = DataObject { objectFields }, typeName } -> pure (typeName, objectFields)-    DataType { typeName } ->-      failure-        $  "Type Mismatch: operation \""-        <> typeName-        <> "\" must be an Object"--getOperationDataType :: Operation a -> Schema -> Validation DataType-getOperationDataType Operation { operationType = Query } lib =-  pure $ snd $ query lib+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 (_, mutation') -> pure mutation'-    Nothing             -> failure $ mutationIsNotDefined operationPosition+    Just x -> pure x+    Nothing       -> failure $ mutationIsNotDefined operationPosition getOperationDataType Operation { operationType = Subscription, operationPosition } lib   = case subscription lib of-    Just (_, subscription') -> pure subscription'+    Just x -> pure x     Nothing -> failure $ subscriptionIsNotDefined operationPosition-

src/Data/Morpheus/Types/Internal/AST/Value.hs view

@@ -27,6 +27,8 @@   , ResolvedValue   , ResolvedObject   , VariableContent(..)+  , ObjectEntry(..)+  , VariableDefinitions   ) where @@ -55,9 +57,10 @@ import           Language.Haskell.TH.Syntax     ( Lift(..) )  -- MORPHEUS+import          Data.Morpheus.Error.NameCollision+                                                ( NameCollision(..) ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( Collection-                                                , Ref(..)+                                                ( Ref(..)                                                 , Name                                                 , RAW                                                 , VALID@@ -65,8 +68,18 @@                                                 , 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@@ -112,7 +125,7 @@   | Float Float   | String Text   | Boolean Bool-  deriving (Show, Generic,Lift)+  deriving (Show, Eq, Generic,Lift)  instance A.ToJSON ScalarValue where   toJSON (Float   x) = A.toJSON x@@ -140,24 +153,56 @@   lift (ValidVariableValue x) = [| ValidVariableValue x |]  deriving instance Show (VariableContent a)+deriving instance Eq (VariableContent a)  data Variable (stage :: Stage) = Variable-  { variableType         :: TypeRef+  { variableName         :: Name+  , variableType         :: TypeRef   , variablePosition     :: Position   , variableValue        :: VariableContent (VAR stage)-  } deriving (Show,Lift)+  } deriving (Show, Eq, Lift) -data Value (valid :: Stage) where+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 a -> Value a-  List ::[Value a] -> Value a-  Enum ::Name -> Value a-  Scalar ::ScalarValue -> Value a-  Null ::Value a+  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) -type Object a = Collection (Value a)+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@@ -166,7 +211,9 @@ 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@@ -174,11 +221,11 @@   show (ResolvedVariable Ref { refName } Variable { variableValue }) =     "($" <> unpack refName <> ": " <> show variableValue <> ") "   show (VariableValue Ref { refName }) = "$" <> unpack refName <> " "-  show (Object        keys           ) = "{" <> foldl toEntry "" keys <> "}"+  show (Object  keys ) = "{" <> foldWithKey toEntry "" keys <> "}"    where-    toEntry :: String -> (Name, Value a) -> String-    toEntry ""  (key, value) = unpack key <> ":" <> show value-    toEntry txt (key, value) = txt <> ", " <> unpack key <> ":" <> show value+    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@@ -194,8 +241,8 @@   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 fields-    where toEntry (name, value) = name A..= A.toJSON value+  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@@ -205,9 +252,10 @@   toEncoding (Enum   x ) = A.toEncoding x   toEncoding (Scalar x ) = A.toEncoding x   toEncoding (List   x ) = A.toEncoding x-  toEncoding (Object []) = A.toEncoding $ A.object []-  toEncoding (Object x ) = A.pairs $ foldl1 (<>) $ map encodeField x-    where encodeField (key, value) = convertToJSONName key A..= value+  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@@ -244,4 +292,6 @@   gqlBoolean = Scalar . Boolean   gqlString  = Scalar . String   gqlList    = List-  gqlObject  = Object+  gqlObject  = Object . unsafeFromValues . map toEntry+    where +      toEntry (key,value) = ObjectEntry key value

− src/Data/Morpheus/Types/Internal/Apollo.hs

@@ -1,92 +0,0 @@-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns    #-}-{-# LANGUAGE OverloadedStrings #-}--module Data.Morpheus.Types.Internal.Apollo-  ( SubAction(..)-  , apolloFormat-  , acceptApolloSubProtocol-  , toApolloResponse-  ) where--import           Data.Aeson                 (FromJSON (..), ToJSON (..), Value (..), eitherDecode, encode, pairs,-                                             withObject, (.:), (.:?), (.=))-import           Data.ByteString.Lazy.Char8 (ByteString)-import           Data.Morpheus.Types        (GQLRequest (..))-import           Data.Morpheus.Types.IO     (GQLResponse)-import           Data.Semigroup             ((<>))-import           Data.Text                  (Text)-import           GHC.Generics               (Generic)-import           Network.WebSockets         (AcceptRequest (..), RequestHead, getRequestSubprotocols)--type ApolloID = Text--data ApolloSubscription payload =-  ApolloSubscription-    { apolloId      :: Maybe ApolloID-    , apolloType    :: Text-    , apolloPayload :: Maybe payload-    }-  deriving (Show, Generic)--instance FromJSON a => FromJSON (ApolloSubscription a) where-  parseJSON = withObject "ApolloSubscription" objectParser-    where-      objectParser o =-        ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload"--data RequestPayload =-  RequestPayload-    { payloadOperationName :: Maybe Text-    , payloadQuery         :: Maybe Text-    , payloadVariables     :: Maybe Value-    }-  deriving (Show, Generic)--instance FromJSON RequestPayload where-  parseJSON = withObject "ApolloPayload" objectParser-    where-      objectParser o =-        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'--acceptApolloSubProtocol :: RequestHead -> AcceptRequest-acceptApolloSubProtocol reqHead =-  apolloProtocol (getRequestSubprotocols reqHead)-  where-    apolloProtocol ["graphql-subscriptions"] =-      AcceptRequest (Just "graphql-subscriptions") []-    apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") []-    apolloProtocol _ = AcceptRequest Nothing []--toApolloResponse :: ApolloID -> GQLResponse -> ByteString-toApolloResponse sid val =-  encode $ ApolloSubscription (Just sid) "data" (Just val)--data SubAction-  = RemoveSub ApolloID-  | AddSub ApolloID GQLRequest-  | SubError String--apolloFormat :: ByteString -> SubAction-apolloFormat = toWsAPI . eitherDecode-  where-    toWsAPI :: Either String (ApolloSubscription RequestPayload) -> SubAction-    toWsAPI (Right ApolloSubscription { apolloType = "start"-                                      , apolloId = Just sessionId-                                      , apolloPayload = Just RequestPayload { payloadQuery = Just query-                                                                            , payloadOperationName = operationName-                                                                            , payloadVariables = variables-                                                                            }-                                      }) =-      AddSub sessionId (GQLRequest {query, operationName, variables})-    toWsAPI (Right ApolloSubscription { apolloType = "stop"-                                      , apolloId = Just sessionId-                                      }) = RemoveSub sessionId-    toWsAPI (Right x) = SubError (show x)-    toWsAPI (Left x) = SubError x

+ src/Data/Morpheus/Types/Internal/Operation.hs view

@@ -0,0 +1,100 @@+{-# 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 view

@@ -5,13 +5,11 @@     , Resolver     , MapStrategy(..)     , LiftOperation-    , resolveObject-    , runResolver-    , unsafeBind+    , runResolverModel     , toResolver     , lift     , SubEvent-    , Validation+    , Eventless     , Failure(..)     , GQLChannel(..)     , ResponseEvent(..)@@ -22,18 +20,18 @@     , unpackEvents     , LibUpdater     , resolveUpdates-    , GQLErrors-    , GQLError(..)-    , Position-    , resolve__typename-    , DataResolver(..)+    , setTypeName+    , ObjectDeriving(..)+    , Deriving(..)     , FieldRes     , WithOperation     , PushEvents(..)-    , runDataResolver     , subscribe     , Context(..)     , unsafeInternalContext+    , ResolverModel(..)+    , unsafeBind+    , liftStateless     ) where

src/Data/Morpheus/Types/Internal/Resolving/Core.hs view

@@ -1,8 +1,6 @@ {-# LANGUAGE FlexibleInstances          #-} {-# LANGUAGE MultiParamTypeClasses      #-} {-# LANGUAGE DeriveFunctor              #-}-{-# LANGUAGE DeriveAnyClass             #-}-{-# LANGUAGE DeriveGeneric              #-} {-# LANGUAGE DataKinds                  #-} {-# LANGUAGE PolyKinds                  #-} {-# LANGUAGE NamedFieldPuns             #-}@@ -12,10 +10,7 @@ {-# LANGUAGE UndecidableInstances       #-}  module Data.Morpheus.Types.Internal.Resolving.Core-  ( GQLError(..)-  , Position(..)-  , GQLErrors-  , Validation+  ( Eventless   , Result(..)   , Failure(..)   , ResultT(..)@@ -24,11 +19,11 @@   , resolveUpdates   , mapEvent   , cleanEvents-  , StatelessResT   , Event(..)   , Channel(..)   , GQLChannel(..)   , PushEvents(..)+  , statelessToResultT   ) where @@ -36,38 +31,21 @@ import           Data.Function                  ( (&) ) import           Control.Monad.Trans.Class      ( MonadTrans(..) ) import           Control.Applicative            ( liftA2 )-import           Data.Aeson                     ( FromJSON-                                                , ToJSON+import           Data.Morpheus.Types.Internal.Operation+                                                ( +                                                  Failure(..)                                                 ) import           Data.Morpheus.Types.Internal.AST.Base-                                                ( -                                                  Position(..)-                                                  , Message +                                                ( GQLErrors+                                                , GQLError(..)                                                 ) import           Data.Text                      ( Text                                                 , pack-                                                , unpack                                                 )-import           GHC.Generics                   ( Generic ) import           Data.Semigroup                 ( (<>) )  -class Applicative f => Failure error (f :: * -> *) where-  failure :: error -> f v--instance Failure error (Either error) where-  failure = Left--data GQLError = GQLError-  { message      :: Text-  , locations :: [Position]-  } deriving (Show, Generic, FromJSON, ToJSON)--type GQLErrors = [GQLError]--type StatelessResT = ResultT () GQLError 'True-type Validation = Result () GQLError 'True-+type Eventless = Result ()  -- EVENTS class PushEvents e m where @@ -97,7 +75,7 @@   { channels :: [e], content  :: c}  -unpackEvents :: Result event c e a -> [event]+unpackEvents :: Result event a -> [event] unpackEvents Success { events } = events unpackEvents _                  = [] @@ -105,44 +83,56 @@ -- Result -- ---data Result events error (concurency :: Bool) a -  = Success { result :: a , warnings :: [error] , events:: [events] }-  | Failure [error] deriving (Functor)+data Result events a +  = Success { result :: a , warnings :: GQLErrors , events:: [events] }+  | Failure { errors :: GQLErrors } deriving (Functor) -instance Applicative (Result e cocnurency  error) where+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  cocnurency error)  where+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 [error] (Result ev error con) where+instance Failure [GQLError] (Result ev) where   failure = Failure -instance Failure Text Validation where+instance Failure Text Eventless where   failure text =-    Failure [GQLError { message = "INTERNAL ERROR: " <> text, locations = [] }]+    Failure [GQLError { message = "INTERNAL: " <> text, locations = [] }] -instance PushEvents events (Result events err con) where+instance PushEvents events (Result events) where   pushEvents events = Success { result = (), warnings = [], events }  - -- ResultT-newtype ResultT event error (concurency :: Bool)  (m :: * -> * ) a = ResultT { runResultT :: m (Result event error concurency a )  }-  deriving (Functor)+newtype ResultT event (m :: * -> * ) a +  = ResultT +    { +      runResultT :: m (Result event a)  +    }+    deriving (Functor) -instance Applicative m => Applicative (ResultT event error concurency m) where+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 error concurency m) where+instance Monad m => Monad (ResultT event m) where   return = pure   (ResultT m1) >>= mFunc = ResultT $ do     result1 <- m1@@ -154,27 +144,23 @@           Failure errors   -> pure $ Failure (errors <> w1)           Success v2 w2 e2 -> return $ Success v2 (w1 <> w2) (e1 <> e2) -instance MonadTrans (ResultT event error concurency) where+instance MonadTrans (ResultT event) where   lift = ResultT . fmap pure -instance Monad m => Failure Message (ResultT event String concurency m) where-  failure message = ResultT $ pure $ Failure [unpack message]--instance Applicative m => Failure String (ResultT ev GQLError con m) where+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 GQLError concurency m) where+instance Monad m => Failure GQLErrors (ResultT event m) where   failure = ResultT . pure . failure -instance Applicative m => PushEvents events (ResultT events err con m) where+instance Applicative m => PushEvents event (ResultT event m) where   pushEvents = ResultT . pure . pushEvents - cleanEvents   :: Functor m-  => ResultT e1 error concurency m a-  -> ResultT e2 error concurency m a+  => ResultT e m a+  -> ResultT e' m a cleanEvents resT = ResultT $ replace <$> runResultT resT  where   replace (Success v w _) = Success v w []@@ -182,9 +168,9 @@  mapEvent   :: Monad m-  => (ea -> eb)-  -> ResultT ea er con m value-  -> ResultT eb er con m value+  => (e -> e')+  -> ResultT e m value+  -> ResultT e' m value mapEvent func (ResultT ma) = ResultT $ mapEv <$> ma  where   mapEv Success { result, warnings, events } =@@ -192,7 +178,7 @@   mapEv (Failure err) = Failure err  -- Helper Functions-type LibUpdater lib = lib -> Validation lib+type LibUpdater lib = lib -> Eventless lib -resolveUpdates :: lib -> [LibUpdater lib] -> Validation lib+resolveUpdates :: lib -> [LibUpdater lib] -> Eventless lib resolveUpdates = foldM (&)

src/Data/Morpheus/Types/Internal/Resolving/Resolver.hs view

@@ -8,7 +8,6 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE PolyKinds                  #-} {-# LANGUAGE ScopedTypeVariables        #-}-{-# LANGUAGE TupleSections              #-} {-# LANGUAGE TypeFamilies               #-} {-# LANGUAGE TypeOperators              #-} {-# LANGUAGE UndecidableInstances       #-}@@ -24,30 +23,31 @@   , Resolver   , MapStrategy(..)   , LiftOperation-  , resolveObject-  , runDataResolver-  , runResolver   , unsafeBind   , toResolver   , lift+  , subscribe   , SubEvent   , GQLChannel(..)   , ResponseEvent(..)   , ResponseStream-  , resolve__typename-  , DataResolver(..)+  , ObjectDeriving(..)+  , Deriving(..)   , FieldRes   , WithOperation-  , subscribe   , 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                     ( fromMaybe )+import           Data.Maybe                     ( maybe ) import           Data.Semigroup                 ( (<>)                                                 , Semigroup(..)                                                 )@@ -60,29 +60,37 @@ import           Data.Morpheus.Types.Internal.AST.Selection                                                 ( Selection(..)                                                 , SelectionContent(..)-                                                , ValidSelection-                                                , ValidSelectionRec-                                                , ValidSelectionSet-                                                , ValidSelection-                                                , ValidArguments-                                                , ValidOperation+                                                , SelectionSet+                                                , UnionTag(..)+                                                , UnionSelection+                                                , Operation(..)                                                 ) import           Data.Morpheus.Types.Internal.AST.Base                                                 ( Message-                                                , Key                                                 , Name-                                                )-import           Data.Morpheus.Types.Internal.AST.Data-                                                ( MUTATION                                                 , OperationType                                                 , QUERY+                                                , MUTATION                                                 , SUBSCRIPTION-                                                , Schema+                                                , 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-                                                ( GQLErrors-                                                , GQLError(..)-                                                , Validation+                                                ( Eventless                                                 , Result(..)                                                 , Failure(..)                                                 , ResultT(..)@@ -93,10 +101,14 @@                                                 , StreamChannel                                                 , GQLChannel(..)                                                 , PushEvents(..)+                                                , statelessToResultT                                                 ) import           Data.Morpheus.Types.Internal.AST.Value                                                 ( GQLValue(..)                                                 , ValidValue+                                                , ObjectEntry(..)+                                                , Value(..)+                                                , ScalarValue(..)                                                 ) import           Data.Morpheus.Types.IO         ( renderResponse                                                 , GQLResponse@@ -104,24 +116,33 @@  type WithOperation (o :: OperationType) = LiftOperation o -type ResponseStream event m = ResultT (ResponseEvent m event) GQLError 'True m+type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m -data ResponseEvent m event+data ResponseEvent event (m :: * -> *)   = Publish event-  | Subscribe (SubEvent m event)+  | Subscribe (SubEvent event m) -type SubEvent m event = Event (Channel event) (event -> m GQLResponse)+type SubEvent event m = Event (Channel event) (event -> m GQLResponse) -data Context = Context {-  currentSelection :: (Name,ValidSelection),-  schema :: Schema,-  operation :: ValidOperation-} deriving (Show)+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 GQLError 'True m) a-} deriving (Functor, Applicative, Monad)+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@@ -140,29 +161,27 @@ instance (Monad m) => PushEvents e (ResolverState e m) where     pushEvents = ResolverState . lift . pushEvents  - mapResolverState :: -  ( ReaderT Context (ResultT e1 GQLError 'True m1) a1 -    -> ReaderT Context (ResultT e2 GQLError 'True m2) a2 -  ) -> ResolverState e1 m1 a1 -    -> ResolverState e2 m2 a2+  ( 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 (Name,ValidSelection)+getState :: (Monad m) => ResolverState e m (Selection VALID) getState = ResolverState $ currentSelection <$> ask  -setState :: (Name,ValidSelection) -> ResolverState e m a -> ResolverState e m a-setState currentSelection = mapResolverState (withReaderT (\ctx -> ctx { currentSelection } ))+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 e1 m a -> ResolverState e2 m a+clearStateResolverEvents :: (Functor m) => ResolverState e m a -> ResolverState e' m a clearStateResolverEvents = mapResolverState (mapReaderT cleanEvents) -resolverFailureMessage :: (Name,ValidSelection) -> Message -> GQLError-resolverFailureMessage (name, Selection { selectionPosition }) message = GQLError-  { message   = "Failure on Resolving Field \"" <> name <> "\": " <> message+resolverFailureMessage :: Selection VALID -> Message -> GQLError+resolverFailureMessage Selection { selectionName, selectionPosition } message = GQLError+  { message   = "Failure on Resolving Field \"" <> selectionName <> "\": " <> message   , locations = [selectionPosition]   } @@ -175,6 +194,11 @@     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@@ -185,11 +209,7 @@   ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2  -- Monad -instance (Monad m) => Monad (Resolver QUERY e m) where-  return = pure-  (>>=) = unsafeBind--instance (Monad m) => Monad (Resolver MUTATION e m) where+instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where   return = pure   (>>=) = unsafeBind @@ -209,15 +229,29 @@  -- Failure instance (LiftOperation o, Monad m) => Failure Message (Resolver o e m) where-   failure = packResolver .failure+  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 +  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@@ -239,13 +273,22 @@     value <- clearStateResolverEvents ctxRes     runResolverS $ toRes value -setSelection :: Monad m => (Name, ValidSelection) -> Resolver o e m a -> Resolver o e m a -setSelection sel (ResolverQ res)  = ResolverQ (setState sel res)-setSelection sel (ResolverM res)  = ResolverM (setState sel res) -setSelection sel (ResolverS resM)  = ResolverS $ do++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 $ setState sel (runResolverQ (runReaderT res e)) +    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 @@ -261,12 +304,19 @@ 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+         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 +  :: 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)@@ -280,136 +330,179 @@ 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 a -> Resolver to e m a+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+  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----type FieldRes o e m-  = (Key, Resolver o e m ValidValue)- toResolver   :: forall o e m a b. (LiftOperation o, Monad m)-  => (ValidArguments -> Validation a)-  -> (a -> Resolver o e m b)+  => (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+    Selection { selectionArguments } <- getState     let resT = ResultT $ pure $ toArgs selectionArguments     ResolverState $ lift $ cleanEvents resT  -- DataResolver-data DataResolver o e m =-    EnumRes  Name-  | UnionRes  (Name,[FieldRes o e m])-  | ObjectRes  [FieldRes o e m ]-  | UnionRef (FieldRes o e m)-  | InvalidRes Name+type FieldRes o e m+  = (Name, Resolver o e m (Deriving o e m)) -instance Semigroup (DataResolver o e m) where-  ObjectRes x <> ObjectRes y = ObjectRes (x <> y)-  _           <> _           = InvalidRes "can't merge: incompatible resolvers"+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"  -pickSelection :: Name -> [(Name, ValidSelectionSet)] -> ValidSelectionSet-pickSelection name = fromMaybe [] . lookup name+instance Merge (ObjectDeriving o e m) where+  merge _ (ObjectDeriving tyname x) (ObjectDeriving _ y) +    = pure $ ObjectDeriving tyname (x <> y) -resolve__typename-  :: (Monad m, LiftOperation o)-  => Name-  -> (Key, Resolver o e m ValidValue)-resolve__typename name = ("__typename", pure $ gqlString name) -resolveEnum-  :: (Monad m, LiftOperation o)-  => Name-  -> Name-  -> ValidSelectionRec-  -> Resolver o e m ValidValue-resolveEnum _        enum SelectionField              = pure $ gqlString enum-resolveEnum typeName enum (UnionSelection selections) = resolveObject-  currentSelection-  resolvers- where-  enumObjectTypeName = typeName <> "EnumObject"-  currentSelection   = fromMaybe [] $ lookup enumObjectTypeName selections-  resolvers          = ObjectRes-    [ ("enum", pure $ gqlString enum)-    , resolve__typename enumObjectTypeName-    ]-resolveEnum _ _ _ =-  failure $ internalResolvingError "wrong selection on enum value"+pickSelection :: Name -> UnionSelection -> SelectionSet VALID+pickSelection = selectOr empty unionTagSelection  withObject   :: (LiftOperation o, Monad m)-  => (ValidSelectionSet -> Resolver o e m value)-  -> (Key, ValidSelection)+  => (SelectionSet VALID -> Resolver o e m value)+  -> Selection VALID   -> Resolver o e m value-withObject f (key, Selection { selectionContent , selectionPosition }) = checkContent selectionContent+withObject f Selection { selectionName, selectionContent , selectionPosition } = checkContent selectionContent  where   checkContent (SelectionSet selection) = f selection-  checkContent _ = failure (subfieldsNotSelected key "" selectionPosition)--lookupRes :: (LiftOperation o, Monad m) => Name -> [(Name,Resolver o e m ValidValue)] -> Resolver o e m ValidValue-lookupRes key = fromMaybe (pure gqlNull) . lookup key +  checkContent _ = failure (subfieldsNotSelected selectionName "" selectionPosition) -outputSelectionName :: (Name,ValidSelection) -> Name-outputSelectionName (name,Selection { selectionAlias }) = fromMaybe name selectionAlias+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)-  => ValidSelectionSet-  -> DataResolver o e m+  => SelectionSet VALID+  -> Deriving o e m   -> Resolver o e m ValidValue-resolveObject selectionSet (ObjectRes resolvers) =-  gqlObject <$> traverse resolver selectionSet+resolveObject selectionSet (DerivingObject drv@ObjectDeriving { __typename }) =+  Object . toOrderedMap <$> traverse resolver selectionSet  where-  resolver :: (Name,ValidSelection) -> Resolver o e m (Name,ValidValue)-  resolver sel@(name,_) = setSelection sel $ (outputSelectionName sel, ) <$> lookupRes name resolvers+  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 :: 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) => Name -> DataResolver o e m -> Resolver o e m ValidValue-runDataResolver typename  = withResolver getState . __encode++runDataResolver :: (Monad m, LiftOperation o) => Deriving o e m -> Resolver o e m ValidValue+runDataResolver = withResolver getState . __encode    where-    __encode obj (key, sel@Selection { selectionContent })  = encodeNode obj selectionContent +    __encode obj sel@Selection { selectionContent }  = encodeNode obj selectionContent        where +      -- LIST+      encodeNode (DerivingList x) _ = List <$> traverse runDataResolver x       -- Object ------------------      encodeNode (ObjectRes fields) _ = withObject encodeObject (key, sel)-        where-        encodeObject selection =-          resolveObject selection-            $ ObjectRes-            $ resolve__typename typename-            : fields-      encodeNode (EnumRes enum) _ =-        resolveEnum typename enum selectionContent-      -- Type Reference ---------      encodeNode (UnionRef (fieldTypeName, fieldResolver)) (UnionSelection selections)-        = setSelection (key, sel { selectionContent = SelectionSet currentSelection }) fieldResolver-          where currentSelection = pickSelection fieldTypeName selections-      -- Union Record -----------------      encodeNode (UnionRes (name, fields)) (UnionSelection selections) =-        resolveObject selection resolver-        where-          selection = pickSelection name selections-          resolver = ObjectRes (resolve__typename name : fields)-      encodeNode _ _ = failure $ internalResolvingError-        "union Resolver should only recieve UnionSelection"+      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@@ -417,9 +510,9 @@   -> 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 (ResolverM resT) sel = mapEvent Publish $ (runReaderT $ runResolverState resT) sel  runResolver (ResolverS resT) sel = ResultT $ do -    (readResValue :: Result (Channel event1) GQLError 'True (ReaderT event (Resolver QUERY event m) ValidValue))  <- runResultT $ (runReaderT $ runResolverState $ resT) sel+    (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@@ -430,6 +523,18 @@           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,@@ -439,3 +544,28 @@   , 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

@@ -0,0 +1,131 @@+{-# LANGUAGE NamedFieldPuns          #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE ScopedTypeVariables     #-}++module Data.Morpheus.Types.Internal.Subscription+  ( connectionThread+  , toOutStream+  , runStreamWS+  , runStreamHTTP+  , Stream+  , Scope(..)+  , Input(..)+  , WS+  , HTTP+  , acceptApolloRequest+  , publish+  , Store(..)+  , initDefaultStore+  , publishEventWith+  )+where+++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+                                                )++-- 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)++-- | PubSubStore interface+-- shared GraphQL state between __websocket__ and __http__ server,+-- you can define your own store if you provide write and read methods+-- 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 ()+  }++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 = do+  store <- 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 api scope = do+  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+

+ src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs view

@@ -0,0 +1,144 @@+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE FlexibleInstances #-}+{-# 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+                                            )++-- MORPHEUS+import           Data.Morpheus.Types.IO     ( GQLResponse +                                            , GQLRequest (..)+                                            )++type ID = Text++data ApolloSubscription payload =+  ApolloSubscription+    { apolloId      :: Maybe ID+    , apolloType    :: Text+    , apolloPayload :: Maybe payload+    }+  deriving (Show, Generic)++instance FromJSON a => FromJSON (ApolloSubscription a) where+  parseJSON = withObject "ApolloSubscription" objectParser+    where+      objectParser o =+        ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload"++data RequestPayload =+  RequestPayload+    { payloadOperationName :: Maybe Text+    , payloadQuery         :: Maybe Text+    , payloadVariables     :: Maybe Value+    }+  deriving (Show, Generic)++instance FromJSON RequestPayload where+  parseJSON = withObject "ApolloPayload" objectParser+    where+      objectParser o =+        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))++acceptApolloSubProtocol :: RequestHead -> AcceptRequest+acceptApolloSubProtocol reqHead =+  apolloProtocol (getRequestSubprotocols reqHead)+  where+    apolloProtocol ["graphql-subscriptions"] =+      AcceptRequest (Just "graphql-subscriptions") []+    apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") []+    apolloProtocol _ = AcceptRequest Nothing []++toApolloResponse :: ID -> GQLResponse -> ByteString+toApolloResponse sid val =+  encode $ ApolloSubscription (Just sid) "data" (Just val)++data ApolloAction+  = SessionStop ID+  | SessionStart ID GQLRequest+  | ConnectionInit++type Validation = Either ByteString++apolloFormat :: ByteString -> Validation ApolloAction+apolloFormat = validateReq . eitherDecode+  where+    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+        sessionId <- validateSession apolloId+        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) <> "\"."+    --------------------------------------------+    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}

+ src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs view

@@ -0,0 +1,162 @@+{-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE KindSignatures   #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore+  ( ID+  , Session+  , ClientConnectionStore+  , Updates(..)+  , startSession+  , endSession+  , empty+  , insert+  , delete+  , publish+  )+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+                                                )+++-- 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++type SesionID = Text++type Session = (ID, SesionID)+++data ClientConnection e ( m :: * -> * ) =+  ClientConnection+    { connectionId       :: ID+    , connectionCallback :: ByteString -> m ()+    -- one connection can have multiple subsciprion session+    , connectionSessions :: HashMap SesionID (SubEvent e m)+    }++instance Show (ClientConnection e m) where+  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 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++++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)++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) }++++-- 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)++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 f = ClientConnectionStore . f . unpackStore++elems :: ClientConnectionStore e m ->  [ClientConnection e m]+elems = HM.elems . unpackStore++instance Empty (ClientConnectionStore e m) where+  empty = ClientConnectionStore HM.empty++insert +  :: ID+  -> (ByteString -> m ())+  -> StoreMap e m+insert connectionId connectionCallback = mapStore (HM.insert connectionId  c)+  where+    c = ClientConnection { connectionId , connectionCallback, connectionSessions = HM.empty }++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 key = mapStore (HM.delete key)

+ src/Data/Morpheus/Types/Internal/Subscription/Stream.hs view

@@ -0,0 +1,235 @@+{-# LANGUAGE NamedFieldPuns          #-}+{-# LANGUAGE FlexibleContexts        #-}+{-# LANGUAGE FlexibleInstances       #-}+{-# LANGUAGE UndecidableInstances    #-}+{-# LANGUAGE MultiParamTypeClasses   #-}+{-# LANGUAGE DataKinds               #-}+{-# LANGUAGE GADTs                   #-}+{-# LANGUAGE TypeFamilies            #-}+{-# LANGUAGE ScopedTypeVariables     #-}+{-# LANGUAGE OverloadedStrings       #-}++module Data.Morpheus.Types.Internal.Subscription.Stream+  ( toOutStream+  , runStreamWS+  , runStreamHTTP+  , Stream+  , Scope(..)+  , Input(..)+  , API(..)+  , HTTP+  , WS+  )+where++import           Data.Foldable                  ( traverse_ )+import           Data.ByteString.Lazy.Char8     (ByteString)++-- 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+                                                )+ +data API = HTTP | WS++type WS = 'WS++type HTTP = 'HTTP ++data Input +  (api:: API) +  where+  Init :: ID -> Input WS +  Request :: GQLRequest -> Input HTTP ++run :: Scope WS e m -> Updates e m -> m ()+run ScopeWS { update } (Updates changes) = update changes++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+++data Stream +    (api:: API) +    e +    (m :: * -> * ) +  where+  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++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 gqlApp clientId = handle . apolloFormat+  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)]++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 +    >>= either callback (traverse_ (run 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 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 +  res+  ScopeHTTP { httpCallback } = do+    x <- runResultT (handleRes res execute)+    case x of +      Success r _ events-> do +        traverse_ httpCallback events+        pure $ Data r +      Failure err -> pure (Errors err)+    where+     execute (Publish event) = pure event+     execute Subscribe {}  = failure ("http can't handle subscription" :: String)++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+  events' <- traverse execute events+  ResultT $ pure $ Success +    { result+    , warnings+    , events = events'+    }+unfoldRes _ Failure { errors } = ResultT $ pure $ Failure { errors }

+ src/Data/Morpheus/Types/Internal/Validation.hs view

@@ -0,0 +1,354 @@+{-# 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 view

@@ -0,0 +1,201 @@+{-# 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 view

@@ -0,0 +1,226 @@+{-# 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/Internal/WebSocket.hs

@@ -1,47 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}--module Data.Morpheus.Types.Internal.WebSocket-  ( GQLClient(..)-  , ClientID-  , ClientDB-  , GQLState-  , SesionID-  )-where--import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( Text )-import           Data.UUID                      ( UUID )-import           Network.WebSockets             ( Connection )-import           Data.HashMap.Lazy              ( HashMap , keys)-import           Control.Concurrent             ( MVar )---- MORPHEUS-import           Data.Morpheus.Types.Internal.Resolving-                                                ( SubEvent )----- | shared GraphQL state between __websocket__ and __http__ server,--- stores information about subscriptions-type GQLState m e = MVar (ClientDB m e) -- SharedState--type ClientDB m e = HashMap ClientID (GQLClient m e)--type ClientID = UUID--type SesionID = Text--data GQLClient m e  =-  GQLClient-    { clientID         :: ClientID-    , clientConnection :: Connection-    , clientSessions   :: HashMap SesionID (SubEvent m e)-    }--instance (Show e) => Show (GQLClient m e) where-  show GQLClient { clientID, clientSessions } =-    "GQLClient {id:"-      <> show clientID-      <> ", sessions:"-      <> show (keys clientSessions)-      <> "}"

src/Data/Morpheus/Validation/Document/Validation.hs view

@@ -1,7 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TupleSections  #-} - module Data.Morpheus.Validation.Document.Validation   ( validatePartialDocument   )@@ -19,55 +17,56 @@ import           Data.Morpheus.Rendering.RenderGQL                                                 ( RenderGQL(..) ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)-                                                , DataType(..)-                                                , DataObject-                                                , DataTypeContent(..)-                                                , Name-                                                , Key+                                                ( Name+                                                , FieldDefinition(..)+                                                , TypeDefinition(..)+                                                , FieldsDefinition(..)+                                                , TypeContent(..)                                                 , TypeRef(..)                                                 , isWeaker+                                                , lookupWith                                                 )+import           Data.Morpheus.Types.Internal.Operation+                                                ( Selectable(..)+                                                , Listable(..)+                                                ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+                                                ( Eventless                                                 , Failure(..)                                                 ) -validatePartialDocument :: [(Key, DataType)] -> Validation [(Key, DataType)]+validatePartialDocument :: [TypeDefinition] -> Eventless [TypeDefinition] validatePartialDocument lib = catMaybes <$> traverse validateType lib  where-  validateType :: (Key, DataType) -> Validation (Maybe (Key, DataType))-  validateType (name, dt@DataType { typeName , typeContent = DataObject { objectImplements , objectFields}  }) = do         +  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 (name, dt) +        [] -> pure (Just dt)          errors -> failure $ partialImplements typeName errors-  validateType (_,DataType { typeContent = DataInterface {}}) = pure Nothing-  validateType (name, x) = pure $ Just (name, x)+  validateType TypeDefinition { typeContent = DataInterface {}} = pure Nothing+  validateType x = pure (Just x)   mustBeSubset-    :: DataObject -> (Name, DataObject) -> [(Key, Key, ImplementsError)]-  mustBeSubset objFields (typeName, interfaceFields ) = concatMap-    checkField-    interfaceFields+    :: FieldsDefinition -> (Name, FieldsDefinition) -> [(Name, Name, ImplementsError)]+  mustBeSubset objFields (typeName, fields) = concatMap checkField (toList fields)    where-    checkField :: (Key, DataField) -> [(Key, Key, ImplementsError)]-    checkField (key, DataField { fieldType = interfaceT@TypeRef { typeConName = interfaceTypeName, typeWrappers = interfaceWrappers } })-      = case lookup key objFields of-        Just DataField { fieldType = objT@TypeRef { typeConName, typeWrappers } }-          | typeConName == interfaceTypeName && not-            (isWeaker typeWrappers interfaceWrappers)-          -> []+    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-               , key+            = [ ( typeName , fieldName                , UnexpectedType { expectedType = render interfaceT                                 , foundType    = render objT                                 }                )              ]-        Nothing -> [(typeName, key, UndefinedField)]   --------------------------------  getInterfaceByKey :: Key -> Validation (Name,DataObject)-  getInterfaceByKey key = case lookup key lib of-    Just DataType { typeContent = DataInterface { interfaceFields } } -> pure (key,interfaceFields)-    _ -> failure $ unknownInterface key+  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 view

@@ -3,198 +3,191 @@ {-# LANGUAGE OverloadedStrings #-}  module Data.Morpheus.Validation.Internal.Value-  ( validateInputValue-  , validateEnum-  )+  ( 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      ( InputError(..)-                                                , InputValidation-                                                , Prop(..)-                                                )+import           Data.Morpheus.Error.Input      ( typeViolation ) import           Data.Morpheus.Types.Internal.AST-                                                ( DataField(..)-                                                , DataTypeContent(..)-                                                , DataType(..)-                                                , Schema(..)-                                                , DataValidator(..)-                                                , Key+                                                ( FieldDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)+                                                , ScalarDefinition(..)                                                 , TypeRef(..)                                                 , TypeWrapper(..)                                                 , DataEnumValue(..)-                                                , lookupField-                                                , lookupInputType                                                 , Value(..)                                                 , ValidValue                                                 , Variable(..)                                                 , Ref(..)-                                                , isWeaker-                                                , DataScalar                                                 , Message                                                 , Name                                                 , ResolvedValue                                                 , VALID                                                 , VariableContent(..)-                                                , unpackInputUnion-                                                , isFieldNullable                                                 , TypeRef(..)+                                                , isWeaker                                                 , isNullableWrapper+                                                , ObjectEntry(..)+                                                , RESOLVED+                                                , InputFieldsDefinition(..)+                                                , Variable(..)                                                 )--import           Data.Morpheus.Types.Internal.Resolving+import           Data.Morpheus.Types.Internal.AST.OrderedMap+                                                ( unsafeFromValues )+import           Data.Morpheus.Types.Internal.Operation                                                 ( Failure(..) )-import           Data.Morpheus.Rendering.RenderGQL-                                                ( RenderGQL(..) )+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-  -> InputValidation ValidValue-checkTypeEquality (tyConName, tyWrappers) Ref { refName, refPosition } Variable { variableValue = ValidVariableValue value, variableType }+  -> InputValidator ValidValue+checkTypeEquality (tyConName, tyWrappers) ref var@Variable { variableValue = ValidVariableValue value, variableType }   | typeConName variableType == tyConName && not     (isWeaker (typeWrappers variableType) tyWrappers)   = pure value   | otherwise-  = failure $ GlobalInputError $ incompatibleVariableType refName-                                                          varSignature-                                                          fieldSignature-                                                          refPosition- where-  varSignature   = render variableType-  fieldSignature = render TypeRef { typeConName  = tyConName-                                  , typeWrappers = tyWrappers-                                  , typeArgs     = Nothing-                                  }--+  = failure $ incompatibleVariableType +      ref+      var+      TypeRef +        { typeConName = tyConName+        , typeWrappers = tyWrappers+        , typeArgs     = Nothing+        }  -- Validate Variable Argument or all Possible input Values-validateInputValue-  :: Schema-  -> [Prop]-  -> [TypeWrapper]-  -> DataType-  -> (Key, ResolvedValue)-  -> InputValidation ValidValue-validateInputValue lib props rw datatype@DataType { typeContent, typeName } =-  validateWrapped rw typeContent+validateInput+  :: [TypeWrapper]+  -> TypeDefinition+  -> ObjectEntry RESOLVED+  -> InputValidator ValidValue+validateInput tyWrappers TypeDefinition { typeContent = tyCont, typeName } =+  withScopeType typeName +  . validateWrapped tyWrappers tyCont  where-  throwError :: [TypeWrapper] -> ResolvedValue -> InputValidation ValidValue-  throwError wrappers value =-    Left $ UnexpectedType props (renderWrapped datatype wrappers) value Nothing+  mismatchError :: [TypeWrapper] -> ResolvedValue -> InputValidator ValidValue+  mismatchError  wrappers = castFailure (TypeRef typeName Nothing wrappers) Nothing     -- VALIDATION   validateWrapped     :: [TypeWrapper]-    -> DataTypeContent-    -> (Key, ResolvedValue)-    -> InputValidation ValidValue+    -> TypeContent+    -> ObjectEntry RESOLVED+    -> InputValidator ValidValue   -- Validate Null. value = null ?-  validateWrapped wrappers _ (_, ResolvedVariable ref variable) =+  validateWrapped wrappers _  ObjectEntry { entryValue = ResolvedVariable ref variable} =     checkTypeEquality (typeName, wrappers) ref variable-  validateWrapped wrappers _ (_, Null)+  validateWrapped wrappers _ ObjectEntry { entryValue = Null}     | isNullableWrapper wrappers = return Null-    | otherwise                  = throwError wrappers Null+    | otherwise                  = mismatchError wrappers Null   -- Validate LIST   validateWrapped (TypeMaybe : wrappers) _ value =-    validateInputValue lib props wrappers datatype value-  validateWrapped (TypeList : wrappers) _ (key, List list) =-    List <$> mapM validateElement list+    validateWrapped wrappers tyCont value+  validateWrapped (TypeList : wrappers) _ (ObjectEntry key (List list)) =+    List <$> traverse validateElement list    where-    validateElement element =-      validateInputValue lib props wrappers datatype (key, element)+    validateElement = validateWrapped wrappers tyCont . ObjectEntry key    {-- 2. VALIDATE TYPES, all wrappers are already Processed --}   {-- VALIDATE OBJECT--}   validateWrapped [] dt v = validate dt v    where     validate-      :: DataTypeContent -> (Key, ResolvedValue) -> InputValidation ValidValue-    validate (DataInputObject parentFields) (_, Object fields) =-      traverse requiredFieldsDefined parentFields-        >>  Object-        <$> traverse validateField fields+      :: TypeContent -> ObjectEntry RESOLVED -> InputValidator ValidValue+    validate (DataInputObject parentFields) ObjectEntry { entryValue = Object fields} = do +      traverse_ requiredFieldsDefined (unInputFieldsDefinition parentFields)+      Object <$> traverse validateField fields      where-      requiredFieldsDefined (fName, datafield)-        | fName `elem` map fst fields || isFieldNullable datafield = pure ()-        | otherwise = failure (UndefinedField props fName)+      requiredFieldsDefined :: FieldDefinition -> InputValidator (ObjectEntry RESOLVED)+      requiredFieldsDefined fieldDef@FieldDefinition { fieldName}+        = selectWithDefaultValue (ObjectEntry fieldName Null) fieldDef fields        validateField-        :: (Name, ResolvedValue) -> InputValidation (Name, ValidValue)-      validateField (_name, value) = do-        (type', currentProp') <- validationData value-        wrappers'             <- typeWrappers . fieldType <$> getField-        value''               <- validateInputValue lib-                                                    currentProp'-                                                    wrappers'-                                                    type'-                                                    (_name, value)-        return (_name, value'')+        :: 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-        validationData :: ResolvedValue -> InputValidation (DataType, [Prop])-        validationData x = do-          fieldTypeName' <- typeConName . fieldType <$> getField-          let currentProp = props ++ [Prop _name fieldTypeName']-          type' <- lookupInputType fieldTypeName'-                                   lib-                                   (typeMismatch x fieldTypeName' currentProp)-          return (type', currentProp)-        getField = lookupField _name parentFields (UnknownField props _name)+        getField = selectKnown entry parentFields     -- VALIDATE INPUT UNION-    validate (DataInputUnion inputUnion) (_, Object rawFields) =-      case unpackInputUnion inputUnion rawFields of-        Left message -> failure-          $ UnexpectedType props typeName (Object rawFields) (Just message)-        Right (name, Nothing   ) -> return (Object [("__typename", Enum name)])+    -- 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-          currentUnionDatatype <- lookupInputType-            name-            lib-            (typeMismatch value name props)-          validValue <- validateInputValue lib-                                           props-                                           [TypeMaybe]-                                           currentUnionDatatype-                                           (name, value)-          return (Object [("__typename", Enum name), (name, validValue)])-+          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) (_, value) =-      validateEnum (UnexpectedType props typeName value Nothing) tags value+    validate (DataEnum tags) ObjectEntry { entryValue } =+      validateEnum (castFailure (TypeRef typeName Nothing []) Nothing) tags entryValue     {-- VALIDATE SCALAR --}-    validate (DataScalar dataScalar) (_, value) =-      validateScalar dataScalar value (UnexpectedType props typeName)-    validate _ (_, value) = throwError [] value+    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 _ (_, value) = throwError wrappers value-+  validateWrapped wrappers _ ObjectEntry { entryValue }  = mismatchError wrappers entryValue  validateScalar-  :: DataScalar+  :: ScalarDefinition   -> ResolvedValue-  -> (ResolvedValue -> Maybe Message -> InputError)-  -> InputValidation ValidValue-validateScalar DataValidator { validateValue } value err = do+  -> (Maybe Message -> ResolvedValue -> InputValidator ValidValue)+  -> InputValidator ValidValue+validateScalar ScalarDefinition { validateValue } value err = do   scalarValue <- toScalar value   case validateValue scalarValue of     Right _            -> return scalarValue-    Left  ""           -> failure (err value Nothing)-    Left  errorMessage -> failure $ err value (Just errorMessage)+    Left  ""           -> err Nothing value+    Left  message -> err (Just message) value  where-  toScalar :: ResolvedValue -> InputValidation ValidValue+  toScalar :: ResolvedValue -> InputValidator ValidValue   toScalar (Scalar x) = pure (Scalar x)-  toScalar scValue    = Left (err scValue Nothing)+  toScalar scValue    = err Nothing scValue  -validateEnum-  :: error -> [DataEnumValue] -> ResolvedValue -> Either error ValidValue-validateEnum gqlError enumValues (Enum enumValue)+validateEnum +  :: (ResolvedValue -> InputValidator ValidValue) +  -> [DataEnumValue] +  -> ResolvedValue +  -> InputValidator ValidValue+validateEnum err enumValues value@(Enum enumValue)   | enumValue `elem` tags = pure (Enum enumValue)-  | otherwise             = Left gqlError+  | otherwise             = err value    where tags = map enumName enumValues-validateEnum gqlError _ _ = Left gqlError--typeMismatch :: ResolvedValue -> Key -> [Prop] -> InputError-typeMismatch jsType expected' path' =-  UnexpectedType path' expected' jsType Nothing+validateEnum err _ value = err value

src/Data/Morpheus/Validation/Query/Arguments.hs view

@@ -1,161 +1,123 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE GADTs            #-}+{-# LANGUAGE NamedFieldPuns   #-}+{-# LANGUAGE RecordWildCards  #-}  module Data.Morpheus.Validation.Query.Arguments   ( validateArguments   ) where -import           Data.Maybe                     ( maybe )-import           Data.Morpheus.Error.Arguments  ( argumentGotInvalidValue-                                                , argumentNameCollision-                                                , undefinedArgument-                                                , unknownArguments-                                                )-import           Data.Morpheus.Error.Input      ( InputValidation-                                                , inputErrorMessage-                                                )-import           Data.Morpheus.Error.Internal   ( internalUnknownTypeMessage )-import           Data.Morpheus.Error.Variable   ( undefinedVariable )+import           Data.Foldable                  (traverse_) import           Data.Morpheus.Types.Internal.AST-                                                ( ValidVariables-                                                , Variable(..)-                                                , Argument(..)-                                                , RawArgument-                                                , RawArguments-                                                , ValidArgument-                                                , ValidArguments+                                                ( Argument(..)+                                                , ArgumentsDefinition(..)                                                 , Arguments-                                                , Ref(..)-                                                , Position-                                                , DataArgument-                                                , DataField(..)-                                                , Schema+                                                , ArgumentDefinition+                                                , FieldDefinition(..)                                                 , TypeRef(..)-                                                , isFieldNullable-                                                , lookupInputType                                                 , Value(..)-                                                , Name                                                 , RawValue                                                 , ResolvedValue                                                 , RESOLVED                                                 , VALID-                                                , checkForUnknownKeys-                                                , checkNameCollision+                                                , ObjectEntry(..)+                                                , RAW                                                 )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation-                                                , Failure(..)+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-                                                ( validateInputValue )-import           Data.Text                      ( Text )+                                                ( validateInput )  -- only Resolves , doesnot checks the types-resolveObject :: Name -> ValidVariables -> RawValue -> Validation ResolvedValue-resolveObject operationName variables = resolve+resolveObject :: RawValue -> SelectionValidator ResolvedValue+resolveObject = resolve  where-  resolve :: RawValue -> Validation ResolvedValue+  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 mapSecond obj-    where mapSecond (fName, y) = (fName, ) <$> resolve y+  resolve (Object obj) = Object <$> traverse resolveEntry obj   resolve (VariableValue ref) =-    ResolvedVariable ref <$> variableByRef operationName variables ref-    --  >>= checkTypeEquality ref fieldType-  -- RAW | RESOLVED | Valid --variableByRef :: Name -> ValidVariables -> Ref -> Validation (Variable VALID)-variableByRef operationName variables Ref { refName, refPosition } = maybe-  variableError-  pure-  (lookup refName variables)- where-  variableError = failure $ undefinedVariable operationName refPosition refName--+     variables <$> askContext+    >>= fmap (ResolvedVariable ref) +        . selectRequired ref   resolveArgumentVariables-  :: Name-  -> ValidVariables-  -> DataField-  -> RawArguments-  -> Validation (Arguments RESOLVED)-resolveArgumentVariables operationName variables DataField { fieldName, fieldArgs }-  = mapM resolveVariable+  :: Arguments RAW+  -> SelectionValidator (Arguments RESOLVED)+resolveArgumentVariables+  = traverse resolveVariable  where-  resolveVariable :: (Text, RawArgument) -> Validation (Text, Argument RESOLVED)-  resolveVariable (key, Argument val position) = case lookup key fieldArgs of-    Nothing -> failure $ unknownArguments fieldName [Ref key position]-    Just _  -> do-      constValue <- resolveObject operationName variables val-      pure (key, Argument constValue position)+  resolveVariable :: Argument RAW -> SelectionValidator (Argument RESOLVED)+  resolveVariable (Argument key val position) = do +    constValue <- resolveObject val+    pure $ Argument key constValue position  validateArgument-  :: Schema-  -> Position-  -> Arguments RESOLVED-  -> (Text, DataArgument)-  -> Validation (Text, ValidArgument)-validateArgument lib fieldPosition requestArgs (key, argType@DataField { fieldType = TypeRef { typeConName, typeWrappers } })-  = case lookup key requestArgs of-    Nothing -> handleNullable-    -- TODO: move it in value validation-   -- Just argument@Argument { argumentOrigin = VARIABLE } ->-   --   pure (key, argument) -- Variables are already checked in Variable Validation-    Just Argument { argumentValue = Null } -> handleNullable-    Just argument -> validateArgumentValue argument+  :: 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-  handleNullable-    | isFieldNullable argType-    = pure-      (key, Argument { argumentValue = Null, argumentPosition = fieldPosition })-    | otherwise-    = failure $ undefinedArgument (Ref key fieldPosition)   --------------------------------------------------------------------------  validateArgumentValue :: Argument RESOLVED -> Validation (Text, ValidArgument)-  validateArgumentValue Argument { argumentValue = value, argumentPosition } =-    do-      datatype <- lookupInputType typeConName-                                  lib-                                  (internalUnknownTypeMessage typeConName)-      argumentValue <- handleInputError-        $ validateInputValue lib [] typeWrappers datatype (key, value)-      pure (key, Argument { argumentValue, argumentPosition })-   where-    ----------    handleInputError :: InputValidation a -> Validation a-    handleInputError (Left err) = failure $ case inputErrorMessage err of-      Left  errors  -> errors-      Right message -> argumentGotInvalidValue key message argumentPosition-    handleInputError (Right x) = pure x+  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-  :: Schema-  -> Text-  -> ValidVariables-  -> (Text, DataField)-  -> Position-  -> RawArguments-  -> Validation ValidArguments-validateArguments typeLib operatorName variables (key, field@DataField { fieldArgs }) pos rawArgs+  :: FieldDefinition+  -> Arguments RAW+  -> SelectionValidator (Arguments VALID)+validateArguments+    fieldDef@FieldDefinition {  fieldArgs }+    rawArgs   = do-    args     <- resolveArgumentVariables operatorName variables field rawArgs-    dataArgs <- checkForUnknownArguments args-    mapM (validateArgument typeLib pos args) dataArgs+    args <- resolveArgumentVariables rawArgs+    traverse_ checkUnknown (toList args)+    traverse (validateArgument args) argsDef  where-  checkForUnknownArguments-    :: Arguments RESOLVED -> Validation [(Text, DataField)]-  checkForUnknownArguments args =-    checkForUnknownKeys enhancedKeys fieldKeys argError-      >> checkNameCollision enhancedKeys argumentNameCollision-      >> pure fieldArgs-   where-    argError     = unknownArguments key-    enhancedKeys = map argToKey args-    argToKey :: (Name, Argument RESOLVED) -> Ref-    argToKey (key', Argument { argumentPosition }) = Ref key' argumentPosition-    fieldKeys = map fst fieldArgs+  argsDef = case fieldArgs of +    (ArgumentsDefinition _ argsD) -> argsD+    NoArguments -> empty+  -------------------------------------------------+  checkUnknown :: Argument RESOLVED -> SelectionValidator ArgumentDefinition+  checkUnknown = (`selectKnown` fieldDef)

src/Data/Morpheus/Validation/Query/Fragment.hs view

@@ -1,125 +1,137 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE GADTs              #-}+{-# LANGUAGE FlexibleContexts   #-}+{-# LANGUAGE NamedFieldPuns     #-}+{-# LANGUAGE FlexibleInstances  #-}  module Data.Morpheus.Validation.Query.Fragment   ( validateFragments   , castFragmentType   , resolveSpread-  , getFragment   ) where -import           Data.List                      ( (\\) ) import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( Text )+import           Data.Foldable                  (traverse_)   -- MORPHEUS import           Data.Morpheus.Error.Fragment   ( cannotBeSpreadOnType                                                 , cannotSpreadWithinItself-                                                , fragmentNameCollision-                                                , unknownFragment-                                                , unusedFragment                                                 )-import           Data.Morpheus.Error.Variable   ( unknownType ) import           Data.Morpheus.Types.Internal.AST-                                                ( Fragment(..)-                                                , FragmentLib-                                                , RawSelection+                                                ( Name+                                                , Fragment(..)+                                                , Fragments                                                 , SelectionContent(..)                                                 , Selection(..)                                                 , Ref(..)                                                 , Position-                                                , Schema-                                                , DataLookup(..)-                                                , checkNameCollision-                                                , DataObject-                                                , Name+                                                , SelectionSet+                                                , RAW                                                 )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+import           Data.Morpheus.Types.Internal.Operation+                                                ( selectOr+                                                , toList                                                 , Failure(..)                                                 )---validateFragments-  :: Schema -> FragmentLib -> [(Text, RawSelection)] -> Validation ()-validateFragments lib fragments operatorSel =-  validateNameCollision >> checkLoop >> checkUnusedFragments- where-  validateNameCollision =-    checkNameCollision fragmentsKeys fragmentNameCollision-  checkUnusedFragments =-    case fragmentsKeys \\ usedFragments fragments operatorSel of-      []     -> return ()-      unused -> failure (unusedFragment unused)-  checkLoop = mapM (validateFragment lib) fragments >>= detectLoopOnFragments-  fragmentsKeys = map toRef fragments-    where toRef (key, Fragment { fragmentPosition }) = Ref key fragmentPosition--type Node = Ref--type NodeEdges = (Node, [Node])+import           Data.Morpheus.Types.Internal.Validation+                                                ( BaseValidator+                                                , askSchema+                                                , askFragments+                                                , selectKnown+                                                , constraint+                                                , Constraint(..)+                                                , Validator+                                                , checkUnused+                                                ) -type Graph = [NodeEdges]+validateFragments :: SelectionSet RAW -> BaseValidator ()+validateFragments selectionSet +  = fragmentsCycleChecking +    *> checkUnusedFragments selectionSet+    *> fragmentsConditionTypeChecking -getFragment :: Ref -> FragmentLib -> Validation Fragment-getFragment Ref { refName, refPosition } lib = case lookup refName lib of-  Nothing       -> failure $ unknownFragment refName refPosition-  Just fragment -> pure fragment+checkUnusedFragments :: SelectionSet RAW -> BaseValidator ()+checkUnusedFragments selectionSet = do+    fragments <- askFragments+    checkUnused +      (usedFragments fragments (toList selectionSet)) +      (toList fragments)  castFragmentType-  :: Maybe Text -> Position -> [Text] -> Fragment -> Validation Fragment-castFragmentType key' position' typeMembers fragment@Fragment { fragmentType }-  = if fragmentType `elem` typeMembers-    then pure fragment-    else failure $ cannotBeSpreadOnType key' fragmentType position' typeMembers+  :: 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 :: FragmentLib -> [Text] -> Ref -> Validation Fragment-resolveSpread fragments allowedTargets reference@Ref { refName, refPosition } =-  getFragment reference fragments+resolveSpread :: [Name] -> Ref -> Validator ctx Fragment+resolveSpread allowedTargets ref@Ref { refName, refPosition } +  = askFragments+    >>= selectKnown ref     >>= castFragmentType (Just refName) refPosition allowedTargets -usedFragments :: FragmentLib -> [(Text, RawSelection)] -> [Node]-usedFragments fragments = concatMap (findAllUses . snd)+usedFragments :: Fragments -> [Selection RAW] -> [Node]+usedFragments fragments = concatMap findAllUses  where-  findAllUses :: RawSelection -> [Node]+  findAllUses :: Selection RAW -> [Node]   findAllUses Selection { selectionContent = SelectionField } = []   findAllUses Selection { selectionContent = SelectionSet selectionSet } =-    concatMap (findAllUses . snd) selectionSet+    concatMap findAllUses selectionSet   findAllUses (InlineFragment Fragment { fragmentSelection }) =-    concatMap (findAllUses . snd) fragmentSelection+    concatMap findAllUses fragmentSelection   findAllUses (Spread Ref { refName, refPosition }) =     [Ref refName refPosition] <> searchInFragment    where-    searchInFragment = maybe-      []-      (concatMap (findAllUses . snd) . fragmentSelection)-      (lookup refName fragments)+    searchInFragment = selectOr +      [] +      (concatMap findAllUses . fragmentSelection) +      refName +      fragments -scanForSpread :: (Text, RawSelection) -> [Node]-scanForSpread (_, Selection { selectionContent = SelectionField }) = []-scanForSpread (_, Selection { selectionContent = SelectionSet selectionSet }) =+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 = selection' }) =-  concatMap scanForSpread selection'-scanForSpread (_, Spread Ref { refName = name', refPosition = position' }) =-  [Ref name' position']+scanForSpread (InlineFragment Fragment { fragmentSelection }) =+  concatMap scanForSpread fragmentSelection+scanForSpread (Spread Ref { refName, refPosition }) =+  [Ref refName refPosition] -validateFragment :: Schema -> (Text, Fragment) -> Validation NodeEdges-validateFragment lib (fName, Fragment { fragmentSelection, fragmentType, fragmentPosition })-  = (lookupResult validationError fragmentType lib :: Validation ( Name, DataObject) )>> pure-    (Ref fName fragmentPosition, concatMap scanForSpread fragmentSelection)-  where validationError = unknownType fragmentType fragmentPosition+type Node = Ref -detectLoopOnFragments :: Graph -> Validation ()-detectLoopOnFragments lib = mapM_ checkFragment lib+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] -> Validation Graph+checkForCycle :: Graph -> Node -> [Node] -> BaseValidator Graph checkForCycle lib parentNode history = case lookup parentNode lib of-  Just node -> concat <$> mapM checkNode node+  Just node -> concat <$> traverse checkNode node   Nothing   -> pure []  where   checkNode x = if x `elem` history then cycleError x else recurse x

src/Data/Morpheus/Validation/Query/Selection.hs view

@@ -5,52 +5,58 @@ {-# LANGUAGE OverloadedStrings   #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE MultiParamTypeClasses #-}  module Data.Morpheus.Validation.Query.Selection-  ( validateSelectionSet+  ( validateOperation   ) where  -import           Data.Maybe                     ( fromMaybe )-import           Data.Text                      ( Text )+import           Data.Semigroup                 ( (<>) )  -- MORPHEUS-import           Data.Morpheus.Error.Selection  ( cannotQueryField-                                                , duplicateQuerySelections-                                                , hasNoSubfields+import           Data.Morpheus.Error.Selection  ( hasNoSubfields                                                 , subfieldsNotSelected                                                 )-import           Data.Morpheus.Error.Variable   ( unknownType ) import           Data.Morpheus.Types.Internal.AST-                                                ( ValidVariables-                                                , Selection(..)+                                                ( Selection(..)                                                 , SelectionContent(..)-                                                , ValidSelection-                                                , ValidSelectionSet                                                 , Fragment(..)-                                                , FragmentLib-                                                , RawSelection-                                                , RawSelectionSet-                                                , DataField(..)+                                                , SelectionSet+                                                , FieldDefinition(..)+                                                , FieldsDefinition(..)+                                                , TypeContent(..)+                                                , TypeDefinition(..)+                                                , Operation(..)                                                 , Ref(..)-                                                , DataObject-                                                , DataTypeContent(..)-                                                , DataType(..)-                                                , Schema(..)-                                                , TypeRef(..)                                                 , Name+                                                , RAW+                                                , VALID+                                                , Arguments                                                 , isEntNode-                                                , lookupFieldAsSelectionSet-                                                , lookupSelectionField-                                                , DataLookup(..)-                                                , lookupUnionTypes-                                                , checkNameCollision+                                                , getOperationDataType+                                                , GQLError(..)+                                                , OperationType(..)                                                 )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+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@@ -58,177 +64,142 @@                                                 , resolveSpread                                                 ) -checkDuplicatesOn :: Name -> ValidSelectionSet -> Validation ValidSelectionSet-checkDuplicatesOn typeName keys = checkNameCollision enhancedKeys selError-  >> pure keys- where-  selError     = duplicateQuerySelections typeName-  enhancedKeys = map selToKey keys-  selToKey :: (Name, ValidSelection) -> Ref-  selToKey (key, Selection { selectionPosition = position', selectionAlias }) =-    Ref (fromMaybe key selectionAlias) position'+type TypeDef = (Name, FieldsDefinition) -clusterUnionSelection-  :: FragmentLib-  -> Text-  -> [Name]-  -> (Text, RawSelection)-  -> Validation ([Fragment], ValidSelectionSet)-clusterUnionSelection fragments type' typeNames = splitFrag- where-  packFragment fragment = return ([fragment], [])-  splitFrag-    :: (Text, RawSelection) -> Validation ([Fragment], ValidSelectionSet)-  splitFrag (_, Spread ref) =-    resolveSpread fragments typeNames ref >>= packFragment-  splitFrag ("__typename", selection@Selection { selectionContent = SelectionField })-    = pure-      ( []-      , [ ( "__typename"-          , selection { selectionArguments = [], selectionContent = SelectionField }-          )-        ]-      )-  splitFrag (key, Selection { selectionPosition }) =-    failure $ cannotQueryField key type' selectionPosition---  splitFrag (key', RawAlias {rawAliasPosition = position'}) = failure $ cannotQueryField key' type' position'-  splitFrag (_, InlineFragment fragment') =-    castFragmentType Nothing (fragmentPosition fragment') typeNames fragment'-      >>= packFragment -categorizeTypes-  :: [(Name, DataObject)] -> [Fragment] -> [((Name, DataObject), [Fragment])]-categorizeTypes types fragments = filter notEmpty $ map categorizeType types- where-  notEmpty = (0 /=) . length . snd-  categorizeType :: (Name, DataObject) -> ((Name, DataObject), [Fragment])-  categorizeType datatype = (datatype, filter matches fragments)-    where matches fragment = fragmentType fragment == fst datatype+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" -flatTuple :: [([a], [b])] -> ([a], [b])-flatTuple list' = (concatMap fst list', concatMap snd list')- {--    - 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 : [-          ("T1",[<SelectionA>]),-          ("T2",[<SelectionB>,<SelectionC>])-      ]- -} +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-  :: Schema-  -> FragmentLib-  -> Text-  -> ValidVariables-  -> (Name, DataObject)-  -> RawSelectionSet-  -> Validation ValidSelectionSet-validateSelectionSet lib fragments' operatorName variables = __validate- where-  __validate-    :: (Name, DataObject) -> RawSelectionSet -> Validation ValidSelectionSet-  __validate dataType@(typeName, objectFields) selectionSet =-    concat-    <$> mapM validateSelection selectionSet-    >>= checkDuplicatesOn typeName+    :: TypeDef -> SelectionSet RAW -> SelectionValidator (SelectionSet VALID)+validateSelectionSet dataType@(typeName,fieldsDef) =+      concatTraverse validateSelection     where-    -- getValidationData :: Name -> ValidSelection -> (DataField, DataTypeContent, ValidArguments)-    getValidationData key (selectionArguments, selectionPosition) = do-      selectionField <- lookupSelectionField selectionPosition-                                             key-                                             typeName-                                             objectFields-      -- validate field Argument ------      arguments <- validateArguments lib-                                     operatorName-                                     variables-                                     (key, selectionField)-                                     selectionPosition-                                     selectionArguments-      -- check field Type existence  ------      fieldDataType <- lookupResult-        (unknownType (typeConName $fieldType selectionField) selectionPosition) -        (typeConName $ fieldType selectionField)-        lib-      return (selectionField, fieldDataType, arguments)     -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet-    ---    validateSelection :: (Text, RawSelection) -> Validation ValidSelectionSet-    validateSelection ("__typename", sel@Selection { selectionArguments = [], selectionContent = SelectionField}) = -      pure [("__typename", sel { selectionArguments = [], selectionContent = SelectionField })]-    validateSelection (key', fullRawSelection@Selection { selectionArguments = selArgs, selectionContent = SelectionSet rawSelection, selectionPosition })-      = do-        (dataField, datatype, arguments) <- getValidationData-          key'-          (selArgs, selectionPosition)-        case typeContent datatype of-          DataUnion _ -> do-            (categories, __typename) <- clusterTypes-            mapM (validateCluster __typename) categories-              >>= returnSelection arguments-              .   UnionSelection+    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-            clusterTypes = do-              unionTypes <- lookupUnionTypes selectionPosition-                                             key'-                                             lib-                                             dataField-              (spreads, __typename) <--                flatTuple-                  <$> mapM-                        (   clusterUnionSelection fragments' typeName-                        $   fst-                        <$> unionTypes-                        )-                        rawSelection-              return (categorizeTypes unionTypes spreads, __typename)-            ---            --    second arguments will be added to every selection cluster-            validateCluster-              :: ValidSelectionSet-              -> ((Name, DataObject), [Fragment])-              -> Validation (Text, ValidSelectionSet)-            validateCluster sysSelection' (type', frags') = do-              selection' <- __validate type'-                                       (concatMap fragmentSelection frags')-              return (fst type', sysSelection' ++ selection')-          DataObject {} -> do-            fieldType' <- lookupFieldAsSelectionSet selectionPosition-                                                    key'-                                                    lib-                                                    dataField-            __validate fieldType' rawSelection-              >>= returnSelection arguments-              .   SelectionSet-          _ -> failure $ hasNoSubfields key'-                                        (typeConName $fieldType dataField)-                                        selectionPosition-     where-      returnSelection selectionArguments selectionContent =-        pure [(key', fullRawSelection { selectionArguments, selectionContent })]-    validateSelection (key, rawSelection@Selection { selectionArguments = selArgs, selectionPosition, selectionContent = SelectionField })-      = do-        (dataField, datatype, selectionArguments) <- getValidationData-          key-          (selArgs, selectionPosition)-        isLeaf (typeContent datatype) dataField-        pure-          [ ( key-            , rawSelection { selectionArguments, selectionContent = SelectionField }-            )-          ]-     where-      isLeaf datatype DataField { fieldType = TypeRef { typeConName } }-        | isEntNode datatype = pure ()-        | otherwise = failure-        $ subfieldsNotSelected key typeConName selectionPosition-    validateSelection (_, Spread reference') =-      resolveSpread fragments' [typeName] reference' >>= validateFragment-    validateSelection (_, InlineFragment fragment') =-      castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment'+            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-    validateFragment Fragment { fragmentSelection } = __validate dataType fragmentSelection+    validateSelection (InlineFragment fragment') +      = castFragmentType Nothing (fragmentPosition fragment') [typeName] fragment'+        >>= validateFragment+    --------------------------------------------------------------------------------+    validateFragment Fragment { fragmentSelection } = validateSelectionSet dataType fragmentSelection

+ src/Data/Morpheus/Validation/Query/UnionSelection.hs view

@@ -0,0 +1,127 @@+{-# 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 view

@@ -1,7 +1,9 @@-{-# LANGUAGE FlexibleInstances   #-}-{-# LANGUAGE NamedFieldPuns      #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE FlexibleInstances      #-}+{-# LANGUAGE NamedFieldPuns         #-}+{-# LANGUAGE ScopedTypeVariables    #-}+{-# LANGUAGE TypeOperators          #-}+{-# LANGUAGE DuplicateRecordFields  #-}+{-# LANGUAGE OverloadedStrings      #-}  module Data.Morpheus.Validation.Query.Validation   ( validateRequest@@ -11,43 +13,62 @@ import           Data.Map                       ( fromList ) import           Data.Morpheus.Types.Internal.AST                                                 ( Operation(..)-                                                , ValidOperation-                                                , getOperationName-                                                , getOperationObject+                                                , VALID                                                 , Schema(..)                                                 , GQLQuery(..)                                                 , VALIDATION_MODE                                                 )+import           Data.Morpheus.Types.Internal.Validation+                                                ( Context(..)+                                                , runValidator+                                                , SelectionContext(..)+                                                ) import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation )+                                                ( Eventless ) import           Data.Morpheus.Validation.Query.Fragment                                                 ( validateFragments ) import           Data.Morpheus.Validation.Query.Selection-                                                ( validateSelectionSet )+                                                ( validateOperation ) import           Data.Morpheus.Validation.Query.Variable                                                 ( resolveOperationVariables )   validateRequest-  :: Schema -> VALIDATION_MODE -> GQLQuery -> Validation ValidOperation-validateRequest lib validationMode GQLQuery { fragments, inputVariables, operation = rawOperation@Operation { operationName, operationType, operationSelection, operationPosition } }+  :: Schema +  -> VALIDATION_MODE +  -> GQLQuery +  -> Eventless (Operation VALID)+validateRequest +  schema +  validationMode +  GQLQuery +    { fragments+    , inputVariables, +    operation = operation@Operation +      { operationName+      , operationSelection+      , operationPosition +      } +    }   = do-    operationDataType <-  getOperationObject rawOperation lib-    variables         <- resolveOperationVariables lib-                                                   fragments-                                                   (fromList inputVariables)-                                                   validationMode-                                                   rawOperation-    validateFragments lib fragments operationSelection-    selection <- validateSelectionSet lib-                                      fragments-                                      (getOperationName operationName)-                                      variables-                                      operationDataType-                                      operationSelection-    pure $ Operation { operationName-                     , operationType-                     , operationArguments      = []-                     , operationSelection = selection-                     , operationPosition-                     }+      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 view

@@ -8,172 +8,162 @@   ) where -import           Data.List                      ( (\\) )+ import qualified Data.Map                      as M                                                 ( lookup ) import           Data.Maybe                     ( maybe ) import           Data.Semigroup                 ( (<>) )-import           Data.Text                      ( Text )  --- MORPHEUS-import           Data.Morpheus.Error.Input      ( inputErrorMessage )-import           Data.Morpheus.Error.Variable   ( uninitializedVariable-                                                , unknownType-                                                , unusedVariables-                                                , variableGotInvalidValue-                                                )+import           Data.Morpheus.Error.Variable   ( uninitializedVariable) import           Data.Morpheus.Types.Internal.AST                                                 ( DefaultValue                                                 , Operation(..)-                                                , RawOperation-                                                , ValidVariables                                                 , Variable(..)-                                                , getOperationName+                                                , VariableDefinitions                                                 , Fragment(..)-                                                , FragmentLib                                                 , Argument(..)-                                                , RawArgument                                                 , Selection(..)                                                 , SelectionContent(..)-                                                , RawSelection-                                                , RawSelectionSet+                                                , SelectionSet                                                 , Ref(..)-                                                , Position-                                                , DataType-                                                , Schema-                                                , lookupInputType+                                                , TypeDefinition                                                 , Variables                                                 , Value(..)                                                 , ValidValue                                                 , RawValue                                                 , ResolvedValue-                                                , Name                                                 , VALID                                                 , RAW                                                 , VariableContent(..)                                                 , isNullable                                                 , TypeRef(..)                                                 , VALIDATION_MODE(..)+                                                , ObjectEntry(..)                                                 )-import           Data.Morpheus.Types.Internal.Resolving-                                                ( Validation+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-                                                ( validateInputValue )-import           Data.Morpheus.Validation.Query.Fragment-                                                ( getFragment )--getVariableType :: Text -> Position -> Schema -> Validation DataType-getVariableType type' position' lib' = lookupInputType type' lib' error'-  where error' = unknownType type' position'--concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]-concatMapM f = fmap concat . mapM f-+                                                ( validateInput )  class ExploreRefs a where   exploreRefs :: a -> [Ref]  instance ExploreRefs RawValue where   exploreRefs (VariableValue ref   ) = [ref]-  exploreRefs (Object        fields) = concatMap (exploreRefs . snd) fields+  exploreRefs (Object        fields) = concatMap (exploreRefs . entryValue) fields   exploreRefs (List          ls    ) = concatMap exploreRefs ls   exploreRefs _                      = [] -instance ExploreRefs (Text, RawArgument) where-  exploreRefs (_, Argument { argumentValue }) = exploreRefs argumentValue+instance ExploreRefs (Argument RAW) where+  exploreRefs = exploreRefs . argumentValue -allVariableRefs :: FragmentLib -> [RawSelectionSet] -> Validation [Ref]-allVariableRefs fragmentLib = concatMapM (concatMapM searchRefs)- where+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 :: (Text, RawSelection) -> Validation [Ref]-  searchRefs (_, Selection { selectionArguments, selectionContent = SelectionField })+  searchRefs :: Selection RAW -> BaseValidator [Ref]+  searchRefs Selection { selectionArguments, selectionContent = SelectionField }     = return $ concatMap exploreRefs selectionArguments-  searchRefs (_, Selection { selectionArguments, selectionContent = SelectionSet selSet })-    = getArgs <$> concatMapM searchRefs selSet+  searchRefs Selection { selectionArguments, selectionContent = SelectionSet selSet }+    = getArgs <$> mapSelection searchRefs selSet    where     getArgs :: [Ref] -> [Ref]     getArgs x = concatMap exploreRefs selectionArguments <> x-  searchRefs (_, InlineFragment Fragment { fragmentSelection }) =-    concatMapM searchRefs fragmentSelection-  searchRefs (_, Spread reference) =-    getFragment reference fragmentLib-      >>= concatMapM searchRefs+  searchRefs (InlineFragment Fragment { fragmentSelection })+    = mapSelection searchRefs fragmentSelection+  searchRefs (Spread reference)+    = askFragments+      >>= selectKnown reference+      >>= mapSelection searchRefs       .   fragmentSelection  resolveOperationVariables-  :: Schema-  -> FragmentLib-  -> Variables+  :: Variables   -> VALIDATION_MODE-  -> RawOperation-  -> Validation ValidVariables-resolveOperationVariables typeLib lib root validationMode Operation { operationName, operationSelection, operationArguments }-  = do-    allVariableRefs lib [operationSelection] >>= checkUnusedVariables-    mapM (lookupAndValidateValueOnBody typeLib root validationMode)-         operationArguments+  -> Operation RAW+  -> BaseValidator (VariableDefinitions VALID)+resolveOperationVariables +    root +    validationMode +    Operation +      { operationSelection+      , operationArguments +      }+  = checkUnusedVariables *>+    traverse (lookupAndValidateValueOnBody root validationMode) operationArguments  where-  varToKey :: (Text, Variable a) -> Ref-  varToKey (key', Variable { variablePosition }) = Ref key' variablePosition-  ---  checkUnusedVariables :: [Ref] -> Validation ()-  checkUnusedVariables refs = case map varToKey operationArguments \\ refs of-    [] -> pure ()-    unused' ->-      failure $ unusedVariables (getOperationName operationName) unused'+  checkUnusedVariables :: BaseValidator ()+  checkUnusedVariables = do+    uses <- allVariableRefs [operationSelection]+    checkUnused uses (toList operationArguments)  lookupAndValidateValueOnBody-  :: Schema-  -> Variables+  :: Variables   -> VALIDATION_MODE-  -> (Text, Variable RAW)-  -> Validation (Text, Variable VALID)-lookupAndValidateValueOnBody typeLib bodyVariables validationMode (key, var@Variable { variableType, variablePosition, variableValue = DefaultValue defaultValue })-  = toVariable-    <$> (   getVariableType (typeConName variableType) variablePosition typeLib-        >>= checkType getVariable defaultValue+  -> 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 (varKey, x) =-    (varKey, var { variableValue = ValidVariableValue x })+  toVariable x = var { variableValue = ValidVariableValue x }   getVariable :: Maybe ResolvedValue-  getVariable = M.lookup key bodyVariables+  getVariable = M.lookup variableName bodyVariables   ------------------------------------------------------------------   -- checkType ::    checkType     :: Maybe ResolvedValue     -> DefaultValue-    -> DataType-    -> Validation (Name, ValidValue)+    -> 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 variablePosition (typeConName variableType) key+    = failure $ uninitializedVariable var     | otherwise     = returnNull    where     returnNull =-      maybe (pure (key, Null)) (validator varType) (M.lookup key bodyVariables)+      maybe (pure Null) (validator varType) (M.lookup variableName bodyVariables)   ------------------------------------------------------------------------------------------------  validator :: DataType -> ResolvedValue -> Validation (Name, ValidValue)-  validator varType varValue =-    case-        validateInputValue typeLib-                           []-                           (typeWrappers variableType)-                           varType-                           (key, varValue)-      of-        Left message -> failure $ case inputErrorMessage message of-          Left errors -> errors-          Right errMessage ->-            variableGotInvalidValue key errMessage variablePosition-        Right value -> pure (key, value)+  validator :: TypeDefinition -> ResolvedValue -> BaseValidator ValidValue+  validator varType varValue +    = startInput (SourceVariable var) +        $ validateInput+          (typeWrappers variableType)+          varType+          (ObjectEntry variableName varValue)

test/Feature/Holistic/API.hs view

@@ -54,8 +54,6 @@  importGQLDocument "test/Feature/Holistic/schema.gql" -- alwaysFail :: IO (Either String a) alwaysFail = pure $ Left "fail with Either" @@ -63,12 +61,15 @@ rootResolver :: GQLRootResolver IO EVENT Query Mutation Subscription rootResolver = GQLRootResolver   { queryResolver        = Query { user-                                 , testUnion = pure Nothing+                                 , 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)}+  , subscriptionResolver = Subscription +    { newUser = subscribe [Channel] (pure $ const user)+    , newAddress = subscribe [Channel] (pure resolveAddress)+    }   }  where   user :: Applicative m => m (User m)@@ -78,9 +79,9 @@                      , office  = resolveAddress                      , friend  = pure Nothing                      }-   where-    resolveAddress :: Applicative m => a -> m (Address m)-    resolveAddress _ = pure Address { city        = pure ""+  ----------------------------------------------------- +  resolveAddress :: Applicative m => a -> m (Address m)+  resolveAddress _ = pure Address { city        = pure ""                                     , houseNumber = pure 0                                     , street      = const $ pure Nothing                                     }

test/Feature/Holistic/arguments/nameConflict/response.json view

@@ -5,7 +5,7 @@       "locations": [         {           "line": 3,-          "column": 35+          "column": 26         }       ]     }

test/Feature/Holistic/arguments/undefinedArgument/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Required Argument: \"coordinates\" was not Defined",+      "message": "Field \"address\" argument \"coordinates\" is required but not provided.",       "locations": [         {           "line": 3,

test/Feature/Holistic/arguments/unknownArguments/query.gql view

@@ -1,5 +1,5 @@ {-  user (name:bal , parent:sa ){+  user (name:bal , parent:sa ) {     name   } }

test/Feature/Holistic/arguments/unknownArguments/response.json view

@@ -5,7 +5,7 @@       "locations": [         {           "line": 2,-          "column": 14+          "column": 9         }       ]     },@@ -14,7 +14,7 @@       "locations": [         {           "line": 2,-          "column": 27+          "column": 20         }       ]     }

test/Feature/Holistic/cases.json view

@@ -28,14 +28,22 @@     "description": "fail when: is not selected subFields on object type"   },   {-    "path": "selection/nameConflict",-    "description": "fail when: selected fields has same name"+    "path": "selection/mergeConflict/arguments",+    "description": "fail when: selections with on same fields have different arguments"   },   {-    "path": "selection/AliasNameConflict",-    "description": "fail when: selected alias has same name"+    "path": "selection/mergeConflict/union",+    "description": "fail when: conflicting union"   },   {+    "path": "selection/mergeUnionSelection",+    "description": "merge union selections"+  },+  {+    "path": "selection/mergeConflict/alias",+    "description": "fail when: selections on different fields have same alias"+  },+  {     "path": "selection/AliasResolve",     "description": "resolves same field with different name"   },@@ -64,6 +72,14 @@     "description": "fail when: fragments are defined with same name"   },   {+    "path": "fragment/conditionTypeViolation",+    "description": "fail when: condtion type is not an Object"+  },+  {+    "path": "fragment/unknownConditionType",+    "description": "fail when: condtion type is not defined by schema"+  },+  {     "path": "parsing/duplicatedFields",     "description": "fail when: user supplies duplicated fields"   },@@ -92,6 +108,10 @@     "description": "fails on a query with too many commas"   },   {+    "path": "parsing/inputListValues",+    "description": "returns query when input list values are separated by newlines or commas"+  },+  {     "path": "parsing/notNullSpacing",     "description": "returns on a query that pads all '!' chars with whitespace"   },@@ -234,5 +254,17 @@   {     "path": "selection/__typename",     "description": "test __typename on object types"+  },+  {+    "path": "selection/mergeSelection",+    "description": "merge selection on same fields"+  },+  {+    "path": "selection/subscription/singleTopLevelField/fail",+    "description": "fail if subscription selects more then one top level field."+  },+  {+    "path": "selection/subscription/singleTopLevelField/failAnonymous",+    "description": "fail if subscription selects more then one top level field. (for anonymous subscription)"   } ]

+ test/Feature/Holistic/fragment/conditionTypeViolation/query.gql view

@@ -0,0 +1,8 @@+{+  user {+    ...MyFragment+  }+}+fragment MyFragment on Coordinates {+  latitude+}

+ test/Feature/Holistic/fragment/conditionTypeViolation/response.json view

@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "Fragment \"MyFragment\" cannot condition on non composite type \"Coordinates\".",+      "locations": [+        {+          "line": 6,+          "column": 10+        }+      ]+    }+  ]+}

test/Feature/Holistic/fragment/loopingFragment/response.json view

@@ -3,9 +3,92 @@     {       "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.",+      "locations": [+        {+          "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.",+      "locations": [+        {+          "line": 9,+          "column": 3+        },+        {+          "line": 16,+          "column": 10+        },+        {+          "line": 17,+          "column": 3+        }+      ]+    },+    {+      "message": "Fragment \"A\" is never used.",+      "locations": [+        {+          "line": 7,+          "column": 10+        }+      ]+    },+    {+      "message": "Fragment \"B\" is never used.",+      "locations": [+        {+          "line": 12,+          "column": 10+        }+      ]+    },+    {+      "message": "Fragment \"C\" is never used.",+      "locations": [+        {+          "line": 16,+          "column": 10+        }+      ]+    },+    {+      "message": "Fragment \"D\" is never used.",+      "locations": [+        {+          "line": 20,+          "column": 10+        }       ]     }   ]

+ test/Feature/Holistic/fragment/unknownConditionType/query.gql view

@@ -0,0 +1,8 @@+{+  user {+    ...MyFragment+  }+}+fragment MyFragment on BjsK {+  name+}

+ test/Feature/Holistic/fragment/unknownConditionType/response.json view

@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "Unknown type \"BjsK\".",+      "locations": [+        {+          "line": 6,+          "column": 10+        }+      ]+    }+  ]+}

test/Feature/Holistic/parsing/complex/response.json view

@@ -1,32 +1,67 @@ {   "errors": [     {-      "message": "Argument coordinates got invalid value ;on longitude Expected type \"Int\" found [null,[[],[{\"uid\":\"1\"}]]].",-      "locations": [{ "line": 8, "column": 36 }]+      "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [null,[[],[{\"uid\":\"1\"}]]].",+      "locations": [+        {+          "line": 8,+          "column": 23+        }+      ]     },     {-      "message": "Argument coordinates got invalid value ;on longitude Expected type \"Int\" found [].",-      "locations": [{ "line": 11, "column": 36 }]+      "message": "Argument \"coordinates\" got invalid value. in field \"longitude\": Expected type \"Int!\" found [].",+      "locations": [+        {+          "line": 11,+          "column": 23+        }+      ]     },     {-      "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".",-      "locations": [{ "line": 15, "column": 21 }]+      "message": "Argument \"cityID\" got invalid value. Expected type \"TestEnum!\" found \"HH\".",+      "locations": [+        {+          "line": 15,+          "column": 25+        }+      ]     },     {-      "message": "Argument cityID got invalid value ; Expected type \"TestEnum\" found \"HH\".",-      "locations": [{ "line": 15, "column": 33 }]+      "message": "Variable \"$v\" of type \"[[[ID!]]!]\" used in position expecting type \"[Int!]\".",+      "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": 18+        }+      ]     },     {       "message": "Cannot query field \"myUnion\" on type \"User\".",-      "locations": [{ "line": 32, "column": 18 }]+      "locations": [+        {+          "line": 32,+          "column": 18+        }+      ]     }   ] }

test/Feature/Holistic/parsing/directive/notOnArgument/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', IgnoredTokens, assignment, or white space\n",+      "message": "offset=51:\nunexpected '@'\nexpecting '#', ')', ',', Argument, IgnoredTokens, or white space\n",       "locations": [         {           "line": 2,

test/Feature/Holistic/parsing/duplicatedFields/response.json view

@@ -1,13 +1,7 @@ {-	"errors": [-    {-      "message": "duplicate selection of key \"email\" on type \"User\".",-      "locations": [-        {-          "line": 1,-          "column": 17-        }-      ]+  "data": {+    "user": {+      "email": ""     }-  ]+  } }

test/Feature/Holistic/parsing/extraCommas/query.gql view

@@ -1,24 +1,24 @@ {-    user {name,,,address}+    user {name,,,email} -    user {name, ,address}+    user {name, ,email} -    user {name , address , }+    user {name , email , }      user {         name,-        address+        email     }      user {-        name,address+        name,email     }      user {-        name, address+        name, email     }      user {-        name ,address+        name ,email     } }

test/Feature/Holistic/parsing/extraCommas/response.json view

@@ -1,32 +1,8 @@ {-  "errors": [-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 2, "column": 18 }]-    },-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 4, "column": 18 }]-    },-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 6, "column": 18 }]-    },-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 10, "column": 9 }]-    },-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 14, "column": 14 }]-    },-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 18, "column": 15 }]-    },-    {-      "message": "Required Argument: \"coordinates\" was not Defined",-      "locations": [{ "line": 22, "column": 15 }]+  "data": {+    "user": {+      "name": "testName",+      "email": ""     }-  ]+  } }

+ test/Feature/Holistic/parsing/inputListValues/query.gql view

@@ -0,0 +1,19 @@+query GetUsers($v1: Int!, $v2: Int!, $v3: Int!) {+  newlines: user {+    office(+      zipCode: [+        $v1 # Comment to prevent formatting+        $v2 # Comment to prevent formatting+        $v3 # Comment to prevent formatting+      ]+      cityID: EnumA+    ) {+      houseNumber+    }+  }+  commas: user {+    office(zipCode: [$v1, $v2, $v3], cityID: EnumA) {+      houseNumber+    }+  }+}

+ test/Feature/Holistic/parsing/inputListValues/response.json view

@@ -0,0 +1,14 @@+{+  "data": {+    "newlines": {+      "office": {+        "houseNumber": 0+      }+    },+    "commas": {+      "office": {+        "houseNumber": 0+      }+    }+  }+}

+ test/Feature/Holistic/parsing/inputListValues/variables.json view

@@ -0,0 +1,5 @@+{+  "v1": 1,+  "v2": 2,+  "v3": 3+}

test/Feature/Holistic/schema.gql view

@@ -102,4 +102,5 @@  type Subscription {   newUser: User!+  newAddress: Address! }

− test/Feature/Holistic/selection/AliasNameConflict/query.gql

@@ -1,8 +0,0 @@-{-  user {-    name2: name-    name2: name-    name2: name-    name-  }-}

− test/Feature/Holistic/selection/AliasNameConflict/response.json

@@ -1,22 +0,0 @@-{-  "errors": [-    {-      "message": "duplicate selection of key \"name2\" on type \"User\".",-      "locations": [-        {-          "line": 4,-          "column": 5-        }-      ]-    },-    {-      "message": "duplicate selection of key \"name2\" on type \"User\".",-      "locations": [-        {-          "line": 5,-          "column": 5-        }-      ]-    }-  ]-}

+ test/Feature/Holistic/selection/mergeConflict/alias/query.gql view

@@ -0,0 +1,19 @@+{+  user {+    bla: email+    email+    bla: email+    address(coordinates: {latitude:"", longitude: []}) {+      city+			bla : city+    }+  }+  user {+    address(coordinates: {latitude:"", longitude: []}) {+      street+      bla: houseNumber+    }+    city+    bla: email+  }+}

+ test/Feature/Holistic/selection/mergeConflict/alias/response.json view

@@ -0,0 +1,25 @@+{+  "errors": [+    {+      "message": "Fields \"user\" conflict because subfields \"address\" conflict because \"city\" and \"houseNumber\" are different fields. Use different aliases on the fields to fetch both if this was intentional.",+      "locations": [+        {+          "line": 2,+          "column": 8+        },+        {+          "line": 6,+          "column": 56+        },+        {+          "line": 8,+          "column": 25+        },+        {+          "line": 14,+          "column": 7+        }+      ]+    }+  ]+}

+ test/Feature/Holistic/selection/mergeConflict/arguments/query.gql view

@@ -0,0 +1,19 @@+{+  user {+    bla: email+    email+    bla: email+    address(coordinates: {latitude:"", longitude: 3}) {+      city+			houseNumber+    }+  }+  user {+    address(coordinates: {latitude:"", longitude: 2}) {+      city+      bla: houseNumber+    }+    name+    bla: email+  }+}

+ test/Feature/Holistic/selection/mergeConflict/arguments/response.json view

@@ -0,0 +1,25 @@+{+  "errors": [+    {+      "message": "Fields \"user\" conflict because subfields \"address\" conflict because they have differing arguments. Use different aliases on the fields to fetch both if this was intentional.",+      "locations": [+        {+          "line": 2,+          "column": 8+        },+        {+          "line": 6,+          "column": 55+        },+        {+          "line": 6,+          "column": 55+        },+        {+          "line": 12,+          "column": 55+        }+      ]+    }+  ]+}

+ test/Feature/Holistic/selection/mergeConflict/union/query.gql view

@@ -0,0 +1,20 @@+{+  testUnion {+    ... on User {+      name+      email+      address(coordinates: { latitude: "", longitude: 1 }) {+        city: houseNumber+      }+    }+  }+  +  testUnion {+    ... on User {+      name: email+      address(coordinates: { latitude: "", longitude: 1 }) {+        city+      }+    }+  }+}

+ test/Feature/Holistic/selection/mergeConflict/union/response.json view

@@ -0,0 +1,17 @@+{+  "errors": [+    {+      "message": "\"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+        }+      ]+    }+  ]+}

+ test/Feature/Holistic/selection/mergeSelection/query.gql view

@@ -0,0 +1,32 @@+{+  user {+    name+    name+    name+    name2 : name+    name2 : name+    name2 : name+    name: name+  }+  user { +    name+    name2 : name+  }+  user {+    bla: email+    email+    bla: email+    address(coordinates: {latitude:"", longitude: 2}) {+      city+			houseNumber+    }+  }+  user {+    address(coordinates: {latitude:"", longitude: 2}) {+      city+      bla: houseNumber+    }+    name+    bla: email+  }+}

+ test/Feature/Holistic/selection/mergeSelection/response.json view

@@ -0,0 +1,15 @@+{+  "data": {+    "user": {+      "name": "testName",+      "name2": "testName",+      "bla": "",+      "email": "",+      "address": {+        "city": "",+        "houseNumber": 0,+        "bla": 0+      }+    }+  }+}

+ test/Feature/Holistic/selection/mergeUnionSelection/query.gql view

@@ -0,0 +1,19 @@+{+  testUnion {+    ... on User {+      name+      email+    }+  }+  +  testUnion {+    ... on User {+      name+      email2: email+      address(coordinates: { latitude: "", longitude: 1 }) {+        city+      }+    }+  }+}+

+ test/Feature/Holistic/selection/mergeUnionSelection/response.json view

@@ -0,0 +1,12 @@+{+  "data": {+    "testUnion": {+      "name": "testName",+      "email": "",+      "email2": "",+      "address": {+        "city": ""+      }+    }+  }+}

− test/Feature/Holistic/selection/nameConflict/query.gql

@@ -1,7 +0,0 @@-{-  user {-    name-    name-    name-  }-}

− test/Feature/Holistic/selection/nameConflict/response.json

@@ -1,22 +0,0 @@-{-  "errors": [-    {-      "message": "duplicate selection of key \"name\" on type \"User\".",-      "locations": [-        {-          "line": 4,-          "column": 5-        }-      ]-    },-    {-      "message": "duplicate selection of key \"name\" on type \"User\".",-      "locations": [-        {-          "line": 5,-          "column": 5-        }-      ]-    }-  ]-}

+ test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/query.gql view

@@ -0,0 +1,8 @@+subscription SomeTestSubscription {+  newUser {+    name+  }+  newAddress {+    houseNumber+  }+}

+ test/Feature/Holistic/selection/subscription/singleTopLevelField/fail/response.json view

@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "Subscription \"SomeTestSubscription\" must select only one top level field.",+      "locations": [+        {+          "line": 5,+          "column": 14+        }+      ]+    }+  ]+}

+ test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/query.gql view

@@ -0,0 +1,11 @@+subscription {+  newUser {+    name+  }+  newAddress {+    houseNumber+  }+  address2: newAddress {+    houseNumber+  }+}

+ test/Feature/Holistic/selection/subscription/singleTopLevelField/failAnonymous/response.json view

@@ -0,0 +1,22 @@+{+  "errors": [+    {+      "message": "Anonymous Subscription must select only one top level field.",+      "locations": [+        {+          "line": 5,+          "column": 14+        }+      ]+    },+    {+      "message": "Anonymous Subscription must select only one top level field.",+      "locations": [+        {+          "line": 8,+          "column": 24+        }+      ]+    }+  ]+}

test/Feature/Input/Enum/decodeInvalidValue/query.gql view

@@ -1,3 +1,3 @@ query ValidDecoding {-  test2 (level:LK)+  test2 ( level: LK ) }

test/Feature/Input/Enum/decodeInvalidValue/response.json view

@@ -1,11 +1,11 @@ {   "errors": [     {-      "message": "Argument level got invalid value ; Expected type \"TwoCon\" found \"LK\".",+      "message": "Argument \"level\" got invalid value. Expected type \"TwoCon!\" found \"LK\".",       "locations": [         {           "line": 2,-          "column": 16+          "column": 11         }       ]     }

test/Feature/Input/Object/API.hs view

@@ -25,7 +25,8 @@  data InputObject = InputObject {   field :: Text,-  nullableField :: Maybe Int+  nullableField :: Maybe Int,+  recursive :: Maybe InputObject } deriving (Generic, Show)  instance GQLType InputObject where

test/Feature/Input/Object/nullableUndefinedField/response.json view

@@ -1,5 +1,5 @@ {   "data": {-    "input": "InputObject {field = \"value\", nullableField = Nothing}"+    "input": "InputObject {field = \"value\", nullableField = Nothing, recursive = Nothing}"   } }

test/Feature/Input/Object/resolveObject/query.gql view

@@ -1,4 +1,4 @@ query ResolveObject {   i1: input(value: { field: "v1", nullableField: 123 })-  i2: input(value: { field: "v2" })+  i2: input(value: { field: "v2" , recursive: { field: "v3" } }) }

test/Feature/Input/Object/resolveObject/response.json view

@@ -1,6 +1,6 @@ {   "data": {-    "i1": "InputObject {field = \"v1\", nullableField = Just 123}",-    "i2": "InputObject {field = \"v2\", nullableField = Nothing}"+    "i1": "InputObject {field = \"v1\", nullableField = Just 123, recursive = Nothing}",+    "i2": "InputObject {field = \"v2\", nullableField = Nothing, recursive = Just (InputObject {field = \"v3\", nullableField = Nothing, recursive = Nothing})}"   } }

test/Feature/Input/Object/resolveVariable/response.json view

@@ -1,6 +1,6 @@ {   "data": {-    "i1": "InputObject {field = \"string from variable\", nullableField = Just 123011}",-    "i2": "InputObject {field = \"\", nullableField = Nothing}"+    "i1": "InputObject {field = \"string from variable\", nullableField = Just 123011, recursive = Nothing}",+    "i2": "InputObject {field = \"\", nullableField = Nothing, recursive = Nothing}"   } }

test/Feature/Input/Object/undefinedField/query.gql view

@@ -1,4 +1,5 @@ query UndefinedField {   i1: input(value: { nullableField: 1 })-  i2: input(value: {})+  i2: input(value: { })+  i3: input(value: { field: "v2" , recursive: { field: "v3" , recursive: {}  } }) }

test/Feature/Input/Object/undefinedField/response.json view

@@ -1,12 +1,31 @@ {   "errors": [     {-      "message": "Argument value got invalid value ; Undefined Field \"field\".",-      "locations": [{ "line": 2, "column": 20 }]+      "message": "Argument \"value\" got invalid value. Undefined Field \"field\".",+      "locations": [+        {+          "line": 2,+          "column": 13+        }+      ]     },     {-      "message": "Argument value got invalid value ; Undefined Field \"field\".",-      "locations": [{ "line": 3, "column": 20 }]+      "message": "Argument \"value\" got invalid value. Undefined Field \"field\".",+      "locations": [+        {+          "line": 3,+          "column": 13+        }+      ]+    },+    {+      "message": "Argument \"value\" got invalid value. in field \"recursive.recursive\": Undefined Field \"field\".",+      "locations": [+        {+          "line": 4,+          "column": 13+        }+      ]     }   ] }

test/Feature/Input/Object/unexpectedValue/query.gql view

@@ -3,4 +3,7 @@   i2: input(value: 1)   i3: input(value: { field: {} })   i4: input(value: { field: 3 })+  i5: input(value: { field: null } )+  # deep recursive+  i6: input(value: { field: "v2" , recursive: { field: "v3" , recursive: { field: 5 }  } }) }

test/Feature/Input/Object/unexpectedValue/response.json view

@@ -1,20 +1,58 @@ {   "errors": [     {-      "message": "Argument value got invalid value ; Expected type \"InputObject!\" found \"some text\".",-      "locations": [{ "line": 2, "column": 20 }]+      "message": "Argument \"value\" got invalid value. Expected type \"InputObject!\" found \"some text\".",+      "locations": [+        {+          "line": 2,+          "column": 13+        }+      ]     },     {-      "message": "Argument value got invalid value ; Expected type \"InputObject!\" found 1.",-      "locations": [{ "line": 3, "column": 20 }]+      "message": "Argument \"value\" got invalid value. Expected type \"InputObject!\" found 1.",+      "locations": [+        {+          "line": 3,+          "column": 13+        }+      ]     },     {-      "message": "Argument value got invalid value ;on field Expected type \"String\" found {}.",-      "locations": [{ "line": 4, "column": 20 }]+      "message": "Argument \"value\" got invalid value. in field \"field\": Expected type \"String!\" found {}.",+      "locations": [+        {+          "line": 4,+          "column": 13+        }+      ]     },     {-      "message": "Argument value got invalid value ;on field Expected type \"String\" found 3.",-      "locations": [{ "line": 5, "column": 20 }]+      "message": "Argument \"value\" got invalid value. in field \"field\": Expected type \"String!\" found 3.",+      "locations": [+        {+          "line": 5,+          "column": 13+        }+      ]+    },+    {+      "message": "Argument \"value\" got invalid value. in field \"field\": Expected type \"String!\" found null.",+      "locations": [+        {+          "line": 6,+          "column": 13+        }+      ]+    },+    {+      "message": "Argument \"value\" got invalid value. in field \"recursive.recursive.field\": Expected type \"String!\" found 5.",+      "locations": [+        {+          "line": 8,+          "column": 13+        }+      ]     }   ] }

test/Feature/Input/Object/unknownField/query.gql view

@@ -1,3 +1,4 @@-query UndefinedField {-  input(value: { moo: 1, field: "some field" })+query UnknownField {+  i1: input( value: { moo: 1, field: "some field" })+  i2: input(value: { field: "v2" , recursive: { field: "v3" , recursive: { field: "bal" , unkField : "test Unkown" }  } }) }

test/Feature/Input/Object/unknownField/response.json view

@@ -1,8 +1,22 @@ {   "errors": [     {-      "message": "Argument value got invalid value ; Unknown Field \"moo\".",-      "locations": [{ "line": 2, "column": 16 }]+      "message": "Argument \"value\" got invalid value. Unknown Field \"moo\".",+      "locations": [+        {+          "line": 2,+          "column": 14+        }+      ]+    },+    {+      "message": "Argument \"value\" got invalid value. in field \"recursive.recursive\": Unknown Field \"unkField\".",+      "locations": [+        {+          "line": 3,+          "column": 13+        }+      ]     }   ] }

test/Feature/InputType/cases.json view

@@ -74,5 +74,13 @@   {     "path": "variables/incompatibleType/weakerType3",     "description": "weaker types are invalid"+  },+  {+    "path": "variables/nameCollision",+    "description": "fail on: variable name collision"+  },+  {+    "path": "variables/nonInputTypeViolation",+    "description": "fail on: non-input type in variable definition"   } ]

test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value;  Expected type \"[[[Int!]!]]!\" found {\"id\":\"12\"}.",+      "message": "Variable \"$v1\" got invalid value. Expected type \"[[[Int!]!]]!\" found {\"id\":\"12\"}.",       "locations": [         {           "line": 1,

test/Feature/InputType/variables/invalidValue/invalidDefaultValueButVariableProvided/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value;  Expected type \"[Int!]!\" found \"boo\".",+      "message": "Variable \"$v1\" got invalid value. Expected type \"[Int!]!\" found \"boo\".",       "locations": [         {           "line": 1,

test/Feature/InputType/variables/invalidValue/invalidListVariable/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value;  Expected type \"String!\" found null.",+      "message": "Variable \"$v1\" got invalid value. Expected type \"String!\" found null.",       "locations": [         {           "line": 1,

test/Feature/InputType/variables/invalidValue/nestedListNonNullListReceivedNull/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value;  Expected type \"[Int!]!\" found null.",+      "message": "Variable \"$v1\" got invalid value. Expected type \"[Int!]!\" found null.",       "locations": [         {           "line": 1,

+ test/Feature/InputType/variables/nameCollision/query.gql view

@@ -0,0 +1,5 @@+query variableNameCollision($v1: String!, $v1: String! ) {+  q1 {+    a2(argList: $v1)+  }+}

+ test/Feature/InputType/variables/nameCollision/response.json view

@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "There can Be only One Variable Named \"v1\"",+      "locations": [+        {+          "line": 1,+          "column": 43+        }+      ]+    }+  ]+}

+ test/Feature/InputType/variables/nameCollision/variables.json view

@@ -0,0 +1,5 @@+{+  "v1": [+    "a"+  ]+}

+ test/Feature/InputType/variables/nonInputTypeViolation/query.gql view

@@ -0,0 +1,5 @@+query testUnknownType ($bo: A ){+  q1 {+      a1(arg1:$bo)+  }+}

+ test/Feature/InputType/variables/nonInputTypeViolation/response.json view

@@ -0,0 +1,13 @@+{+  "errors": [+    {+      "message": "Variable \"$bo\" cannot be non-input type \"A\".",+      "locations": [+        {+          "line": 1,+          "column": 24+        }+      ]+    }+  ]+}

test/Feature/TypeInference/API.hs view

@@ -27,12 +27,12 @@ data Power = Thunderbolts | Shapeshift | Hurricanes   deriving (Generic,GQLType) -data Deity = Deity {+data Deity (m :: * -> *) = Deity {   name :: Text ,   power :: Power } deriving(Generic,GQLType) -deityRes :: Deity+deityRes :: Deity m deityRes = Deity { name = "Morpheus", power = Shapeshift }  data Hydra = Hydra {@@ -52,30 +52,29 @@ instance GQLType Monster where   type KIND Monster = INPUT -data Character  =-  CharacterDeity Deity -- Only <tycon name><type ref name> should generate direct link+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}+  | BoxedDeity { boxedDeity :: Deity m}   | ScalarRecord { scalarText :: Text }   --- Types    | CharacterInt Int -- all scalars mus be boxed   -- Types-  | SomeDeity Deity+  | SomeDeity (Deity m)   | SomeMutli Int Text   --- ENUMS   | Zeus   | Cronus deriving (Generic, GQLType)  - newtype MonsterArgs = MonsterArgs {   monster :: Monster } deriving (Generic)  data Query (m :: * -> *) = Query-  { deity :: Deity,-    character :: [Character],+  { deity :: Deity m,+    character :: [Character m],     showMonster :: MonsterArgs -> m Text   } deriving (Generic, GQLType) @@ -87,7 +86,7 @@   }  where   showMonster MonsterArgs { monster } = pure (pack $ show monster)-  character :: [Character]+  character :: [Character m]   character =     [ CharacterDeity deityRes     , Creature { creatureName = "Lamia", creatureAge = 205 }

test/Feature/TypeInference/introspection/complexInput/response.json view

@@ -6,17 +6,25 @@       "fields": null,       "inputFields": [         {-          "name": "__typename",+          "name": "inputname",           "type": {             "kind": "NON_NULL",             "name": null,-            "ofType": { "kind": "ENUM", "name": "MonsterTags", "ofType": null }+            "ofType": {+              "kind": "ENUM",+              "name": "MonsterTags",+              "ofType": null+            }           },           "defaultValue": null         },         {           "name": "Hydra",-          "type": { "kind": "INPUT_OBJECT", "name": "Hydra", "ofType": null },+          "type": {+            "kind": "INPUT_OBJECT",+            "name": "Hydra",+            "ofType": null+          },           "defaultValue": null         },         {@@ -40,7 +48,11 @@       "inputFields": null,       "interfaces": null,       "enumValues": [-        { "name": "Hydra", "isDeprecated": false, "deprecationReason": null },+        {+          "name": "Hydra",+          "isDeprecated": false,+          "deprecationReason": null+        },         {           "name": "Cerberus",           "isDeprecated": false,

test/Feature/TypeInference/resolving/complexUnion/response.json view

@@ -1,18 +1,49 @@ {   "data": {     "character": [-      { "__typename": "Deity", "name": "Morpheus" },-      { "__typename": "Creature", "creatureName": "Lamia", "creatureAge": 205 },-      { "__typename": "BoxedDeity", "boxedDeity": { "power": "Shapeshift" } },-      { "__typename": "ScalarRecord", "scalarText": "Some Text" },       {+        "__typename": "Deity",+        "name": "Morpheus"+      },+      {+        "__typename": "Creature",+        "creatureName": "Lamia",+        "creatureAge": 205+      },+      {+        "__typename": "BoxedDeity",+        "boxedDeity": {+          "power": "Shapeshift"+        }+      },+      {+        "__typename": "ScalarRecord",+        "scalarText": "Some Text"+      },+      {         "__typename": "SomeDeity",-        "_0": { "name": "Morpheus", "power": "Shapeshift" }+        "_0": {+          "name": "Morpheus",+          "power": "Shapeshift"+        }       },-      { "__typename": "CharacterInt", "_0": 12 },-      { "__typename": "SomeMutli", "_0": 21, "_1": "some text" },-      { "__typename": "CharacterEnumObject", "enum": "Zeus" },-      { "__typename": "CharacterEnumObject", "enum": "Cronus" }+      {+        "__typename": "CharacterInt",+        "_0": 12+      },+      {+        "__typename": "SomeMutli",+        "_0": 21,+        "_1": "some text"+      },+      {+        "__typename": "CharacterEnumObject",+        "enum": "Zeus"+      },+      {+        "__typename": "CharacterEnumObject",+        "enum": "Cronus"+      }     ]   } }

test/Feature/TypeInference/resolving/input/query.gql view

@@ -1,9 +1,9 @@ {   object: showMonster(-    monster: { __typename: Hydra, Hydra: { name: "someName", age: 12 } }+    monster: { inputname: Hydra, Hydra: { name: "someName", age: 12 } }   )   record: showMonster(-    monster: { __typename: Cerberus, Cerberus: { name: "someName" } }+    monster: { inputname: Cerberus, Cerberus: { name: "someName" } }   )-  enum: showMonster(monster: { __typename: UnidentifiedMonster })+  enum: showMonster(monster: { inputname: UnidentifiedMonster }) }

test/Feature/UnionType/selectionWithoutFragmentNotAllowed/response.json view

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Cannot query field \"aText\" on type \"Query\".",+      "message": "Cannot query field \"aText\" on type \"Sum\".",       "locations": [         {           "line": 4,

test/TestFeature.hs view

@@ -23,8 +23,11 @@ import           Test.Tasty.HUnit           (assertFailure, testCase)  packGQLRequest :: ByteString -> Maybe Value -> GQLRequest-packGQLRequest queryBS variables =-  GQLRequest {operationName = Nothing, query = LT.toStrict $ decodeUtf8 queryBS, variables}+packGQLRequest queryBS variables = GQLRequest +  { operationName = Nothing+  , query = LT.toStrict $ decodeUtf8 queryBS+  , variables+  }  data Case = Case   { path        :: Text