diff --git a/morpheus-graphql-client.cabal b/morpheus-graphql-client.cabal --- a/morpheus-graphql-client.cabal +++ b/morpheus-graphql-client.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: morpheus-graphql-client -version: 0.19.3 +version: 0.20.0 synopsis: Morpheus GraphQL Client description: Build GraphQL APIs with your favourite functional language! category: web, graphql, client @@ -22,22 +22,30 @@ changelog.md data-files: test/Case/Enum/schema.gql + test/Case/Github/query.gql test/Case/Github/schema.gql + test/Case/Interface/query.gql test/Case/Interface/schema.gql + test/Case/LocalGlobal/schema.gql + test/Case/LocalGlobal/users1.gql + test/Case/LocalGlobal/users2.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/ErrorsWithType/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/LocalGlobal/cities.json + test/Case/LocalGlobal/users1.json + test/Case/LocalGlobal/users2.json test/Case/LowercaseTypeName/response.json + test/Case/ResponseTypes/errors.json + test/Case/ResponseTypes/errorsWithType.json + test/Case/ResponseTypes/mutation.json + test/Case/ResponseTypes/noResponseOrError.json + test/Case/ResponseTypes/partialResponse.json + test/Case/ResponseTypes/query.json + test/Case/ResponseTypes/schema.json + test/Case/ResponseTypes/subscription.json test/Case/Scalar/response.json source-repository head @@ -48,37 +56,43 @@ exposed-modules: Data.Morpheus.Client other-modules: - Data.Morpheus.Client.Build + Data.Morpheus.Client.Declare Data.Morpheus.Client.Declare.Aeson Data.Morpheus.Client.Declare.Client + Data.Morpheus.Client.Declare.Fetch Data.Morpheus.Client.Declare.Type Data.Morpheus.Client.Fetch Data.Morpheus.Client.Internal.TH Data.Morpheus.Client.Internal.Types Data.Morpheus.Client.Internal.Utils - Data.Morpheus.Client.JSONSchema.Parse - Data.Morpheus.Client.JSONSchema.TypeKind - Data.Morpheus.Client.JSONSchema.TypeRef - Data.Morpheus.Client.JSONSchema.Types + Data.Morpheus.Client.QuasiQuoter + Data.Morpheus.Client.Schema.JSON.Parse + Data.Morpheus.Client.Schema.JSON.TypeKind + Data.Morpheus.Client.Schema.JSON.TypeRef + Data.Morpheus.Client.Schema.JSON.Types + Data.Morpheus.Client.Schema.Parse + Data.Morpheus.Client.Transform Data.Morpheus.Client.Transform.Core - Data.Morpheus.Client.Transform.Inputs - Data.Morpheus.Client.Transform.Selection + Data.Morpheus.Client.Transform.Global + Data.Morpheus.Client.Transform.Local Paths_morpheus_graphql_client hs-source-dirs: src ghc-options: -Wall build-depends: - aeson >=1.4.4.0 && <3 - , base >=4.7 && <5 - , bytestring >=0.10.4 && <0.11 - , morpheus-graphql-code-gen >=0.19.0 && <0.20.0 - , morpheus-graphql-core >=0.19.0 && <0.20.0 - , mtl >=2.0 && <3.0 - , relude >=0.3.0 && <2.0 - , template-haskell >=2.0 && <3.0 - , text >=1.2.3.0 && <1.3 - , transformers >=0.3 && <0.6 - , unordered-containers >=0.2.8.0 && <0.3 + aeson >=1.4.4 && <3.0.0 + , base >=4.7.0 && <5.0.0 + , bytestring >=0.10.4 && <0.12.0 + , containers >=0.4.2.1 && <0.7.0 + , file-embed >=0.0.10 && <1.0.0 + , morpheus-graphql-code-gen >=0.20.0 && <0.21.0 + , morpheus-graphql-core >=0.20.0 && <0.21.0 + , mtl >=2.0.0 && <3.0.0 + , relude >=0.3.0 && <2.0.0 + , template-haskell >=2.0.0 && <3.0.0 + , text >=1.2.3 && <1.3.0 + , transformers >=0.3.0 && <0.6.0 + , unordered-containers >=0.2.8 && <0.3.0 default-language: Haskell2010 test-suite morpheus-graphql-client-test @@ -88,14 +102,10 @@ Case.Enum.Test Case.Github.Test Case.Interface.Test - Case.JSON.Custom.Errors - Case.JSON.Custom.ErrorsWithType - Case.JSON.Custom.Mutation - Case.JSON.Custom.NoResponseOrError - Case.JSON.Custom.PartialResponse - Case.JSON.Custom.Query - Case.JSON.Custom.Subscription + Case.LocalGlobal.Api + Case.LocalGlobal.Test Case.LowercaseTypeName.Test + Case.ResponseTypes.Test Case.Scalar.Test Spec.Utils Paths_morpheus_graphql_client @@ -103,19 +113,21 @@ test ghc-options: -Wall build-depends: - aeson >=1.4.4.0 && <3 - , base >=4.7 && <5 - , bytestring >=0.10.4 && <0.11 - , directory >=1.0 && <2.0 + aeson >=1.4.4 && <3.0.0 + , base >=4.7.0 && <5.0.0 + , bytestring >=0.10.4 && <0.12.0 + , containers >=0.4.2.1 && <0.7.0 + , directory >=1.0.0 && <2.0.0 + , file-embed >=0.0.10 && <1.0.0 , morpheus-graphql-client - , morpheus-graphql-code-gen >=0.19.0 && <0.20.0 - , morpheus-graphql-core >=0.19.0 && <0.20.0 - , mtl >=2.0 && <3.0 - , relude >=0.3.0 && <2.0 - , tasty >=0.1 && <1.5 - , tasty-hunit >=0.1 && <1.0 - , template-haskell >=2.0 && <3.0 - , text >=1.2.3.0 && <1.3 - , transformers >=0.3 && <0.6 - , unordered-containers >=0.2.8.0 && <0.3 + , morpheus-graphql-code-gen >=0.20.0 && <0.21.0 + , morpheus-graphql-core >=0.20.0 && <0.21.0 + , mtl >=2.0.0 && <3.0.0 + , relude >=0.3.0 && <2.0.0 + , tasty >=0.1.0 && <1.5.0 + , tasty-hunit >=0.1.0 && <1.0.0 + , template-haskell >=2.0.0 && <3.0.0 + , text >=1.2.3 && <1.3.0 + , transformers >=0.3.0 && <0.6.0 + , unordered-containers >=0.2.8 && <0.3.0 default-language: Haskell2010 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 @@ -2,20 +2,26 @@ {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client - ( gql, + ( raw, Fetch (..), - FetchError(..), - defineQuery, + FetchError (..), + ScalarValue (..), + DecodeScalar (..), + EncodeScalar (..), + ID (..), + declareGlobalTypes, + declareGlobalTypesByName, + declareLocalTypes, + declareLocalTypesInline, + clientTypeDeclarations, + -- DEPRECATED EXPORTS + gql, defineByDocument, defineByDocumentFile, defineByDocumentFile', defineByIntrospection, defineByIntrospectionFile, defineByIntrospectionFile', - ScalarValue (..), - DecodeScalar (..), - EncodeScalar (..), - ID (..), ) where @@ -23,65 +29,76 @@ import qualified Data.ByteString.Lazy as L ( readFile, ) -import Data.Morpheus.Client.Build - ( defineQuery, +import Data.Morpheus.Client.Declare + ( clientTypeDeclarations, + declareGlobalTypes, + declareGlobalTypesByName, + declareLocalTypes, + declareLocalTypesInline, + internalLegacyLocalDeclareTypes, + raw, ) import Data.Morpheus.Client.Fetch ( Fetch (..), ) -import Data.Morpheus.Client.JSONSchema.Parse - ( decodeIntrospection, - ) import Data.Morpheus.Client.Internal.Types - ( FetchError(..), - ) -import Data.Morpheus.Core - ( parseFullSchema, - ) -import Data.Morpheus.Internal.Ext - ( GQLResult, + ( ExecutableSource, + FetchError (..), + SchemaSource (..), ) -import Data.Morpheus.QuasiQuoter (gql) import Data.Morpheus.Types.GQLScalar ( DecodeScalar (..), EncodeScalar (..), ) import Data.Morpheus.Types.ID (ID (..)) import Data.Morpheus.Types.Internal.AST - ( ExecutableDocument, - ScalarValue (..), - Schema, - VALID, + ( ScalarValue (..), ) import Language.Haskell.TH +import Language.Haskell.TH.Quote (QuasiQuoter) import Language.Haskell.TH.Syntax ( qAddDependentFile, ) import Relude hiding (ByteString) -defineByDocumentFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec] -defineByDocumentFile filePath args = do - qAddDependentFile filePath - defineByDocument (L.readFile filePath) args +{-# DEPRECATED gql "use raw" #-} +gql :: QuasiQuoter +gql = raw +-- DEPRECATED: Legacy Code Exports + +{-# DEPRECATED defineByDocumentFile' "use declareLocalTypes" #-} + -- | 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' :: Q FilePath -> ExecutableSource -> Q [Dec] defineByDocumentFile' qFilePath args = qFilePath >>= flip defineByDocumentFile args -defineByIntrospectionFile :: FilePath -> (ExecutableDocument, String) -> Q [Dec] +{-# DEPRECATED defineByIntrospectionFile' "use declareLocalTypes" #-} + +-- | 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 -> ExecutableSource -> Q [Dec] +defineByIntrospectionFile' path args = path >>= flip defineByIntrospectionFile args + +-- with file + +{-# DEPRECATED defineByIntrospectionFile "use declareLocalTypes" #-} +defineByIntrospectionFile :: FilePath -> ExecutableSource -> 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 +{-# DEPRECATED defineByDocumentFile "use declareLocalTypes" #-} +defineByDocumentFile :: FilePath -> ExecutableSource -> Q [Dec] +defineByDocumentFile filePath args = do + qAddDependentFile filePath + defineByDocument (L.readFile filePath) args -defineByDocument :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec] -defineByDocument doc = defineQuery (schemaByDocument doc) +-- direct -schemaByDocument :: IO ByteString -> IO (GQLResult (Schema VALID)) -schemaByDocument = fmap parseFullSchema +{-# DEPRECATED defineByDocument "use clientTypeDeclarations" #-} +defineByDocument :: IO ByteString -> ExecutableSource -> Q [Dec] +defineByDocument doc = internalLegacyLocalDeclareTypes (GQL <$> doc) -defineByIntrospection :: IO ByteString -> (ExecutableDocument, String) -> Q [Dec] -defineByIntrospection json = defineQuery (decodeIntrospection <$> json) +{-# DEPRECATED defineByIntrospection "use clientTypeDeclarations" #-} +defineByIntrospection :: IO ByteString -> ExecutableSource -> Q [Dec] +defineByIntrospection doc = internalLegacyLocalDeclareTypes (JSON <$> doc) diff --git a/src/Data/Morpheus/Client/Build.hs b/src/Data/Morpheus/Client/Build.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Build.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Build - ( defineQuery, - ) -where - --- --- MORPHEUS -import Data.Morpheus.Client.Declare.Client - ( declareClient, - ) -import Data.Morpheus.Client.Internal.Types - ( ClientDefinition (..), - ) -import Data.Morpheus.Client.Transform.Selection - ( toClientDefinition, - ) -import Data.Morpheus.Core - ( Config (..), - VALIDATION_MODE (..), - validateRequest, - ) -import Data.Morpheus.Error - ( gqlWarnings, - renderGQLErrors, - ) -import Data.Morpheus.Internal.Ext - ( GQLResult, - Result (..), - ) -import Data.Morpheus.Types.Internal.AST - ( ExecutableDocument (..), - Operation (..), - Schema, - VALID, - ) -import Language.Haskell.TH -import Relude - -defineQuery :: IO (GQLResult (Schema VALID)) -> (ExecutableDocument, String) -> Q [Dec] -defineQuery ioSchema (query, src) = do - schema <- runIO ioSchema - case schema >>= (`validateWith` query) of - Failure errors -> fail (renderGQLErrors errors) - Success - { result, - warnings - } -> gqlWarnings warnings >> declareClient src result - -validateWith :: Schema VALID -> ExecutableDocument -> GQLResult ClientDefinition -validateWith - schema - rawRequest@ExecutableDocument - { operation = Operation {operationArguments} - } = do - validOperation <- validateRequest Config {debug = False, validationMode = WITHOUT_VARIABLES} schema rawRequest - toClientDefinition - schema - operationArguments - validOperation diff --git a/src/Data/Morpheus/Client/Declare.hs b/src/Data/Morpheus/Client/Declare.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Declare.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Declare + ( declareGlobalTypes, + declareGlobalTypesByName, + declareLocalTypes, + declareLocalTypesInline, + internalLegacyLocalDeclareTypes, + clientTypeDeclarations, + raw, + ) +where + +import Data.Morpheus.Client.Declare.Client + ( declareTypes, + ) +import Data.Morpheus.Client.Declare.Fetch +import Data.Morpheus.Client.Internal.Types + ( ExecutableSource, + SchemaSource, + ) +import Data.Morpheus.Client.Internal.Utils (getFile, getSource, handleResult) +import Data.Morpheus.Client.QuasiQuoter (raw) +import Data.Morpheus.Client.Schema.Parse (parseSchema) +import Data.Morpheus.Client.Transform + ( toGlobalDefinitions, + toLocalDefinitions, + ) +import Data.Morpheus.CodeGen.Internal.AST +import Data.Morpheus.Core (parseRequest) +import Data.Morpheus.Types.IO (GQLRequest (..)) +import Data.Set +import qualified Data.Set as S +import Language.Haskell.TH (Dec, Q, runIO) +import Relude + +internalLegacyLocalDeclareTypes :: IO SchemaSource -> ExecutableSource -> Q [Dec] +internalLegacyLocalDeclareTypes schemaSrc query = do + schemaText <- runIO schemaSrc + let request = + GQLRequest + { query, + operationName = Nothing, + variables = Nothing + } + handleResult + ( do + schemaDoc <- parseSchema schemaText + executableDoc <- parseRequest request + toLocalDefinitions executableDoc schemaDoc + ) + ( \(fetch, types) -> + (<>) + <$> declareFetch query fetch + <*> declareTypes types + ) + +globalTypeDeclarations :: SchemaSource -> (TypeName -> Bool) -> Q [Dec] +globalTypeDeclarations src f = handleResult (toGlobalDefinitions f <$> parseSchema src) declareTypes + +-- | declares global or local types, depending +-- on whether the second argument is specified or not +clientTypeDeclarations :: + SchemaSource -> + Maybe ExecutableSource -> + Q [Dec] +clientTypeDeclarations src (Just doc) = internalLegacyLocalDeclareTypes (pure src) doc +clientTypeDeclarations src Nothing = globalTypeDeclarations src (const True) + +{- ORMOLU_DISABLE -} +-- | declares input, enum and scalar types for specified schema +-- +-- Example where the schema is defined in SDL format +-- +-- @ +-- 'declareGlobalTypes' "schema.gql" +-- @ +-- +-- Example with schema as introspection in JSON format. +-- +-- @ +-- 'declareGlobalTypes' "schema.json" +-- @ +declareGlobalTypes :: + FilePath -- ^ the schema path relative to the project location, + -- both introspection (.json) and + -- schema definition (.gql, .graphql) are accepted. + -> Q [Dec] +declareGlobalTypes = flip declareClientTypes Nothing +{- ORMOLU_ENABLE -} + +-- | declares global types like 'declareGlobalTypes', +-- while enabling to select only the types that are needed. +declareGlobalTypesByName :: FilePath -> [TypeName] -> Q [Dec] +declareGlobalTypesByName path names = do + schema <- getSource path + globalTypeDeclarations schema (`member` S.fromList names) + +{- ORMOLU_DISABLE -} +-- | declares object, interface and union types for +-- specified schema and query. +-- +-- Example where the schema is defined in SDL format +-- +-- @ +-- 'declareLocalTypes' "schema.gql" "query.gql" +-- @ +-- +-- Example with schema as introspection in JSON format. +-- +-- @ +-- 'declareLocalTypes' "schema.json" "query.gql" +-- @ +declareLocalTypes :: + FilePath -- ^ the schema path relative to the project location. + -- both introspection (`.json`) and + -- schema definition (`.gql`, `.graphql`) are accepted. + -> FilePath -- ^ query path relative to the project location + -> Q [Dec] +declareLocalTypes schema query = declareClientTypes schema (Just query) +{- ORMOLU_ENABLE -} + +{- ORMOLU_DISABLE -} +-- | inline version of `declareLocalTypes`, however +-- instead of specifying the file path, you can simply +-- pass the query as text using QuasiQuoter `raw` +-- +-- @ +-- `declareLocalTypesInline` "schema.gql" +-- [`raw`| +-- query GetUsers { +-- users { +-- name +-- } +-- } +-- ] +-- @ +declareLocalTypesInline :: + FilePath -- ^ the schema path relative to the project location. + -- both introspection (`.json`) and + -- schema definition (`.gql`, `.graphql`) are accepted. + -> ExecutableSource -- ^ inline graphql query in Text format + -> Q [Dec] +declareLocalTypesInline schemaPath query = do + schema <- getSource schemaPath + clientTypeDeclarations schema (Just query) +{- ORMOLU_ENABLE -} + +declareClientTypes :: + FilePath -> + Maybe FilePath -> + Q [Dec] +declareClientTypes schemaPath queryPath = do + schema <- getSource schemaPath + query <- traverse getFile queryPath + clientTypeDeclarations schema query 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 @@ -1,11 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client.Declare.Client - ( declareClient, + ( declareTypes, ) where @@ -15,48 +14,17 @@ import Data.Morpheus.Client.Declare.Type ( typeDeclarations, ) -import Data.Morpheus.Client.Fetch - ( deriveFetch, - ) import Data.Morpheus.Client.Internal.Types - ( ClientDefinition (..), - ClientTypeDefinition (..), - TypeNameTH (..), + ( ClientTypeDefinition (..), ) -import Data.Morpheus.CodeGen.Internal.TH (toCon) import Language.Haskell.TH import Relude hiding (Type) -declareClient :: String -> ClientDefinition -> Q [Dec] -declareClient _ ClientDefinition {clientTypes = []} = pure [] -declareClient src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} = - (<>) - <$> defineOperationType - (queryArgumentType clientArguments) - src - rootType - <*> (concat <$> traverse declareType subTypes) +declareTypes :: [ClientTypeDefinition] -> Q [Dec] +declareTypes subTypes = concat <$> traverse declareType subTypes declareType :: ClientTypeDefinition -> Q [Dec] -declareType clientType@ClientTypeDefinition{clientKind} = do - types <- typeDeclarations clientKind clientType - instances <- aesonDeclarations clientKind clientType - pure (types <> instances) - -queryArgumentType :: Maybe ClientTypeDefinition -> (Type, Q [Dec]) -queryArgumentType Nothing = (toCon ("()" :: String), pure []) -queryArgumentType (Just client@ClientTypeDefinition {clientTypeName}) = - (toCon (typename clientTypeName), declareType client) - -defineOperationType :: (Type, Q [Dec]) -> String -> ClientTypeDefinition -> Q [Dec] -defineOperationType - (argType, argumentTypes) - query - clientType@ClientTypeDefinition - { clientTypeName = TypeNameTH {typename} - } = - do - rootType <- declareType clientType - typeClassFetch <- deriveFetch argType typename query - argsT <- argumentTypes - pure $ rootType <> typeClassFetch <> argsT +declareType clientType@ClientTypeDefinition {clientKind} = do + types <- typeDeclarations clientKind clientType + instances <- aesonDeclarations clientKind clientType + pure (types <> instances) diff --git a/src/Data/Morpheus/Client/Declare/Fetch.hs b/src/Data/Morpheus/Client/Declare/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Declare/Fetch.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Declare.Fetch + ( declareFetch, + ) +where + +import Data.Morpheus.Client.Fetch (Fetch (..)) +import Data.Morpheus.Client.Internal.Types + ( FetchDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.CodeGen.Internal.TH + ( applyCons, + toCon, + typeInstanceDec, + ) +import qualified Data.Text as T +import Language.Haskell.TH + ( Dec, + Q, + Type, + clause, + cxt, + funD, + instanceD, + normalB, + ) +import Relude hiding (ByteString, Type) + +declareFetch :: Text -> FetchDefinition -> Q [Dec] +declareFetch query FetchDefinition {clientArgumentsTypeName, rootTypeName} = + pure <$> instanceD (cxt []) iHead methods + where + queryString = T.unpack query + typeName = typename rootTypeName + iHead = applyCons ''Fetch [typeName] + methods = + [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []], + pure $ typeInstanceDec ''Args (toCon typeName) (argumentType clientArgumentsTypeName) + ] + +argumentType :: Maybe TypeNameTH -> Type +argumentType Nothing = toCon ("()" :: String) +argumentType (Just clientTypeName) = toCon (typename clientTypeName) 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 @@ -1,14 +1,10 @@ {-# LANGUAGE ConstrainedClassMethods #-} {-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client.Fetch ( Fetch (..), - deriveFetch, ) where @@ -24,26 +20,19 @@ import Data.Morpheus.Client.Internal.Types ( FetchError (..), ) -import Data.Morpheus.Client.JSONSchema.Types +import Data.Morpheus.Client.Schema.JSON.Types ( JSONResponse (..), ) -import Data.Morpheus.CodeGen.Internal.TH - ( applyCons, - toCon, - typeInstanceDec, - ) import Data.Morpheus.Types.IO ( GQLRequest (..), ) import Data.Morpheus.Types.Internal.AST ( FieldName, - TypeName, ) import Data.Text ( pack, ) -import Language.Haskell.TH -import Relude hiding (ByteString, Type) +import Relude hiding (ByteString) fixVars :: A.Value -> Maybe A.Value fixVars x @@ -51,7 +40,7 @@ | otherwise = Just x class Fetch a where - type Args a :: * + type Args a :: Type __fetch :: (Monad m, Show a, ToJSON (Args a), FromJSON a) => String -> @@ -67,13 +56,3 @@ 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 = - pure <$> instanceD (cxt []) iHead methods - where - iHead = applyCons ''Fetch [typeName] - methods = - [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []], - pure $ typeInstanceDec ''Args (toCon typeName) resultType - ] 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,15 +1,18 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client.Internal.Types ( ClientTypeDefinition (..), TypeNameTH (..), - ClientDefinition (..), + FetchDefinition (..), ClientConstructorDefinition (..), - FetchError (..) + FetchError (..), + SchemaSource (..), + ExecutableSource, ) where +import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Types.Internal.AST ( ANY, FieldDefinition, @@ -19,7 +22,7 @@ TypeName, VALID, ) -import Relude +import Relude hiding (ByteString) data TypeNameTH = TypeNameTH { namespace :: [FieldName], @@ -40,9 +43,9 @@ } deriving (Show) -data ClientDefinition = ClientDefinition - { clientArguments :: Maybe ClientTypeDefinition, - clientTypes :: [ClientTypeDefinition] +data FetchDefinition = FetchDefinition + { rootTypeName :: TypeNameTH, + clientArgumentsTypeName :: Maybe TypeNameTH } deriving (Show) @@ -51,3 +54,10 @@ | FetchErrorProducedErrors GQLErrors (Maybe a) | FetchErrorNoResult deriving (Show, Eq, Generic) + +data SchemaSource + = JSON ByteString + | GQL ByteString + deriving (Show, Eq) + +type ExecutableSource = Text 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 @@ -1,14 +1,28 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.Client.Internal.Utils ( removeDuplicates, isEnum, + getSource, + handleResult, + getFile, ) where +import Control.Monad.Except (MonadError (catchError)) +import qualified Data.ByteString.Lazy.Char8 as L +import Data.FileEmbed (makeRelativeToProject) +import Data.List (isSuffixOf) import Data.Morpheus.Client.Internal.Types ( ClientConstructorDefinition (cFields), + SchemaSource (..), ) +import Data.Morpheus.Error (gqlWarnings, renderGQLErrors) +import Data.Morpheus.Internal.Ext (GQLResult, Result (..)) +import qualified Data.Text.IO as TIO +import Language.Haskell.TH (Q, runIO) +import Language.Haskell.TH.Syntax (qAddDependentFile) import Relude removeDuplicates :: Eq a => [a] -> [a] @@ -25,3 +39,29 @@ isEnum :: [ClientConstructorDefinition] -> Bool isEnum = all (null . cFields) + +getSource :: FilePath -> Q SchemaSource +getSource p + | ".json" `isSuffixOf` p = JSON <$> readWith L.readFile p + | ".gql" `isSuffixOf` p || ".graphql" `isSuffixOf` p = GQL <$> readWith L.readFile p + | otherwise = fail "Unsupported file format! The input should have one of the following extensions: json, gql, graphql" + +getFile :: FilePath -> Q Text +getFile = readWith TIO.readFile + +readWith :: (FilePath -> IO a) -> FilePath -> Q a +readWith f path = do + p <- makeRelativeToProject path + qAddDependentFile p + file <- runIO (catchError ((fmap Right . f) p) (pure . Left . show)) + case file of + Left x -> fail x + Right x -> pure x + +handleResult :: GQLResult t -> (t -> Q a) -> Q a +handleResult x f = case x of + Failure errors -> fail (renderGQLErrors errors) + Success + { result, + warnings + } -> gqlWarnings warnings >> f result diff --git a/src/Data/Morpheus/Client/JSONSchema/Parse.hs b/src/Data/Morpheus/Client/JSONSchema/Parse.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/JSONSchema/Parse.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.JSONSchema.Parse - ( decodeIntrospection, - ) -where - -import Control.Monad.Except (MonadError (throwError)) -import Data.Aeson -import Data.ByteString.Lazy (ByteString) -import Data.Morpheus.Client.JSONSchema.TypeKind (TypeKind (..)) -import qualified Data.Morpheus.Client.JSONSchema.TypeRef as Ref -import Data.Morpheus.Client.JSONSchema.Types - ( EnumValue (..), - Field (..), - InputValue (..), - Introspection (..), - JSONResponse (..), - Schema (..), - Type (..), - ) -import Data.Morpheus.Core - ( defaultConfig, - validateSchema, - ) -import Data.Morpheus.Internal.Ext - ( GQLResult, - ) -import Data.Morpheus.Internal.Utils - ( empty, - fromElems, - ) -import qualified Data.Morpheus.Types.Internal.AST as AST - ( Schema, - ) -import Data.Morpheus.Types.Internal.AST - ( ANY, - ArgumentDefinition (..), - CONST, - FieldDefinition, - GQLError, - IN, - OUT, - OperationType (..), - RootOperationTypeDefinition (..), - SchemaDefinition (..), - TypeContent (..), - TypeDefinition (..), - TypeRef (..), - TypeWrapper (..), - VALID, - buildSchema, - createScalarType, - mkEnumContent, - mkField, - mkMaybeType, - mkObjectField, - mkType, - mkUnionContent, - msg, - toAny, - ) -import Relude hiding - ( ByteString, - Type, - empty, - fromList, - show, - ) -import Prelude (show) - -decoderError :: GQLError -> GQLResult a -decoderError = throwError - -decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID) -decodeIntrospection jsonDoc = case jsonSchema of - Left errors -> decoderError $ msg errors - Right - JSONResponse - { responseData = - Just - Introspection - { __schema = - schema@Schema {types} - } - } -> do - schemaDef <- mkSchemaDef schema - gqlTypes <- concat <$> traverse parse types - buildSchema (Just schemaDef, gqlTypes, empty) >>= validate - Right res -> decoderError (msg $ show res) - where - validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID) - validate = validateSchema False defaultConfig - jsonSchema :: Either String (JSONResponse Introspection) - jsonSchema = eitherDecode jsonDoc - -mkSchemaDef :: - (Monad m, MonadError GQLError m) => - Schema -> - m SchemaDefinition -mkSchemaDef - Schema - { queryType, - mutationType, - subscriptionType - } = - SchemaDefinition empty - <$> fromElems - ( catMaybes - [ Just (RootOperationTypeDefinition Query $ Ref.name queryType), - RootOperationTypeDefinition Mutation . Ref.name <$> mutationType, - RootOperationTypeDefinition Subscription . Ref.name <$> subscriptionType - ] - ) - -class ParseJSONSchema a b where - parse :: a -> GQLResult b - -instance ParseJSONSchema Type [TypeDefinition ANY CONST] where - parse Type {name = Just typeName, kind = SCALAR} = - pure [createScalarType typeName] - parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} = - pure [mkType typeName $ mkEnumContent (fmap enumName enums)] - parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} = - case traverse name unions of - Nothing -> decoderError "ERROR: GQL ERROR" - Just uni -> pure [toAny $ mkType typeName $ mkUnionContent uni] - parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = - do - (fields :: [FieldDefinition IN CONST]) <- traverse parse iFields - fs <- fromElems fields - pure [mkType typeName $ DataInputObject fs] - parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = - do - (fields :: [FieldDefinition OUT CONST]) <- traverse parse oFields - fs <- fromElems fields - pure [mkType typeName $ DataObject [] fs] - parse _ = pure [] - -instance ParseJSONSchema Field (FieldDefinition OUT CONST) where - parse Field {fieldName, fieldArgs, fieldType} = do - TypeRef typename wrappers <- fieldTypeFromJSON fieldType - args <- traverse genArg fieldArgs >>= fromElems - pure $ mkObjectField args fieldName wrappers typename - where - genArg InputValue {inputName = argName, inputType = argType} = - ArgumentDefinition . mkField Nothing argName <$> fieldTypeFromJSON argType - -instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where - parse InputValue {inputName, inputType} = mkField Nothing inputName <$> fieldTypeFromJSON inputType - -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/TypeKind.hs b/src/Data/Morpheus/Client/JSONSchema/TypeKind.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/JSONSchema/TypeKind.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.JSONSchema.TypeKind - ( TypeKind (..), - ) -where - -import Data.Aeson (FromJSON (..)) -import GHC.Generics -import Relude - -data TypeKind - = SCALAR - | OBJECT - | INTERFACE - | UNION - | ENUM - | INPUT_OBJECT - | LIST - | NON_NULL - deriving (Eq, Generic, FromJSON, Show) diff --git a/src/Data/Morpheus/Client/JSONSchema/TypeRef.hs b/src/Data/Morpheus/Client/JSONSchema/TypeRef.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/JSONSchema/TypeRef.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.JSONSchema.TypeRef - ( TypeRef (..), - ) -where - -import Data.Aeson (FromJSON) -import Data.Morpheus.Types.Internal.AST - ( TypeName, - ) -import Relude - -newtype TypeRef = TypeRef {name :: TypeName} - deriving (Generic, Show, FromJSON) diff --git a/src/Data/Morpheus/Client/JSONSchema/Types.hs b/src/Data/Morpheus/Client/JSONSchema/Types.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/JSONSchema/Types.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.JSONSchema.Types - ( Introspection (..), - Schema (..), - Type (..), - Field (..), - InputValue (..), - EnumValue (..), - JSONResponse (..), - ) -where - -import Data.Aeson --- --- MORPHEUS -import Data.Morpheus.Client.JSONSchema.TypeKind (TypeKind) -import Data.Morpheus.Client.JSONSchema.TypeRef (TypeRef) -import Data.Morpheus.Types.Internal.AST - ( FieldName, - GQLError, - TypeName, - ) -import Relude hiding (Type) - --- TYPES FOR DECODING JSON INTROSPECTION --- -newtype Introspection = Introspection - { __schema :: Schema - } - deriving (Generic, Show, FromJSON) - -data Schema = Schema - { types :: [Type], - queryType :: TypeRef, - mutationType :: Maybe TypeRef, - subscriptionType :: Maybe TypeRef - -- TODO: directives - --directives: [__Directive] - } - deriving (Generic, Show, FromJSON) - -data Type = Type - { kind :: TypeKind, - name :: Maybe TypeName, - fields :: Maybe [Field], - interfaces :: Maybe [Type], - possibleTypes :: Maybe [Type], - enumValues :: Maybe [EnumValue], - inputFields :: Maybe [InputValue], - ofType :: Maybe Type - } - deriving (Generic, Show, FromJSON) - --- FIELD -data Field = Field - { fieldName :: FieldName, - fieldArgs :: [InputValue], - fieldType :: Type - } - deriving (Show, Generic) - -instance FromJSON Field where - parseJSON = withObject "Field" objectParser - where - objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type" - --- INPUT -data InputValue = InputValue - { inputName :: FieldName, - inputType :: Type - } - deriving (Show, Generic) - -instance FromJSON InputValue where - parseJSON = withObject "InputValue" objectParser - where - objectParser o = InputValue <$> o .: "name" <*> o .: "type" - --- ENUM -newtype EnumValue = EnumValue - { enumName :: TypeName - } - deriving (Generic, Show) - -instance FromJSON EnumValue where - parseJSON = withObject "EnumValue" objectParser - where - objectParser o = EnumValue <$> o .: "name" - -instance FromJSON a => FromJSON (JSONResponse a) where - parseJSON = withObject "JSONResponse" objectParser - where - objectParser o = - JSONResponse <$> o .:? "data" <*> o .:? "errors" .!= [] - -data JSONResponse a = JSONResponse - { responseData :: Maybe a, - responseErrors :: [GQLError] - } - deriving (Generic, Show, ToJSON) diff --git a/src/Data/Morpheus/Client/QuasiQuoter.hs b/src/Data/Morpheus/Client/QuasiQuoter.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/QuasiQuoter.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskellQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.QuasiQuoter + ( raw, + ) +where + +import qualified Data.Text as T +import Language.Haskell.TH.Quote +import Relude hiding (ByteString) + +notSupported :: Text -> a +notSupported things = + error $ + things + <> " are not supported by the GraphQL QuasiQuoter" + +-- | QuasiQuoter to insert multiple lines of text in Haskell +raw :: QuasiQuoter +raw = + QuasiQuoter + { quoteExp = \txt -> [|T.pack txt|], + quotePat = notSupported "Patterns", + quoteType = notSupported "Types", + quoteDec = notSupported "Declarations" + } diff --git a/src/Data/Morpheus/Client/Schema/JSON/Parse.hs b/src/Data/Morpheus/Client/Schema/JSON/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Schema/JSON/Parse.hs @@ -0,0 +1,169 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Schema.JSON.Parse + ( decodeIntrospection, + ) +where + +import Control.Monad.Except (MonadError (throwError)) +import Data.Aeson +import Data.ByteString.Lazy (ByteString) +import Data.Morpheus.Client.Schema.JSON.TypeKind (TypeKind (..)) +import qualified Data.Morpheus.Client.Schema.JSON.TypeRef as Ref +import Data.Morpheus.Client.Schema.JSON.Types + ( EnumValue (..), + Field (..), + InputValue (..), + Introspection (..), + JSONResponse (..), + Schema (..), + Type (..), + ) +import Data.Morpheus.Core + ( defaultConfig, + validateSchema, + ) +import Data.Morpheus.Internal.Ext + ( GQLResult, + ) +import Data.Morpheus.Internal.Utils + ( empty, + fromElems, + ) +import qualified Data.Morpheus.Types.Internal.AST as AST + ( Schema, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentDefinition (..), + CONST, + FieldDefinition, + GQLError, + IN, + OUT, + OperationType (..), + RootOperationTypeDefinition (..), + SchemaDefinition (..), + TypeContent (..), + TypeDefinition (..), + TypeRef (..), + TypeWrapper (..), + VALID, + buildSchema, + createScalarType, + mkEnumContent, + mkField, + mkMaybeType, + mkObjectField, + mkType, + mkUnionContent, + msg, + toAny, + ) +import Relude hiding + ( ByteString, + Type, + empty, + fromList, + show, + ) +import Prelude (show) + +decoderError :: GQLError -> GQLResult a +decoderError = throwError + +decodeIntrospection :: ByteString -> GQLResult (AST.Schema VALID) +decodeIntrospection jsonDoc = case jsonSchema of + Left errors -> decoderError $ msg errors + Right + JSONResponse + { responseData = + Just + Introspection + { __schema = + schema@Schema {types} + } + } -> do + schemaDef <- mkSchemaDef schema + gqlTypes <- concat <$> traverse parse types + buildSchema (Just schemaDef, gqlTypes, empty) >>= validate + Right res -> decoderError (msg $ show res) + where + validate :: AST.Schema CONST -> GQLResult (AST.Schema VALID) + validate = validateSchema False defaultConfig + jsonSchema :: Either String (JSONResponse Introspection) + jsonSchema = eitherDecode jsonDoc + +mkSchemaDef :: + (Monad m, MonadError GQLError m) => + Schema -> + m SchemaDefinition +mkSchemaDef + Schema + { queryType, + mutationType, + subscriptionType + } = + SchemaDefinition empty + <$> fromElems + ( catMaybes + [ Just (RootOperationTypeDefinition Query $ Ref.name queryType), + RootOperationTypeDefinition Mutation . Ref.name <$> mutationType, + RootOperationTypeDefinition Subscription . Ref.name <$> subscriptionType + ] + ) + +class ParseJSONSchema a b where + parse :: a -> GQLResult b + +instance ParseJSONSchema Type [TypeDefinition ANY CONST] where + parse Type {name = Just typeName, kind = SCALAR} = + pure [createScalarType typeName] + parse Type {name = Just typeName, kind = ENUM, enumValues = Just enums} = + pure [mkType typeName $ mkEnumContent (fmap enumName enums)] + parse Type {name = Just typeName, kind = UNION, possibleTypes = Just unions} = + case traverse name unions of + Nothing -> decoderError "ERROR: GQL ERROR" + Just uni -> pure [toAny $ mkType typeName $ mkUnionContent uni] + parse Type {name = Just typeName, kind = INPUT_OBJECT, inputFields = Just iFields} = + do + (fields :: [FieldDefinition IN CONST]) <- traverse parse iFields + fs <- fromElems fields + pure [mkType typeName $ DataInputObject fs] + parse Type {name = Just typeName, kind = OBJECT, fields = Just oFields} = + do + (fields :: [FieldDefinition OUT CONST]) <- traverse parse oFields + fs <- fromElems fields + pure [mkType typeName $ DataObject [] fs] + parse _ = pure [] + +instance ParseJSONSchema Field (FieldDefinition OUT CONST) where + parse Field {fieldName, fieldArgs, fieldType} = do + TypeRef typename wrappers <- fieldTypeFromJSON fieldType + args <- traverse genArg fieldArgs >>= fromElems + pure $ mkObjectField args fieldName wrappers typename + where + genArg InputValue {inputName = argName, inputType = argType} = + ArgumentDefinition . mkField Nothing argName <$> fieldTypeFromJSON argType + +instance ParseJSONSchema InputValue (FieldDefinition IN CONST) where + parse InputValue {inputName, inputType} = mkField Nothing inputName <$> fieldTypeFromJSON inputType + +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/Schema/JSON/TypeKind.hs b/src/Data/Morpheus/Client/Schema/JSON/TypeKind.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Schema/JSON/TypeKind.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Schema.JSON.TypeKind + ( TypeKind (..), + ) +where + +import Data.Aeson (FromJSON (..)) +import GHC.Generics +import Relude + +data TypeKind + = SCALAR + | OBJECT + | INTERFACE + | UNION + | ENUM + | INPUT_OBJECT + | LIST + | NON_NULL + deriving (Eq, Generic, FromJSON, Show) diff --git a/src/Data/Morpheus/Client/Schema/JSON/TypeRef.hs b/src/Data/Morpheus/Client/Schema/JSON/TypeRef.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Schema/JSON/TypeRef.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Schema.JSON.TypeRef + ( TypeRef (..), + ) +where + +import Data.Aeson (FromJSON) +import Data.Morpheus.Types.Internal.AST + ( TypeName, + ) +import Relude + +newtype TypeRef = TypeRef {name :: TypeName} + deriving (Generic, Show, FromJSON) diff --git a/src/Data/Morpheus/Client/Schema/JSON/Types.hs b/src/Data/Morpheus/Client/Schema/JSON/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Schema/JSON/Types.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Schema.JSON.Types + ( Introspection (..), + Schema (..), + Type (..), + Field (..), + InputValue (..), + EnumValue (..), + JSONResponse (..), + ) +where + +import Data.Aeson +-- +-- MORPHEUS +import Data.Morpheus.Client.Schema.JSON.TypeKind (TypeKind) +import Data.Morpheus.Client.Schema.JSON.TypeRef (TypeRef) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + GQLError, + TypeName, + ) +import Relude hiding (Type) + +-- TYPES FOR DECODING JSON INTROSPECTION +-- +newtype Introspection = Introspection + { __schema :: Schema + } + deriving (Generic, Show, FromJSON) + +data Schema = Schema + { types :: [Type], + queryType :: TypeRef, + mutationType :: Maybe TypeRef, + subscriptionType :: Maybe TypeRef + -- TODO: directives + --directives: [__Directive] + } + deriving (Generic, Show, FromJSON) + +data Type = Type + { kind :: TypeKind, + name :: Maybe TypeName, + fields :: Maybe [Field], + interfaces :: Maybe [Type], + possibleTypes :: Maybe [Type], + enumValues :: Maybe [EnumValue], + inputFields :: Maybe [InputValue], + ofType :: Maybe Type + } + deriving (Generic, Show, FromJSON) + +-- FIELD +data Field = Field + { fieldName :: FieldName, + fieldArgs :: [InputValue], + fieldType :: Type + } + deriving (Show, Generic) + +instance FromJSON Field where + parseJSON = withObject "Field" objectParser + where + objectParser o = Field <$> o .: "name" <*> o .: "args" <*> o .: "type" + +-- INPUT +data InputValue = InputValue + { inputName :: FieldName, + inputType :: Type + } + deriving (Show, Generic) + +instance FromJSON InputValue where + parseJSON = withObject "InputValue" objectParser + where + objectParser o = InputValue <$> o .: "name" <*> o .: "type" + +-- ENUM +newtype EnumValue = EnumValue + { enumName :: TypeName + } + deriving (Generic, Show) + +instance FromJSON EnumValue where + parseJSON = withObject "EnumValue" objectParser + where + objectParser o = EnumValue <$> o .: "name" + +instance FromJSON a => FromJSON (JSONResponse a) where + parseJSON = withObject "JSONResponse" objectParser + where + objectParser o = + JSONResponse <$> o .:? "data" <*> o .:? "errors" .!= [] + +data JSONResponse a = JSONResponse + { responseData :: Maybe a, + responseErrors :: [GQLError] + } + deriving (Generic, Show, ToJSON) diff --git a/src/Data/Morpheus/Client/Schema/Parse.hs b/src/Data/Morpheus/Client/Schema/Parse.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Schema/Parse.hs @@ -0,0 +1,18 @@ +module Data.Morpheus.Client.Schema.Parse + ( parseSchema, + ) +where + +import Data.Morpheus.Client.Internal.Types (SchemaSource (..)) +import Data.Morpheus.Client.Schema.JSON.Parse + ( decodeIntrospection, + ) +import Data.Morpheus.Core + ( parseFullSchema, + ) +import Data.Morpheus.Internal.Ext (GQLResult) +import Data.Morpheus.Types.Internal.AST (Schema, VALID) + +parseSchema :: SchemaSource -> GQLResult (Schema VALID) +parseSchema (JSON doc) = decodeIntrospection doc +parseSchema (GQL doc) = parseFullSchema doc diff --git a/src/Data/Morpheus/Client/Transform.hs b/src/Data/Morpheus/Client/Transform.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Transform.hs @@ -0,0 +1,10 @@ +module Data.Morpheus.Client.Transform + ( toGlobalDefinitions, + toLocalDefinitions, + ) +where + +import Data.Morpheus.Client.Transform.Global (toGlobalDefinitions) +import Data.Morpheus.Client.Transform.Local + ( toLocalDefinitions, + ) 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 @@ -11,19 +11,12 @@ ( Converter (..), compileError, getType, - leafType, typeFrom, deprecationWarning, - customScalarTypes, - UpdateT (..), - resolveUpdates, ) where -import Control.Monad.Except (MonadError (throwError)) -import Data.Morpheus.Client.Internal.Types - ( ClientTypeDefinition (..), - ) +import Control.Monad.Except (MonadError) import Data.Morpheus.CodeGen.Internal.TH ( camelCaseTypeName, ) @@ -45,14 +38,12 @@ RAW, Ref (..), Schema (..), - TRUE, TypeContent (..), TypeDefinition (..), TypeName, VALID, VariableDefinitions, internal, - isNotSystemTypeName, lookupDeprecated, lookupDeprecatedReason, msg, @@ -77,11 +68,6 @@ MonadError GQLError ) -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 :: GQLError -> GQLError compileError x = internal $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" @@ -89,19 +75,6 @@ getType typename = asks (typeDefinitions . fst) >>= selectBy (compileError $ " can't find Type" <> msg typename) typename - -customScalarTypes :: TypeName -> [TypeName] -customScalarTypes typeName - | isNotSystemTypeName typeName = [typeName] - | otherwise = [] - -leafType :: TypeDefinition a VALID -> Converter ([ClientTypeDefinition], [TypeName]) -leafType TypeDefinition {typeName, typeContent} = fromKind typeContent - where - fromKind :: TypeContent TRUE a VALID -> Converter ([ClientTypeDefinition], [TypeName]) - fromKind DataEnum {} = pure ([], [typeName]) - fromKind DataScalar {} = pure ([], customScalarTypes typeName) - fromKind _ = throwError $ compileError "Invalid schema Expected scalar" typeFrom :: [FieldName] -> TypeDefinition a VALID -> TypeName typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent diff --git a/src/Data/Morpheus/Client/Transform/Global.hs b/src/Data/Morpheus/Client/Transform/Global.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Transform/Global.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Transform.Global + ( toArgumentsType, + toGlobalDefinitions, + ) +where + +import Data.Morpheus.Client.Internal.Types + ( ClientConstructorDefinition (..), + ClientTypeDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.Internal.Utils + ( empty, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + DataEnumValue (DataEnumValue, enumName), + FieldDefinition (..), + RAW, + Schema (Schema, types), + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeKind (..), + TypeName, + VALID, + Variable (..), + VariableDefinitions, + isNotSystemTypeName, + isResolverType, + toAny, + ) +import Relude hiding (empty) + +toArgumentsType :: + TypeName -> + VariableDefinitions RAW -> + Maybe ClientTypeDefinition +toArgumentsType cName variables + | null variables = Nothing + | otherwise = + Just + ClientTypeDefinition + { clientTypeName = TypeNameTH [] cName, + clientKind = KindInputObject, + clientCons = + [ ClientConstructorDefinition + { cName, + cFields = toFieldDefinition <$> toList variables + } + ] + } + +toFieldDefinition :: Variable RAW -> FieldDefinition ANY VALID +toFieldDefinition Variable {variableName, variableType} = + FieldDefinition + { fieldName = variableName, + fieldContent = Nothing, + fieldType = variableType, + fieldDescription = Nothing, + fieldDirectives = empty + } + +toGlobalDefinitions :: (TypeName -> Bool) -> Schema VALID -> [ClientTypeDefinition] +toGlobalDefinitions f Schema {types} = + mapMaybe generateGlobalType $ + filter shouldInclude (toList types) + where + shouldInclude t = + not (isResolverType t) + && isNotSystemTypeName (typeName t) + && f (typeName t) + +generateGlobalType :: TypeDefinition ANY VALID -> Maybe ClientTypeDefinition +generateGlobalType TypeDefinition {typeName, typeContent} = do + (clientKind, clientCons) <- genContent typeContent + pure + ClientTypeDefinition + { clientTypeName = TypeNameTH [] typeName, + clientKind, + clientCons + } + where + genContent :: TypeContent TRUE ANY VALID -> Maybe (TypeKind, [ClientConstructorDefinition]) + genContent (DataInputObject inputFields) = do + pure + ( KindInputObject, + [ ClientConstructorDefinition + { cName = typeName, + cFields = toAny <$> toList inputFields + } + ] + ) + genContent (DataEnum enumTags) = pure (KindEnum, mkConsEnum <$> enumTags) + genContent DataScalar {} = pure (KindScalar, []) + genContent _ = Nothing + +mkConsEnum :: DataEnumValue s -> ClientConstructorDefinition +mkConsEnum DataEnumValue {enumName} = ClientConstructorDefinition enumName [] diff --git a/src/Data/Morpheus/Client/Transform/Inputs.hs b/src/Data/Morpheus/Client/Transform/Inputs.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Transform/Inputs.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Transform.Inputs - ( renderNonOutputTypes, - renderOperationArguments, - ) -where - -import Data.Morpheus.Client.Internal.Types - ( ClientConstructorDefinition (..), - ClientTypeDefinition (..), - TypeNameTH (..), - ) -import Data.Morpheus.Client.Internal.Utils - ( removeDuplicates, - ) -import Data.Morpheus.Client.Transform.Core - ( Converter (..), - UpdateT (..), - customScalarTypes, - getType, - resolveUpdates, - typeFrom, - ) -import Data.Morpheus.Internal.Utils - ( empty, - ) -import Data.Morpheus.Types.Internal.AST - ( ANY, - DataEnumValue (DataEnumValue, enumName), - FieldDefinition (..), - IN, - Operation (..), - RAW, - TRUE, - TypeContent (..), - TypeDefinition (..), - TypeKind (..), - TypeName, - TypeRef (..), - VALID, - Variable (..), - VariableDefinitions, - getOperationName, - toAny, - ) -import Relude hiding (empty) - -renderArguments :: - VariableDefinitions RAW -> - TypeName -> - Maybe ClientTypeDefinition -renderArguments variables cName - | null variables = Nothing - | otherwise = Just rootArgumentsType - where - rootArgumentsType :: ClientTypeDefinition - rootArgumentsType = - ClientTypeDefinition - { clientTypeName = TypeNameTH [] cName, - clientKind = KindInputObject, - clientCons = - [ ClientConstructorDefinition - { cName, - cFields = fieldD <$> toList variables - } - ] - } - where - fieldD :: Variable RAW -> FieldDefinition ANY VALID - fieldD Variable {variableName, variableType} = - FieldDefinition - { fieldName = variableName, - fieldContent = Nothing, - fieldType = variableType, - fieldDescription = Nothing, - fieldDirectives = empty - } - -renderOperationArguments :: - Operation VALID -> - Converter (Maybe ClientTypeDefinition) -renderOperationArguments Operation {operationName} = - asks ((`renderArguments` (getOperationName operationName <> "Args")) . snd) - --- INPUTS -renderNonOutputTypes :: - [TypeName] -> - Converter [ClientTypeDefinition] -renderNonOutputTypes leafTypes = do - variables <- asks (toList . snd) - inputTypeRequests <- resolveUpdates [] $ fmap (UpdateT . exploreInputTypeNames . typeConName . variableType) variables - concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> leafTypes) - -exploreInputTypeNames :: TypeName -> [TypeName] -> Converter [TypeName] -exploreInputTypeNames name collected - | name `elem` collected = pure collected - | otherwise = getType name >>= scanInpType - where - scanInpType TypeDefinition {typeContent, typeName} = scanType typeContent - where - scanType (DataInputObject fields) = - resolveUpdates - (name : collected) - (toInputTypeD <$> toList fields) - where - toInputTypeD :: FieldDefinition IN VALID -> UpdateT Converter [TypeName] - toInputTypeD FieldDefinition {fieldType = TypeRef {typeConName}} = - UpdateT (exploreInputTypeNames typeConName) - scanType (DataEnum _) = pure (collected <> [typeName]) - scanType (DataScalar _) = pure (collected <> customScalarTypes typeName) - scanType _ = pure collected - -buildInputType :: - TypeName -> - Converter [ClientTypeDefinition] -buildInputType name = getType name >>= generateTypes - where - generateTypes TypeDefinition {typeName, typeContent} = subTypes typeContent - where - subTypes :: TypeContent TRUE ANY VALID -> Converter [ClientTypeDefinition] - subTypes (DataInputObject inputFields) = do - fields <- traverse toClientFieldDefinition (toList inputFields) - pure - [ mkInputType - typeName - KindInputObject - [ ClientConstructorDefinition - { cName = typeName, - cFields = fmap toAny fields - } - ] - ] - subTypes (DataEnum enumTags) = - pure - [ mkInputType - typeName - KindEnum - (fmap mkConsEnum enumTags) - ] - subTypes DataScalar {} = - pure - [ mkInputType - typeName - KindScalar - [] - ] - subTypes _ = pure [] - -mkConsEnum :: DataEnumValue s -> ClientConstructorDefinition -mkConsEnum DataEnumValue {enumName} = ClientConstructorDefinition enumName [] - -mkInputType :: TypeName -> TypeKind -> [ClientConstructorDefinition] -> ClientTypeDefinition -mkInputType typename clientKind clientCons = - ClientTypeDefinition - { clientTypeName = TypeNameTH [] typename, - clientKind, - clientCons - } - -toClientFieldDefinition :: FieldDefinition IN VALID -> Converter (FieldDefinition IN VALID) -toClientFieldDefinition FieldDefinition {fieldType, ..} = do - typeConName <- typeFrom [] <$> getType (typeConName fieldType) - pure FieldDefinition {fieldType = fieldType {typeConName}, ..} diff --git a/src/Data/Morpheus/Client/Transform/Local.hs b/src/Data/Morpheus/Client/Transform/Local.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Transform/Local.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Data.Morpheus.Client.Transform.Local + ( toLocalDefinitions, + ) +where + +import Control.Monad.Except (MonadError (throwError)) +import Data.Morpheus.Client.Internal.Types + ( ClientConstructorDefinition (..), + ClientTypeDefinition (..), + FetchDefinition (..), + TypeNameTH (..), + ) +import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, typeFrom) +import Data.Morpheus.Client.Transform.Global (toArgumentsType) +import Data.Morpheus.Core (Config (..), VALIDATION_MODE (WITHOUT_VARIABLES), validateRequest) +import Data.Morpheus.Internal.Ext + ( GQLResult, + ) +import Data.Morpheus.Internal.Utils + ( empty, + keyOf, + selectBy, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ExecutableDocument (..), + FieldDefinition (..), + FieldName, + OUT, + Operation (..), + Ref (..), + Schema (..), + Selection (..), + SelectionContent (..), + SelectionSet, + TRUE, + TypeContent (..), + TypeDefinition (..), + TypeKind (..), + TypeName, + TypeRef (..), + UnionTag (..), + VALID, + getOperationDataType, + getOperationName, + mkTypeRef, + msg, + toAny, + ) +import Relude hiding (empty, show) +import Prelude (show) + +clientConfig :: Config +clientConfig = + Config + { debug = False, + validationMode = WITHOUT_VARIABLES + } + +toLocalDefinitions :: + ExecutableDocument -> + Schema VALID -> + GQLResult + ( FetchDefinition, + [ClientTypeDefinition] + ) +toLocalDefinitions request schema = do + validOperation <- validateRequest clientConfig schema request + flip runReaderT (schema, operationArguments $ operation request) $ + runConverter $ genOperation validOperation + +genOperation :: Operation VALID -> Converter (FetchDefinition, [ClientTypeDefinition]) +genOperation op@Operation {operationName, operationSelection} = do + (schema, varDefs) <- asks id + datatype <- getOperationDataType op schema + let argumentsType = toArgumentsType (getOperationName operationName <> "Args") varDefs + (rootType :| localTypes) <- + genLocalTypes + [] + (getOperationName operationName) + (toAny datatype) + operationSelection + pure + ( FetchDefinition + { clientArgumentsTypeName = fmap clientTypeName argumentsType, + rootTypeName = clientTypeName rootType + }, + rootType : (localTypes <> maybeToList argumentsType) + ) + +------------------------------------------------------------------------- +-- generates selection Object Types +genLocalTypes :: + [FieldName] -> + TypeName -> + TypeDefinition ANY VALID -> + SelectionSet VALID -> + Converter (NonEmpty ClientTypeDefinition) +genLocalTypes path tName dataType recordSelSet = do + (con, subTypes) <- toConstructorDefinition (if null path then [coerce tName] else path) tName dataType recordSelSet + pure $ + ClientTypeDefinition + { clientTypeName = TypeNameTH path tName, + clientCons = [con], + clientKind = KindObject Nothing + } + :| subTypes + +toConstructorDefinition :: + [FieldName] -> + TypeName -> + TypeDefinition ANY VALID -> + SelectionSet VALID -> + Converter (ClientConstructorDefinition, [ClientTypeDefinition]) +toConstructorDefinition path cName datatype selSet = do + (cFields, subTypes) <- unzip <$> traverse genField (toList selSet) + pure (ClientConstructorDefinition {cName, cFields}, concat subTypes) + where + genField :: Selection VALID -> Converter (FieldDefinition ANY VALID, [ClientTypeDefinition]) + genField sel = do + let fieldName = keyOf sel + let fieldPath = path <> [fieldName] + (fieldDataType, fieldType) <- getFieldType fieldPath datatype sel + subTypes <- subTypesBySelection fieldPath fieldDataType sel + pure + ( FieldDefinition + { fieldName, + fieldType, + fieldContent = Nothing, + fieldDescription = Nothing, + fieldDirectives = empty + }, + subTypes + ) + +------------------------------------------ +subTypesBySelection :: + [FieldName] -> + TypeDefinition ANY VALID -> + Selection VALID -> + Converter [ClientTypeDefinition] +subTypesBySelection _ _ Selection {selectionContent = SelectionField} = pure [] +subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} = do + toList <$> genLocalTypes path (typeFrom [] dType) dType selectionSet +subTypesBySelection path dType Selection {selectionContent = UnionSelection interface unionSelections} = + do + let variants = UnionTag (typeName dType) interface : toList unionSelections + (clientCons, subTypes) <- unzip <$> traverse (getVariantType path) variants + pure + ( ClientTypeDefinition + { clientTypeName = TypeNameTH path (typeFrom [] dType), + clientCons, + clientKind = KindUnion + } : + concat subTypes + ) + +getVariantType :: [FieldName] -> UnionTag -> Converter (ClientConstructorDefinition, [ClientTypeDefinition]) +getVariantType path (UnionTag selectedTyName selectionVariant) = do + conDatatype <- getType selectedTyName + toConstructorDefinition path selectedTyName conDatatype selectionVariant + +getFieldType :: + [FieldName] -> + TypeDefinition ANY VALID -> + Selection VALID -> + Converter (TypeDefinition ANY VALID, TypeRef) +getFieldType + path + TypeDefinition {typeContent, typeName} + Selection + { selectionName, + selectionPosition + } = toFieldDef typeContent >>= processFieldDefinition + where + toFieldDef :: TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID) + toFieldDef _ + | selectionName == "__typename" = + pure + FieldDefinition + { fieldName = "__typename", + fieldDescription = Nothing, + fieldType = mkTypeRef "String", + fieldDirectives = empty, + fieldContent = Nothing + } + toFieldDef DataObject {objectFields} = selectBy selError selectionName objectFields + toFieldDef DataInterface {interfaceFields} = selectBy selError selectionName interfaceFields + toFieldDef dt = throwError (compileError $ "Type should be output Object \"" <> msg (show dt)) + selError = compileError $ "can't find field " <> msg selectionName <> " on type: " <> msg (show typeContent) + -- + processFieldDefinition + FieldDefinition + { fieldType = TypeRef {..}, + fieldDirectives + } = + checkDeprecated *> (trans <$> getType typeConName) + where + trans x = (x, TypeRef {typeConName = typeFrom path x, ..}) + ------------------------------------------------------------------ + checkDeprecated :: Converter () + checkDeprecated = deprecationWarning fieldDirectives (coerce typeName, Ref selectionName selectionPosition) diff --git a/src/Data/Morpheus/Client/Transform/Selection.hs b/src/Data/Morpheus/Client/Transform/Selection.hs deleted file mode 100644 --- a/src/Data/Morpheus/Client/Transform/Selection.hs +++ /dev/null @@ -1,233 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Data.Morpheus.Client.Transform.Selection - ( toClientDefinition, - ClientDefinition (..), - ) -where - -import Control.Monad.Except (MonadError (throwError)) -import Data.Morpheus.Client.Internal.Types - ( ClientConstructorDefinition (..), - ClientDefinition (..), - ClientTypeDefinition (..), - TypeNameTH (..), - ) -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 - ( GQLResult, - ) -import Data.Morpheus.Internal.Utils - ( empty, - keyOf, - selectBy, - ) -import Data.Morpheus.Types.Internal.AST - ( ANY, - FieldDefinition (..), - FieldName, - Operation (..), - RAW, - Ref (..), - Schema (..), - Selection (..), - SelectionContent (..), - SelectionSet, - TypeContent (..), - TypeDefinition (..), - TypeKind (..), - TypeName, - TypeRef (..), - UnionTag (..), - VALID, - VariableDefinitions, - getOperationDataType, - getOperationName, - mkTypeRef, - msg, - toAny, - ) -import Relude hiding (empty, show) -import Prelude (show) - -toClientDefinition :: - Schema VALID -> - VariableDefinitions RAW -> - Operation VALID -> - GQLResult ClientDefinition -toClientDefinition schema vars = flip runReaderT (schema, vars) . runConverter . genOperation - -genOperation :: Operation VALID -> Converter ClientDefinition -genOperation operation = do - (clientArguments, outputTypes, enums) <- renderOperationType operation - nonOutputTypes <- renderNonOutputTypes enums - pure ClientDefinition {clientArguments, clientTypes = outputTypes <> nonOutputTypes} - -renderOperationType :: - Operation VALID -> - Converter - ( Maybe ClientTypeDefinition, - [ClientTypeDefinition], - [TypeName] - ) -renderOperationType op@Operation {operationName, operationSelection} = do - datatype <- asks fst >>= getOperationDataType op - arguments <- renderOperationArguments op - (outputTypes, enums) <- - genRecordType - [] - (getOperationName operationName) - (toAny datatype) - operationSelection - pure (arguments, outputTypes, enums) - -------------------------------------------------------------------------- --- generates selection Object Types -genRecordType :: - [FieldName] -> - TypeName -> - TypeDefinition ANY VALID -> - SelectionSet VALID -> - Converter ([ClientTypeDefinition], [TypeName]) -genRecordType path tName dataType recordSelSet = do - (con, subTypes, requests) <- genConsD path tName dataType recordSelSet - pure - ( ClientTypeDefinition - { clientTypeName = TypeNameTH path tName, - clientCons = [con], - clientKind = KindObject Nothing - } - : subTypes, - requests - ) - -genConsD :: - [FieldName] -> - TypeName -> - TypeDefinition ANY VALID -> - SelectionSet VALID -> - Converter - ( ClientConstructorDefinition, - [ClientTypeDefinition], - [TypeName] - ) -genConsD path cName datatype selSet = do - (cFields, subTypes, requests) <- unzip3 <$> traverse genField (toList selSet) - pure (ClientConstructorDefinition {cName, cFields}, concat subTypes, concat requests) - where - genField :: - Selection VALID -> - Converter (FieldDefinition ANY VALID, [ClientTypeDefinition], [TypeName]) - genField sel = - do - (fieldDataType, fieldType) <- - getFieldType - fieldPath - datatype - sel - (subTypes, requests) <- subTypesBySelection fieldPath fieldDataType sel - pure - ( FieldDefinition - { fieldName, - fieldType, - fieldContent = Nothing, - fieldDescription = Nothing, - fieldDirectives = empty - }, - subTypes, - requests - ) - where - fieldPath = path <> [fieldName] - ------------------------------- - fieldName = keyOf sel - ------------------------------------------- -subTypesBySelection :: - [FieldName] -> - TypeDefinition ANY VALID -> - Selection VALID -> - Converter - ( [ClientTypeDefinition], - [TypeName] - ) -subTypesBySelection _ dType Selection {selectionContent = SelectionField} = - leafType dType -subTypesBySelection path dType Selection {selectionContent = SelectionSet selectionSet} = - genRecordType path (typeFrom [] dType) dType selectionSet -subTypesBySelection path dType Selection {selectionContent = UnionSelection interface unionSelections} = - do - (clientCons, subTypes, requests) <- - unzip3 - <$> traverse - getUnionType - ( UnionTag (typeName dType) interface : toList unionSelections - ) - pure - ( ClientTypeDefinition - { clientTypeName = TypeNameTH path (typeFrom [] dType), - clientCons, - clientKind = KindUnion - } - : concat subTypes, - concat requests - ) - where - getUnionType (UnionTag selectedTyName selectionVariant) = do - conDatatype <- getType selectedTyName - genConsD path selectedTyName conDatatype selectionVariant - -getFieldType :: - [FieldName] -> - TypeDefinition ANY VALID -> - Selection VALID -> - Converter (TypeDefinition ANY VALID, TypeRef) -getFieldType - path - TypeDefinition {typeContent, typeName} - Selection - { selectionName, - selectionPosition - } - | selectionName == "__typename" = - processDeprecation - FieldDefinition - { fieldName = "__typename", - fieldDescription = Nothing, - fieldType = mkTypeRef "String", - fieldDirectives = empty, - fieldContent = Nothing - } - | otherwise = withTypeContent typeContent - where - withTypeContent DataObject {objectFields} = - selectBy selError selectionName objectFields >>= processDeprecation - withTypeContent DataInterface {interfaceFields} = - selectBy selError selectionName interfaceFields >>= processDeprecation - withTypeContent 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 - { fieldType = alias@TypeRef {typeConName}, - fieldDirectives - } = - checkDeprecated *> (trans <$> getType typeConName) - where - trans x = - (x, alias {typeConName = typeFrom path x}) - ------------------------------------------------------------------ - checkDeprecated :: Converter () - checkDeprecated = - deprecationWarning - fieldDirectives - ( 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 @@ -11,63 +11,46 @@ ) where -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) import Data.Morpheus.Client - ( Fetch (..), - FetchError, - gql, + ( declareGlobalTypes, + declareLocalTypesInline, + raw, ) +import Relude import Spec.Utils - ( defineClientWith, - mockApi, + ( assertFetch, + path, ) import Test.Tasty ( TestTree, ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - Either (..), - IO, - String, - ) -defineClientWith - "Enum" - [gql| +declareGlobalTypes (path "Enum/schema.gql") + +declareLocalTypesInline + (path "Enum/schema.gql") + [raw| query MyQuery( $inputCity: City!) { city(city:$inputCity) cities } |] -resolver :: ByteString -> IO ByteString -resolver = mockApi "Enum" - -client :: IO (Either (FetchError MyQuery) MyQuery) -client = fetch resolver MyQueryArgs {inputCity = CityAthens} - test :: TestTree -test = testCase "test Enum" $ do - value <- client - assertEqual - "test Enum" +test = + assertFetch + "Enum" + Nothing + MyQueryArgs {inputCity = CityAthens} ( Right - ( MyQuery - { city = CityAthens, - cities = - [ CityAthens, - CitySparta, - CityCorinth, - CityDelphi, - CityArgos - ] - } - ) + MyQuery + { city = CityAthens, + cities = + [ CityAthens, + CitySparta, + CityCorinth, + CityDelphi, + CityArgos + ] + } ) - value 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 @@ -9,44 +9,25 @@ {-# LANGUAGE NoImplicitPrelude #-} module Case.Github.Test - ( testInterface, + ( test, ) where -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) import Data.Morpheus.Client ( DecodeScalar (..), EncodeScalar (..), - Fetch (..), - FetchError, ScalarValue (..), - gql, + declareGlobalTypesByName, + declareLocalTypes, ) -import Data.Text (Text) +import Relude import Spec.Utils - ( defineClientWith, - mockApi, + ( assertFetch, + path, ) import Test.Tasty ( TestTree, ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - Applicative (..), - Bool (..), - Either (..), - Eq (..), - IO, - Maybe (..), - Show, - String, - ) newtype GitTimestamp = GitTimestamp { unGitTimestamp :: Text @@ -60,86 +41,54 @@ instance EncodeScalar GitTimestamp where encodeScalar (GitTimestamp x) = String x -defineClientWith - "Github" - [gql| - query GetTags ($user: String!, $repo: String!) - { - repository(owner: $user, name: $repo) { - refs(refPrefix: "refs/tags/", first: 100) { - pageInfo { - endCursor - hasNextPage - } - edges { - cursor - node { - name - target { - __typename - ... on Tag { - tagger { - date - } - } - } - } - } - } - } - } - |] +declareGlobalTypesByName + (path "Github/schema.gql") + ["GitTimestamp"] -resolver :: ByteString -> IO ByteString -resolver = mockApi "Interface" +declareLocalTypes + (path "Github/schema.gql") + (path "Github/query.gql") -client :: IO (Either (FetchError GetTags) GetTags) -client = - fetch - resolver +test :: TestTree +test = + assertFetch + "Github" + Nothing GetTagsArgs { user = "UserName", repo = "repoName" } - -testInterface :: TestTree -testInterface = testCase "test Github interfaces" $ do - value <- client - assertEqual - "test Github interface" ( Right - ( GetTags - { repository = - Just - RepositoryRepository - { refs = - Just - RepositoryRefsRefConnection - { pageInfo = - RepositoryRefsPageInfoPageInfo - { endCursor = Just "", - hasNextPage = False - }, - edges = - Just - [ Just - RepositoryRefsEdgesRefEdge - { cursor = "", - node = - Just - RepositoryRefsEdgesNodeRef - { name = "", - target = - Just - RepositoryRefsEdgesNodeTargetGitObject - { __typename = "" - } - } - } - ] - } - } - } - ) + GetTags + { repository = + Just + GetTagsRepositoryRepository + { refs = + Just + GetTagsRepositoryRefsRefConnection + { pageInfo = + GetTagsRepositoryRefsPageInfoPageInfo + { endCursor = Just "test value 1", + hasNextPage = False + }, + edges = + Just + [ Just + GetTagsRepositoryRefsEdgesRefEdge + { cursor = "test cursor", + node = + Just + GetTagsRepositoryRefsEdgesNodeRef + { name = "test name", + target = + Just + GetTagsRepositoryRefsEdgesNodeTargetGitObject + { __typename = "GitObject" + } + } + } + ] + } + } + } ) - value diff --git a/test/Case/Github/query.gql b/test/Case/Github/query.gql new file mode 100644 --- /dev/null +++ b/test/Case/Github/query.gql @@ -0,0 +1,24 @@ +query GetTags($user: String!, $repo: String!) { + repository(owner: $user, name: $repo) { + refs(refPrefix: "refs/tags/", first: 100) { + pageInfo { + endCursor + hasNextPage + } + edges { + cursor + node { + name + target { + __typename + ... on Tag { + tagger { + date + } + } + } + } + } + } + } +} diff --git a/test/Case/Github/response.json b/test/Case/Github/response.json --- a/test/Case/Github/response.json +++ b/test/Case/Github/response.json @@ -1,52 +1,23 @@ { "data": { - "character": [ - { - "__typename": "Deity", - "name": "Deity Name", - "power": "Deity Power" - }, - { - "__typename": "Character", - "name": "Character Name" - }, - { - "__typename": "Hero", - "name": "Hero Name", - "hobby": "Deity Power" - } - ], - "character2": [ - { - "name1": "test name", - "name": "test name" - } - ], - "character3": [ - { - "__typename": "Hero", - "hobby": "Hero Hobby", - "name2": "Hero name2" - }, - { - "__typename": "Deity", - "name2": "Hero name2" - }, - { - "__typename": "Character", - "name2": "Character name2" - } - ], - "character4": [ - { - "__typename": "Character", - "name2": "Character name2" - }, - { - "__typename": "Hero", - "hobby": "Hero Hobby", - "name2": "Hero name2" + "repository": { + "refs": { + "pageInfo": { + "endCursor": "test value 1", + "hasNextPage": false + }, + "edges": [ + { + "cursor": "test cursor", + "node": { + "name": "test name", + "target": { + "__typename": "GitObject" + } + } + } + ] } - ] + } } } 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 @@ -9,135 +9,83 @@ {-# LANGUAGE NoImplicitPrelude #-} module Case.Interface.Test - ( testInterface, + ( test, ) where -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) import Data.Morpheus.Client - ( Fetch (..), - FetchError, - gql, + ( declareLocalTypes, ) -import Data.Text (Text) +import Relude import Spec.Utils - ( defineClientWith, - mockApi, + ( assertFetch, + path, ) import Test.Tasty ( TestTree, ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - Either (..), - IO, - String, - ) -defineClientWith - "Interface" - [gql| - query MyQuery { - character { - name - ... on Deity { - power - } - - ... on Hero { - hobby - } - } - character2: character { - name1: name - name - } - character3: character { - ... on Hero { - hobby - } - ... on Character { - name2: name - } - } - character4: character { - ... on Hero { - hobby - } - } - } - |] - -resolver :: ByteString -> IO ByteString -resolver = mockApi "Interface" - -client :: IO (Either (FetchError MyQuery) MyQuery) -client = fetch resolver () +declareLocalTypes + (path "Interface/schema.gql") + (path "Interface/query.gql") -testInterface :: TestTree -testInterface = testCase "test interfaces" $ do - value <- client - assertEqual - "test interface" +test :: TestTree +test = + assertFetch + "Interface" + Nothing + () ( Right - ( MyQuery - { character = - [ CharacterDeity - { __typename = "Deity", - name = "Deity Name", - power = "Deity Power" - }, - CharacterCharacter - { __typename = "Character", - name = "Character Name" - }, - CharacterHero - { __typename = "Hero", - name = "Hero Name", - hobby = "Deity Power" - } - ], - character2 = - [ Character2Character - { __typename = "Character", - name1 = "test name", - name = "test name" - } - ], - character3 = - [ Character3Hero - { __typename = "Hero", - hobby = "Hero Hobby", - name2 = "Hero name2" - }, - Character3Character - { __typename = "Deity", - name2 = "Hero name2" - }, - Character3Character - { __typename = "Character", - name2 = "Character name2" - } - ], - character4 = - [ Character4Character - { __typename = "Character" - }, - Character4Hero - { __typename = "Hero", - hobby = "Hero Hobby" - }, - Character4Character - { __typename = "Deity" - } - ] - } - ) + MyQuery + { character = + [ MyQueryCharacterDeity + { __typename = "Deity", + name = "Deity Name", + power = "Deity Power" + }, + MyQueryCharacterCharacter + { __typename = "Character", + name = "Character Name" + }, + MyQueryCharacterHero + { __typename = "Hero", + name = "Hero Name", + hobby = "Deity Power" + } + ], + character2 = + [ MyQueryCharacter2Character + { __typename = "Character", + name1 = "test name", + name = "test name" + } + ], + character3 = + [ MyQueryCharacter3Hero + { __typename = "Hero", + hobby = "Hero Hobby", + name2 = "Hero name2" + }, + MyQueryCharacter3Character + { __typename = "Deity", + name2 = "Hero name2" + }, + MyQueryCharacter3Character + { __typename = "Character", + name2 = "Character name2" + } + ], + character4 = + [ MyQueryCharacter4Character + { __typename = "Character" + }, + MyQueryCharacter4Hero + { __typename = "Hero", + hobby = "Hero Hobby" + }, + MyQueryCharacter4Character + { __typename = "Deity" + } + ] + } ) - value diff --git a/test/Case/Interface/query.gql b/test/Case/Interface/query.gql new file mode 100644 --- /dev/null +++ b/test/Case/Interface/query.gql @@ -0,0 +1,29 @@ +query MyQuery { + character { + name + ... on Deity { + power + } + + ... on Hero { + hobby + } + } + character2: character { + name1: name + name + } + character3: character { + ... on Hero { + hobby + } + ... on Character { + name2: name + } + } + character4: character { + ... on Hero { + hobby + } + } +} diff --git a/test/Case/JSON/Custom/Errors.hs b/test/Case/JSON/Custom/Errors.hs deleted file mode 100644 --- a/test/Case/JSON/Custom/Errors.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# 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, PropName (PropIndex), - ) -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", PropIndex 0] :| []) - (Just TestQuery {queryTypeName = Just "TestQuery"}) - ) - ) - value diff --git a/test/Case/JSON/Custom/Errors/response.json b/test/Case/JSON/Custom/Errors/response.json deleted file mode 100644 --- a/test/Case/JSON/Custom/Errors/response.json +++ /dev/null @@ -1,17 +0,0 @@ -{ - "data": { - "queryTypeName": "TestQuery" - }, - "errors": [ - { - "locations": [ - { - "line": 3, - "column": 7 - } - ], - "path": ["queryTypeName", 0], - "message": "Failure" - } - ] -} diff --git a/test/Case/JSON/Custom/ErrorsWithType.hs b/test/Case/JSON/Custom/ErrorsWithType.hs deleted file mode 100644 --- a/test/Case/JSON/Custom/ErrorsWithType.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Case.JSON.Custom.ErrorsWithType - ( 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, - custom, - 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/ErrorsWithType" - -client :: IO (Either (FetchError TestQuery) TestQuery) -client = fetch resolver () - -test :: TestTree -test = testCase "test Errors With Type" $ do - value <- client - assertEqual - "test custom Errors" - ( Left - ( FetchErrorProducedErrors - (("Failure" `at` Position {line = 3, column = 7}) `withPath` ["queryTypeName"] `custom` "QUERY_BAD" :| []) - (Just TestQuery {queryTypeName = Just "TestQuery"}) - ) - ) - value diff --git a/test/Case/JSON/Custom/ErrorsWithType/response.json b/test/Case/JSON/Custom/ErrorsWithType/response.json deleted file mode 100644 --- a/test/Case/JSON/Custom/ErrorsWithType/response.json +++ /dev/null @@ -1,20 +0,0 @@ -{ - "data": { - "queryTypeName": "TestQuery" - }, - "errors": [ - { - "type": "QUERY_BAD", - "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 deleted file mode 100644 --- a/test/Case/JSON/Custom/Mutation.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Case.JSON.Custom.Mutation - ( test, - ) -where - -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) -import Data.Morpheus.Client - ( Fetch (..), - FetchError, - gql, - ) -import Data.Text (Text) -import Spec.Utils - ( defineClientWithJSON, - mockApi, - ) -import Test.Tasty - ( TestTree, - ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - Either (..), - IO, - Maybe (..), - String, - ) - -defineClientWithJSON - "JSON/Custom" - [gql| - mutation TestMutation - { - mutationTypeName - } - |] - -resolver :: ByteString -> IO ByteString -resolver = mockApi "JSON/Custom/Mutation" - -client :: IO (Either (FetchError TestMutation) TestMutation) -client = fetch resolver () - -test :: TestTree -test = testCase "test Mutation" $ do - value <- client - assertEqual - "test custom Mutation" - ( Right - ( TestMutation - { mutationTypeName = Just "TestMutation" - } - ) - ) - value diff --git a/test/Case/JSON/Custom/Mutation/response.json b/test/Case/JSON/Custom/Mutation/response.json deleted file mode 100644 --- a/test/Case/JSON/Custom/Mutation/response.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "data": { - "mutationTypeName": "TestMutation" - } -} diff --git a/test/Case/JSON/Custom/NoResponseOrError.hs b/test/Case/JSON/Custom/NoResponseOrError.hs deleted file mode 100644 --- a/test/Case/JSON/Custom/NoResponseOrError.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Case/JSON/Custom/NoResponseOrError/response.json +++ /dev/null @@ -1,1 +0,0 @@ -{} diff --git a/test/Case/JSON/Custom/PartialResponse.hs b/test/Case/JSON/Custom/PartialResponse.hs deleted file mode 100644 --- a/test/Case/JSON/Custom/PartialResponse.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# 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 deleted file mode 100644 --- a/test/Case/JSON/Custom/PartialResponse/response.json +++ /dev/null @@ -1,6 +0,0 @@ -{ - "data": { - "queryTypeName": 1 - }, - "errors": [] -} diff --git a/test/Case/JSON/Custom/Query.hs b/test/Case/JSON/Custom/Query.hs deleted file mode 100644 --- a/test/Case/JSON/Custom/Query.hs +++ /dev/null @@ -1,82 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Case.JSON.Custom.Query - ( 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, - Maybe (..), - 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/Query" - -client :: IO (Either (FetchError TestQuery) TestQuery) -client = fetch resolver () - -test :: TestTree -test = testCase "test Query" $ do - value <- client - assertEqual - "test custom Query" - ( Right - ( TestQuery - { queryTypeName = Just "TestQuery" - } - ) - ) - value diff --git a/test/Case/JSON/Custom/Query/response.json b/test/Case/JSON/Custom/Query/response.json deleted file mode 100644 --- a/test/Case/JSON/Custom/Query/response.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "data": { - "queryTypeName": "TestQuery" - } -} diff --git a/test/Case/JSON/Custom/Subscription.hs b/test/Case/JSON/Custom/Subscription.hs deleted file mode 100644 --- a/test/Case/JSON/Custom/Subscription.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE NoImplicitPrelude #-} - -module Case.JSON.Custom.Subscription - ( test, - ) -where - -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) -import Data.Morpheus.Client - ( Fetch (..), - FetchError, - gql, - ) -import Data.Text (Text) -import Spec.Utils - ( defineClientWithJSON, - mockApi, - ) -import Test.Tasty - ( TestTree, - ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - Either (..), - IO, - Maybe (..), - String, - ) - -defineClientWithJSON - "JSON/Custom" - [gql| - subscription TestSubscription - { - subscriptionTypeName - } - |] - -resolver :: ByteString -> IO ByteString -resolver = mockApi "JSON/Custom/Subscription" - -client :: IO (Either (FetchError TestSubscription) TestSubscription) -client = fetch resolver () - -test :: TestTree -test = testCase "test Subscription" $ do - value <- client - assertEqual - "test custom Subscription" - ( Right - ( TestSubscription - { subscriptionTypeName = - Just "TestSubscription" - } - ) - ) - value diff --git a/test/Case/JSON/Custom/Subscription/response.json b/test/Case/JSON/Custom/Subscription/response.json deleted file mode 100644 --- a/test/Case/JSON/Custom/Subscription/response.json +++ /dev/null @@ -1,5 +0,0 @@ -{ - "data": { - "subscriptionTypeName": "TestSubscription" - } -} diff --git a/test/Case/JSON/Custom/schema.json b/test/Case/JSON/Custom/schema.json deleted file mode 100644 --- a/test/Case/JSON/Custom/schema.json +++ /dev/null @@ -1,70 +0,0 @@ -{ - "data": { - "__schema": { - "queryType": { - "name": "CustomQueryType" - }, - "mutationType": { - "name": "CustomMutationType" - }, - "subscriptionType": { - "name": "CustomSubscriptionType" - }, - "types": [ - { - "kind": "OBJECT", - "name": "CustomQueryType", - "fields": [ - { - "name": "queryTypeName", - "args": [], - "type": { - "kind": "SCALAR", - "name": "String" - }, - "isDeprecated": false - } - ], - "interfaces": [] - }, - { - "kind": "OBJECT", - "name": "CustomMutationType", - "fields": [ - { - "name": "mutationTypeName", - "args": [], - "type": { - "kind": "SCALAR", - "name": "String" - }, - "isDeprecated": false - } - ], - "interfaces": [] - }, - { - "kind": "OBJECT", - "name": "CustomSubscriptionType", - "fields": [ - { - "name": "subscriptionTypeName", - "args": [], - "type": { - "kind": "SCALAR", - "name": "String" - }, - "isDeprecated": false - } - ], - "interfaces": [] - }, - { - "kind": "SCALAR", - "name": "String" - } - ], - "directives": [] - } - } -} diff --git a/test/Case/LocalGlobal/Api.hs b/test/Case/LocalGlobal/Api.hs new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/Api.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.LocalGlobal.Api + ( schema, + loc, + ) +where + +import Relude +import Spec.Utils + ( path, + ) + +loc :: FilePath -> FilePath +loc x = path ("LocalGlobal/" <> x) + +schema :: FilePath +schema = loc "schema.gql" diff --git a/test/Case/LocalGlobal/Test.hs b/test/Case/LocalGlobal/Test.hs new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/Test.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.LocalGlobal.Test + ( test, + ) +where + +import Case.LocalGlobal.Api +import Data.Aeson +import Data.Morpheus.Client + ( Fetch (..), + ID, + declareGlobalTypes, + declareLocalTypes, + declareLocalTypesInline, + raw, + ) +import Relude +import Spec.Utils + ( assertFetch, + ) +import Test.Tasty + ( TestTree, + testGroup, + ) + +declareGlobalTypes schema + +declareLocalTypesInline + schema + [raw| + query GetCities ( $inputCity: City!) { + city(city:$inputCity) + cities + } + |] + +declareLocalTypes schema (loc "users1.gql") +declareLocalTypes schema (loc "users2.gql") + +checkQuery :: + ( Fetch a, + FromJSON a, + Eq a, + Show a + ) => + FilePath -> + Args a -> + a -> + TestTree +checkQuery x args v = + assertFetch + "LocalGlobal" + (Just x) + args + (Right v) + +checkCities :: TestTree +checkCities = + checkQuery + "cities" + GetCitiesArgs {inputCity = CityAthens} + GetCities + { city = CityAthens, + cities = + [ CityAthens, + CitySparta, + CityCorinth, + CityDelphi + ] + } + +checkUsers1 :: TestTree +checkUsers1 = + checkQuery + "users1" + GetUsers1Args {user = UserInput {name = "odysseus"}} + GetUsers1 + { user = + Just + ( GetUsers1UserUser + { name = "Odysseus", + home = Just CityIthaca + } + ) + } + +checkUsers2 :: TestTree +checkUsers2 = + checkQuery + "users2" + GetUsers2Args {user = UserInput {name = "odysseus"}} + GetUsers2 + { user = + Just + ( GetUsers2UserUser + { name = "Morpheus" + } + ) + } + +test :: TestTree +test = + testGroup + "Local/Global" + [ checkCities, + checkUsers1, + checkUsers2 + ] diff --git a/test/Case/LocalGlobal/cities.json b/test/Case/LocalGlobal/cities.json new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/cities.json @@ -0,0 +1,6 @@ +{ + "data": { + "city": "Athens", + "cities": ["Athens", "Sparta", "Corinth", "delphi"] + } +} diff --git a/test/Case/LocalGlobal/schema.gql b/test/Case/LocalGlobal/schema.gql new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/schema.gql @@ -0,0 +1,23 @@ +enum City { + Athens + Sparta + Corinth + delphi + Argos + Ithaca +} + +input UserInput { + name: ID! +} + +type User { + name: String! + home: City +} + +type Query { + user(user: UserInput): User + city(city: City!): City! + cities: [City!]! +} diff --git a/test/Case/LocalGlobal/users1.gql b/test/Case/LocalGlobal/users1.gql new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/users1.gql @@ -0,0 +1,6 @@ +query GetUsers1($user: UserInput!) { + user(user: $user) { + name + home + } +} diff --git a/test/Case/LocalGlobal/users1.json b/test/Case/LocalGlobal/users1.json new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/users1.json @@ -0,0 +1,8 @@ +{ + "data": { + "user": { + "name": "Odysseus", + "home": "Ithaca" + } + } +} diff --git a/test/Case/LocalGlobal/users2.gql b/test/Case/LocalGlobal/users2.gql new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/users2.gql @@ -0,0 +1,5 @@ +query GetUsers2($user: UserInput!) { + user(user: $user) { + name + } +} diff --git a/test/Case/LocalGlobal/users2.json b/test/Case/LocalGlobal/users2.json new file mode 100644 --- /dev/null +++ b/test/Case/LocalGlobal/users2.json @@ -0,0 +1,7 @@ +{ + "data": { + "user": { + "name": "Morpheus" + } + } +} 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 @@ -9,43 +9,26 @@ {-# LANGUAGE NoImplicitPrelude #-} module Case.LowercaseTypeName.Test - ( testLowercaseTypeName, + ( test, ) where -import Control.Applicative (pure) -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) import Data.Morpheus.Client ( DecodeScalar (..), EncodeScalar (..), - Fetch (..), - FetchError(..), ScalarValue (..), - gql, + declareGlobalTypes, + declareLocalTypesInline, + raw, ) -import Data.Text (Text) +import Relude import Spec.Utils - ( defineClientWith, - mockApi, + ( assertFetch, + path, ) import Test.Tasty ( TestTree, ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - (.), - Either (..), - Eq, - IO, - Show, - String, - ) newtype Uuid = Uuid { uuid :: Text @@ -59,9 +42,11 @@ decodeScalar (String x) = pure (Uuid x) decodeScalar _ = Left "not valid uid" -defineClientWith - "LowercaseTypeName" - [gql| +declareGlobalTypes (path "LowercaseTypeName/schema.gql") + +declareLocalTypesInline + (path "LowercaseTypeName/schema.gql") + [raw| query MyQuery { user(id: "11343135") { id @@ -69,24 +54,17 @@ } |] -resolver :: ByteString -> IO ByteString -resolver = mockApi "LowercaseTypeName" - -client :: IO (Either (FetchError MyQuery) MyQuery) -client = fetch resolver () - -testLowercaseTypeName :: TestTree -testLowercaseTypeName = testCase "test lowercase type names" $ do - value <- client - assertEqual - "test interface" +test :: TestTree +test = + assertFetch + "LowercaseTypeName" + Nothing + () ( Right - ( MyQuery - { user = - UserUser - { id = Uuid "11343135" - } - } - ) + MyQuery + { user = + MyQueryUserUser + { id = Uuid "11343135" + } + } ) - value diff --git a/test/Case/ResponseTypes/Test.hs b/test/Case/ResponseTypes/Test.hs new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/Test.hs @@ -0,0 +1,202 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Case.ResponseTypes.Test + ( test, + ) +where + +import Data.Aeson (FromJSON) +import Data.Morpheus.Client + ( EncodeScalar (..), + Fetch (..), + FetchError (..), + ScalarValue (..), + declareLocalTypesInline, + raw, + ) +import Data.Morpheus.Types.Internal.AST + ( Position (..), + PropName (PropIndex), + at, + custom, + withPath, + ) +import Relude +import Spec.Utils + ( assertFetch, + path, + ) +import Test.Tasty + ( TestTree, + testGroup, + ) + +newtype GitTimestamp = GitTimestamp + { unGitTimestamp :: Text + } + deriving (Eq, Show) + +instance EncodeScalar GitTimestamp where + encodeScalar (GitTimestamp x) = String x + +type Res a = Either (FetchError a) a + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + query SimpleQuery + { queryTypeName + } + |] + +simpleQuery :: Res SimpleQuery +simpleQuery = + Right + SimpleQuery + { queryTypeName = Just "TestQuery" + } + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + query PartialResponse + { queryTypeName + } + |] + +partialResponse :: Res PartialResponse +partialResponse = + Left + ( FetchErrorParseFailure + "Error in $.data.queryTypeName: parsing Text failed, expected String, but encountered Number" + ) + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + query NoResponseOrError + { + queryTypeName + } + |] + +noResponseOrError :: Res NoResponseOrError +noResponseOrError = Left FetchErrorNoResult + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + mutation SimpleMutation + { + mutationTypeName + } + |] + +simpleMutation :: Either a SimpleMutation +simpleMutation = + Right + ( SimpleMutation + { mutationTypeName = Just "TestMutation" + } + ) + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + subscription SimpleSubscription + { + subscriptionTypeName + } + |] + +simpleSubscription :: Res SimpleSubscription +simpleSubscription = + Right + ( SimpleSubscription + { subscriptionTypeName = + Just "TestSubscription" + } + ) + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + query ErrorsWithType + { + queryTypeName + } + |] + +errorsWithType :: Res ErrorsWithType +errorsWithType = + Left + ( FetchErrorProducedErrors + ( ("Failure" `at` Position {line = 3, column = 7}) + `withPath` ["queryTypeName"] + `custom` "QUERY_BAD" :| [] + ) + (Just ErrorsWithType {queryTypeName = Just "TestQuery"}) + ) + +declareLocalTypesInline + (path "ResponseTypes/schema.json") + [raw| + query TestErrorsQuery + { + queryTypeName + } + |] + +testErrorsQuery :: Res TestErrorsQuery +testErrorsQuery = + Left + ( FetchErrorProducedErrors + ( ("Failure" `at` Position {line = 3, column = 7}) + `withPath` [ "queryTypeName", + PropIndex 0 + ] + :| [] + ) + ( Just + TestErrorsQuery + { queryTypeName = Just "TestQuery" + } + ) + ) + +check :: + ( Args a ~ (), + Fetch a, + FromJSON a, + Eq a, + Show a + ) => + FilePath -> + Res a -> + TestTree +check name = + assertFetch + "ResponseTypes" + (Just name) + () + +test :: TestTree +test = + testGroup + "Response Types" + [ check "query" simpleQuery, + check "partialResponse" partialResponse, + check "noResponseOrError" noResponseOrError, + check "mutation" simpleMutation, + check "subscription" simpleSubscription, + check "errorsWithType" errorsWithType, + check "errors" testErrorsQuery + ] diff --git a/test/Case/ResponseTypes/errors.json b/test/Case/ResponseTypes/errors.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/errors.json @@ -0,0 +1,17 @@ +{ + "data": { + "queryTypeName": "TestQuery" + }, + "errors": [ + { + "locations": [ + { + "line": 3, + "column": 7 + } + ], + "path": ["queryTypeName", 0], + "message": "Failure" + } + ] +} diff --git a/test/Case/ResponseTypes/errorsWithType.json b/test/Case/ResponseTypes/errorsWithType.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/errorsWithType.json @@ -0,0 +1,20 @@ +{ + "data": { + "queryTypeName": "TestQuery" + }, + "errors": [ + { + "type": "QUERY_BAD", + "locations": [ + { + "line": 3, + "column": 7 + } + ], + "path": [ + "queryTypeName" + ], + "message": "Failure" + } + ] +} diff --git a/test/Case/ResponseTypes/mutation.json b/test/Case/ResponseTypes/mutation.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/mutation.json @@ -0,0 +1,5 @@ +{ + "data": { + "mutationTypeName": "TestMutation" + } +} diff --git a/test/Case/ResponseTypes/noResponseOrError.json b/test/Case/ResponseTypes/noResponseOrError.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/noResponseOrError.json @@ -0,0 +1,1 @@ +{} diff --git a/test/Case/ResponseTypes/partialResponse.json b/test/Case/ResponseTypes/partialResponse.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/partialResponse.json @@ -0,0 +1,6 @@ +{ + "data": { + "queryTypeName": 1 + }, + "errors": [] +} diff --git a/test/Case/ResponseTypes/query.json b/test/Case/ResponseTypes/query.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/query.json @@ -0,0 +1,5 @@ +{ + "data": { + "queryTypeName": "TestQuery" + } +} diff --git a/test/Case/ResponseTypes/schema.json b/test/Case/ResponseTypes/schema.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/schema.json @@ -0,0 +1,70 @@ +{ + "data": { + "__schema": { + "queryType": { + "name": "CustomQueryType" + }, + "mutationType": { + "name": "CustomMutationType" + }, + "subscriptionType": { + "name": "CustomSubscriptionType" + }, + "types": [ + { + "kind": "OBJECT", + "name": "CustomQueryType", + "fields": [ + { + "name": "queryTypeName", + "args": [], + "type": { + "kind": "SCALAR", + "name": "String" + }, + "isDeprecated": false + } + ], + "interfaces": [] + }, + { + "kind": "OBJECT", + "name": "CustomMutationType", + "fields": [ + { + "name": "mutationTypeName", + "args": [], + "type": { + "kind": "SCALAR", + "name": "String" + }, + "isDeprecated": false + } + ], + "interfaces": [] + }, + { + "kind": "OBJECT", + "name": "CustomSubscriptionType", + "fields": [ + { + "name": "subscriptionTypeName", + "args": [], + "type": { + "kind": "SCALAR", + "name": "String" + }, + "isDeprecated": false + } + ], + "interfaces": [] + }, + { + "kind": "SCALAR", + "name": "String" + } + ], + "directives": [] + } + } +} diff --git a/test/Case/ResponseTypes/subscription.json b/test/Case/ResponseTypes/subscription.json new file mode 100644 --- /dev/null +++ b/test/Case/ResponseTypes/subscription.json @@ -0,0 +1,5 @@ +{ + "data": { + "subscriptionTypeName": "TestSubscription" + } +} diff --git a/test/Case/Scalar/Test.hs b/test/Case/Scalar/Test.hs --- a/test/Case/Scalar/Test.hs +++ b/test/Case/Scalar/Test.hs @@ -11,39 +11,22 @@ ) where -import Data.ByteString.Lazy.Char8 - ( ByteString, - ) import Data.Morpheus.Client - ( Fetch (..), - FetchError (..), - gql, + ( declareLocalTypesInline, + raw, ) -import Data.Text (Text) +import Relude import Spec.Utils - ( defineClientWith, - mockApi, + ( assertFetch, + path, ) import Test.Tasty ( TestTree, ) -import Test.Tasty.HUnit - ( assertEqual, - testCase, - ) -import Prelude - ( ($), - Bool (True), - Double, - Either (..), - IO, - Int, - String, - ) -defineClientWith - "Scalar" - [gql| +declareLocalTypesInline + (path "Scalar/schema.gql") + [raw| query MyQuery( $inputBoolean: Boolean! $inputInt: Int! @@ -57,9 +40,6 @@ } |] -resolver :: ByteString -> IO ByteString -resolver = mockApi "Scalar" - -- GraphQL Boolean types must be represented with Haskell Bool types testBoolean :: Bool testBoolean = True @@ -76,29 +56,22 @@ testText :: Text testText = "Athens" -client :: IO (Either (FetchError MyQuery) MyQuery) -client = - fetch - resolver +test :: TestTree +test = + assertFetch + "Scalar" + Nothing MyQueryArgs { inputBoolean = 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 - } - ) + MyQuery + { booleanResolver = testBoolean, + intResolver = testInt, + floatResolver = testFloat, + stringResolver = testText + } ) - value diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -7,41 +7,31 @@ where 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.ErrorsWithType as JSONCustomErrorsWithType -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.Github.Test as Github +import qualified Case.Interface.Test as Interface +import qualified Case.LocalGlobal.Test as LocalGlobal +import qualified Case.LowercaseTypeName.Test as LowercaseTypeName +import qualified Case.ResponseTypes.Test as ResponseTypes import qualified Case.Scalar.Test as Scalar import Test.Tasty ( defaultMain, testGroup, ) import Prelude - ( ($), - IO, + ( IO, + ($), ) main :: IO () main = defaultMain $ testGroup - "client tests" - [ testInterface, - testLowercaseTypeName, + "Client tests" + [ Interface.test, + LowercaseTypeName.test, + LocalGlobal.test, Enum.test, Scalar.test, - JSONCustomErrors.test, - JSONCustomErrorsWithType.test, - JSONCustomMutation.test, - JSONCustomPartialResponse.test, - JSONCustomQuery.test, - JSONCustomSubscription.test, - JSONNoResponseOrError.test + ResponseTypes.test, + Github.test ] diff --git a/test/Spec/Utils.hs b/test/Spec/Utils.hs --- a/test/Spec/Utils.hs +++ b/test/Spec/Utils.hs @@ -3,66 +3,51 @@ {-# LANGUAGE NoImplicitPrelude #-} module Spec.Utils - ( mockApi, - defineClientWith, - defineClientWithJSON, + ( path, + assertFetch, ) where +import Data.Aeson (FromJSON) import qualified Data.ByteString.Lazy as L (readFile) import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Functor ((<$>)) import Data.Morpheus.Client - ( defineByDocumentFile, - defineByIntrospectionFile, - ) -import Data.Morpheus.Types.Internal.AST - ( ExecutableDocument, - FieldName, - unpackName, + ( Fetch (..), + FetchError, ) -import Data.Semigroup ((<>)) -import qualified Data.Text as T -import Language.Haskell.TH - ( Dec, - Q, - runIO, +import Relude hiding (ByteString, exp) +import Test.Tasty + ( TestTree, ) -import System.Directory (doesFileExist) -import Prelude - ( Bool (..), - FilePath, - IO, - String, +import Test.Tasty.HUnit + ( assertEqual, + testCase, ) -path :: FieldName -> FilePath -path name = "test/Case/" <> T.unpack (unpackName name) +path :: FilePath -> FilePath +path name = "test/Case/" <> name -withProject :: FilePath -> FilePath -withProject = ("morpheus-graphql-client/" <>) +getFile :: FilePath -> IO ByteString +getFile p = L.readFile (path p) -mockApi :: FieldName -> ByteString -> IO ByteString -mockApi p _ = L.readFile (path p <> "/response.json") +mockJSON :: FilePath -> ByteString -> IO ByteString +mockJSON p _ = getFile (p <> ".json") -fixFilePath :: FilePath -> Q FilePath -fixFilePath x = prefix <$> runIO (doesFileExist x) +assertFetch :: + ( Fetch a, + FromJSON a, + Eq a, + Show a + ) => + FilePath -> + Maybe FilePath -> + Args a -> + Either (FetchError a) a -> + TestTree +assertFetch folder file args v = + testCase display $ do + response <- fetch (mockJSON (folder <> "/" <> fileName)) args + assertEqual ("Test " <> display) v response where - prefix True = x - prefix False = withProject x - -defineClientWith :: - FieldName -> - (ExecutableDocument, String) -> - Q [Dec] -defineClientWith url exp = do - p <- fixFilePath (path url <> "/schema.gql") - defineByDocumentFile p exp - -defineClientWithJSON :: - FieldName -> - (ExecutableDocument, String) -> - Q [Dec] -defineClientWithJSON url exp = do - p <- fixFilePath (path url <> "/schema.json") - defineByIntrospectionFile p exp + fileName = fromMaybe "response" file + display = fromMaybe folder file