diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2019 Daviti Nalchevanidze + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,114 @@ +# Morpheus GraphQL Client + +## Morpheus `GraphQL Client` with Template haskell QuasiQuotes + +```hs +defineByDocumentFile + "./schema.gql" + [gql| + query GetHero ($character: Character) + { + deity (fatherOf:$character) { + name + power + worships { + deity2Name: name + } + } + } + |] +``` + +with schema: + +```gql +input Character { + name: String! +} + +type Deity { + name: String! + worships: Deity + power: Power! +} + +enum Power { + Lightning + Teleportation + Omniscience +} +``` + +will validate query and Generate: + +- namespaced response and variable types +- instance for `Fetch` typeClass + +```hs +data GetHero = GetHero { + deity: DeityDeity +} + +-- from: {user +data DeityDeity = DeityDeity { + name: Text, + worships: Maybe DeityWorshipsDeity + power: Power +} + +-- from: {deity{worships +data DeityWorshipsDeity = DeityWorshipsDeity { + name: Text, +} + +data Power = + PowerLightning + | PowerTeleportation + | PowerOmniscience + +data GetHeroArgs = GetHeroArgs { + getHeroArgsCharacter: Character +} + +data Character = Character { + characterName: Person +} +``` + +as you see, response type field name collision can be handled with GraphQL `alias`. + +with `fetch` you can fetch well typed response `GetHero`. + +```haskell + fetchHero :: Args GetHero -> m (Either String GetHero) + fetchHero = fetch jsonRes args + where + args = GetHeroArgs {getHeroArgsCharacter = Person {characterName = "Zeus"}} + jsonRes :: ByteString -> m ByteString + jsonRes = +``` + +in this case, `jsonRes` resolves a request into a response in some monad `m`. + +A `fetch` resolver implementation against [a real API](https://swapi.graph.cool) may look like the following: + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Network.HTTP.Req + +resolver :: String -> ByteString -> IO ByteString +resolver tok b = runReq defaultHttpConfig $ do + let headers = header "Content-Type" "application/json" + responseBody <$> req POST (https "swapi.graph.cool") (ReqBodyLbs b) lbsResponse headers +``` + +this is demonstrated in examples/src/Client/StarWarsClient.hs + +types can be generated from `introspection` too: + +```haskell +defineByIntrospectionFile "./introspection.json" +``` diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,3 @@ +# Changelog + +## 0.12.0 - 21.05.2020 diff --git a/morpheus-graphql-client.cabal b/morpheus-graphql-client.cabal new file mode 100644 --- /dev/null +++ b/morpheus-graphql-client.cabal @@ -0,0 +1,54 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 8749fc28a63b46eed778a0eb7cfcb2e6f184c7e9c49a7f3a2847b7b735e2599e + +name: morpheus-graphql-client +version: 0.12.0 +synopsis: Morpheus GraphQL Client +description: Build GraphQL APIs with your favourite functional language! +category: web, graphql, client +homepage: https://morpheusgraphql.com +bug-reports: https://github.com/nalchevanidze/morpheus-graphql/issues +author: Daviti Nalchevanidze +maintainer: d.nalchevanidze@gmail.com +copyright: (c) 2019 Daviti Nalchevanidze +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + changelog.md + README.md + +source-repository head + type: git + location: https://github.com/nalchevanidze/morpheus-graphql + +library + exposed-modules: + Data.Morpheus.Client + other-modules: + Data.Morpheus.Client.Aeson + Data.Morpheus.Client.Build + Data.Morpheus.Client.Fetch + Data.Morpheus.Client.Transform.Core + Data.Morpheus.Client.Transform.Inputs + Data.Morpheus.Client.Transform.Selection + Paths_morpheus_graphql_client + hs-source-dirs: + src + ghc-options: -Wall + build-depends: + aeson >=1.4.4.0 && <=1.6 + , base >=4.7 && <5 + , bytestring >=0.10.4 && <0.11 + , morpheus-graphql-core >=0.12.0 + , mtl >=2.0 && <=3.0 + , template-haskell >=2.0 && <=3.0 + , text >=1.2.3.0 && <1.3 + , transformers >=0.3.0.0 && <1.0 + , unordered-containers >=0.2.8.0 && <0.3 + default-language: Haskell2010 diff --git a/src/Data/Morpheus/Client.hs b/src/Data/Morpheus/Client.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Data.Morpheus.Client + ( gql, + Fetch (..), + defineQuery, + defineByDocument, + defineByDocumentFile, + defineByIntrospection, + defineByIntrospectionFile, + ) +where + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L + ( readFile, + ) +-- MORPHEUS + +import Data.Morpheus.Client.Build + ( defineQuery, + ) +import Data.Morpheus.Client.Fetch + ( Fetch (..), + ) +import Data.Morpheus.Core + ( decodeIntrospection, + parseFullGQLDocument, + ) +import Data.Morpheus.QuasiQuoter (gql) +import Data.Morpheus.Types.Internal.AST + ( GQLQuery, + Schema, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Language.Haskell.TH + +defineByDocumentFile :: String -> (GQLQuery, String) -> Q [Dec] +defineByDocumentFile = defineByDocument . L.readFile + +defineByIntrospectionFile :: String -> (GQLQuery, String) -> Q [Dec] +defineByIntrospectionFile = defineByIntrospection . L.readFile + +defineByDocument :: IO ByteString -> (GQLQuery, String) -> Q [Dec] +defineByDocument doc = defineQuery (schemaByDocument doc) + +schemaByDocument :: IO ByteString -> IO (Eventless Schema) +schemaByDocument documentGQL = parseFullGQLDocument <$> documentGQL + +defineByIntrospection :: IO ByteString -> (GQLQuery, String) -> Q [Dec] +defineByIntrospection json = defineQuery (decodeIntrospection <$> json) diff --git a/src/Data/Morpheus/Client/Aeson.hs b/src/Data/Morpheus/Client/Aeson.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Aeson.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Client.Aeson + ( deriveFromJSON, + deriveToJSON, + takeValueType, + ) +where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.HashMap.Lazy as H + ( lookup, + ) +-- +-- MORPHEUS +import Data.Morpheus.Internal.TH + ( destructRecord, + instanceFunD, + instanceHeadT, + mkTypeName, + nameConE, + nameLitP, + nameStringL, + nameVarE, + nameVarP, + ) +import Data.Morpheus.Internal.Utils + ( nameSpaceType, + ) +import Data.Morpheus.Types.Internal.AST + ( ConsD (..), + FieldDefinition (..), + FieldName, + Message, + TypeD (..), + TypeName (..), + isEnum, + isFieldNullable, + msg, + toFieldName, + ) +import Data.Semigroup ((<>)) +import Data.Text + ( unpack, + ) +import Language.Haskell.TH + +failure :: Message -> Q a +failure = fail . show + +-- FromJSON +deriveFromJSON :: TypeD -> Q Dec +deriveFromJSON TypeD {tCons = [], tName} = + failure $ "Type " <> msg tName <> " Should Have at least one Constructor" +deriveFromJSON TypeD {tName, tNamespace, tCons = [cons]} = + defineFromJSON + name + (aesonObject tNamespace) + cons + where + name = nameSpaceType tNamespace tName +deriveFromJSON typeD@TypeD {tName, tCons, tNamespace} + | isEnum tCons = defineFromJSON name (aesonFromJSONEnumBody tName) tCons + | otherwise = defineFromJSON name (aesonUnionObject tNamespace) typeD + where + name = nameSpaceType tNamespace tName + +aesonObject :: [FieldName] -> ConsD -> ExpQ +aesonObject tNamespace con@ConsD {cName} = + appE + [|withObject name|] + (lamE [nameVarP "o"] (aesonObjectBody tNamespace con)) + where + name = nameSpaceType tNamespace cName + +aesonObjectBody :: [FieldName] -> ConsD -> ExpQ +aesonObjectBody namespace ConsD {cName, cFields} = handleFields cFields + where + consName = nameConE (nameSpaceType namespace cName) + ---------------------------------------------------------- + handleFields [] = + failure $ + "Type \"" + <> msg cName + <> "\" is Empty Object" + handleFields fields = startExp fields + where + ---------------------------------------------------------- + + defField field@FieldDefinition {fieldName} + | isFieldNullable field = [|o .:? fieldName|] + | otherwise = [|o .: fieldName|] + -------------------------------------------------------- + startExp fNames = + uInfixE + consName + (varE '(<$>)) + (applyFields fNames) + where + applyFields [] = fail "No Empty fields" + applyFields [x] = defField x + applyFields (x : xs) = + uInfixE (defField x) (varE '(<*>)) (applyFields xs) + +aesonUnionObject :: [FieldName] -> TypeD -> ExpQ +aesonUnionObject namespace TypeD {tCons} = + appE + (varE 'takeValueType) + (lamCaseE (map buildMatch tCons <> [elseCaseEXP])) + where + buildMatch cons@ConsD {cName} = match objectPattern body [] + where + objectPattern = tupP [nameLitP cName, nameVarP "o"] + body = normalB $ aesonObjectBody namespace cons + +takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a +takeValueType f (Object hMap) = case H.lookup "__typename" hMap of + Nothing -> fail "key \"__typename\" not found on object" + Just (String x) -> pure (unpack x, hMap) >>= f + Just val -> + fail $ "key \"__typename\" should be string but found: " <> show val +takeValueType _ _ = fail "expected Object" + +defineFromJSON :: TypeName -> (t -> ExpQ) -> t -> DecQ +defineFromJSON tName parseJ cFields = instanceD (cxt []) iHead [method] + where + iHead = instanceHeadT ''FromJSON tName [] + ----------------------------------------- + method = instanceFunD 'parseJSON [] (parseJ cFields) + +aesonFromJSONEnumBody :: TypeName -> [ConsD] -> ExpQ +aesonFromJSONEnumBody tName cons = lamCaseE handlers + where + handlers = map buildMatch cons <> [elseCaseEXP] + where + buildMatch ConsD {cName} = match enumPat body [] + where + enumPat = nameLitP cName + body = + normalB $ + appE + (varE 'pure) + (nameConE $ nameSpaceType [toFieldName tName] cName) + +elseCaseEXP :: MatchQ +elseCaseEXP = match (nameVarP varName) body [] + where + varName = "invalidValue" + body = + normalB $ + appE + (nameVarE "fail") + ( uInfixE + (appE (varE 'show) (nameVarE varName)) + (varE '(<>)) + (stringE " is Not Valid Union Constructor") + ) + +aesonToJSONEnumBody :: TypeName -> [ConsD] -> ExpQ +aesonToJSONEnumBody tName cons = lamCaseE handlers + where + handlers = map buildMatch cons + where + buildMatch ConsD {cName} = match enumPat body [] + where + enumPat = conP (mkTypeName $ nameSpaceType [toFieldName tName] cName) [] + body = normalB $ litE (nameStringL cName) + +-- ToJSON +deriveToJSON :: TypeD -> Q [Dec] +deriveToJSON TypeD {tCons = []} = + fail "Type Should Have at least one Constructor" +deriveToJSON TypeD {tName, tCons = [ConsD {cFields}]} = + pure <$> instanceD (cxt []) appHead methods + where + appHead = instanceHeadT ''ToJSON tName [] + ------------------------------------------------------------------ + -- defines: toJSON (User field1 field2 ...)= object ["name" .= name, "age" .= age, ...] + methods = [funD 'toJSON [clause argsE (normalB body) []]] + where + argsE = [destructRecord tName varNames] + body = appE (varE 'object) (listE $ map decodeVar varNames) + decodeVar name = [|name .= $(varName)|] where varName = nameVarE name + varNames = map fieldName cFields +deriveToJSON TypeD {tName, tCons} + | isEnum tCons = + let methods = [funD 'toJSON clauses] + clauses = [clause [] (normalB $ aesonToJSONEnumBody tName tCons) []] + in pure <$> instanceD (cxt []) (instanceHeadT ''ToJSON tName []) methods + | otherwise = + fail "Input Unions are not yet supported" diff --git a/src/Data/Morpheus/Client/Build.hs b/src/Data/Morpheus/Client/Build.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Build.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} + +module Data.Morpheus.Client.Build + ( defineQuery, + ) +where + +-- +-- MORPHEUS + +import Data.Morpheus.Client.Aeson + ( deriveFromJSON, + deriveToJSON, + ) +import Data.Morpheus.Client.Fetch + ( deriveFetch, + ) +import Data.Morpheus.Client.Transform.Selection + ( ClientDefinition (..), + toClientDefinition, + ) +import Data.Morpheus.Core + ( validateRequest, + ) +import Data.Morpheus.Error + ( gqlWarnings, + renderGQLErrors, + ) +import Data.Morpheus.Internal.TH + ( Scope (..), + declareType, + nameConType, + nameConType, + ) +import qualified Data.Morpheus.Types.Internal.AST as O + ( Operation (..), + ) +import Data.Morpheus.Types.Internal.AST + ( DataTypeKind (..), + GQLQuery (..), + Schema, + TypeD (..), + TypeD (..), + VALIDATION_MODE (..), + isOutputObject, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Result (..), + ) +import Data.Semigroup ((<>)) +import Language.Haskell.TH + +defineQuery :: IO (Eventless Schema) -> (GQLQuery, 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 >> defineQueryD src result + +defineQueryD :: String -> ClientDefinition -> Q [Dec] +defineQueryD _ ClientDefinition {clientTypes = []} = return [] +defineQueryD src ClientDefinition {clientArguments, clientTypes = rootType : subTypes} = + do + rootDeclaration <- + defineOperationType + (queryArgumentType clientArguments) + src + rootType + typeDeclarations <- concat <$> traverse declareT subTypes + pure (rootDeclaration <> typeDeclarations) + where + declareT clientType@TypeD {tKind} + | isOutputObject tKind || tKind == KindUnion = + withToJSON + declareOutputType + clientType + | tKind == KindEnum = withToJSON declareInputType clientType + | otherwise = declareInputType clientType + +declareOutputType :: TypeD -> Q [Dec] +declareOutputType typeD = pure [declareType CLIENT False Nothing [''Show] typeD] + +declareInputType :: TypeD -> Q [Dec] +declareInputType typeD = do + toJSONDec <- deriveToJSON typeD + pure $ declareType CLIENT True Nothing [''Show] typeD : toJSONDec + +withToJSON :: (TypeD -> Q [Dec]) -> TypeD -> Q [Dec] +withToJSON f datatype = do + toJson <- deriveFromJSON datatype + dec <- f datatype + pure (toJson : dec) + +queryArgumentType :: Maybe TypeD -> (Type, Q [Dec]) +queryArgumentType Nothing = (nameConType "()", pure []) +queryArgumentType (Just rootType@TypeD {tName}) = + (nameConType tName, declareInputType rootType) + +defineOperationType :: (Type, Q [Dec]) -> String -> TypeD -> Q [Dec] +defineOperationType (argType, argumentTypes) query clientType = + do + rootType <- withToJSON declareOutputType clientType + typeClassFetch <- deriveFetch argType (tName clientType) query + argsT <- argumentTypes + pure $ rootType <> typeClassFetch <> argsT + +validateWith :: Schema -> GQLQuery -> Eventless ClientDefinition +validateWith schema rawRequest@GQLQuery {operation} = do + validOperation <- validateRequest schema WITHOUT_VARIABLES rawRequest + toClientDefinition + schema + (O.operationArguments operation) + validOperation diff --git a/src/Data/Morpheus/Client/Fetch.hs b/src/Data/Morpheus/Client/Fetch.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Fetch.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE ConstrainedClassMethods #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} + +module Data.Morpheus.Client.Fetch + ( Fetch (..), + deriveFetch, + ) +where + +import Control.Monad ((>=>)) +import Data.Aeson + ( FromJSON, + ToJSON (..), + eitherDecode, + encode, + ) +import qualified Data.Aeson as A +import qualified Data.Aeson.Types as A +import Data.ByteString.Lazy (ByteString) +-- +-- MORPHEUS + +import Data.Morpheus.Internal.TH + ( instanceHeadT, + nameConType, + typeInstanceDec, + ) +import Data.Morpheus.Types.IO + ( GQLRequest (..), + JSONResponse (..), + ) +import Data.Morpheus.Types.Internal.AST + ( FieldName, + TypeName, + ) +import Data.Text + ( pack, + ) +import Language.Haskell.TH + +fixVars :: A.Value -> Maybe A.Value +fixVars x + | x == A.emptyArray = Nothing + | otherwise = Just x + +class Fetch a where + type Args a :: * + __fetch :: + (Monad m, Show a, ToJSON (Args a), FromJSON a) => + String -> + FieldName -> + (ByteString -> m ByteString) -> + Args a -> + m (Either String a) + __fetch strQuery opName trans vars = (eitherDecode >=> processResponse) <$> trans (encode gqlReq) + where + gqlReq = GQLRequest {operationName = Just opName, query = pack strQuery, variables = fixVars (toJSON vars)} + ------------------------------------------------------------- + processResponse JSONResponse {responseData = Just x} = Right x + processResponse invalidResponse = Left (show invalidResponse) + fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either String a) + +deriveFetch :: Type -> TypeName -> String -> Q [Dec] +deriveFetch resultType typeName queryString = + pure <$> instanceD (cxt []) iHead methods + where + iHead = instanceHeadT ''Fetch typeName [] + methods = + [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []], + pure $ typeInstanceDec ''Args (nameConType typeName) resultType + ] diff --git a/src/Data/Morpheus/Client/Transform/Core.hs b/src/Data/Morpheus/Client/Transform/Core.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Transform/Core.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Client.Transform.Core + ( Converter (..), + compileError, + getType, + leafType, + typeFrom, + deprecationWarning, + ) +where + +-- +-- MORPHEUS +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader + ( ReaderT (..), + ) +import Data.Morpheus.Error + ( deprecatedField, + globalErrorMessage, + ) +import Data.Morpheus.Internal.Utils + ( Failure (..), + nameSpaceType, + selectBy, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + FieldName, + GQLErrors, + Message, + Meta, + RAW, + Ref (..), + Schema (..), + TRUE, + TypeContent (..), + TypeD, + TypeDefinition (..), + TypeName, + VariableDefinitions, + lookupDeprecated, + lookupDeprecatedReason, + msg, + typeFromScalar, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + Result (..), + ) +import Data.Semigroup ((<>)) + +type Env = (Schema, VariableDefinitions RAW) + +newtype Converter a = Converter + { runConverter :: + ReaderT + Env + Eventless + a + } + deriving (Functor, Applicative, Monad, MonadReader Env) + +instance Failure GQLErrors Converter where + failure = Converter . lift . failure + +compileError :: Message -> GQLErrors +compileError x = + globalErrorMessage $ "Unhandled Compile Time Error: \"" <> x <> "\" ;" + +getType :: TypeName -> Converter (TypeDefinition ANY) +getType typename = asks fst >>= selectBy (compileError $ " cant find Type" <> msg typename) typename + +leafType :: TypeDefinition a -> Converter ([TypeD], [TypeName]) +leafType TypeDefinition {typeName, typeContent} = fromKind typeContent + where + fromKind :: TypeContent TRUE a -> Converter ([TypeD], [TypeName]) + fromKind DataEnum {} = pure ([], [typeName]) + fromKind DataScalar {} = pure ([], []) + fromKind _ = failure $ compileError "Invalid schema Expected scalar" + +typeFrom :: [FieldName] -> TypeDefinition a -> TypeName +typeFrom path TypeDefinition {typeName, typeContent} = __typeFrom typeContent + where + __typeFrom DataScalar {} = typeFromScalar typeName + __typeFrom DataObject {} = nameSpaceType path typeName + __typeFrom DataUnion {} = nameSpaceType path typeName + __typeFrom _ = typeName + +deprecationWarning :: Maybe Meta -> (FieldName, Ref) -> Converter () +deprecationWarning meta (typename, ref) = case meta >>= lookupDeprecated of + Just deprecation -> Converter $ lift $ Success {result = (), warnings, events = []} + where + warnings = + deprecatedField + typename + ref + (lookupDeprecatedReason deprecation) + Nothing -> pure () diff --git a/src/Data/Morpheus/Client/Transform/Inputs.hs b/src/Data/Morpheus/Client/Transform/Inputs.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Transform/Inputs.hs @@ -0,0 +1,142 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Client.Transform.Inputs + ( renderNonOutputTypes, + renderOperationArguments, + ) +where + +-- +-- MORPHEUS +import Control.Monad.Reader (asks) +import Data.Morpheus.Client.Transform.Core (Converter (..), getType, typeFrom) +import Data.Morpheus.Internal.Utils + ( elems, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + ConsD (..), + DataTypeKind (..), + FieldDefinition (..), + IN, + Operation (..), + RAW, + TRUE, + TypeContent (..), + TypeD (..), + TypeDefinition (..), + TypeName, + TypeRef (..), + VALID, + Variable (..), + VariableDefinitions, + getOperationName, + mkConsEnum, + removeDuplicates, + ) +import Data.Morpheus.Types.Internal.Resolving + ( resolveUpdates, + ) +import Data.Semigroup ((<>)) + +renderArguments :: VariableDefinitions RAW -> TypeName -> Maybe TypeD +renderArguments variables argsName + | null variables = Nothing + | otherwise = Just rootArgumentsType + where + rootArgumentsType :: TypeD + rootArgumentsType = + TypeD + { tName = argsName, + tNamespace = [], + tCons = [ConsD {cName = argsName, cFields = map fieldD (elems variables)}], + tMeta = Nothing, + tKind = KindInputObject + } + where + fieldD :: Variable RAW -> FieldDefinition ANY + fieldD Variable {variableName, variableType} = + FieldDefinition + { fieldName = variableName, + fieldArgs = NoArguments, + fieldType = variableType, + fieldMeta = Nothing + } + +renderOperationArguments :: Operation VALID -> Converter (Maybe TypeD) +renderOperationArguments Operation {operationName} = do + variables <- asks snd + pure $ renderArguments variables (getOperationName operationName <> "Args") + +-- INPUTS +renderNonOutputTypes :: [TypeName] -> Converter [TypeD] +renderNonOutputTypes enums = do + variables <- elems <$> asks snd + inputTypeRequests <- resolveUpdates [] $ map (exploreInputTypeNames . typeConName . variableType) variables + concat <$> traverse buildInputType (removeDuplicates $ inputTypeRequests <> enums) + +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) + (map toInputTypeD $ elems fields) + where + toInputTypeD :: FieldDefinition IN -> [TypeName] -> Converter [TypeName] + toInputTypeD FieldDefinition {fieldType = TypeRef {typeConName}} = + exploreInputTypeNames typeConName + scanType (DataEnum _) = pure (collected <> [typeName]) + scanType _ = pure collected + +buildInputType :: TypeName -> Converter [TypeD] +buildInputType name = getType name >>= generateTypes + where + generateTypes TypeDefinition {typeName, typeContent} = subTypes typeContent + where + subTypes :: TypeContent TRUE ANY -> Converter [TypeD] + subTypes (DataInputObject inputFields) = do + fields <- traverse toFieldD (elems inputFields) + pure + [ mkInputType + typeName + KindInputObject + [ ConsD + { cName = typeName, + cFields = fields + } + ] + ] + subTypes (DataEnum enumTags) = + pure + [ mkInputType + typeName + KindEnum + (map mkConsEnum enumTags) + ] + subTypes _ = pure [] + +mkInputType :: TypeName -> DataTypeKind -> [ConsD] -> TypeD +mkInputType tName tKind tCons = + TypeD + { tName, + tNamespace = [], + tCons, + tKind, + tMeta = Nothing + } + +toFieldD :: FieldDefinition cat -> Converter (FieldDefinition ANY) +toFieldD field@FieldDefinition {fieldType} = do + typeConName <- typeFrom [] <$> getType (typeConName fieldType) + pure $ field {fieldType = fieldType {typeConName}} diff --git a/src/Data/Morpheus/Client/Transform/Selection.hs b/src/Data/Morpheus/Client/Transform/Selection.hs new file mode 100644 --- /dev/null +++ b/src/Data/Morpheus/Client/Transform/Selection.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Data.Morpheus.Client.Transform.Selection + ( toClientDefinition, + ClientDefinition (..), + ) +where + +-- +-- MORPHEUS +import Control.Monad.Reader (asks, runReaderT) +import Data.Morpheus.Client.Transform.Core (Converter (..), compileError, deprecationWarning, getType, leafType, typeFrom) +import Data.Morpheus.Client.Transform.Inputs (renderNonOutputTypes, renderOperationArguments) +import Data.Morpheus.Internal.Utils + ( Failure (..), + elems, + keyOf, + selectBy, + ) +import Data.Morpheus.Types.Internal.AST + ( ANY, + ArgumentsDefinition (..), + ConsD (..), + DataTypeKind (..), + FieldDefinition (..), + FieldName, + Operation (..), + RAW, + Ref (..), + Schema (..), + Selection (..), + SelectionContent (..), + SelectionSet, + TypeContent (..), + TypeD (..), + TypeDefinition (..), + TypeName, + TypeRef (..), + UnionTag (..), + VALID, + VariableDefinitions, + getOperationDataType, + getOperationName, + msg, + toAny, + toFieldName, + ) +import Data.Morpheus.Types.Internal.Resolving + ( Eventless, + ) +import Data.Semigroup ((<>)) + +data ClientDefinition = ClientDefinition + { clientArguments :: Maybe TypeD, + clientTypes :: [TypeD] + } + deriving (Show) + +toClientDefinition :: + Schema -> + VariableDefinitions RAW -> + Operation VALID -> + Eventless 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 TypeD, [TypeD], [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 -> + SelectionSet VALID -> + Converter ([TypeD], [TypeName]) +genRecordType path tName dataType recordSelSet = do + (con, subTypes, requests) <- genConsD path tName dataType recordSelSet + pure + ( TypeD + { tName, + tNamespace = path, + tCons = [con], + tKind = KindObject Nothing, + tMeta = Nothing + } + : subTypes, + requests + ) + +genConsD :: + [FieldName] -> + TypeName -> + TypeDefinition ANY -> + SelectionSet VALID -> + Converter (ConsD, [TypeD], [TypeName]) +genConsD path cName datatype selSet = do + (cFields, subTypes, requests) <- unzip3 <$> traverse genField (elems selSet) + pure (ConsD {cName, cFields}, concat subTypes, concat requests) + where + genField :: + Selection VALID -> + Converter (FieldDefinition ANY, [TypeD], [TypeName]) + genField sel = + do + (fieldDataType, fieldType) <- + getFieldType + fieldPath + datatype + sel + (subTypes, requests) <- subTypesBySelection fieldPath fieldDataType sel + pure + ( FieldDefinition + { fieldName, + fieldType, + fieldArgs = NoArguments, + fieldMeta = Nothing + }, + subTypes, + requests + ) + where + fieldPath = path <> [fieldName] + ------------------------------- + fieldName = keyOf sel + +------------------------------------------ +subTypesBySelection :: + [FieldName] -> + TypeDefinition ANY -> + Selection VALID -> + Converter ([TypeD], [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 unionSelections} = + do + (tCons, subTypes, requests) <- + unzip3 <$> traverse getUnionType (elems unionSelections) + pure + ( TypeD + { tNamespace = path, + tName = typeFrom [] dType, + tCons, + tKind = KindUnion, + tMeta = Nothing + } + : concat subTypes, + concat requests + ) + where + getUnionType (UnionTag selectedTyName selectionVariant) = do + conDatatype <- getType selectedTyName + genConsD path selectedTyName conDatatype selectionVariant + +getFieldType :: + [FieldName] -> + TypeDefinition ANY -> + Selection VALID -> + Converter (TypeDefinition ANY, TypeRef) +getFieldType + path + TypeDefinition {typeContent = DataObject {objectFields}, typeName} + Selection + { selectionName, + selectionPosition + } = + selectBy selError selectionName objectFields >>= processDeprecation + where + selError = compileError $ "cant find field " <> msg (show objectFields) + processDeprecation FieldDefinition {fieldType = alias@TypeRef {typeConName}, fieldMeta} = + checkDeprecated >> (trans <$> getType typeConName) + where + trans x = + (x, alias {typeConName = typeFrom path x, typeArgs = Nothing}) + ------------------------------------------------------------------ + checkDeprecated :: Converter () + checkDeprecated = + deprecationWarning + fieldMeta + (toFieldName typeName, Ref {refName = selectionName, refPosition = selectionPosition}) +getFieldType _ dt _ = + failure (compileError $ "Type should be output Object \"" <> msg (show dt))