morpheus-graphql-client 0.17.0 → 0.18.0
raw patch · 38 files changed
+663/−206 lines, 38 filesdep +morpheus-graphql-code-gendep ~morpheus-graphql-corePVP ok
version bump matches the API change (PVP)
Dependencies added: morpheus-graphql-code-gen
Dependency ranges changed: morpheus-graphql-core
API changes (from Hackage documentation)
+ Data.Morpheus.Client: FetchErrorNoResult :: FetchError a
+ Data.Morpheus.Client: FetchErrorParseFailure :: String -> FetchError a
+ Data.Morpheus.Client: FetchErrorProducedErrors :: GQLErrors -> Maybe a -> FetchError a
+ Data.Morpheus.Client: data FetchError a
+ Data.Morpheus.Client: defineByDocumentFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec]
+ Data.Morpheus.Client: defineByIntrospectionFile' :: Q FilePath -> (ExecutableDocument, String) -> Q [Dec]
- Data.Morpheus.Client: __fetch :: (Fetch a, Monad m, Show a, ToJSON (Args a), FromJSON a) => String -> FieldName -> (ByteString -> m ByteString) -> Args a -> m (Either String a)
+ Data.Morpheus.Client: __fetch :: (Fetch a, Monad m, Show a, ToJSON (Args a), FromJSON a) => String -> FieldName -> (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a)
- Data.Morpheus.Client: defineQuery :: IO (Eventless (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec]
+ Data.Morpheus.Client: defineQuery :: IO (GQLResult (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec]
- Data.Morpheus.Client: fetch :: (Fetch a, Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a)
+ Data.Morpheus.Client: fetch :: (Fetch a, Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a)
Files
- changelog.md +12/−0
- morpheus-graphql-client.cabal +17/−6
- src/Data/Morpheus/Client.hs +16/−2
- src/Data/Morpheus/Client/Build.hs +3/−3
- src/Data/Morpheus/Client/Declare/Aeson.hs +30/−34
- src/Data/Morpheus/Client/Declare/Client.hs +1/−1
- src/Data/Morpheus/Client/Declare/Type.hs +11/−9
- src/Data/Morpheus/Client/Fetch.hs +10/−6
- src/Data/Morpheus/Client/Internal/TH.hs +13/−13
- src/Data/Morpheus/Client/Internal/Types.hs +16/−4
- src/Data/Morpheus/Client/Internal/Utils.hs +3/−4
- src/Data/Morpheus/Client/JSONSchema/Parse.hs +30/−31
- src/Data/Morpheus/Client/JSONSchema/Types.hs +3/−2
- src/Data/Morpheus/Client/Transform/Core.hs +26/−29
- src/Data/Morpheus/Client/Transform/Inputs.hs +13/−12
- src/Data/Morpheus/Client/Transform/Selection.hs +19/−16
- test/Case/Enum/Test.hs +2/−1
- test/Case/Enum/response.json +1/−1
- test/Case/Enum/schema.gql +3/−2
- test/Case/Github/Test.hs +2/−1
- test/Case/Interface/Test.hs +22/−20
- test/Case/Interface/response.json +2/−1
- test/Case/Interface/schema.gql +1/−1
- test/Case/JSON/Custom/Errors.hs +89/−0
- test/Case/JSON/Custom/Errors/response.json +19/−0
- test/Case/JSON/Custom/Mutation.hs +2/−1
- test/Case/JSON/Custom/NoResponseOrError.hs +76/−0
- test/Case/JSON/Custom/NoResponseOrError/response.json +1/−0
- test/Case/JSON/Custom/PartialResponse.hs +78/−0
- test/Case/JSON/Custom/PartialResponse/response.json +6/−0
- test/Case/JSON/Custom/Query.hs +2/−1
- test/Case/JSON/Custom/Subscription.hs +2/−1
- test/Case/LowercaseTypeName/Test.hs +2/−1
- test/Case/Scalar/Test.hs +104/−0
- test/Case/Scalar/response.json +8/−0
- test/Case/Scalar/schema.gql +6/−0
- test/Spec.hs +9/−1
- test/Spec/Utils.hs +3/−2
changelog.md view
@@ -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
morpheus-graphql-client.cabal view
@@ -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
src/Data/Morpheus/Client.hs view
@@ -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]
src/Data/Morpheus/Client/Build.hs view
@@ -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
src/Data/Morpheus/Client/Declare/Aeson.hs view
@@ -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
src/Data/Morpheus/Client/Declare/Client.hs view
@@ -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)
src/Data/Morpheus/Client/Declare/Type.hs view
@@ -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
src/Data/Morpheus/Client/Fetch.hs view
@@ -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 =
src/Data/Morpheus/Client/Internal/TH.hs view
@@ -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
src/Data/Morpheus/Client/Internal/Types.hs view
@@ -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)
src/Data/Morpheus/Client/Internal/Utils.hs view
@@ -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)
src/Data/Morpheus/Client/JSONSchema/Parse.hs view
@@ -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)
src/Data/Morpheus/Client/JSONSchema/Types.hs view
@@ -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)
src/Data/Morpheus/Client/Transform/Core.hs view
@@ -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 ()
src/Data/Morpheus/Client/Transform/Inputs.hs view
@@ -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,
src/Data/Morpheus/Client/Transform/Selection.hs view
@@ -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}+ )
test/Case/Enum/Test.hs view
@@ -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
test/Case/Enum/response.json view
@@ -1,6 +1,6 @@ { "data": { "city": "Athens",- "cities": ["Athens", "Sparta", "Corinth", "Delphi", "Argos"]+ "cities": ["Athens", "Sparta", "Corinth", "delphi", "argos"] } }
test/Case/Enum/schema.gql view
@@ -2,8 +2,9 @@ Athens Sparta Corinth- Delphi- Argos+ # test lowercase enum+ delphi+ argos } type Query {
test/Case/Github/Test.hs view
@@ -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
test/Case/Interface/Test.hs view
@@ -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"
test/Case/Interface/response.json view
@@ -19,7 +19,8 @@ "character2": [ { "name1": "test name",- "name": "test name"+ "name": "test name",+ "__typename": "Character" } ], "character3": [
test/Case/Interface/schema.gql view
@@ -3,7 +3,7 @@ } interface Supernatural {- power: [String!]!+ power: String! } type Hero implements Character {
+ test/Case/JSON/Custom/Errors.hs view
@@ -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
+ test/Case/JSON/Custom/Errors/response.json view
@@ -0,0 +1,19 @@+{+ "data": {+ "queryTypeName": "TestQuery"+ },+ "errors": [+ {+ "locations": [+ {+ "line": 3,+ "column": 7+ }+ ],+ "path": [+ "queryTypeName"+ ],+ "message": "Failure"+ }+ ]+}
test/Case/JSON/Custom/Mutation.hs view
@@ -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
+ test/Case/JSON/Custom/NoResponseOrError.hs view
@@ -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
+ test/Case/JSON/Custom/NoResponseOrError/response.json view
@@ -0,0 +1,1 @@+{}
+ test/Case/JSON/Custom/PartialResponse.hs view
@@ -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
+ test/Case/JSON/Custom/PartialResponse/response.json view
@@ -0,0 +1,6 @@+{+ "data": {+ "queryTypeName": 1+ },+ "errors": []+}
test/Case/JSON/Custom/Query.hs view
@@ -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
test/Case/JSON/Custom/Subscription.hs view
@@ -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
test/Case/LowercaseTypeName/Test.hs view
@@ -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
+ test/Case/Scalar/Test.hs view
@@ -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
+ test/Case/Scalar/response.json view
@@ -0,0 +1,8 @@+{+ "data": {+ "booleanResolver": true,+ "intResolver": 1242345,+ "floatResolver": 21233.1234145,+ "stringResolver": "Athens"+ }+}
+ test/Case/Scalar/schema.gql view
@@ -0,0 +1,6 @@+type Query {+ booleanResolver(booleanValue: Boolean!): Boolean!+ intResolver(intValue: Int!): Int!+ floatResolver(booleanValue: Float!): Float!+ stringResolver(stringValue: String!): String!+}
test/Spec.hs view
@@ -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 ]
test/Spec/Utils.hs view
@@ -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/" <>)