diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,5 +1,17 @@ # Changelog +## 0.18.0 - 08.11.2021 + +### Minor Changes + +- added `morpheus-graphql-code-gen` to dependency +- Add defineBy\*File' variants that take a `Q FilePath` [#584](https://github.com/morpheusgraphql/morpheus-graphql/pull/584) + +- fixed: Generation of data constructors for non-capitalized enums +- fixed invalid scalar type generation and added tests to ensure their validity for each upcoming version [#583](https://github.com/morpheusgraphql/morpheus-graphql/issues/583) + +- return all response errors gracefully as a Left when fetching [#577](https://github.com/morpheusgraphql/morpheus-graphql/issues/577) - Thanks @AlistairB + ## 0.17.0 - 25.02.2021 ### Breaking changes diff --git a/morpheus-graphql-client.cabal b/morpheus-graphql-client.cabal --- a/morpheus-graphql-client.cabal +++ b/morpheus-graphql-client.cabal @@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack -- --- hash: e02463ebba831a7d044e68be7f21aa39b4fba099002f076f46478158b913b2a7 +-- hash: d8afe2a76ad3163ac3b8f0ac2cac8965a875cbcf8d86ea660ac0a65d325f71de name: morpheus-graphql-client -version: 0.17.0 +version: 0.18.0 synopsis: Morpheus GraphQL Client description: Build GraphQL APIs with your favourite functional language! category: web, graphql, client @@ -27,14 +27,19 @@ test/Case/Github/schema.gql test/Case/Interface/schema.gql test/Case/LowercaseTypeName/schema.gql + test/Case/Scalar/schema.gql test/Case/Enum/response.json test/Case/Github/response.json test/Case/Interface/response.json + test/Case/JSON/Custom/Errors/response.json test/Case/JSON/Custom/Mutation/response.json + test/Case/JSON/Custom/NoResponseOrError/response.json + test/Case/JSON/Custom/PartialResponse/response.json test/Case/JSON/Custom/Query/response.json test/Case/JSON/Custom/schema.json test/Case/JSON/Custom/Subscription/response.json test/Case/LowercaseTypeName/response.json + test/Case/Scalar/response.json source-repository head type: git @@ -67,7 +72,8 @@ aeson >=1.4.4.0 && <=1.6 , base >=4.7 && <5 , bytestring >=0.10.4 && <0.11 - , morpheus-graphql-core >=0.17.0 && <0.18.0 + , morpheus-graphql-code-gen >=0.18.0 && <0.19.0 + , morpheus-graphql-core >=0.18.0 && <0.19.0 , mtl >=2.0 && <=3.0 , relude >=0.3.0 , template-haskell >=2.0 && <=3.0 @@ -76,17 +82,21 @@ , unordered-containers >=0.2.8.0 && <0.3 default-language: Haskell2010 -test-suite morpheus-client-test +test-suite morpheus-graphql-client-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: Case.Enum.Test Case.Github.Test Case.Interface.Test + Case.JSON.Custom.Errors Case.JSON.Custom.Mutation + Case.JSON.Custom.NoResponseOrError + Case.JSON.Custom.PartialResponse Case.JSON.Custom.Query Case.JSON.Custom.Subscription Case.LowercaseTypeName.Test + Case.Scalar.Test Spec.Utils Paths_morpheus_graphql_client hs-source-dirs: @@ -98,7 +108,8 @@ , bytestring >=0.10.4 && <0.11 , directory >=1.0 , morpheus-graphql-client - , morpheus-graphql-core >=0.17.0 && <0.18.0 + , morpheus-graphql-code-gen >=0.18.0 && <0.19.0 + , morpheus-graphql-core >=0.18.0 && <0.19.0 , mtl >=2.0 && <=3.0 , relude >=0.3.0 , tasty diff --git a/src/Data/Morpheus/Client.hs b/src/Data/Morpheus/Client.hs --- a/src/Data/Morpheus/Client.hs +++ b/src/Data/Morpheus/Client.hs @@ -4,11 +4,14 @@ module Data.Morpheus.Client ( gql, Fetch (..), + FetchError(..), defineQuery, defineByDocument, defineByDocumentFile, + defineByDocumentFile', defineByIntrospection, defineByIntrospectionFile, + defineByIntrospectionFile', ScalarValue (..), DecodeScalar (..), EncodeScalar (..), @@ -29,11 +32,14 @@ import Data.Morpheus.Client.JSONSchema.Parse ( decodeIntrospection, ) +import Data.Morpheus.Client.Internal.Types + ( FetchError(..), + ) import Data.Morpheus.Core ( parseFullSchema, ) import Data.Morpheus.Internal.Ext - ( Eventless, + ( GQLResult, ) import Data.Morpheus.QuasiQuoter (gql) import Data.Morpheus.Types.GQLScalar @@ -58,15 +64,23 @@ qAddDependentFile filePath defineByDocument (L.readFile filePath) args +-- | This variant exposes 'Q FilePath' enabling the use of TH to generate the 'FilePath'. For example, https://hackage.haskell.org/package/file-embed-0.0.13.0/docs/Data-FileEmbed.html#v:makeRelativeToProject can be used to handle multi package projects more reliably. +defineByDocumentFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec] +defineByDocumentFile' qFilePath args = qFilePath >>= flip defineByDocumentFile args + defineByIntrospectionFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec] defineByIntrospectionFile filePath args = do qAddDependentFile filePath defineByIntrospection (L.readFile filePath) args +-- | This variant exposes 'Q FilePath' enabling the use of TH to generate the 'FilePath'. For example, https://hackage.haskell.org/package/file-embed-0.0.13.0/docs/Data-FileEmbed.html#v:makeRelativeToProject can be used to handle multi package projects more reliably. +defineByIntrospectionFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec] +defineByIntrospectionFile' qFilePath args = qFilePath >>= flip defineByIntrospectionFile args + defineByDocument :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec] defineByDocument doc = defineQuery (schemaByDocument doc) -schemaByDocument :: IO ByteString -> IO (Eventless (Schema VALID)) +schemaByDocument :: IO ByteString -> IO (GQLResult (Schema VALID)) schemaByDocument = fmap parseFullSchema defineByIntrospection :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec] diff --git a/src/Data/Morpheus/Client/Build.hs b/src/Data/Morpheus/Client/Build.hs --- a/src/Data/Morpheus/Client/Build.hs +++ b/src/Data/Morpheus/Client/Build.hs @@ -29,7 +29,7 @@ renderGQLErrors, ) import Data.Morpheus.Internal.Ext - ( Eventless, + ( GQLResult, Result (..), ) import Data.Morpheus.Types.Internal.AST @@ -41,7 +41,7 @@ import Language.Haskell.TH import Relude -defineQuery :: IO (Eventless (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec] +defineQuery :: IO (GQLResult (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec] defineQuery ioSchema (query, src) = do schema <- runIO ioSchema case schema >>= (`validateWith` query) of @@ -51,7 +51,7 @@ warnings } -> gqlWarnings warnings >> declareClient src result -validateWith :: Schema VALID -> ExecutableDocument -> Eventless ClientDefinition +validateWith :: Schema VALID -> ExecutableDocument -> GQLResult ClientDefinition validateWith schema rawRequest@ExecutableDocument diff --git a/src/Data/Morpheus/Client/Declare/Aeson.hs b/src/Data/Morpheus/Client/Declare/Aeson.hs --- a/src/Data/Morpheus/Client/Declare/Aeson.hs +++ b/src/Data/Morpheus/Client/Declare/Aeson.hs @@ -28,38 +28,35 @@ mkFieldsE, ) import Data.Morpheus.Client.Internal.Types - ( ClientConsD, + ( ClientConstructorDefinition (..), ClientTypeDefinition (..), TypeNameTH (..), ) import Data.Morpheus.Client.Internal.Utils ( isEnum, ) -import Data.Morpheus.Internal.TH +import Data.Morpheus.CodeGen.Internal.TH ( _', applyCons, + camelCaseTypeName, funDSimple, toCon, toName, toString, v', ) -import Data.Morpheus.Internal.Utils - ( nameSpaceType, - ) import Data.Morpheus.Types.GQLScalar ( scalarFromJSON, scalarToJSON, ) import Data.Morpheus.Types.Internal.AST - ( ConsD (..), - FieldName, - Message, + ( FieldName, + GQLError, + Msg (msg), TypeKind (..), - TypeName (..), + TypeName, + internal, isResolverType, - msg, - toFieldName, ) import qualified Data.Text as T import Language.Haskell.TH @@ -74,7 +71,6 @@ cxt, instanceD, tupP, - varE, ) import Relude hiding (toString) @@ -85,7 +81,7 @@ | isResolverType kind = [deriveFromJSON] | otherwise = [deriveToJSON] -failure :: Message -> Q a +failure :: GQLError -> Q a failure = fail . show deriveScalarJSON :: [ClientTypeDefinition -> DecQ] @@ -93,7 +89,7 @@ deriveScalarFromJSON :: ClientTypeDefinition -> DecQ deriveScalarFromJSON ClientTypeDefinition {clientTypeName} = - defineFromJSON clientTypeName (varE 'scalarFromJSON) + defineFromJSON clientTypeName [|scalarFromJSON|] deriveScalarToJSON :: ClientTypeDefinition -> DecQ deriveScalarToJSON @@ -102,12 +98,12 @@ } = instanceD (cxt []) typeDef body where typeDef = applyCons ''ToJSON [typename] - body = [funDSimple 'toJSON [] (varE 'scalarToJSON)] + body = [funDSimple 'toJSON [] [|scalarToJSON|]] -- FromJSON deriveFromJSON :: ClientTypeDefinition -> DecQ deriveFromJSON ClientTypeDefinition {clientCons = [], clientTypeName} = - failure $ + failure $ internal $ "Type " <> msg (typename clientTypeName) <> " Should Have at least one Constructor" @@ -126,8 +122,8 @@ defineFromJSON clientTypeName $ aesonUnionObject typeD -aesonObject :: [FieldName] -> ClientConsD cat -> ExpQ -aesonObject tNamespace con@ConsD {cName} = +aesonObject :: [FieldName] -> ClientConstructorDefinition -> ExpQ +aesonObject tNamespace con@ClientConstructorDefinition {cName} = withBody <$> aesonObjectBody tNamespace con where @@ -136,13 +132,13 @@ (AppE (VarE 'withObject) name) (LamE [v'] body) name :: Exp - name = toString (nameSpaceType tNamespace cName) + name = toString (camelCaseTypeName tNamespace cName) -aesonObjectBody :: [FieldName] -> ClientConsD cat -> ExpQ -aesonObjectBody namespace ConsD {cName, cFields} = +aesonObjectBody :: [FieldName] -> ClientConstructorDefinition -> ExpQ +aesonObjectBody namespace ClientConstructorDefinition {cName, cFields} = decodeObjectE entry - (nameSpaceType namespace cName) + (camelCaseTypeName namespace cName) cFields entry :: Bool -> Name @@ -156,7 +152,7 @@ { clientCons, clientTypeName = TypeNameTH {namespace, typename} } = - appE (varE 'takeValueType) $ + appE [|takeValueType|] $ matchWith elseCondition f clientCons where elseCondition = @@ -164,7 +160,7 @@ . aesonObjectBody namespace <$> find ((typename ==) . cName) clientCons - f cons@ConsD {cName, cFields} = + f cons@ClientConstructorDefinition {cName, cFields} = ( tupP [toString cName, if null cFields then _' else v'], aesonObjectBody namespace cons ) @@ -179,7 +175,7 @@ namespaced :: TypeNameTH -> TypeName namespaced TypeNameTH {namespace, typename} = - nameSpaceType namespace typename + camelCaseTypeName namespace typename defineFromJSON :: TypeNameTH -> ExpQ -> DecQ defineFromJSON name expr = instanceD (cxt []) typeDef body @@ -187,21 +183,21 @@ typeDef = applyCons ''FromJSON [namespaced name] body = [funDSimple 'parseJSON [] expr] -aesonFromJSONEnumBody :: TypeNameTH -> [ClientConsD cat] -> ExpQ +aesonFromJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ aesonFromJSONEnumBody TypeNameTH {typename} = matchWith (Just (v', failExp)) f where - f :: ClientConsD cat -> (PatQ, ExpQ) - f ConsD {cName} = + f :: ClientConstructorDefinition -> (PatQ, ExpQ) + f ClientConstructorDefinition {cName} = ( toString cName, - appE (varE 'pure) $ toCon $ nameSpaceType [toFieldName typename] cName + appE [|pure|] $ toCon $ camelCaseTypeName [typename] cName ) -aesonToJSONEnumBody :: TypeNameTH -> [ClientConsD cat] -> ExpQ +aesonToJSONEnumBody :: TypeNameTH -> [ClientConstructorDefinition] -> ExpQ aesonToJSONEnumBody TypeNameTH {typename} = matchWith Nothing f where - f :: ClientConsD cat -> (PatQ, ExpQ) - f ConsD {cName} = - ( conP (toName $ nameSpaceType [toFieldName typename] cName) [], + f :: ClientConstructorDefinition -> (PatQ, ExpQ) + f ClientConstructorDefinition {cName} = + ( conP (toName $ camelCaseTypeName [typename] cName) [], toString cName ) @@ -215,7 +211,7 @@ deriveToJSON ClientTypeDefinition { clientTypeName = TypeNameTH {typename}, - clientCons = [ConsD {cFields}] + clientCons = [ClientConstructorDefinition {cFields}] } = instanceD (cxt []) appHead methods where diff --git a/src/Data/Morpheus/Client/Declare/Client.hs b/src/Data/Morpheus/Client/Declare/Client.hs --- a/src/Data/Morpheus/Client/Declare/Client.hs +++ b/src/Data/Morpheus/Client/Declare/Client.hs @@ -23,7 +23,7 @@ ClientTypeDefinition (..), TypeNameTH (..), ) -import Data.Morpheus.Internal.TH (toCon) +import Data.Morpheus.CodeGen.Internal.TH (toCon) import Language.Haskell.TH import Relude hiding (Type) diff --git a/src/Data/Morpheus/Client/Declare/Type.hs b/src/Data/Morpheus/Client/Declare/Type.hs --- a/src/Data/Morpheus/Client/Declare/Type.hs +++ b/src/Data/Morpheus/Client/Declare/Type.hs @@ -11,22 +11,21 @@ where import Data.Morpheus.Client.Internal.Types - ( ClientConsD, + ( ClientConstructorDefinition (..), ClientTypeDefinition (..), TypeNameTH (..), ) import Data.Morpheus.Client.Internal.Utils ( isEnum, ) -import Data.Morpheus.Internal.TH - ( declareTypeRef, - nameSpaceType, +import Data.Morpheus.CodeGen.Internal.TH + ( camelCaseTypeName, + declareTypeRef, toCon, toName, ) import Data.Morpheus.Types.Internal.AST ( ANY, - ConsD (..), FieldDefinition (..), FieldName, TypeKind (..), @@ -56,13 +55,13 @@ where derive className = DerivClause Nothing [ConT className] -declareCons :: TypeNameTH -> [ClientConsD ANY] -> [Con] +declareCons :: TypeNameTH -> [ClientConstructorDefinition] -> [Con] declareCons TypeNameTH {namespace, typename} clientCons | isEnum clientCons = map consE clientCons | otherwise = map consR clientCons where - consE ConsD {cName} = NormalC (mkConName namespace (typename <> cName)) [] - consR ConsD {cName, cFields} = + consE ClientConstructorDefinition {cName} = NormalC (mkTypeName namespace typename cName) [] + consR ClientConstructorDefinition {cName, cFields} = RecC (mkConName namespace cName) (map declareField cFields) @@ -74,5 +73,8 @@ declareTypeRef toCon fieldType ) +mkTypeName :: [FieldName] -> TypeName -> TypeName -> Name +mkTypeName namespace typename = mkConName namespace . camelCaseTypeName [typename] + mkConName :: [FieldName] -> TypeName -> Name -mkConName namespace = toName . nameSpaceType namespace +mkConName namespace = toName . camelCaseTypeName namespace diff --git a/src/Data/Morpheus/Client/Fetch.hs b/src/Data/Morpheus/Client/Fetch.hs --- a/src/Data/Morpheus/Client/Fetch.hs +++ b/src/Data/Morpheus/Client/Fetch.hs @@ -21,10 +21,13 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Types as A import Data.ByteString.Lazy (ByteString) +import Data.Morpheus.Client.Internal.Types + ( FetchError (..), + ) import Data.Morpheus.Client.JSONSchema.Types ( JSONResponse (..), ) -import Data.Morpheus.Internal.TH +import Data.Morpheus.CodeGen.Internal.TH ( applyCons, toCon, typeInstanceDec, @@ -55,14 +58,15 @@ FieldName -> (ByteString -> m ByteString) -> Args a -> - m (Either String a) - __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq) + m (Either (FetchError a) a) + __fetch strQuery opName trans vars = ((first FetchErrorParseFailure . eitherDecode) >=> processResponse) <$> trans (encode gqlReq) where gqlReq = GQLRequest {operationName = Just opName, query = pack strQuery, variables = fixVars (toJSON vars)} ------------------------------------------------------------- - processResponse JSONResponse {responseData = Just x} = Right x - processResponse invalidResponse = Left (show invalidResponse) - fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a) + processResponse JSONResponse {responseData = Just x, responseErrors = []} = Right x + processResponse JSONResponse {responseData = Nothing, responseErrors = []} = Left FetchErrorNoResult + processResponse JSONResponse {responseData = result, responseErrors = (x : xs)} = Left $ FetchErrorProducedErrors (x :| xs) result + fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a) deriveFetch :: Type -> TypeName -> String -> Q [Dec] deriveFetch resultType typeName queryString = diff --git a/src/Data/Morpheus/Client/Internal/TH.hs b/src/Data/Morpheus/Client/Internal/TH.hs --- a/src/Data/Morpheus/Client/Internal/TH.hs +++ b/src/Data/Morpheus/Client/Internal/TH.hs @@ -21,18 +21,18 @@ where import Data.Foldable (foldr1) -import Data.Morpheus.Internal.TH - ( toCon, +import Data.Morpheus.CodeGen.Internal.TH + ( camelCaseFieldName, + toCon, toName, toString, toVar, v', vars, ) -import Data.Morpheus.Internal.Utils (nameSpaceField) import Data.Morpheus.Types.Internal.AST ( FieldDefinition (..), - TypeName (..), + TypeName, isNullable, ) import Language.Haskell.TH @@ -56,21 +56,21 @@ appE (toVar 'fail) ( uInfixE - (appE (varE 'show) v') - (varE '(<>)) + (appE [|show|] v') + [|(<>)|] (stringE " is Not Valid Union Constructor") ) decodeObjectE :: (Bool -> Name) -> TypeName -> [FieldDefinition cat s] -> ExpQ -decodeObjectE _ conName [] = appE (varE 'pure) (toCon conName) +decodeObjectE _ conName [] = appE [|pure|] (toCon conName) decodeObjectE funName conName fields = uInfixE (toCon conName) - (varE '(<$>)) + [|(<$>)|] (foldr1 withApplicative $ map (defField funName) fields) withApplicative :: ExpQ -> ExpQ -> ExpQ -withApplicative x = uInfixE x (varE '(<*>)) +withApplicative x = uInfixE x [|(<*>)|] defField :: (Bool -> Name) -> FieldDefinition cat s -> ExpQ defField f field@FieldDefinition {fieldName} = uInfixE v' (varE $ f (isNullable field)) (toString fieldName) @@ -101,19 +101,19 @@ mkEntryWith conName f FieldDefinition {fieldName} = AppE (AppE (VarE f) (toString fieldName)) - (toVar $ nameSpaceField conName fieldName) + (toVar $ camelCaseFieldName conName fieldName) -- | -- input: -- >>> --- destructRecord "User" ["name","id"] +-- WAS WAS destructRecord "User" ["name","id"] -- >>> -- -- expression: -- >>> --- (User name id) +-- WAS WAS (User name id) -- >>> destructRecord :: TypeName -> [FieldDefinition cat s] -> PatQ destructRecord conName fields = conP (toName conName) (vars names) where - names = map (nameSpaceField conName . fieldName) fields + names = map (camelCaseFieldName conName . fieldName) fields diff --git a/src/Data/Morpheus/Client/Internal/Types.hs b/src/Data/Morpheus/Client/Internal/Types.hs --- a/src/Data/Morpheus/Client/Internal/Types.hs +++ b/src/Data/Morpheus/Client/Internal/Types.hs @@ -1,18 +1,20 @@ {-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DeriveGeneric #-} module Data.Morpheus.Client.Internal.Types ( ClientTypeDefinition (..), TypeNameTH (..), ClientDefinition (..), - ClientConsD, + ClientConstructorDefinition (..), + FetchError (..) ) where import Data.Morpheus.Types.Internal.AST ( ANY, - ConsD (..), FieldDefinition, FieldName, + GQLErrors, TypeKind, TypeName, VALID, @@ -25,11 +27,15 @@ } deriving (Show) -type ClientConsD c = ConsD (FieldDefinition c VALID) +data ClientConstructorDefinition = ClientConstructorDefinition + { cName :: TypeName, + cFields :: [FieldDefinition ANY VALID] + } + deriving (Show) data ClientTypeDefinition = ClientTypeDefinition { clientTypeName :: TypeNameTH, - clientCons :: [ClientConsD ANY], + clientCons :: [ClientConstructorDefinition], clientKind :: TypeKind } deriving (Show) @@ -39,3 +45,9 @@ clientTypes :: [ClientTypeDefinition] } deriving (Show) + +data FetchError a + = FetchErrorParseFailure String + | FetchErrorProducedErrors GQLErrors (Maybe a) + | FetchErrorNoResult + deriving (Show, Eq, Generic) diff --git a/src/Data/Morpheus/Client/Internal/Utils.hs b/src/Data/Morpheus/Client/Internal/Utils.hs --- a/src/Data/Morpheus/Client/Internal/Utils.hs +++ b/src/Data/Morpheus/Client/Internal/Utils.hs @@ -6,15 +6,14 @@ ) where -import Data.Morpheus.Types.Internal.AST - ( ConsD (..), +import Data.Morpheus.Client.Internal.Types + ( ClientConstructorDefinition (cFields), ) import Relude removeDuplicates :: Eq a => [a] -> [a] removeDuplicates = fst . splitDuplicates --- elems -> (unique elements, duplicate elems) splitDuplicates :: Eq a => [a] -> ([a], [a]) splitDuplicates = collectElems ([], []) where @@ -24,5 +23,5 @@ | x `elem` collected = collectElems (collected, errors <> [x]) xs | otherwise = collectElems (collected <> [x], errors) xs -isEnum :: [ConsD f] -> Bool +isEnum :: [ClientConstructorDefinition] -> Bool isEnum = all (null . cFields) diff --git a/src/Data/Morpheus/Client/JSONSchema/Parse.hs b/src/Data/Morpheus/Client/JSONSchema/Parse.hs --- a/src/Data/Morpheus/Client/JSONSchema/Parse.hs +++ b/src/Data/Morpheus/Client/JSONSchema/Parse.hs @@ -11,6 +11,7 @@ ) where +import Control.Monad.Except (MonadError (throwError)) import Data.Aeson import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Client.JSONSchema.TypeKind (TypeKind (..)) @@ -28,12 +29,11 @@ ( defaultConfig, validateSchema, ) -import Data.Morpheus.Error (globalErrorMessage) import Data.Morpheus.Internal.Ext - ( Eventless, + ( GQLResult, ) import Data.Morpheus.Internal.Utils - ( Failure (..), + ( empty, fromElems, ) import qualified Data.Morpheus.Types.Internal.AST as AST @@ -43,43 +43,42 @@ ( ANY, ArgumentDefinition (..), CONST, - DataTypeWrapper (..), FieldDefinition, + GQLError, IN, - Message, OUT, OperationType (..), RootOperationTypeDefinition (..), SchemaDefinition (..), TypeContent (..), TypeDefinition (..), - TypeName, - TypeWrapper, + TypeRef (..), + TypeWrapper (..), VALID, - ValidationErrors, buildSchema, createScalarType, mkEnumContent, - mkInputValue, + mkField, + mkMaybeType, mkObjectField, mkType, mkUnionContent, msg, toAny, - toHSWrappers, ) import Relude hiding ( ByteString, Type, + empty, fromList, show, ) import Prelude (show) -decoderError :: Message -> Eventless a -decoderError = failure . globalErrorMessage +decoderError :: GQLError -> GQLResult a +decoderError = throwError -decodeIntrospection :: ByteString -> Eventless (AST.Schema VALID) +decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID) decodeIntrospection jsonDoc = case jsonSchema of Left errors -> decoderError $ msg errors Right @@ -96,13 +95,13 @@ buildSchema (Just schemaDef, gqlTypes, empty) >>= validate Right res -> decoderError (msg $ show res) where - validate :: AST.Schema CONST -> Eventless (AST.Schema VALID) + validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID) validate = validateSchema False defaultConfig jsonSchema :: Either String (JSONResponse Introspection) jsonSchema = eitherDecode jsonDoc mkSchemaDef :: - (Monad m, Failure ValidationErrors m) => + (Monad m, MonadError GQLError m) => Schema -> m SchemaDefinition mkSchemaDef @@ -121,7 +120,7 @@ ) class ParseJSONSchema a b where - parse :: a -> Eventless b + parse :: a -> GQLResult b instance ParseJSONSchema Type [TypeDefinition ANY CONST] where parse Type {name = Just typeName, kind = SCALAR} = @@ -146,25 +145,25 @@ instance ParseJSONSchema Field (FieldDefinition OUT CONST) where parse Field {fieldName, fieldArgs, fieldType} = do - (wrappers, typename) <- fieldTypeFromJSON fieldType + TypeRef typename wrappers <- fieldTypeFromJSON fieldType args <- traverse genArg fieldArgs >>= fromElems pure $ mkObjectField args fieldName wrappers typename where genArg InputValue {inputName = argName, inputType = argType} = - ArgumentDefinition . uncurry (mkInputValue argName) <$> fieldTypeFromJSON argType + ArgumentDefinition . mkField Nothing argName <$> fieldTypeFromJSON argType instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where - parse InputValue {inputName, inputType} = uncurry (mkInputValue inputName) <$> fieldTypeFromJSON inputType + parse InputValue {inputName, inputType} = mkField Nothing inputName <$> fieldTypeFromJSON inputType -fieldTypeFromJSON :: Type -> Eventless ([TypeWrapper], TypeName) -fieldTypeFromJSON = fmap toHs . fieldTypeRec [] - where - toHs (w, t) = (toHSWrappers w, t) - fieldTypeRec :: - [DataTypeWrapper] -> Type -> Eventless ([DataTypeWrapper], TypeName) - fieldTypeRec acc Type {kind = LIST, ofType = Just ofType} = - fieldTypeRec (ListType : acc) ofType - fieldTypeRec acc Type {kind = NON_NULL, ofType = Just ofType} = - fieldTypeRec (NonNullType : acc) ofType - fieldTypeRec acc Type {name = Just name} = pure (acc, name) - fieldTypeRec _ x = decoderError $ "Unsupported Field" <> msg (show x) +fieldTypeFromJSON :: Type -> GQLResult TypeRef +fieldTypeFromJSON Type {kind = NON_NULL, ofType = Just ofType} = withListNonNull <$> fieldTypeFromJSON ofType +fieldTypeFromJSON Type {kind = LIST, ofType = Just ofType} = withList <$> fieldTypeFromJSON ofType +fieldTypeFromJSON Type {name = Just name} = pure (TypeRef name mkMaybeType) +fieldTypeFromJSON x = decoderError $ "Unsupported Field" <> msg (show x) + +withList :: TypeRef -> TypeRef +withList (TypeRef name x) = TypeRef name (TypeList x False) + +withListNonNull :: TypeRef -> TypeRef +withListNonNull (TypeRef name (TypeList y _)) = TypeRef name (TypeList y True) +withListNonNull (TypeRef name (BaseType _)) = TypeRef name (BaseType True) diff --git a/src/Data/Morpheus/Client/JSONSchema/Types.hs b/src/Data/Morpheus/Client/JSONSchema/Types.hs --- a/src/Data/Morpheus/Client/JSONSchema/Types.hs +++ b/src/Data/Morpheus/Client/JSONSchema/Types.hs @@ -96,10 +96,11 @@ instance FromJSON a => FromJSON (JSONResponse a) where parseJSON = withObject "JSONResponse" objectParser where - objectParser o = JSONResponse <$> o .:? "data" <*> o .:? "errors" + objectParser o = + JSONResponse <$> o .:? "data" <*> o .:? "errors" .!= [] data JSONResponse a = JSONResponse { responseData :: Maybe a, - responseErrors :: Maybe [GQLError] + responseErrors :: [GQLError] } deriving (Generic, Show, ToJSON) diff --git a/src/Data/Morpheus/Client/Transform/Core.hs b/src/Data/Morpheus/Client/Transform/Core.hs --- a/src/Data/Morpheus/Client/Transform/Core.hs +++ b/src/Data/Morpheus/Client/Transform/Core.hs @@ -20,28 +20,28 @@ ) where +import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.Client.Internal.Types ( ClientTypeDefinition (..), ) +import Data.Morpheus.CodeGen.Internal.TH + ( camelCaseTypeName, + ) import Data.Morpheus.Error ( deprecatedField, - globalErrorMessage, ) import Data.Morpheus.Internal.Ext - ( Eventless, + ( GQLResult, Result (..), ) import Data.Morpheus.Internal.Utils - ( Failure (..), - nameSpaceType, - selectBy, + ( selectBy, ) import Data.Morpheus.Types.Internal.AST ( ANY, Directives, FieldName, - GQLErrors, - Message, + GQLError, RAW, Ref (..), Schema (..), @@ -50,14 +50,13 @@ TypeDefinition (..), TypeName, VALID, - ValidationError, VariableDefinitions, - hsTypeName, + internal, isNotSystemTypeName, lookupDeprecated, lookupDeprecatedReason, msg, - toGQLError, + typeDefinitions, ) import Relude @@ -67,7 +66,7 @@ { runConverter :: ReaderT Env - Eventless + GQLResult a } deriving @@ -75,23 +74,21 @@ Applicative, Monad, MonadReader Env, - Failure GQLErrors + MonadError GQLError ) -instance Failure ValidationError Converter where - failure err = failure [toGQLError err] - newtype UpdateT m a = UpdateT {updateTState :: a -> m a} resolveUpdates :: Monad m => a -> [UpdateT m a] -> m a resolveUpdates a = foldlM (&) a . fmap updateTState -compileError :: Message -> GQLErrors -compileError x = - globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" +compileError :: GQLError -> GQLError +compileError x = internal $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" getType :: TypeName -> Converter (TypeDefinition ANY VALID) -getType typename = asks fst >>= selectBy (compileError $ " can't find Type" <> msg typename) typename +getType typename = + asks (typeDefinitions . fst) + >>= selectBy (compileError $ " can't find Type" <> msg typename) typename customScalarTypes :: TypeName -> [TypeName] customScalarTypes typeName @@ -104,24 +101,24 @@ fromKind :: TypeContent TRUE a VALID -> Converter ([ClientTypeDefinition], [TypeName]) fromKind DataEnum {} = pure ([], [typeName]) fromKind DataScalar {} = pure ([], customScalarTypes typeName) - fromKind _ = failure $ compileError "Invalid schema Expected scalar" + fromKind _ = throwError $ compileError "Invalid schema Expected scalar" typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent where - __typeFrom DataScalar {} = hsTypeName typeName - __typeFrom DataObject {} = nameSpaceType path typeName - __typeFrom DataInterface {} = nameSpaceType path typeName - __typeFrom DataUnion {} = nameSpaceType path typeName + __typeFrom DataObject {} = camelCaseTypeName path typeName + __typeFrom DataInterface {} = camelCaseTypeName path typeName + __typeFrom DataUnion {} = camelCaseTypeName path typeName __typeFrom _ = typeName deprecationWarning :: Directives VALID -> (FieldName, Ref FieldName) -> Converter () deprecationWarning dirs (typename, ref) = case lookupDeprecated dirs of - Just deprecation -> Converter $ lift $ Success {result = (), warnings, events = []} + Just deprecation -> Converter $ lift $ Success {result = (), warnings} where warnings = - deprecatedField - typename - ref - (lookupDeprecatedReason deprecation) + [ deprecatedField + typename + ref + (lookupDeprecatedReason deprecation) + ] Nothing -> pure () diff --git a/src/Data/Morpheus/Client/Transform/Inputs.hs b/src/Data/Morpheus/Client/Transform/Inputs.hs --- a/src/Data/Morpheus/Client/Transform/Inputs.hs +++ b/src/Data/Morpheus/Client/Transform/Inputs.hs @@ -13,7 +13,7 @@ where import Data.Morpheus.Client.Internal.Types - ( ClientConsD, + ( ClientConstructorDefinition (..), ClientTypeDefinition (..), TypeNameTH (..), ) @@ -29,12 +29,11 @@ typeFrom, ) import Data.Morpheus.Internal.Utils - ( elems, - empty, + ( empty, ) import Data.Morpheus.Types.Internal.AST ( ANY, - ConsD (..), + DataEnumValue (DataEnumValue, enumName), FieldDefinition (..), IN, Operation (..), @@ -49,7 +48,6 @@ Variable (..), VariableDefinitions, getOperationName, - mkConsEnum, toAny, ) import Relude hiding (empty) @@ -68,9 +66,9 @@ { clientTypeName = TypeNameTH [] cName, clientKind = KindInputObject, clientCons = - [ ConsD + [ ClientConstructorDefinition { cName, - cFields = fieldD <$> elems variables + cFields = fieldD <$> toList variables } ] } @@ -96,7 +94,7 @@ [TypeName] -> Converter [ClientTypeDefinition] renderNonOutputTypes leafTypes = do - variables <- asks (elems . snd) + variables <- asks (toList . snd) inputTypeRequests <- resolveUpdates [] $ fmap (UpdateT . exploreInputTypeNames . typeConName . variableType) variables concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> leafTypes) @@ -110,7 +108,7 @@ scanType (DataInputObject fields) = resolveUpdates (name : collected) - (toInputTypeD <$> elems fields) + (toInputTypeD <$> toList fields) where toInputTypeD :: FieldDefinition IN VALID -> UpdateT Converter [TypeName] toInputTypeD FieldDefinition {fieldType = TypeRef {typeConName}} = @@ -128,12 +126,12 @@ where subTypes :: TypeContent TRUE ANY VALID -> Converter [ClientTypeDefinition] subTypes (DataInputObject inputFields) = do - fields <- traverse toClientFieldDefinition (elems inputFields) + fields <- traverse toClientFieldDefinition (toList inputFields) pure [ mkInputType typeName KindInputObject - [ ConsD + [ ClientConstructorDefinition { cName = typeName, cFields = fmap toAny fields } @@ -155,7 +153,10 @@ ] subTypes _ = pure [] -mkInputType :: TypeName -> TypeKind -> [ClientConsD ANY] -> ClientTypeDefinition +mkConsEnum :: DataEnumValue s -> ClientConstructorDefinition +mkConsEnum DataEnumValue {enumName} = ClientConstructorDefinition enumName [] + +mkInputType :: TypeName -> TypeKind -> [ClientConstructorDefinition] -> ClientTypeDefinition mkInputType typename clientKind clientCons = ClientTypeDefinition { clientTypeName = TypeNameTH [] typename, diff --git a/src/Data/Morpheus/Client/Transform/Selection.hs b/src/Data/Morpheus/Client/Transform/Selection.hs --- a/src/Data/Morpheus/Client/Transform/Selection.hs +++ b/src/Data/Morpheus/Client/Transform/Selection.hs @@ -12,8 +12,9 @@ ) where +import Control.Monad.Except (MonadError (throwError)) import Data.Morpheus.Client.Internal.Types - ( ClientConsD, + ( ClientConstructorDefinition (..), ClientDefinition (..), ClientTypeDefinition (..), TypeNameTH (..), @@ -21,18 +22,15 @@ import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, leafType, typeFrom) import Data.Morpheus.Client.Transform.Inputs (renderNonOutputTypes, renderOperationArguments) import Data.Morpheus.Internal.Ext - ( Eventless, + ( GQLResult, ) import Data.Morpheus.Internal.Utils - ( Failure (..), - elems, - empty, + ( empty, keyOf, selectBy, ) import Data.Morpheus.Types.Internal.AST ( ANY, - ConsD (..), FieldDefinition (..), FieldName, Operation (..), @@ -55,7 +53,6 @@ mkTypeRef, msg, toAny, - toFieldName, ) import Relude hiding (empty, show) import Prelude (show) @@ -64,7 +61,7 @@ Schema VALID -> VariableDefinitions RAW -> Operation VALID -> - Eventless ClientDefinition + GQLResult ClientDefinition toClientDefinition schema vars = flip runReaderT (schema, vars) . runConverter . genOperation genOperation :: Operation VALID -> Converter ClientDefinition @@ -117,13 +114,13 @@ TypeDefinition ANY VALID -> SelectionSet VALID -> Converter - ( ClientConsD ANY, + ( ClientConstructorDefinition, [ClientTypeDefinition], [TypeName] ) genConsD path cName datatype selSet = do - (cFields, subTypes, requests) <- unzip3 <$> traverse genField (elems selSet) - pure (ConsD {cName, cFields}, concat subTypes, concat requests) + (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet) + pure (ClientConstructorDefinition {cName, cFields}, concat subTypes, concat requests) where genField :: Selection VALID -> @@ -165,10 +162,14 @@ leafType dType subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} = genRecordType path (typeFrom [] dType) dType selectionSet -subTypesBySelection path dType Selection {selectionContent = UnionSelection unionSelections} = +subTypesBySelection path dType Selection {selectionContent = UnionSelection interface unionSelections} = do (clientCons, subTypes, requests) <- - unzip3 <$> traverse getUnionType (elems unionSelections) + unzip3 + <$> traverse + getUnionType + ( UnionTag (typeName dType) interface : toList unionSelections + ) pure ( ClientTypeDefinition { clientTypeName = TypeNameTH path (typeFrom [] dType), @@ -201,7 +202,7 @@ { fieldName = "__typename", fieldDescription = Nothing, fieldType = mkTypeRef "String", - fieldDirectives = [], + fieldDirectives = empty, fieldContent = Nothing } | otherwise = withTypeContent typeContent @@ -211,7 +212,7 @@ withTypeContent DataInterface {interfaceFields} = selectBy selError selectionName interfaceFields >>= processDeprecation withTypeContent dt = - failure (compileError $ "Type should be output Object \"" <> msg (show dt)) + throwError (compileError $ "Type should be output Object \"" <> msg (show dt)) selError = compileError $ "can't find field " <> msg selectionName <> " on type: " <> msg (show typeContent) processDeprecation FieldDefinition @@ -227,4 +228,6 @@ checkDeprecated = deprecationWarning fieldDirectives - (toFieldName typeName, Ref {refName = selectionName, refPosition = selectionPosition}) + ( coerce typeName, + Ref {refName = selectionName, refPosition = selectionPosition} + ) diff --git a/test/Case/Enum/Test.hs b/test/Case/Enum/Test.hs --- a/test/Case/Enum/Test.hs +++ b/test/Case/Enum/Test.hs @@ -16,6 +16,7 @@ ) import Data.Morpheus.Client ( Fetch (..), + FetchError, gql, ) import Spec.Utils @@ -48,7 +49,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "Enum" -client :: IO (Either String MyQuery) +client :: IO (Either (FetchError MyQuery) MyQuery) client = fetch resolver MyQueryArgs {inputCity = CityAthens} test :: TestTree diff --git a/test/Case/Enum/response.json b/test/Case/Enum/response.json --- a/test/Case/Enum/response.json +++ b/test/Case/Enum/response.json @@ -1,6 +1,6 @@ { "data": { "city": "Athens", - "cities": ["Athens", "Sparta", "Corinth", "Delphi", "Argos"] + "cities": ["Athens", "Sparta", "Corinth", "delphi", "argos"] } } diff --git a/test/Case/Enum/schema.gql b/test/Case/Enum/schema.gql --- a/test/Case/Enum/schema.gql +++ b/test/Case/Enum/schema.gql @@ -2,8 +2,9 @@ Athens Sparta Corinth - Delphi - Argos + # test lowercase enum + delphi + argos } type Query { diff --git a/test/Case/Github/Test.hs b/test/Case/Github/Test.hs --- a/test/Case/Github/Test.hs +++ b/test/Case/Github/Test.hs @@ -20,6 +20,7 @@ ( DecodeScalar (..), EncodeScalar (..), Fetch (..), + FetchError, ScalarValue (..), gql, ) @@ -92,7 +93,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "Interface" -client :: IO (Either String GetTags) +client :: IO (Either (FetchError GetTags) GetTags) client = fetch resolver diff --git a/test/Case/Interface/Test.hs b/test/Case/Interface/Test.hs --- a/test/Case/Interface/Test.hs +++ b/test/Case/Interface/Test.hs @@ -18,6 +18,7 @@ ) import Data.Morpheus.Client ( Fetch (..), + FetchError, gql, ) import Data.Text (Text) @@ -76,7 +77,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "Interface" -client :: IO (Either String MyQuery) +client :: IO (Either (FetchError MyQuery) MyQuery) client = fetch resolver () testInterface :: TestTree @@ -88,39 +89,40 @@ ( MyQuery { character = [ CharacterDeity - { name = "Deity Name", - power = "Deity Power", - __typename = "Deity" + { __typename = "Deity", + name = "Deity Name", + power = "Deity Power" }, CharacterCharacter - { name = "Character Name", - __typename = "Character" + { __typename = "Character", + name = "Character Name" }, CharacterHero - { name = "Hero Name", - hobby = "Deity Power", - __typename = "Hero" + { __typename = "Hero", + name = "Hero Name", + hobby = "Deity Power" } ], character2 = [ Character2Character - { name1 = "test name", + { __typename = "Character", + name1 = "test name", name = "test name" } ], character3 = [ Character3Hero - { hobby = "Hero Hobby", - name2 = "Hero name2", - __typename = "Hero" + { __typename = "Hero", + hobby = "Hero Hobby", + name2 = "Hero name2" }, - Character3Deity - { name2 = "Hero name2", - __typename = "Deity" + Character3Character + { __typename = "Deity", + name2 = "Hero name2" }, Character3Character - { name2 = "Character name2", - __typename = "Character" + { __typename = "Character", + name2 = "Character name2" } ], character4 = @@ -128,8 +130,8 @@ { __typename = "Character" }, Character4Hero - { hobby = "Hero Hobby", - __typename = "Hero" + { __typename = "Hero", + hobby = "Hero Hobby" }, Character4Character { __typename = "Deity" diff --git a/test/Case/Interface/response.json b/test/Case/Interface/response.json --- a/test/Case/Interface/response.json +++ b/test/Case/Interface/response.json @@ -19,7 +19,8 @@ "character2": [ { "name1": "test name", - "name": "test name" + "name": "test name", + "__typename": "Character" } ], "character3": [ diff --git a/test/Case/Interface/schema.gql b/test/Case/Interface/schema.gql --- a/test/Case/Interface/schema.gql +++ b/test/Case/Interface/schema.gql @@ -3,7 +3,7 @@ } interface Supernatural { - power: [String!]! + power: String! } type Hero implements Character { diff --git a/test/Case/JSON/Custom/Errors.hs b/test/Case/JSON/Custom/Errors.hs new file mode 100644 --- /dev/null +++ b/test/Case/JSON/Custom/Errors.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.JSON.Custom.Errors + ( test, + ) +where + +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.List.NonEmpty + ( NonEmpty (..), + ) +import Data.Morpheus.Client + ( EncodeScalar (..), + Fetch (..), + FetchError (..), + ScalarValue (..), + gql, + ) +import Data.Morpheus.Types.Internal.AST + ( Position (..), + at, + withPath, + ) +import Data.Text (Text) +import Spec.Utils + ( defineClientWithJSON, + mockApi, + ) +import Test.Tasty + ( TestTree, + ) +import Test.Tasty.HUnit + ( assertEqual, + testCase, + ) +import Prelude + ( ($), + Either (..), + Eq (..), + IO, + Maybe (..), + Show, + ) + +newtype GitTimestamp = GitTimestamp + { unGitTimestamp :: Text + } + deriving (Eq, Show) + +instance EncodeScalar GitTimestamp where + encodeScalar (GitTimestamp x) = String x + +defineClientWithJSON + "JSON/Custom" + [gql| + query TestQuery + { + queryTypeName + } + |] + +resolver :: ByteString -> IO ByteString +resolver = mockApi "JSON/Custom/Errors" + +client :: IO (Either (FetchError TestQuery) TestQuery) +client = fetch resolver () + +test :: TestTree +test = testCase "test Errors" $ do + value <- client + assertEqual + "test custom Errors" + ( Left + ( FetchErrorProducedErrors + (("Failure" `at` Position {line = 3, column = 7}) `withPath` ["queryTypeName"] :| []) + (Just TestQuery {queryTypeName = Just "TestQuery"}) + ) + ) + value diff --git a/test/Case/JSON/Custom/Errors/response.json b/test/Case/JSON/Custom/Errors/response.json new file mode 100644 --- /dev/null +++ b/test/Case/JSON/Custom/Errors/response.json @@ -0,0 +1,19 @@ +{ + "data": { + "queryTypeName": "TestQuery" + }, + "errors": [ + { + "locations": [ + { + "line": 3, + "column": 7 + } + ], + "path": [ + "queryTypeName" + ], + "message": "Failure" + } + ] +} diff --git a/test/Case/JSON/Custom/Mutation.hs b/test/Case/JSON/Custom/Mutation.hs --- a/test/Case/JSON/Custom/Mutation.hs +++ b/test/Case/JSON/Custom/Mutation.hs @@ -18,6 +18,7 @@ ) import Data.Morpheus.Client ( Fetch (..), + FetchError, gql, ) import Data.Text (Text) @@ -52,7 +53,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "JSON/Custom/Mutation" -client :: IO (Either String TestMutation) +client :: IO (Either (FetchError TestMutation) TestMutation) client = fetch resolver () test :: TestTree diff --git a/test/Case/JSON/Custom/NoResponseOrError.hs b/test/Case/JSON/Custom/NoResponseOrError.hs new file mode 100644 --- /dev/null +++ b/test/Case/JSON/Custom/NoResponseOrError.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.JSON.Custom.NoResponseOrError + ( test, + ) +where + +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.Morpheus.Client + ( EncodeScalar (..), + Fetch (..), + FetchError (..), + ScalarValue (..), + gql, + ) +import Data.Text (Text) +import Spec.Utils + ( defineClientWithJSON, + mockApi, + ) +import Test.Tasty + ( TestTree, + ) +import Test.Tasty.HUnit + ( assertEqual, + testCase, + ) +import Prelude + ( Either (..), + Eq (..), + IO, + Show, + ($), + ) + +newtype GitTimestamp = GitTimestamp + { unGitTimestamp :: Text + } + deriving (Eq, Show) + +instance EncodeScalar GitTimestamp where + encodeScalar (GitTimestamp x) = String x + +defineClientWithJSON + "JSON/Custom" + [gql| + query TestQuery + { + queryTypeName + } + |] + +resolver :: ByteString -> IO ByteString +resolver = mockApi "JSON/Custom/NoResponseOrError" + +client :: IO (Either (FetchError TestQuery) TestQuery) +client = fetch resolver () + +test :: TestTree +test = testCase "test NoResponseOrError" $ do + value <- client + assertEqual + "test custom NoResponseOrError" + ( Left FetchErrorNoResult + ) + value diff --git a/test/Case/JSON/Custom/NoResponseOrError/response.json b/test/Case/JSON/Custom/NoResponseOrError/response.json new file mode 100644 --- /dev/null +++ b/test/Case/JSON/Custom/NoResponseOrError/response.json @@ -0,0 +1,1 @@ +{} diff --git a/test/Case/JSON/Custom/PartialResponse.hs b/test/Case/JSON/Custom/PartialResponse.hs new file mode 100644 --- /dev/null +++ b/test/Case/JSON/Custom/PartialResponse.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.JSON.Custom.PartialResponse + ( test, + ) +where + +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.Morpheus.Client + ( EncodeScalar (..), + Fetch (..), + FetchError (..), + ScalarValue (..), + gql, + ) +import Data.Text (Text) +import Spec.Utils + ( defineClientWithJSON, + mockApi, + ) +import Test.Tasty + ( TestTree, + ) +import Test.Tasty.HUnit + ( assertEqual, + testCase, + ) +import Prelude + ( Either (..), + Eq (..), + IO, + Show, + String, + ($), + ) + +newtype GitTimestamp = GitTimestamp + { unGitTimestamp :: Text + } + deriving (Eq, Show) + +instance EncodeScalar GitTimestamp where + encodeScalar (GitTimestamp x) = String x + +defineClientWithJSON + "JSON/Custom" + [gql| + query TestQuery + { + queryTypeName + } + |] + +resolver :: ByteString -> IO ByteString +resolver = mockApi "JSON/Custom/PartialResponse" + +client :: IO (Either (FetchError TestQuery) TestQuery) +client = fetch resolver () + +test :: TestTree +test = testCase "test PartialResponse" $ do + value <- client + assertEqual + "test custom PartialResponse" + ( Left + (FetchErrorParseFailure "Error in $.data.queryTypeName: parsing Text failed, expected String, but encountered Number") + ) + value diff --git a/test/Case/JSON/Custom/PartialResponse/response.json b/test/Case/JSON/Custom/PartialResponse/response.json new file mode 100644 --- /dev/null +++ b/test/Case/JSON/Custom/PartialResponse/response.json @@ -0,0 +1,6 @@ +{ + "data": { + "queryTypeName": 1 + }, + "errors": [] +} diff --git a/test/Case/JSON/Custom/Query.hs b/test/Case/JSON/Custom/Query.hs --- a/test/Case/JSON/Custom/Query.hs +++ b/test/Case/JSON/Custom/Query.hs @@ -19,6 +19,7 @@ import Data.Morpheus.Client ( EncodeScalar (..), Fetch (..), + FetchError, ScalarValue (..), gql, ) @@ -64,7 +65,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "JSON/Custom/Query" -client :: IO (Either String TestQuery) +client :: IO (Either (FetchError TestQuery) TestQuery) client = fetch resolver () test :: TestTree diff --git a/test/Case/JSON/Custom/Subscription.hs b/test/Case/JSON/Custom/Subscription.hs --- a/test/Case/JSON/Custom/Subscription.hs +++ b/test/Case/JSON/Custom/Subscription.hs @@ -18,6 +18,7 @@ ) import Data.Morpheus.Client ( Fetch (..), + FetchError, gql, ) import Data.Text (Text) @@ -52,7 +53,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "JSON/Custom/Subscription" -client :: IO (Either String TestSubscription) +client :: IO (Either (FetchError TestSubscription) TestSubscription) client = fetch resolver () test :: TestTree diff --git a/test/Case/LowercaseTypeName/Test.hs b/test/Case/LowercaseTypeName/Test.hs --- a/test/Case/LowercaseTypeName/Test.hs +++ b/test/Case/LowercaseTypeName/Test.hs @@ -21,6 +21,7 @@ ( DecodeScalar (..), EncodeScalar (..), Fetch (..), + FetchError(..), ScalarValue (..), gql, ) @@ -71,7 +72,7 @@ resolver :: ByteString -> IO ByteString resolver = mockApi "LowercaseTypeName" -client :: IO (Either String MyQuery) +client :: IO (Either (FetchError MyQuery) MyQuery) client = fetch resolver () testLowercaseTypeName :: TestTree diff --git a/test/Case/Scalar/Test.hs b/test/Case/Scalar/Test.hs new file mode 100644 --- /dev/null +++ b/test/Case/Scalar/Test.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.Scalar.Test + ( test, + ) +where + +import Data.ByteString.Lazy.Char8 + ( ByteString, + ) +import Data.Morpheus.Client + ( Fetch (..), + FetchError(..), + gql, + ) +import Data.Text (Text) +import Spec.Utils + ( defineClientWith, + mockApi, + ) +import Test.Tasty + ( TestTree, + ) +import Test.Tasty.HUnit + ( assertEqual, + testCase, + ) +import Prelude + ( ($), + Bool (True), + Double, + Either (..), + IO, + Int, + String, + ) + +defineClientWith + "Scalar" + [gql| + query MyQuery( + $inputBolean: Boolean! + $inputInt: Int! + $inputFloat: Float! + $inputString: String! + ) { + booleanResolver(booleanValue: $inputBolean) + intResolver(intValue: $inputInt) + floatResolver(booleanValue: $inputFloat) + stringResolver(stringValue: $inputString) + } + |] + +resolver :: ByteString -> IO ByteString +resolver = mockApi "Scalar" + +-- GraphQL Boolean types must be represented with Haskell Bool types +testBoolean :: Bool +testBoolean = True + +-- GraphQL Int types must be represented with Haskell Int types +testInt :: Int +testInt = 1242345 + +-- GraphQL Float types must be represented with Haskell Double types +testFloat :: Double +testFloat = 21233.1234145 + +-- GraphQL String types must be represented with Haskell Text types +testText :: Text +testText = "Athens" + +client :: IO (Either (FetchError MyQuery) MyQuery) +client = + fetch + resolver + MyQueryArgs + { inputBolean = testBoolean, + inputInt = testInt, + inputFloat = testFloat, + inputString = testText + } + +test :: TestTree +test = testCase "test Scalar" $ do + value <- client + assertEqual + "test Scalar" + ( Right + ( MyQuery + { booleanResolver = testBoolean, + intResolver = testInt, + floatResolver = testFloat, + stringResolver = testText + } + ) + ) + value diff --git a/test/Case/Scalar/response.json b/test/Case/Scalar/response.json new file mode 100644 --- /dev/null +++ b/test/Case/Scalar/response.json @@ -0,0 +1,8 @@ +{ + "data": { + "booleanResolver": true, + "intResolver": 1242345, + "floatResolver": 21233.1234145, + "stringResolver": "Athens" + } +} diff --git a/test/Case/Scalar/schema.gql b/test/Case/Scalar/schema.gql new file mode 100644 --- /dev/null +++ b/test/Case/Scalar/schema.gql @@ -0,0 +1,6 @@ +type Query { + booleanResolver(booleanValue: Boolean!): Boolean! + intResolver(intValue: Int!): Int! + floatResolver(booleanValue: Float!): Float! + stringResolver(stringValue: String!): String! +} diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -8,12 +8,16 @@ import qualified Case.Enum.Test as Enum import Case.Interface.Test (testInterface) +import qualified Case.JSON.Custom.Errors as JSONCustomErrors +import qualified Case.JSON.Custom.NoResponseOrError as JSONNoResponseOrError import qualified Case.JSON.Custom.Mutation as JSONCustomMutation +import qualified Case.JSON.Custom.PartialResponse as JSONCustomPartialResponse import qualified Case.JSON.Custom.Query as JSONCustomQuery import qualified Case.JSON.Custom.Subscription as JSONCustomSubscription import Case.LowercaseTypeName.Test ( testLowercaseTypeName, ) +import qualified Case.Scalar.Test as Scalar import Test.Tasty ( defaultMain, testGroup, @@ -31,7 +35,11 @@ [ testInterface, testLowercaseTypeName, Enum.test, + Scalar.test, + JSONCustomErrors.test, JSONCustomMutation.test, + JSONCustomPartialResponse.test, JSONCustomQuery.test, - JSONCustomSubscription.test + JSONCustomSubscription.test, + JSONNoResponseOrError.test ] diff --git a/test/Spec/Utils.hs b/test/Spec/Utils.hs --- a/test/Spec/Utils.hs +++ b/test/Spec/Utils.hs @@ -18,7 +18,8 @@ ) import Data.Morpheus.Types.Internal.AST ( ExecutableDocument, - FieldName (..), + FieldName, + unpackName, ) import Data.Semigroup ((<>)) import qualified Data.Text as T @@ -36,7 +37,7 @@ ) path :: FieldName -> FilePath -path (FieldName name) = "test/Case/" <> T.unpack name +path name = "test/Case/" <> T.unpack (unpackName name) withProject :: FilePath -> FilePath withProject = ("morpheus-graphql-client/" <>)