packages feed

morpheus-graphql-app (empty) → 0.17.0

raw patch · 61 files changed

+3101/−0 lines, 61 filesdep +aesondep +basedep +bytestring

Dependencies added: aeson, base, bytestring, containers, directory, hashable, megaparsec, morpheus-graphql-app, morpheus-graphql-core, mtl, relude, scientific, tasty, tasty-hunit, template-haskell, text, th-lift-instances, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,44 @@+# Morpheus GraphQL App++provides utilities for creating executable GraphQL applications for servers. You can use it to create a schema-first GraphQL server with dynamic typings.++## Build schema-first GraphQL App with dynamic typings++```hs+schema :: Schema VALID+schema =+  [dsl|+  type Query {+    deity(name: String): Deity!+  }++  type Deity {+    name: String!+    power: [String!]!+  }+|]++resolver :: Monad m => RootResolverValue e m+resolver =+  RootResModel+    { query =+        pure $+          mkObject+            "Query"+            [("deity", resolveDeity)],+      mutation = pure mkNull,+      subscription = pure mkNull+    }++resolveDeity :: Monad m => m (ResolverValue  m)+resolveDeity =+  pure $+    mkObject+      "Deity"+      [ ("name", pure $ mkString "Morpheus"),+        ("power", pure $ mkList [mkString "Shapeshifting"])+      ]++api :: ByteString -> IO  ByteString+api = runApp (mkApp schema resolver)+```
+ changelog.md view
@@ -0,0 +1,3 @@+# Changelog++## 0.17.0 (Initial Release) - 25.02.2021
+ morpheus-graphql-app.cabal view
@@ -0,0 +1,142 @@+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: 78e70a5663436c9fe3f864a6d3a10e1a07dd8bae9058f6693b803c2cf08de583++name:           morpheus-graphql-app+version:        0.17.0+synopsis:       Morpheus GraphQL Core+description:    Build GraphQL APIs with your favourite functional language!+category:       web, graphql+homepage:       https://morpheusgraphql.com+bug-reports:    https://github.com/nalchevanidze/morpheus-graphql-app/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+data-files:+    test/api/deity/interface/query.gql+    test/api/deity/schema.gql+    test/api/deity/simple/query.gql+    test/api/validation/fragment/fail-unknown-field-on-interface/query.gql+    test/api/validation/fragment/on-interface-fail-without-casting/query.gql+    test/api/validation/fragment/on-interface-inline/query.gql+    test/api/validation/fragment/on-interface-type-casting-inline/query.gql+    test/api/validation/fragment/on-interface-type-casting/query.gql+    test/api/validation/fragment/on-interface/query.gql+    test/api/validation/fragment/on-type/query.gql+    test/api/validation/fragment/on-union-type/query.gql+    test/api/validation/fragment/schema.gql+    test/merge/schema/query-subscription-mutation/api/app.gql+    test/merge/schema/query-subscription-mutation/api/ext.gql+    test/merge/schema/query-subscription-mutation/expected/ok.gql+    test/merge/schema/query-subscription-mutation/request/mutation/query.gql+    test/merge/schema/query-subscription-mutation/request/query/query.gql+    test/merge/schema/simple-query/api/app.gql+    test/merge/schema/simple-query/api/ext.gql+    test/merge/schema/simple-query/expected/ok.gql+    test/merge/schema/simple-query/request/query/query.gql+    test/api/deity/interface/response.json+    test/api/deity/resolvers.json+    test/api/deity/simple/response.json+    test/api/validation/fragment/fail-unknown-field-on-interface/response.json+    test/api/validation/fragment/on-interface-fail-without-casting/response.json+    test/api/validation/fragment/on-interface-inline/response.json+    test/api/validation/fragment/on-interface-type-casting-inline/response.json+    test/api/validation/fragment/on-interface-type-casting/response.json+    test/api/validation/fragment/on-interface/response.json+    test/api/validation/fragment/on-type/response.json+    test/api/validation/fragment/on-union-type/response.json+    test/api/validation/fragment/resolvers.json+    test/merge/schema/query-subscription-mutation/api/app.json+    test/merge/schema/query-subscription-mutation/api/ext.json+    test/merge/schema/query-subscription-mutation/request/mutation/response.json+    test/merge/schema/query-subscription-mutation/request/query/response.json+    test/merge/schema/simple-query/api/app.json+    test/merge/schema/simple-query/api/ext.json+    test/merge/schema/simple-query/request/query/response.json++source-repository head+  type: git+  location: https://github.com/nalchevanidze/morpheus-graphql-app++library+  exposed-modules:+      Data.Morpheus.App+      Data.Morpheus.App.Internal.Resolving+      Data.Morpheus.Types.GQLWrapper+  other-modules:+      Data.Morpheus.App.Error+      Data.Morpheus.App.Internal.Resolving.Event+      Data.Morpheus.App.Internal.Resolving.Resolver+      Data.Morpheus.App.Internal.Resolving.ResolverState+      Data.Morpheus.App.Internal.Resolving.ResolverValue+      Data.Morpheus.App.Internal.Resolving.RootResolverValue+      Data.Morpheus.App.Internal.Stitching+      Data.Morpheus.App.MapAPI+      Data.Morpheus.App.RenderIntrospection+      Data.Morpheus.App.SchemaAPI+      Paths_morpheus_graphql_app+  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+    , containers >=0.4.2.1 && <0.7+    , hashable >=1.0.0+    , megaparsec >=7.0.0 && <10.0.0+    , morpheus-graphql-core >=0.17.0 && <0.18.0+    , mtl >=2.0 && <=3.0+    , relude >=0.3.0+    , scientific >=0.3.6.2 && <0.4+    , template-haskell >=2.0 && <=3.0+    , text >=1.2.3.0 && <1.3+    , th-lift-instances >=0.1.1 && <=0.3+    , transformers >=0.3.0.0 && <0.6+    , unordered-containers >=0.2.8.0 && <0.3+    , vector >=0.12.0.1 && <0.13+  default-language: Haskell2010++test-suite morpheus-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Utils.Api+      Utils.MergeSchema+      Utils.Utils+      Paths_morpheus_graphql_app+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      aeson+    , base >=4.7 && <5+    , bytestring >=0.10.4 && <0.11+    , containers >=0.4.2.1 && <0.7+    , directory >=1.0+    , hashable >=1.0.0+    , megaparsec >=7.0.0 && <10.0.0+    , morpheus-graphql-app+    , morpheus-graphql-core >=0.17.0 && <0.18.0+    , mtl >=2.0 && <=3.0+    , relude >=0.3.0+    , scientific >=0.3.6.2 && <0.4+    , tasty+    , tasty-hunit+    , template-haskell >=2.0 && <=3.0+    , text >=1.2.3.0 && <1.3+    , th-lift-instances >=0.1.1 && <=0.3+    , transformers >=0.3.0.0 && <0.6+    , unordered-containers >=0.2.8.0 && <0.3+    , vector >=0.12.0.1 && <0.13+  default-language: Haskell2010
+ src/Data/Morpheus/App.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App+  ( Config (..),+    VALIDATION_MODE (..),+    defaultConfig,+    debugConfig,+    App (..),+    AppData (..),+    runApp,+    withDebugger,+    mkApp,+    runAppStream,+    MapAPI (..),+  )+where++import qualified Data.Aeson as A+import Data.Morpheus.App.Internal.Resolving+  ( ResolverContext (..),+    ResponseStream,+    ResultT (..),+    RootResolverValue,+    cleanEvents,+    resultOr,+    runRootResolverValue,+  )+import Data.Morpheus.App.Internal.Stitching (Stitching (..))+import Data.Morpheus.App.MapAPI (MapAPI (..))+import Data.Morpheus.App.SchemaAPI (withSystemFields)+import Data.Morpheus.Core+  ( Config (..),+    RenderGQL (..),+    VALIDATION_MODE (..),+    ValidateSchema (..),+    debugConfig,+    defaultConfig,+    internalSchema,+    parseRequestWith,+  )+import Data.Morpheus.Internal.Ext ((<:>))+import Data.Morpheus.Internal.Utils+  ( empty,+    failure,+    prop,+  )+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+    GQLResponse,+    renderResponse,+  )+import Data.Morpheus.Types.Internal.AST+  ( GQLErrors,+    Operation (..),+    Schema (..),+    Schema (..),+    Selection (..),+    SelectionContent (..),+    VALID,+    Value,+  )+import Relude hiding (empty)++mkApp :: ValidateSchema s => Schema s -> RootResolverValue e m -> App e m+mkApp appSchema appResolvers =+  resultOr+    FailApp+    (App . AppData defaultConfig appResolvers)+    (validateSchema True defaultConfig appSchema)++data App event (m :: * -> *)+  = App {app :: AppData event m VALID}+  | FailApp {appErrors :: GQLErrors}++instance RenderGQL (App e m) where+  renderGQL App {app} = renderGQL app+  renderGQL FailApp {appErrors} = renderGQL (A.encode appErrors)++instance Monad m => Semigroup (App e m) where+  (FailApp err1) <> (FailApp err2) = FailApp (err1 <> err2)+  FailApp {appErrors} <> App {} = FailApp appErrors+  App {} <> FailApp {appErrors} = FailApp appErrors+  (App x) <> (App y) = resultOr FailApp App (stitch x y)++data AppData event (m :: * -> *) s = AppData+  { appConfig :: Config,+    appResolvers :: RootResolverValue event m,+    appSchema :: Schema s+  }++instance RenderGQL (AppData e m s) where+  renderGQL = renderGQL . appSchema++instance Monad m => Stitching (AppData e m s) where+  stitch x y =+    AppData (appConfig y)+      <$> prop stitch appResolvers x y+      <*> prop stitch appSchema x y++runAppData ::+  (Monad m, ValidateSchema s) =>+  AppData event m s ->+  GQLRequest ->+  ResponseStream event m (Value VALID)+runAppData AppData {appConfig, appSchema, appResolvers} request = do+  validRequest <- validateReq appSchema appConfig request+  resolvers <- withSystemFields (schema validRequest) appResolvers+  runRootResolverValue resolvers validRequest++validateReq ::+  ( Monad m,+    ValidateSchema s+  ) =>+  Schema s ->+  Config ->+  GQLRequest ->+  ResponseStream event m ResolverContext+validateReq inputSchema config request = cleanEvents $ ResultT $ pure $ do+  validSchema <- validateSchema True config inputSchema+  schema <- internalSchema <:> validSchema+  operation <- parseRequestWith config validSchema request+  pure $+    ResolverContext+      { schema,+        config,+        operation,+        currentTypeName = "Root",+        currentSelection =+          Selection+            { selectionName = "Root",+              selectionArguments = empty,+              selectionPosition = operationPosition operation,+              selectionAlias = Nothing,+              selectionContent = SelectionSet (operationSelection operation),+              selectionDirectives = []+            }+      }++stateless ::+  Functor m =>+  ResponseStream event m (Value VALID) ->+  m GQLResponse+stateless = fmap renderResponse . runResultT++runAppStream :: Monad m => App event m -> GQLRequest -> ResponseStream event m (Value VALID)+runAppStream App {app} = runAppData app+runAppStream FailApp {appErrors} = const $ failure appErrors++runApp :: (MapAPI a b, Monad m) => App e m -> a -> m b+runApp app = mapAPI (stateless . runAppStream app)++withDebugger :: App e m -> App e m+withDebugger App {app = AppData {appConfig = Config {..}, ..}} =+  App {app = AppData {appConfig = Config {debug = True, ..}, ..}, ..}+withDebugger x = x
+ src/Data/Morpheus/App/Error.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Error+  ( badRequestError,+  )+where++import Data.ByteString.Lazy.Char8+  ( ByteString,+    pack,+  )+import Relude hiding (ByteString)++badRequestError :: String -> ByteString+badRequestError = pack . ("Bad Request. Could not decode Request body: " <>)
+ src/Data/Morpheus/App/Internal/Resolving.hs view
@@ -0,0 +1,107 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving+  ( Resolver,+    LiftOperation,+    runRootResolverValue,+    lift,+    Eventless,+    Failure (..),+    ResponseEvent (..),+    ResponseStream,+    cleanEvents,+    Result (..),+    ResultT (..),+    unpackEvents,+    ResolverObject (..),+    ResolverValue (..),+    WithOperation,+    PushEvents (..),+    subscribe,+    ResolverContext (..),+    unsafeInternalContext,+    RootResolverValue (..),+    resultOr,+    withArguments,+    -- Dynamic Resolver+    mkBoolean,+    mkFloat,+    mkInt,+    mkEnum,+    mkList,+    mkUnion,+    mkObject,+    mkNull,+    mkString,+    SubscriptionField (..),+    getArguments,+    ResolverState,+    liftResolverState,+    mkValue,+    ResolverEntry,+    sortErrors,+    EventHandler (..),+  )+where++import qualified Data.Aeson as A+import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.App.Internal.Resolving.Event+import Data.Morpheus.App.Internal.Resolving.Resolver+import Data.Morpheus.App.Internal.Resolving.ResolverState+import Data.Morpheus.App.Internal.Resolving.ResolverValue+import Data.Morpheus.App.Internal.Resolving.RootResolverValue+import Data.Morpheus.Internal.Ext+import Data.Morpheus.Internal.Utils+  ( mapTuple,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    ScalarValue (..),+    Token,+    TypeName (..),+    decodeScientific,+  )+import qualified Data.Vector as V+  ( toList,+  )+import Relude++mkString :: Token -> ResolverValue m+mkString = ResScalar . String++mkFloat :: Double -> ResolverValue m+mkFloat = ResScalar . Float++mkInt :: Int -> ResolverValue m+mkInt = ResScalar . Int++mkBoolean :: Bool -> ResolverValue m+mkBoolean = ResScalar . Boolean++mkList :: [ResolverValue m] -> ResolverValue m+mkList = ResList++mkNull :: ResolverValue m+mkNull = ResNull++unPackName :: A.Value -> TypeName+unPackName (A.String x) = TypeName x+unPackName _ = "__JSON__"++mkValue ::+  (Monad m) =>+  A.Value ->+  ResolverValue m+mkValue (A.Object v) =+  mkObject+    (maybe "__JSON__" unPackName $ HM.lookup "__typename" v)+    $ fmap+      (mapTuple FieldName (pure . mkValue))+      (HM.toList v)+mkValue (A.Array ls) = mkList (fmap mkValue (V.toList ls))+mkValue A.Null = mkNull+mkValue (A.Number x) = ResScalar (decodeScientific x)+mkValue (A.String x) = ResScalar (String x)+mkValue (A.Bool x) = ResScalar (Boolean x)
+ src/Data/Morpheus/App/Internal/Resolving/Event.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.Event+  ( EventHandler (..),+    ResponseEvent (..),+  )+where++import Data.Morpheus.Types.IO+  ( GQLResponse,+  )++class EventHandler e where+  type Channel e+  getChannels :: e -> [Channel e]++data ResponseEvent event (m :: * -> *)+  = Publish event+  | Subscribe+      { subChannel :: Channel event,+        subRes :: event -> m GQLResponse+      }
+ src/Data/Morpheus/App/Internal/Resolving/Resolver.hs view
@@ -0,0 +1,245 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.Resolver+  ( Resolver,+    LiftOperation,+    lift,+    subscribe,+    ResponseEvent (..),+    ResponseStream,+    WithOperation,+    ResolverContext (..),+    unsafeInternalContext,+    withArguments,+    getArguments,+    SubscriptionField (..),+    liftResolverState,+    runResolver,+  )+where++import Control.Monad.Trans.Reader (mapReaderT)+import Data.Morpheus.App.Internal.Resolving.Event+  ( EventHandler (..),+    ResponseEvent (..),+  )+import Data.Morpheus.App.Internal.Resolving.ResolverState+  ( ResolverContext (..),+    ResolverState,+    ResolverStateT (..),+    clearStateResolverEvents,+    resolverFailureMessage,+    runResolverState,+    runResolverStateM,+    runResolverStateT,+    toResolverStateT,+  )+import Data.Morpheus.Internal.Ext+  ( Eventless,+    Failure (..),+    PushEvents (..),+    Result (..),+    ResultT (..),+    cleanEvents,+    mapEvent,+  )+import Data.Morpheus.Types.IO+  ( GQLResponse,+    renderResponse,+  )+import Data.Morpheus.Types.Internal.AST+  ( Arguments,+    MUTATION,+    OperationType (..),+    QUERY,+    SUBSCRIPTION,+    Selection (..),+    VALID,+    ValidValue,+    Value (..),+    msg,+  )+import Relude hiding+  ( Show,+    empty,+    show,+  )+import Prelude (Show (..))++type WithOperation (o :: OperationType) = LiftOperation o++type ResponseStream event (m :: * -> *) = ResultT (ResponseEvent event m) m++data SubscriptionField (a :: *) where+  SubscriptionField ::+    { channel :: forall e m v. a ~ Resolver SUBSCRIPTION e m v => Channel e,+      unSubscribe :: a+    } ->+    SubscriptionField a++--+-- GraphQL Field Resolver+--+---------------------------------------------------------------+data Resolver (o :: OperationType) event (m :: * -> *) value where+  ResolverQ :: {runResolverQ :: ResolverStateT () m value} -> Resolver QUERY event m value+  ResolverM :: {runResolverM :: ResolverStateT event m value} -> Resolver MUTATION event m value+  ResolverS :: {runResolverS :: ResolverStateT () m (SubEventRes event m value)} -> Resolver SUBSCRIPTION event m value++type SubEventRes event m value = ReaderT event (ResolverStateT () m) value++instance Show (Resolver o e m value) where+  show ResolverQ {} = "Resolver QUERY e m a"+  show ResolverM {} = "Resolver MUTATION e m a"+  show ResolverS {} = "Resolver SUBSCRIPTION e m a"++deriving instance (Functor m) => Functor (Resolver o e m)++-- Applicative+instance (LiftOperation o, Monad m) => Applicative (Resolver o e m) where+  pure = packResolver . pure+  ResolverQ r1 <*> ResolverQ r2 = ResolverQ $ r1 <*> r2+  ResolverM r1 <*> ResolverM r2 = ResolverM $ r1 <*> r2+  ResolverS r1 <*> ResolverS r2 = ResolverS $ (<*>) <$> r1 <*> r2++-- Monad+instance (Monad m, LiftOperation o) => Monad (Resolver o e m) where+  return = pure+  (ResolverQ x) >>= m2 = ResolverQ (x >>= runResolverQ . m2)+  (ResolverM x) >>= m2 = ResolverM (x >>= runResolverM . m2)+  (ResolverS res) >>= m2 = ResolverS (liftSubResolver m2 <$> res)++liftSubResolver ::+  (Monad m) =>+  (t -> Resolver SUBSCRIPTION r m a) ->+  ReaderT r (ResolverStateT () m) t ->+  ReaderT r (ResolverStateT () m) a+liftSubResolver m2 readResA = ReaderT $ \e -> do+  a <- runReaderT readResA e+  readResB <- runResolverS (m2 a)+  runReaderT readResB e++-- MonadIO+instance (MonadIO m, LiftOperation o) => MonadIO (Resolver o e m) where+  liftIO = lift . liftIO++-- Monad Transformers+instance (LiftOperation o) => MonadTrans (Resolver o e) where+  lift = packResolver . lift++-- Failure+instance (LiftOperation o, Monad m, Failure err (ResolverStateT e m)) => Failure err (Resolver o e m) where+  failure = packResolver . failure++instance (Monad m, LiftOperation o) => MonadFail (Resolver o e m) where+  fail = failure . msg++-- PushEvents+instance (Monad m) => PushEvents e (Resolver MUTATION e m) where+  pushEvents = packResolver . pushEvents++instance (Monad m, Semigroup a, LiftOperation o) => Semigroup (Resolver o e m a) where+  x <> y = fmap (<>) x <*> y++instance (LiftOperation o, Monad m) => MonadReader ResolverContext (Resolver o e m) where+  ask = packResolver ask+  local f (ResolverQ res) = ResolverQ (local f res)+  local f (ResolverM res) = ResolverM (local f res)+  local f (ResolverS resM) = ResolverS $ mapReaderT (local f) <$> resM++-- | A function to return the internal 'ResolverContext' within a resolver's monad.+-- Using the 'ResolverContext' itself is unsafe because it expposes internal structures+-- of the AST, but you can use the "Data.Morpheus.Types.SelectionTree" typeclass to manipulate+-- the internal AST with a safe interface.+unsafeInternalContext :: (Monad m, LiftOperation o) => Resolver o e m ResolverContext+unsafeInternalContext = ask++liftResolverState :: (LiftOperation o, Monad m) => ResolverState a -> Resolver o e m a+liftResolverState = packResolver . toResolverStateT++class LiftOperation (o :: OperationType) where+  packResolver :: Monad m => ResolverStateT e m a -> Resolver o e m a++instance LiftOperation QUERY where+  packResolver = ResolverQ . clearStateResolverEvents++instance LiftOperation MUTATION where+  packResolver = ResolverM++instance LiftOperation SUBSCRIPTION where+  packResolver = ResolverS . pure . lift . clearStateResolverEvents++subscribe ::+  (Monad m) =>+  Channel e ->+  Resolver QUERY e m (e -> Resolver SUBSCRIPTION e m a) ->+  SubscriptionField (Resolver SUBSCRIPTION e m a)+subscribe ch res =+  SubscriptionField ch+    $ ResolverS+    $ fromSub <$> runResolverQ res+  where+    fromSub :: Monad m => (e -> Resolver SUBSCRIPTION e m a) -> ReaderT e (ResolverStateT () m) a+    fromSub f = join (ReaderT (runResolverS . f))++withArguments ::+  (LiftOperation o, Monad m) =>+  (Arguments VALID -> Resolver o e m a) ->+  Resolver o e m a+withArguments = (getArguments >>=)++getArguments ::+  (LiftOperation o, Monad m) =>+  Resolver o e m (Arguments VALID)+getArguments = selectionArguments . currentSelection <$> unsafeInternalContext++runResolver ::+  Monad m =>+  Maybe (Selection VALID -> ResolverState (Channel event)) ->+  Resolver o event m ValidValue ->+  ResolverContext ->+  ResponseStream event m ValidValue+runResolver _ (ResolverQ resT) sel = cleanEvents $ runResolverStateT resT sel+runResolver _ (ResolverM resT) sel = mapEvent Publish $ runResolverStateT resT sel+runResolver toChannel (ResolverS resT) ctx = ResultT $ do+  readResValue <- runResolverStateM resT ctx+  pure $ case readResValue >>= subscriptionEvents ctx toChannel . toEventResolver ctx of+    Failure x -> Failure x+    Success {warnings, result} ->+      Success+        { events = [result],+          warnings,+          result = Null+        }++toEventResolver :: Monad m => ResolverContext -> SubEventRes event m ValidValue -> (event -> m GQLResponse)+toEventResolver sel (ReaderT subRes) event = renderResponse <$> runResolverStateM (subRes event) sel++subscriptionEvents ::+  ResolverContext ->+  Maybe (Selection VALID -> ResolverState (Channel e)) ->+  (e -> m GQLResponse) ->+  Eventless (ResponseEvent e m)+subscriptionEvents ctx@ResolverContext {currentSelection} (Just channelGenerator) res =+  runResolverState handle ctx+  where+    handle = do+      channel <- channelGenerator currentSelection+      pure $ Subscribe channel res+subscriptionEvents ctx Nothing _ = failure [resolverFailureMessage ctx "channel Resolver is not defined"]
+ src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.ResolverState+  ( ResolverContext (..),+    ResolverStateT (..),+    resolverFailureMessage,+    clearStateResolverEvents,+    ResolverState,+    toResolverStateT,+    runResolverStateT,+    runResolverStateM,+    runResolverState,+  )+where++import Control.Monad.Trans.Reader (mapReaderT)+import Data.Morpheus.Core+  ( Config (..),+    RenderGQL,+    render,+  )+import Data.Morpheus.Internal.Ext+  ( Eventless,+    Failure (..),+    PushEvents (..),+    Result,+    ResultT (..),+    cleanEvents,+  )+import Data.Morpheus.Types.Internal.AST+  ( GQLError (..),+    GQLErrors,+    InternalError (..),+    Message,+    Operation,+    Schema,+    Selection (..),+    TypeName,+    VALID,+    ValidationError (..),+    msg,+  )+import Relude++data ResolverContext = ResolverContext+  { currentSelection :: Selection VALID,+    schema :: Schema VALID,+    operation :: Operation VALID,+    currentTypeName :: TypeName,+    config :: Config+  }+  deriving (Show)++type ResolverState = ResolverStateT () Identity++runResolverStateT :: ResolverStateT e m a -> ResolverContext -> ResultT e m a+runResolverStateT = runReaderT . _runResolverStateT++runResolverStateM :: ResolverStateT e m a -> ResolverContext -> m (Result e a)+runResolverStateM res = runResultT . runResolverStateT res++runResolverState :: ResolverState a -> ResolverContext -> Eventless a+runResolverState res = runIdentity . runResolverStateM res++-- Resolver Internal State+newtype ResolverStateT event m a = ResolverStateT+  { _runResolverStateT :: ReaderT ResolverContext (ResultT event m) a+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadReader ResolverContext+    )++instance MonadTrans (ResolverStateT e) where+  lift = ResolverStateT . lift . lift++instance (Monad m) => Failure Message (ResolverStateT e m) where+  failure message = do+    cxt <- asks id+    failure [resolverFailureMessage cxt message]++instance (Monad m) => Failure InternalError (ResolverStateT e m) where+  failure message = do+    ctx <- asks id+    failure [renderInternalResolverError ctx message]++instance Monad m => Failure [ValidationError] (ResolverStateT e m) where+  failure messages = do+    ctx <- asks id+    failure $ fmap (resolverFailureMessage ctx . validationMessage) messages++instance (Monad m) => Failure GQLErrors (ResolverStateT e m) where+  failure = ResolverStateT . lift . failure++instance (Monad m) => PushEvents e (ResolverStateT e m) where+  pushEvents = ResolverStateT . lift . pushEvents++mapResolverState ::+  ( ResultT e m a ->+    ResultT e' m' a'+  ) ->+  ResolverStateT e m a ->+  ResolverStateT e' m' a'+mapResolverState f (ResolverStateT x) = ResolverStateT (mapReaderT f x)++toResolverStateT ::+  Applicative m =>+  ResolverState a ->+  ResolverStateT e m a+toResolverStateT = mapResolverState injectResult++injectResult ::+  (Applicative m) =>+  ResultT () Identity a ->+  ResultT e m a+injectResult (ResultT (Identity x)) =+  cleanEvents $ ResultT (pure x)++-- clear evets and starts new resolver with diferenct type of events but with same value+-- use properly. only if you know what you are doing+clearStateResolverEvents :: (Functor m) => ResolverStateT e m a -> ResolverStateT e' m a+clearStateResolverEvents = mapResolverState cleanEvents++resolverFailureMessage :: ResolverContext -> Message -> GQLError+resolverFailureMessage+  ctx@ResolverContext+    { currentSelection =+        Selection {selectionName, selectionPosition}+    }+  message =+    GQLError+      { message =+          "Failure on Resolving Field "+            <> msg selectionName+            <> ": "+            <> message+            <> withInternalContext ctx,+        locations = [selectionPosition]+      }++renderInternalResolverError :: ResolverContext -> InternalError -> GQLError+renderInternalResolverError ctx@ResolverContext {currentSelection} message =+  GQLError+    { message = msg message <> ". " <> renderContext ctx,+      locations = [selectionPosition currentSelection]+    }++withInternalContext :: ResolverContext -> Message+withInternalContext ResolverContext {config = Config {debug = False}} = ""+withInternalContext resCTX = renderContext resCTX++renderContext :: ResolverContext -> Message+renderContext+  ResolverContext+    { currentSelection,+      schema,+      operation,+      currentTypeName+    } =+    renderSection "Current Type" currentTypeName+      <> renderSection "Current Selection" currentSelection+      <> renderSection "OperationDefinition" operation+      <> renderSection "SchemaDefinition" schema++renderSection :: RenderGQL a => Message -> a -> Message+renderSection label content =+  "\n\n" <> label <> ":\n" <> line+    <> "\n\n"+    <> msg (render content)+    <> "\n\n"+  where+    line = stimes (50 :: Int) "-"
+ src/Data/Morpheus/App/Internal/Resolving/ResolverValue.hs view
@@ -0,0 +1,261 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.ResolverValue+  ( ResolverValue (..),+    ResolverObject (..),+    ResolverEntry,+    resolveObject,+    mkUnion,+    mkEnum,+    mkEnumNull,+    mkObject,+  )+where++import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.App.Internal.Resolving.ResolverState+  ( ResolverContext (..),+  )+import Data.Morpheus.Error (subfieldsNotSelected)+import Data.Morpheus.Internal.Ext+  ( SemigroupM (..),+  )+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    empty,+    keyOf,+    selectOr,+    traverseCollection,+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    GQLErrors,+    InternalError,+    Message,+    ObjectEntry (..),+    Ref,+    ScalarValue (..),+    Selection (..),+    SelectionContent (..),+    SelectionSet,+    TypeName (..),+    UnionSelection,+    UnionTag (..),+    VALID,+    ValidValue,+    ValidationErrors,+    Value (..),+    Value (..),+    msg,+    toGQLError,+    unitFieldName,+    unitTypeName,+  )+import Relude hiding (Show, empty)+import Prelude (Show (..))++data ResolverValue (m :: * -> *)+  = ResNull+  | ResScalar ScalarValue+  | ResEnum TypeName+  | ResObject (ResolverObject m)+  | ResList [ResolverValue m]+  | ResUnion TypeName (m (ResolverValue m))++instance Show (ResolverValue m) where+  show _ = "TODO:"++instance+  ( Monad f,+    Monad m,+    Failure InternalError f,+    Failure InternalError m+  ) =>+  SemigroupM f (ResolverValue m)+  where+  mergeM _ ResNull ResNull = pure ResNull+  mergeM _ ResScalar {} x@ResScalar {} = pure x+  mergeM _ ResEnum {} x@ResEnum {} = pure x+  mergeM p (ResObject x) (ResObject y) = ResObject <$> mergeM p x y+  mergeM _ _ _ = failure ("can't merge: incompatible resolvers" :: InternalError)++type ResolverEntry m = (FieldName, m (ResolverValue m))++data ResolverObject m = ResolverObject+  { __typename :: TypeName,+    objectFields :: HashMap FieldName (m (ResolverValue m))+  }++instance Show (ResolverObject m) where+  show _ = "TODO:"++instance+  ( Monad m,+    Applicative f,+    Failure InternalError m+  ) =>+  SemigroupM f (ResolverObject m)+  where+  mergeM path (ResolverObject tyname x) (ResolverObject _ y) =+    pure $ ResolverObject tyname (HM.unionWith (mergeResolver path) x y)++mergeResolver ::+  (Monad m, SemigroupM m a) =>+  [Ref FieldName] ->+  m a ->+  m a ->+  m a+mergeResolver path a b = do+  a' <- a+  b >>= mergeM path a'++lookupRes ::+  ( Monad m,+    MonadReader ResolverContext m,+    Failure GQLErrors m,+    Failure ValidationErrors m,+    Failure Message m,+    Failure InternalError m+  ) =>+  Selection VALID ->+  ResolverObject m ->+  m ValidValue+lookupRes Selection {selectionName}+  | selectionName == "__typename" =+    pure . Scalar . String . readTypeName . __typename+  | otherwise =+    maybe+      (pure Null)+      (>>= runDataResolver)+      . HM.lookup selectionName+      . objectFields++mkUnion ::+  (Monad m) =>+  TypeName ->+  [ResolverEntry m] ->+  ResolverValue m+mkUnion name =+  ResUnion+    name+    . pure+    . mkObject+      name++mkEnum :: TypeName -> ResolverValue m+mkEnum = ResEnum++mkEnumNull :: (Monad m) => [ResolverEntry m]+mkEnumNull = [(unitFieldName, pure $ mkEnum unitTypeName)]++mkObject ::+  TypeName ->+  [ResolverEntry m] ->+  ResolverValue m+mkObject __typename fields =+  ResObject+    ( ResolverObject+        { __typename,+          objectFields = HM.fromList fields+        }+    )++__encode ::+  forall m.+  ( Monad m,+    MonadReader ResolverContext m,+    Failure Message m,+    Failure GQLErrors m,+    Failure ValidationErrors m,+    Failure InternalError m+  ) =>+  ResolverValue m ->+  Selection VALID ->+  m (Value VALID)+__encode obj sel@Selection {selectionContent} = encodeNode obj selectionContent+  where+    -- LIST+    encodeNode ::+      ResolverValue m ->+      SelectionContent VALID ->+      m (Value VALID)+    encodeNode (ResList x) _ = List <$> traverse runDataResolver x+    -- Object -----------------+    encodeNode objDrv@(ResObject ResolverObject {__typename}) _ = withObject __typename (`resolveObject` objDrv) sel+    -- ENUM+    encodeNode (ResEnum enum) SelectionField = pure $ Scalar $ String $ readTypeName enum+    encodeNode (ResEnum name) unionSel@UnionSelection {} =+      encodeNode (mkUnion name mkEnumNull) unionSel+    encodeNode ResEnum {} _ = failure ("wrong selection on enum value" :: Message)+    -- UNION+    encodeNode (ResUnion typename unionRef) (UnionSelection selections) =+      unionRef >>= resolveObject currentSelection+      where+        currentSelection = pickSelection typename selections+    encodeNode (ResUnion name _) _ =+      failure ("union Resolver " <> msg name <> " should only recieve UnionSelection")+    -- SCALARS+    encodeNode ResNull _ = pure Null+    encodeNode (ResScalar x) SelectionField = pure $ Scalar x+    encodeNode ResScalar {} _ =+      failure ("scalar Resolver should only recieve SelectionField" :: Message)++runDataResolver ::+  ( Monad m,+    MonadReader ResolverContext m,+    Failure Message m,+    Failure GQLErrors m,+    Failure ValidationErrors m,+    Failure InternalError m+  ) =>+  ResolverValue m ->+  m ValidValue+runDataResolver res = asks currentSelection >>= __encode res++pickSelection :: TypeName -> UnionSelection VALID -> SelectionSet VALID+pickSelection = selectOr empty unionTagSelection++withObject ::+  ( Monad m,+    Failure GQLErrors m+  ) =>+  TypeName ->+  (SelectionSet VALID -> m value) ->+  Selection VALID ->+  m value+withObject __typename f Selection {selectionName, selectionContent, selectionPosition} = checkContent selectionContent+  where+    checkContent (SelectionSet selection) = f selection+    checkContent (UnionSelection unionSel) =+      f (selectOr empty unionTagSelection __typename unionSel)+    checkContent _ = failure [toGQLError $ subfieldsNotSelected selectionName "" selectionPosition]++resolveObject ::+  forall m.+  ( Monad m,+    MonadReader ResolverContext m,+    Failure ValidationErrors m,+    Failure InternalError m,+    Failure GQLErrors m,+    Failure Message m+  ) =>+  SelectionSet VALID ->+  ResolverValue m ->+  m ValidValue+resolveObject selectionSet (ResObject drv@ResolverObject {__typename}) =+  Object <$> traverseCollection resolver selectionSet+  where+    resolver :: Selection VALID -> m (ObjectEntry VALID)+    resolver currentSelection =+      local (\ctx -> ctx {currentSelection, currentTypeName = __typename}) $+        ObjectEntry (keyOf currentSelection) <$> lookupRes currentSelection drv+resolveObject _ _ = failure ("expected object as resolver" :: InternalError)
+ src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.RootResolverValue+  ( runRootResolverValue,+    RootResolverValue (..),+  )+where++import Data.Morpheus.App.Internal.Resolving.Event+  ( EventHandler (..),+  )+import Data.Morpheus.App.Internal.Resolving.Resolver+  ( LiftOperation,+    Resolver,+    ResponseStream,+    runResolver,+  )+import Data.Morpheus.App.Internal.Resolving.ResolverState+  ( ResolverContext (..),+    ResolverState,+    runResolverStateT,+    toResolverStateT,+  )+import Data.Morpheus.App.Internal.Resolving.ResolverValue+  ( ResolverValue (..),+    resolveObject,+  )+import Data.Morpheus.Types.Internal.AST+  ( MUTATION,+    Operation (..),+    OperationType (..),+    QUERY,+    SUBSCRIPTION,+    Selection,+    VALID,+    Value,+  )+import Relude hiding+  ( Show,+    empty,+    show,+  )++data RootResolverValue e m = RootResolverValue+  { query :: ResolverState (ResolverValue (Resolver QUERY e m)),+    mutation :: ResolverState (ResolverValue (Resolver MUTATION e m)),+    subscription :: ResolverState (ResolverValue (Resolver SUBSCRIPTION e m)),+    channelMap :: Maybe (Selection VALID -> ResolverState (Channel e))+  }++runRootDataResolver ::+  (Monad m, LiftOperation o) =>+  Maybe (Selection VALID -> ResolverState (Channel e)) ->+  ResolverState (ResolverValue (Resolver o e m)) ->+  ResolverContext ->+  ResponseStream e m (Value VALID)+runRootDataResolver+  channels+  res+  ctx@ResolverContext {operation = Operation {operationSelection}} =+    do+      root <- runResolverStateT (toResolverStateT res) ctx+      runResolver channels (resolveObject operationSelection root) ctx++runRootResolverValue :: Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID)+runRootResolverValue+  RootResolverValue+    { query,+      mutation,+      subscription,+      channelMap+    }+  ctx@ResolverContext {operation = Operation {operationType}} =+    selectByOperation operationType+    where+      selectByOperation Query =+        runRootDataResolver channelMap query ctx+      selectByOperation Mutation =+        runRootDataResolver channelMap mutation ctx+      selectByOperation Subscription =+        runRootDataResolver channelMap subscription ctx
+ src/Data/Morpheus/App/Internal/Stitching.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Stitching+  ( Stitching (..),+  )+where++import Data.Morpheus.App.Internal.Resolving (RootResolverValue)+import qualified Data.Morpheus.App.Internal.Resolving as R (RootResolverValue (..))+import Data.Morpheus.Error (NameCollision (..))+import Data.Morpheus.Internal.Ext+  ( SemigroupM (..),+    resolveWith,+    runResolutionT,+    unsafeFromList,+  )+import Data.Morpheus.Internal.Utils+  ( Failure (..),+    mergeT,+    prop,+  )+import Data.Morpheus.Types.Internal.AST+  ( Directive,+    DirectiveDefinition,+    FieldDefinition,+    FieldsDefinition,+    Schema (..),+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeLib,+    ValidationErrors,+  )+import Relude hiding (optional)++equal :: (Eq a, Applicative m, Failure ValidationErrors m) => ValidationErrors -> a -> a -> m a+equal err p1 p2+  | p1 == p2 = pure p2+  | otherwise = failure err++fstM :: Applicative m => a -> a -> m a+fstM x _ = pure x++concatM :: (Applicative m, Semigroup a) => a -> a -> m a+concatM x = pure . (x <>)++class Stitching a where+  stitch :: (Monad m, Failure ValidationErrors m) => a -> a -> m a++instance Stitching a => Stitching (Maybe a) where+  stitch = optional stitch++instance Stitching (Schema s) where+  stitch s1 s2 =+    Schema+      <$> prop stitch types s1 s2+      <*> prop stitchOperation query s1 s2+      <*> prop (optional stitchOperation) mutation s1 s2+      <*> prop (optional stitchOperation) subscription s1 s2+      <*> prop stitch directiveDefinitions s1 s2++instance Stitching (TypeLib s) where+  stitch x y = runResolutionT (mergeT x y) unsafeFromList (resolveWith stitch)++instance Stitching [DirectiveDefinition s] where+  stitch = concatM++instance Stitching [Directive s] where+  stitch = concatM++optional :: Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t)+optional _ Nothing y = pure y+optional _ (Just x) Nothing = pure (Just x)+optional f (Just x) (Just y) = Just <$> f x y++stitchOperation ::+  (Monad m, Failure ValidationErrors m) =>+  TypeDefinition c s ->+  TypeDefinition c s ->+  m (TypeDefinition c s)+stitchOperation x y =+  TypeDefinition+    <$> prop concatM typeDescription x y+    <*> prop fstM typeName x y+    <*> prop stitch typeDirectives x y+    <*> prop stitch typeContent x y++instance Stitching (TypeDefinition cat s) where+  stitch x y =+    TypeDefinition+      <$> prop concatM typeDescription x y+      <*> prop (equal [nameCollision y]) typeName x y+      <*> prop stitch typeDirectives x y+      <*> prop stitch typeContent x y++instance Stitching (TypeContent TRUE cat s) where+  stitch (DataObject i1 fields1) (DataObject i2 fields2) =+    DataObject (i1 <> i2) <$> stitch fields1 fields2+  stitch x y+    | x == y = pure y+    | otherwise = failure (["Schema Stitching works only for objects"] :: ValidationErrors)++instance Stitching (FieldsDefinition cat s) where+  stitch x y = runResolutionT (mergeT x y) unsafeFromList (resolveWith stitch)++instance Stitching (FieldDefinition cat s) where+  stitch old new+    | old == new = pure old+    | otherwise = failure [nameCollision new]++rootProp :: (Monad m, SemigroupM m b) => (a -> m b) -> a -> a -> m b+rootProp f x y = do+  x' <- f x+  y' <- f y+  mergeM [] x' y'++stitchSubscriptions :: Failure ValidationErrors m => Maybe a -> Maybe a -> m (Maybe a)+stitchSubscriptions Just {} Just {} = failure (["can't merge  subscription applications"] :: ValidationErrors)+stitchSubscriptions x Nothing = pure x+stitchSubscriptions Nothing x = pure x++instance Monad m => Stitching (RootResolverValue e m) where+  stitch x y = do+    channelMap <- stitchSubscriptions (R.channelMap x) (R.channelMap y)+    pure $+      R.RootResolverValue+        { R.query = rootProp R.query x y,+          R.mutation = rootProp R.mutation x y,+          R.subscription = rootProp R.subscription x y,+          R.channelMap+        }
+ src/Data/Morpheus/App/MapAPI.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.MapAPI+  ( MapAPI (..),+  )+where++import Data.Aeson+  ( encode,+  )+import Data.Aeson.Internal+  ( formatError,+    ifromJSON,+  )+import Data.Aeson.Parser+  ( eitherDecodeWith,+    jsonNoDup,+  )+import qualified Data.ByteString.Lazy.Char8 as LB+  ( ByteString,+    fromStrict,+    toStrict,+  )+import Data.Morpheus.App.Error (badRequestError)+import Data.Morpheus.Internal.Utils+  ( Failure (..),+  )+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+    GQLResponse (..),+  )+import qualified Data.Text.Lazy as LT+  ( Text,+    fromStrict,+    toStrict,+  )+import Data.Text.Lazy.Encoding+  ( decodeUtf8,+    encodeUtf8,+  )+import Relude hiding+  ( decodeUtf8,+    encodeUtf8,+  )++decodeNoDup :: Failure String m => LB.ByteString -> m GQLRequest+decodeNoDup str = case eitherDecodeWith jsonNoDup ifromJSON str of+  Left (path, x) -> failure $ formatError path x+  Right value -> pure value++class MapAPI a b where+  mapAPI :: Applicative m => (GQLRequest -> m GQLResponse) -> a -> m b++instance MapAPI GQLRequest GQLResponse where+  mapAPI f = f++instance MapAPI LB.ByteString LB.ByteString where+  mapAPI api request = case decodeNoDup request of+    Left aesonError -> pure $ badRequestError aesonError+    Right req -> encode <$> api req++instance MapAPI LT.Text LT.Text where+  mapAPI api = fmap decodeUtf8 . mapAPI api . encodeUtf8++instance MapAPI ByteString ByteString where+  mapAPI api = fmap LB.toStrict . mapAPI api . LB.fromStrict++instance MapAPI Text Text where+  mapAPI api = fmap LT.toStrict . mapAPI api . LT.fromStrict
+ src/Data/Morpheus/App/RenderIntrospection.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.RenderIntrospection+  ( render,+    createObjectType,+    WithSchema,+  )+where++import Data.Foldable (foldr')+import Data.Morpheus.App.Internal.Resolving+  ( Resolver,+    ResolverContext (..),+    ResolverValue,+    mkBoolean,+    mkList,+    mkNull,+    mkObject,+    mkString,+    unsafeInternalContext,+  )+import qualified Data.Morpheus.Core as GQL+import Data.Morpheus.Internal.Utils+  ( Failure,+    elems,+    failure,+    fromLBS,+    selectBy,+  )+import Data.Morpheus.Types.Internal.AST+  ( ANY,+    ArgumentDefinition (..),+    ArgumentsDefinition,+    DataEnumValue (..),+    DataTypeWrapper (..),+    Description,+    DirectiveDefinition (..),+    DirectiveLocation,+    Directives,+    FieldContent (..),+    FieldDefinition (..),+    FieldName (..),+    FieldsDefinition,+    GQLErrors,+    IN,+    Message,+    OUT,+    QUERY,+    Schema,+    TRUE,+    TypeContent (..),+    TypeDefinition (..),+    TypeKind (..),+    TypeName (..),+    TypeRef (..),+    UnionMember (..),+    VALID,+    Value (..),+    fieldVisibility,+    kindOf,+    lookupDeprecated,+    lookupDeprecatedReason,+    mkInputUnionFields,+    msg,+    possibleInterfaceTypes,+    toGQLWrapper,+  )+import Data.Text (pack)+import Relude++class+  ( Monad m,+    Failure Message m,+    Failure GQLErrors m+  ) =>+  WithSchema m+  where+  getSchema :: m (Schema VALID)++instance Monad m => WithSchema (Resolver QUERY e m) where+  getSchema = schema <$> unsafeInternalContext++selectType ::+  WithSchema m =>+  TypeName ->+  m (TypeDefinition ANY VALID)+selectType name =+  getSchema+    >>= selectBy (" INTERNAL: INTROSPECTION Type not Found: \"" <> msg name <> "\"") name++class RenderIntrospection a where+  render :: (Monad m, WithSchema m) => a -> m (ResolverValue m)++instance RenderIntrospection TypeName where+  render = pure . mkString . readTypeName++instance RenderIntrospection FieldName where+  render = pure . mkString . readName++instance RenderIntrospection Description where+  render = pure . mkString++instance RenderIntrospection a => RenderIntrospection [a] where+  render ls = mkList <$> traverse render ls++instance RenderIntrospection a => RenderIntrospection (Maybe a) where+  render (Just value) = render value+  render Nothing = pure mkNull++instance RenderIntrospection Bool where+  render = pure . mkBoolean++instance RenderIntrospection TypeKind where+  render = pure . mkString . fromLBS . GQL.render++instance RenderIntrospection (DirectiveDefinition VALID) where+  render+    DirectiveDefinition+      { directiveDefinitionName,+        directiveDefinitionDescription,+        directiveDefinitionLocations,+        directiveDefinitionArgs+      } =+      pure $+        mkObject+          "__Directive"+          [ renderName directiveDefinitionName,+            description directiveDefinitionDescription,+            ("locations", render directiveDefinitionLocations),+            ("args", render directiveDefinitionArgs)+          ]++instance RenderIntrospection DirectiveLocation where+  render locations = pure $ mkString (pack $ show locations)++instance RenderIntrospection (TypeDefinition cat VALID) where+  render+    TypeDefinition+      { typeName,+        typeDescription,+        typeContent+      } = pure $ renderContent typeContent+      where+        __type ::+          ( Monad m,+            WithSchema m+          ) =>+          TypeKind ->+          [(FieldName, m (ResolverValue m))] ->+          ResolverValue m+        __type kind = mkType kind typeName typeDescription+        renderContent ::+          ( Monad m,+            WithSchema m+          ) =>+          TypeContent bool a VALID ->+          ResolverValue m+        renderContent DataScalar {} = __type KindScalar []+        renderContent (DataEnum enums) = __type KindEnum [("enumValues", render enums)]+        renderContent (DataInputObject inputFields) =+          __type+            KindInputObject+            [("inputFields", render inputFields)]+        renderContent DataObject {objectImplements, objectFields} =+          createObjectType typeName typeDescription objectImplements objectFields+        renderContent (DataUnion union) =+          __type+            KindUnion+            [("possibleTypes", render union)]+        renderContent (DataInputUnion members) =+          mkType+            KindInputObject+            typeName+            ( Just+                ( "Note! This input is an exclusive object,\n"+                    <> "i.e., the customer can provide a value for only one field."+                )+                <> typeDescription+            )+            [ ( "inputFields",+                render (mkInputUnionFields members)+              )+            ]+        renderContent (DataInterface fields) =+          __type+            KindInterface+            [ ("fields", render fields),+              ("possibleTypes", renderPossibleTypes typeName)+            ]++instance RenderIntrospection (UnionMember OUT s) where+  render UnionMember {memberName} = selectType memberName >>= render++instance+  RenderIntrospection (FieldDefinition cat s) =>+  RenderIntrospection (FieldsDefinition cat s)+  where+  render = render . filter fieldVisibility . elems++instance RenderIntrospection (FieldContent TRUE IN VALID) where+  render = render . defaultInputValue++instance RenderIntrospection (Value VALID) where+  render Null = pure mkNull+  render x = pure $ mkString $ fromLBS $ GQL.render x++instance+  RenderIntrospection+    (FieldDefinition OUT VALID)+  where+  render FieldDefinition {..} =+    pure+      $ mkObject "__Field"+      $ [ renderName fieldName,+          description fieldDescription,+          type' fieldType,+          ("args", maybe (pure $ mkList []) render fieldContent)+        ]+        <> renderDeprecated fieldDirectives++instance RenderIntrospection (FieldContent TRUE OUT VALID) where+  render (FieldArgs args) = render args++instance RenderIntrospection (ArgumentsDefinition VALID) where+  render = fmap mkList . traverse (render . argument) . elems++instance RenderIntrospection (FieldDefinition IN VALID) where+  render FieldDefinition {..} =+    pure $+      mkObject+        "__InputValue"+        [ renderName fieldName,+          description fieldDescription,+          type' fieldType,+          defaultValue fieldContent+        ]++instance RenderIntrospection (DataEnumValue VALID) where+  render DataEnumValue {enumName, enumDescription, enumDirectives} =+    pure $ mkObject "__Field" $+      [ renderName enumName,+        description enumDescription+      ]+        <> renderDeprecated enumDirectives++instance RenderIntrospection TypeRef where+  render TypeRef {typeConName, typeWrappers} = do+    kind <- kindOf <$> selectType typeConName+    let currentType = mkType kind typeConName Nothing []+    pure $ foldr' wrap currentType (toGQLWrapper typeWrappers)+    where+      wrap ::+        ( Monad m,+          WithSchema m+        ) =>+        DataTypeWrapper ->+        ResolverValue m ->+        ResolverValue m+      wrap wrapper contentType =+        mkObject+          "__Type"+          [ renderKind (wrapperKind wrapper),+            ("ofType", pure contentType)+          ]+      wrapperKind ListType = KindList+      wrapperKind NonNullType = KindNonNull++renderPossibleTypes ::+  (Monad m, WithSchema m) =>+  TypeName ->+  m (ResolverValue m)+renderPossibleTypes name =+  mkList+    <$> ( getSchema+            >>= traverse render . possibleInterfaceTypes name+        )++renderDeprecated ::+  ( Monad m,+    WithSchema m+  ) =>+  Directives s ->+  [(FieldName, m (ResolverValue m))]+renderDeprecated dirs =+  [ ("isDeprecated", render (isJust $ lookupDeprecated dirs)),+    ("deprecationReason", render (lookupDeprecated dirs >>= lookupDeprecatedReason))+  ]++description ::+  ( Monad m,+    WithSchema m+  ) =>+  Maybe Description ->+  (FieldName, m (ResolverValue m))+description = ("description",) . render++mkType ::+  ( RenderIntrospection name,+    Monad m,+    WithSchema m+  ) =>+  TypeKind ->+  name ->+  Maybe Description ->+  [(FieldName, m (ResolverValue m))] ->+  ResolverValue m+mkType kind name desc etc =+  mkObject+    "__Type"+    ( [ renderKind kind,+        renderName name,+        description desc+      ]+        <> etc+    )++createObjectType ::+  (Monad m, WithSchema m) =>+  TypeName ->+  Maybe Description ->+  [TypeName] ->+  FieldsDefinition OUT VALID ->+  ResolverValue m+createObjectType name desc interfaces fields =+  mkType (KindObject Nothing) name desc [("fields", render fields), ("interfaces", mkList <$> traverse implementedInterface interfaces)]++implementedInterface ::+  (Monad m, WithSchema m) =>+  TypeName ->+  m (ResolverValue m)+implementedInterface name =+  selectType name+    >>= renderContent+  where+    renderContent typeDef@TypeDefinition {typeContent = DataInterface {}} = render typeDef+    renderContent _ = failure ("Type " <> msg name <> " must be an Interface" :: Message)++renderName ::+  ( RenderIntrospection name,+    Monad m,+    WithSchema m+  ) =>+  name ->+  (FieldName, m (ResolverValue m))+renderName = ("name",) . render++renderKind ::+  (Monad m, WithSchema m) =>+  TypeKind ->+  (FieldName, m (ResolverValue m))+renderKind = ("kind",) . render++type' ::+  (Monad m, WithSchema m) =>+  TypeRef ->+  (FieldName, m (ResolverValue m))+type' = ("type",) . render++defaultValue ::+  (Monad m, WithSchema m) =>+  Maybe (FieldContent TRUE IN VALID) ->+  ( FieldName,+    m (ResolverValue m)+  )+defaultValue = ("defaultValue",) . render
+ src/Data/Morpheus/App/SchemaAPI.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.SchemaAPI+  ( withSystemFields,+  )+where++import Data.Morpheus.App.Internal.Resolving+  ( Resolver,+    ResolverValue,+    ResultT,+    RootResolverValue (..),+    mkList,+    mkNull,+    mkObject,+    withArguments,+  )+import Data.Morpheus.App.RenderIntrospection+  ( WithSchema,+    createObjectType,+    render,+  )+import Data.Morpheus.Internal.Ext ((<:>))+import Data.Morpheus.Internal.Utils+  ( elems,+    empty,+    selectOr,+  )+import Data.Morpheus.Types.Internal.AST+  ( Argument (..),+    FieldName,+    OBJECT,+    QUERY,+    ScalarValue (..),+    Schema (..),+    TypeDefinition (..),+    TypeName (..),+    VALID,+    Value (..),+  )+import Relude hiding (empty)++resolveTypes :: (Monad m, WithSchema m) => Schema VALID -> m (ResolverValue m)+resolveTypes schema = mkList <$> traverse render (elems schema)++renderOperation ::+  (Monad m, WithSchema m) =>+  Maybe (TypeDefinition OBJECT VALID) ->+  m (ResolverValue m)+renderOperation (Just TypeDefinition {typeName}) = pure $ createObjectType typeName Nothing [] empty+renderOperation Nothing = pure mkNull++findType ::+  (Monad m, WithSchema m) =>+  TypeName ->+  Schema VALID ->+  m (ResolverValue m)+findType = selectOr (pure mkNull) render++schemaResolver ::+  (Monad m, WithSchema m) =>+  Schema VALID ->+  m (ResolverValue m)+schemaResolver schema@Schema {query, mutation, subscription, directiveDefinitions} =+  pure $+    mkObject+      "__Schema"+      [ ("types", resolveTypes schema),+        ("queryType", renderOperation (Just query)),+        ("mutationType", renderOperation mutation),+        ("subscriptionType", renderOperation subscription),+        ("directives", render directiveDefinitions)+      ]++schemaAPI :: Monad m => Schema VALID -> ResolverValue (Resolver QUERY e m)+schemaAPI schema =+  mkObject+    "Root"+    [ ("__type", withArguments typeResolver),+      ("__schema", schemaResolver schema)+    ]+  where+    typeResolver = selectOr (pure mkNull) handleArg ("name" :: FieldName)+      where+        handleArg+          Argument+            { argumentValue = (Scalar (String typename))+            } = findType (TypeName typename) schema+        handleArg _ = pure mkNull++withSystemFields ::+  Monad m =>+  Schema VALID ->+  RootResolverValue e m ->+  ResultT e' m (RootResolverValue e m)+withSystemFields schema RootResolverValue {query, ..} =+  pure $+    RootResolverValue+      { query = query >>= (<:> schemaAPI schema),+        ..+      }
+ src/Data/Morpheus/Types/GQLWrapper.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Types.GQLWrapper+  ( EncodeWrapper (..),+    DecodeWrapper (..),+    DecodeWrapperConstraint,+  )+where++import qualified Data.List.NonEmpty as NonEmpty+import Data.Morpheus.App.Internal.Resolving+  ( ResolverValue (..),+    SubscriptionField (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( Message,+    ValidValue,+    Value (..),+    msg,+  )+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Vector (Vector)+import qualified Data.Vector as Vector+import Relude++-- | GraphQL Wrapper Serializer+class EncodeWrapper (wrapper :: * -> *) where+  encodeWrapper ::+    (Monad m) =>+    (a -> m (ResolverValue m)) ->+    wrapper a ->+    m (ResolverValue m)++withList ::+  ( EncodeWrapper f,+    Monad m+  ) =>+  (a -> f b) ->+  (b -> m (ResolverValue m)) ->+  a ->+  m (ResolverValue m)+withList f encodeValue = encodeWrapper encodeValue . f++instance EncodeWrapper Maybe where+  encodeWrapper = maybe (pure ResNull)++instance EncodeWrapper [] where+  encodeWrapper encodeValue = fmap ResList . traverse encodeValue++instance EncodeWrapper NonEmpty where+  encodeWrapper = withList toList++instance EncodeWrapper Seq where+  encodeWrapper = withList toList++instance EncodeWrapper Vector where+  encodeWrapper = withList toList++instance EncodeWrapper Set where+  encodeWrapper = withList toList++instance EncodeWrapper SubscriptionField where+  encodeWrapper encode (SubscriptionField _ res) = encode res++type family DecodeWrapperConstraint (f :: * -> *) a :: Constraint where+  DecodeWrapperConstraint Set a = (Ord a)+  DecodeWrapperConstraint f a = ()++-- | GraphQL Wrapper Deserializer+class DecodeWrapper (f :: * -> *) where+  decodeWrapper ::+    (Monad m, DecodeWrapperConstraint f a) =>+    (ValidValue -> m a) ->+    ValidValue ->+    ExceptT Message m (f a)++instance DecodeWrapper Maybe where+  decodeWrapper _ Null = pure Nothing+  decodeWrapper decode x = Just <$> lift (decode x)++instance DecodeWrapper [] where+  decodeWrapper decode (List li) = lift $ traverse decode li+  decodeWrapper _ isType = ExceptT $ pure $ Left (typeMismatch "List" isType)++instance DecodeWrapper NonEmpty where+  decodeWrapper = withRefinedList (maybe (Left "Expected a NonEmpty list") Right . NonEmpty.nonEmpty)++instance DecodeWrapper Seq where+  decodeWrapper decode = fmap Seq.fromList . decodeWrapper decode++instance DecodeWrapper Vector where+  decodeWrapper decode = fmap Vector.fromList . decodeWrapper decode++instance DecodeWrapper Set where+  decodeWrapper decode value = do+    listVal <- decodeWrapper decode value+    haveSameSize (Set.fromList listVal) listVal++haveSameSize ::+  ( Foldable l,+    Monad m+  ) =>+  Set a ->+  l b ->+  ExceptT Message m (Set a)+haveSameSize setVal listVal+  | length setVal == length listVal = pure setVal+  | otherwise = ExceptT $ pure $ Left (fromString ("Expected a List without duplicates, found " <> show (length listVal - length listVal) <> " duplicates"))++withRefinedList ::+  Monad m =>+  ([a] -> Either Message (rList a)) ->+  (ValidValue -> m a) ->+  ValidValue ->+  ExceptT Message m (rList a)+withRefinedList refiner decode (List li) = do+  listRes <- lift (traverse decode li)+  case refiner listRes of+    Left err -> ExceptT $ pure $ Left (typeMismatch err (List li))+    Right value -> pure value+withRefinedList _ _ isType = ExceptT $ pure $ Left (typeMismatch "List" isType)++-- if value is already validated but value has different type+typeMismatch :: Message -> Value s -> Message+typeMismatch text jsType =+  "Type mismatch! expected:" <> msg text <> ", got: "+    <> msg jsType
+ test/Spec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Main+  ( main,+  )+where++import Relude+import Test.Tasty+  ( defaultMain,+    testGroup,+  )+import Utils.Api+  ( apiTest,+  )+import qualified Utils.MergeSchema as MergeSchema++main :: IO ()+main = do+  mergeSchema <- MergeSchema.test+  defaultMain $+    testGroup+      "core tests"+      [ mergeSchema,+        apiTest "api/deity" ["simple", "interface"],+        apiTest+          "api/validation/fragment"+          [ "on-type",+            "on-interface",+            "on-interface-inline",+            "on-union-type",+            "fail-unknown-field-on-interface",+            "on-interface-type-casting",+            "on-interface-type-casting-inline",+            "on-interface-fail-without-casting"+          ]+      ]
+ test/Utils/Api.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Utils.Api+  ( apiTest,+    assertion,+  )+where++import qualified Data.Aeson as A+import Data.Aeson (decode, encode)+import Data.Morpheus.App+  ( mkApp,+    runAppStream,+  )+import Data.Morpheus.App.Internal.Resolving+  ( ResponseStream,+    ResultT (..),+  )+import Data.Morpheus.Types.IO+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    VALID,+    Value (..),+  )+import Data.Text (unpack)+import Relude+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( testCase,+  )+import Utils.Utils+  ( assertValidSchema,+    caseFailure,+    expectedResponse,+    getRequest,+    getResolvers,+  )++assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO ()+assertion expected (ResultT (Identity actual))+  | Just expected == decode actualValue = pure ()+  | otherwise = caseFailure (encode expected) actualValue+  where+    actualValue = encode (renderResponse actual)++apiTest :: FieldName -> [FieldName] -> TestTree+apiTest apiPath requestPath =+  testGroup (unpack $ readName apiPath) $+    fmap (testApiRequest apiPath) requestPath++testApiRequest ::+  FieldName ->+  FieldName ->+  TestTree+testApiRequest apiPath path = testCase (unpack $ readName path) $ do+  schema <- assertValidSchema apiPath+  resolvers <- getResolvers apiPath+  let fullPath = apiPath <> "/" <> path+  let api = mkApp schema resolvers+  actual <- runAppStream api <$> getRequest fullPath+  expected <- expectedResponse fullPath+  assertion expected actual
+ test/Utils/MergeSchema.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Utils.MergeSchema+  ( test,+  )+where++import Data.Aeson (decode, encode)+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as L (readFile)+import Data.Morpheus.App+  ( App (..),+    AppData (..),+    mkApp,+    mkApp,+    runAppStream,+  )+import Data.Morpheus.App.Internal.Resolving+  ( ResponseStream,+    ResultT (..),+    resultOr,+  )+import Data.Morpheus.Core+  ( parseSchema,+    render,+  )+import Data.Morpheus.Types.IO+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    Schema,+    VALID,+    Value,+  )+import Data.Text (unpack)+import Relude+import Test.Tasty+  ( TestTree,+    testGroup,+  )+import Test.Tasty.HUnit+  ( assertFailure,+    testCase,+  )+import Utils.Utils+  ( caseFailure,+    expectedResponse,+    getRequest,+    getResolver,+  )++readSchema :: FieldName -> IO (Schema VALID)+readSchema (FieldName p) = L.readFile (unpack p) >>= (resultOr (fail . show) pure . parseSchema)++loadApi :: FieldName -> IO (App () Identity)+loadApi url = do+  schema <- readSchema ("test/" <> url <> ".gql")+  resolvers <- getResolver ("test/" <> url <> ".json")+  pure $ mkApp schema resolvers++schemaAssertion :: App () Identity -> Schema VALID -> IO ()+schemaAssertion (App AppData {appSchema}) expectedSchema+  | render expectedSchema == render appSchema = pure ()+  | otherwise = caseFailure (render expectedSchema) (render appSchema)+schemaAssertion (FailApp gqlerror) _ = assertFailure $ " error: " <> show gqlerror++schemaCase :: (FieldName, [FieldName]) -> IO TestTree+schemaCase (url, files) = do+  schema <- loadApi (url <> "/api/app")+  extension <- loadApi (url <> "/api/ext")+  let api = schema <> extension+  pure $+    testGroup+      (show url)+      [ testCase+          "Schema"+          (readSchema ("test/" <> url <> "/expected/ok.gql") >>= schemaAssertion api),+        testGroup+          "Requests"+          (fmap (testApiRequest api url) files)+      ]++test :: IO TestTree+test =+  testGroup+    "merge schema"+    <$> traverse+      schemaCase+      [ ("merge/schema/simple-query", ["query"]),+        ("merge/schema/query-subscription-mutation", ["query", "mutation"])+      ]++assertion :: A.Value -> ResponseStream e Identity (Value VALID) -> IO ()+assertion expected (ResultT (Identity actual))+  | Just expected == decode actualValue = pure ()+  | otherwise = caseFailure (encode expected) actualValue+  where+    actualValue = encode (renderResponse actual)++testApiRequest ::+  App () Identity ->+  FieldName ->+  FieldName ->+  TestTree+testApiRequest api base path = testCase (unpack $ readName path) $ do+  let fullPath = base <> "/request/" <> path+  actual <- runAppStream api <$> getRequest fullPath+  expected <- expectedResponse fullPath+  assertion expected actual
+ test/Utils/Utils.hs view
@@ -0,0 +1,167 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Utils.Utils+  ( getGQLBody,+    expectedResponse,+    getCases,+    maybeVariables,+    readSource,+    scanSchemaTests,+    FileUrl (..),+    CaseTree (..),+    toString,+    getRequest,+    assertValidSchema,+    getSchema,+    getResolvers,+    getResolver,+    caseFailure,+  )+where++import Data.Aeson (FromJSON, Value (..), decode)+import qualified Data.ByteString.Lazy as L (readFile)+import qualified Data.ByteString.Lazy.Char8 as LB (unpack)+import Data.ByteString.Lazy.Char8 (ByteString)+import Data.HashMap.Lazy (lookup)+import Data.Morpheus.App.Internal.Resolving+  ( Eventless,+    ResolverValue,+    RootResolverValue (..),+    mkNull,+    mkValue,+    resultOr,+  )+import Data.Morpheus.Core (parseSchema)+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName (..),+    Schema (..),+    VALID,+  )+import Data.Text (unpack)+import qualified Data.Text.IO as T+import Relude hiding (ByteString, toString)+import System.Directory (doesDirectoryExist, listDirectory)+import Test.Tasty.HUnit+  ( assertFailure,+  )++readSource :: FieldName -> IO ByteString+readSource = L.readFile . path . readName++path :: Text -> FilePath+path name = "test/" <> unpack name++gqlLib :: Text -> FilePath+gqlLib x = path x <> "/query.gql"++resLib :: Text -> FilePath+resLib x = path x <> "/response.json"++data FileUrl = FileUrl+  { filePath :: [FilePath],+    fileName :: FilePath+  }+  deriving (Show)++data CaseTree = CaseTree+  { caseUrl :: FileUrl,+    children :: Either [FilePath] [CaseTree]+  }+  deriving (Show)++prefix :: FileUrl -> FilePath -> FileUrl+prefix FileUrl {..} x =+  FileUrl+    { filePath = fileName : filePath,+      fileName = x+    }++toString :: FileUrl -> FilePath+toString FileUrl {..} = intercalate "/" (filePath <> [fileName])++scanSchemaTests :: FilePath -> IO CaseTree+scanSchemaTests = deepScan++deepScan :: FilePath -> IO CaseTree+deepScan = shouldScan . FileUrl []+  where+    shouldScan :: FileUrl -> IO CaseTree+    shouldScan caseUrl = do+      children <- prefixed caseUrl+      pure CaseTree {..}+    isDirectory :: FileUrl -> IO Bool+    isDirectory = doesDirectoryExist . toString+    prefixed :: FileUrl -> IO (Either [FilePath] [CaseTree])+    prefixed p = do+      dir <- isDirectory p+      if dir+        then do+          list <- map (prefix p) <$> listDirectory (toString p)+          areDirectories <- traverse isDirectory list+          if and areDirectories+            then Right <$> traverse shouldScan list+            else pure $ Left []+        else pure $ Left []++maybeVariables :: FieldName -> IO (Maybe Value)+maybeVariables (FieldName x) = decode <$> (L.readFile (path x <> "/variables.json") <|> pure "{}")++getGQLBody :: FieldName -> IO ByteString+getGQLBody (FieldName p) = L.readFile (gqlLib p)++getCases :: FromJSON a => FilePath -> IO [a]+getCases dir = fromMaybe [] . decode <$> L.readFile ("test/" <> dir <> "/cases.json")++getSchema :: FieldName -> IO (Eventless (Schema VALID))+getSchema (FieldName x) = parseSchema <$> L.readFile (path x <> "/schema.gql")++assertValidSchema :: FieldName -> IO (Schema VALID)+assertValidSchema = getSchema >=> resultOr failedSchema pure+  where+    failedSchema err = assertFailure ("unexpected schema validation error: \n " <> show err)++expectedResponse :: FieldName -> IO Value+expectedResponse (FieldName p) = fromMaybe Null . decode <$> L.readFile (resLib p)++getRequest :: FieldName -> IO GQLRequest+getRequest p =+  GQLRequest+    Nothing+    <$> T.readFile (gqlLib $ readName p)+    <*> maybeVariables p++getResolvers :: Monad m => FieldName -> IO (RootResolverValue e m)+getResolvers p = getResolver ("test/" <> p <> "/resolvers.json")++getResolver :: Monad m => FieldName -> IO (RootResolverValue e m)+getResolver (FieldName p) = do+  res <- fromMaybe Null . decode <$> L.readFile (unpack p)+  pure+    RootResolverValue+      { query = pure (lookupRes "query" res),+        mutation = pure (lookupRes "mutation" res),+        subscription = pure (lookupRes "subscription" res),+        channelMap = Nothing+      }++lookupRes ::+  ( Monad m+  ) =>+  Text ->+  Value ->+  ResolverValue m+lookupRes name (Object fields) = maybe mkNull mkValue (lookup name fields)+lookupRes _ _ = mkNull++caseFailure :: ByteString -> ByteString -> IO a+caseFailure expected actualValue =+  assertFailure $+    LB.unpack+      ("expected: \n\n " <> expected <> " \n\n but got: \n\n " <> actualValue)
+ test/api/deity/interface/query.gql view
@@ -0,0 +1,79 @@+query Get__Type {+  interface: __type(name: "Character") {+    ...FullType+  }+  deity: __type(name: "Deity") {+    ...FullType+  }+}++fragment FullType on __Type {+  kind+  name+  fields(includeDeprecated: true) {+    name+    args {+      ...InputValue+    }+    type {+      ...TypeRef+    }+    isDeprecated+    deprecationReason+  }+  inputFields {+    ...InputValue+  }+  interfaces {+    ...TypeRef+  }+  enumValues(includeDeprecated: true) {+    name+    isDeprecated+    deprecationReason+  }+  possibleTypes {+    ...TypeRef+  }+}++fragment InputValue on __InputValue {+  name+  type {+    ...TypeRef+  }+  defaultValue+}++fragment TypeRef on __Type {+  kind+  name+  ofType {+    kind+    name+    ofType {+      kind+      name+      ofType {+        kind+        name+        ofType {+          kind+          name+          ofType {+            kind+            name+            ofType {+              kind+              name+              ofType {+                kind+                name+              }+            }+          }+        }+      }+    }+  }+}
+ test/api/deity/interface/response.json view
@@ -0,0 +1,67 @@+{+  "data": {+    "interface": {+      "kind": "INTERFACE",+      "name": "Character",+      "fields": [+        {+          "name": "name",+          "args": [],+          "type": { "kind": "SCALAR", "name": "String", "ofType": null },+          "isDeprecated": false,+          "deprecationReason": null+        }+      ],+      "inputFields": null,+      "interfaces": null,+      "enumValues": null,+      "possibleTypes": [+        { "kind": "OBJECT", "name": "Deity", "ofType": null },+        { "kind": "OBJECT", "name": "Hero", "ofType": null }+      ]+    },+    "deity": {+      "kind": "OBJECT",+      "name": "Deity",+      "fields": [+        {+          "name": "name",+          "args": [],+          "type": {+            "kind": "NON_NULL",+            "name": null,+            "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+          },+          "isDeprecated": false,+          "deprecationReason": null+        },+        {+          "name": "power",+          "args": [],+          "type": {+            "kind": "NON_NULL",+            "name": null,+            "ofType": {+              "kind": "LIST",+              "name": null,+              "ofType": {+                "kind": "NON_NULL",+                "name": null,+                "ofType": { "kind": "SCALAR", "name": "String", "ofType": null }+              }+            }+          },+          "isDeprecated": false,+          "deprecationReason": null+        }+      ],+      "inputFields": null,+      "interfaces": [+        { "kind": "INTERFACE", "name": "Character", "ofType": null },+        { "kind": "INTERFACE", "name": "Supernatural", "ofType": null }+      ],+      "enumValues": null,+      "possibleTypes": null+    }+  }+}
+ test/api/deity/resolvers.json view
@@ -0,0 +1,8 @@+{+  "query": {+    "deity": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    }+  }+}
+ test/api/deity/schema.gql view
@@ -0,0 +1,20 @@+type Query {+  deity(name: String): Deity!+}++interface Character {+  name: String+}++interface Supernatural {+  power: [String!]!+}++type Hero implements Character {+  name: String+}++type Deity implements Character & Supernatural {+  name: String!+  power: [String!]!+}
+ test/api/deity/simple/query.gql view
@@ -0,0 +1,6 @@+{+  deity {+    name+    power+  }+}
+ test/api/deity/simple/response.json view
@@ -0,0 +1,8 @@+{+  "data": {+    "deity": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    }+  }+}
+ test/api/validation/fragment/fail-unknown-field-on-interface/query.gql view
@@ -0,0 +1,16 @@+{+  deity {+    ...onSupernatural+  }+  character {+    ...OnCharacter+  }+}++fragment OnCharacter on Character {+  power+}++fragment onSupernatural on Supernatural {+  name+}
+ test/api/validation/fragment/fail-unknown-field-on-interface/response.json view
@@ -0,0 +1,12 @@+{+  "errors": [+    {+      "message": "Cannot query field \"power\" on type \"Character\".",+      "locations": [{ "line": 11, "column": 3 }]+    },+    {+      "message": "Cannot query field \"name\" on type \"Supernatural\".",+      "locations": [{ "line": 15, "column": 3 }]+    }+  ]+}
+ test/api/validation/fragment/on-interface-fail-without-casting/query.gql view
@@ -0,0 +1,7 @@+{+  character {+    name+    power+    nickname+  }+}
+ test/api/validation/fragment/on-interface-fail-without-casting/response.json view
@@ -0,0 +1,22 @@+{+  "errors": [+    {+      "message": "Cannot query field \"power\" on type \"Character\".",+      "locations": [+        {+          "line": 4,+          "column": 5+        }+      ]+    },+    {+      "message": "Cannot query field \"nickname\" on type \"Character\".",+      "locations": [+        {+          "line": 5,+          "column": 5+        }+      ]+    }+  ]+}
+ test/api/validation/fragment/on-interface-inline/query.gql view
@@ -0,0 +1,12 @@+{+  deity {+    ... on Supernatural {+      power+    }+  }+  character {+    ... on Character {+      name+    }+  }+}
+ test/api/validation/fragment/on-interface-inline/response.json view
@@ -0,0 +1,19 @@+{+  "data": {+    "deity": { "power": ["Shapeshifting"] },+    "character": [+      {+        "__typename": "Deity",+        "name": "Test Deity"+      },+      {+        "__typename": "Hero",+        "name": "Test Hero"+      },+      {+        "__typename": "Character",+        "name": "Test Character"+      }+    ]+  }+}
+ test/api/validation/fragment/on-interface-type-casting-inline/query.gql view
@@ -0,0 +1,13 @@+{+  character {+    ... on Character {+      name+    }+    ... on Deity {+      power+    }+    ... on Hero {+      nickname+    }+  }+}
+ test/api/validation/fragment/on-interface-type-casting-inline/response.json view
@@ -0,0 +1,20 @@+{+  "data": {+    "character": [+      {+        "__typename": "Deity",+        "name": "Test Deity",+        "power": ["Show Only on Deity"]+      },+      {+        "__typename": "Hero",+        "name": "Test Hero",+        "nickname": "tets Hero NickName"+      },+      {+        "__typename": "Character",+        "name": "Test Character"+      }+    ]+  }+}
+ test/api/validation/fragment/on-interface-type-casting/query.gql view
@@ -0,0 +1,19 @@+{+  character {+    ...OnCharacter+    ...onDeity+    ...onHero+  }+}++fragment OnCharacter on Character {+  name+}++fragment onDeity on Deity {+  power+}++fragment onHero on Hero {+  nickname+}
+ test/api/validation/fragment/on-interface-type-casting/response.json view
@@ -0,0 +1,20 @@+{+  "data": {+    "character": [+      {+        "__typename": "Deity",+        "name": "Test Deity",+        "power": ["Show Only on Deity"]+      },+      {+        "__typename": "Hero",+        "name": "Test Hero",+        "nickname": "tets Hero NickName"+      },+      {+        "__typename": "Character",+        "name": "Test Character"+      }+    ]+  }+}
+ test/api/validation/fragment/on-interface/query.gql view
@@ -0,0 +1,16 @@+{+  deity {+    ...OnSupernatural+  }+  character {+    ...OnCharacter+  }+}++fragment OnSupernatural on Supernatural {+  power+}++fragment OnCharacter on Character {+  name+}
+ test/api/validation/fragment/on-interface/response.json view
@@ -0,0 +1,19 @@+{+  "data": {+    "deity": { "power": ["Shapeshifting"] },+    "character": [+      {+        "__typename": "Deity",+        "name": "Test Deity"+      },+      {+        "__typename": "Hero",+        "name": "Test Hero"+      },+      {+        "__typename": "Character",+        "name": "Test Character"+      }+    ]+  }+}
+ test/api/validation/fragment/on-type/query.gql view
@@ -0,0 +1,9 @@+{+  deity {+    ...OnDeity+  }+}++fragment OnDeity on Deity {+  name+}
+ test/api/validation/fragment/on-type/response.json view
@@ -0,0 +1,7 @@+{+  "data": {+    "deity": {+      "name": "Morpheus"+    }+  }+}
+ test/api/validation/fragment/on-union-type/query.gql view
@@ -0,0 +1,9 @@+{+  myUnion {+    ...onDeity+  }+}++fragment onDeity on Deity {+  power+}
+ test/api/validation/fragment/on-union-type/response.json view
@@ -0,0 +1,5 @@+{+  "data": {+    "myUnion": null+  }+}
+ test/api/validation/fragment/resolvers.json view
@@ -0,0 +1,29 @@+{+  "query": {+    "deity": {+      "__typename": "Deity",+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    },+    "character": [+      {+        "__typename": "Deity",+        "name": "Test Deity",+        "power": ["Show Only on Deity"],+        "nickname": "this should be skipped"+      },+      {+        "__typename": "Hero",+        "name": "Test Hero",+        "power": ["this should be skipped"],+        "nickname": "tets Hero NickName"+      },+      {+        "__typename": "Character",+        "name": "Test Character",+        "nickname": "this should be skipped",+        "power": ["this should be skipped"]+      }+    ]+  }+}
+ test/api/validation/fragment/schema.gql view
@@ -0,0 +1,25 @@+interface Character {+  name: String+}++interface Supernatural {+  power: [String!]!+}++type Hero implements Character {+  name: String+  nickname: String+}++type Deity implements Character & Supernatural {+  name: String!+  power: [String!]!+}++union MyUnion = Hero | Deity++type Query {+  deity: Deity!+  myUnion: MyUnion+  character: [Character!]+}
+ test/merge/schema/query-subscription-mutation/api/app.gql view
@@ -0,0 +1,7 @@+type Query {+  name: String+}++type Mutation {+  name(i: Int): String+}
+ test/merge/schema/query-subscription-mutation/api/app.json view
@@ -0,0 +1,8 @@+{+  "query": {+    "name": "query name from app"+  },+  "mutation": {+    "name": "mutation name from app"+  }+}
+ test/merge/schema/query-subscription-mutation/api/ext.gql view
@@ -0,0 +1,12 @@+type Query {+  id: ID+  name: String+}++type Mutation {+  id: ID+}++type Subscription {+  name: String+}
+ test/merge/schema/query-subscription-mutation/api/ext.json view
@@ -0,0 +1,9 @@+{+  "query": {+    "name": "query name from ext",+    "id": "query id from ext"+  },+  "mutation": {+    "id": "mutation id from ext"+  }+}
+ test/merge/schema/query-subscription-mutation/expected/ok.gql view
@@ -0,0 +1,13 @@+type Query {+  name: String+  id: ID+}++type Mutation {+  name(i: Int): String+  id: ID+}++type Subscription {+  name: String+}
+ test/merge/schema/query-subscription-mutation/request/mutation/query.gql view
@@ -0,0 +1,4 @@+mutation {+  name+  id+}
+ test/merge/schema/query-subscription-mutation/request/mutation/response.json view
@@ -0,0 +1,6 @@+{+  "data": {+    "name": "mutation name from app",+    "id": "mutation id from ext"+  }+}
+ test/merge/schema/query-subscription-mutation/request/query/query.gql view
@@ -0,0 +1,4 @@+query {+  name+  id+}
+ test/merge/schema/query-subscription-mutation/request/query/response.json view
@@ -0,0 +1,6 @@+{+  "data": {+    "name": "query name from ext",+    "id": "query id from ext"+  }+}
+ test/merge/schema/simple-query/api/app.gql view
@@ -0,0 +1,12 @@+type Type1 {+  name: String+}++type Type2 {+  name: String+  age: Int+}++type Query {+  type: Type2+}
+ test/merge/schema/simple-query/api/app.json view
@@ -0,0 +1,8 @@+{+  "query": {+    "type": {+      "name": "name from app",+      "age": 23+    }+  }+}
+ test/merge/schema/simple-query/api/ext.gql view
@@ -0,0 +1,9 @@+type Type2 {+  name: String+  id: ID+}++type Query {+  id: ID+  type: Type2+}
+ test/merge/schema/simple-query/api/ext.json view
@@ -0,0 +1,9 @@+{+  "query": {+    "type": {+      "name": "name from ext",+      "id": "id from ext"+    },+    "id": "id from ext"+  }+}
+ test/merge/schema/simple-query/expected/ok.gql view
@@ -0,0 +1,14 @@+type Type2 {+  name: String+  age: Int+  id: ID+}++type Type1 {+  name: String+}++type Query {+  type: Type2+  id: ID+}
+ test/merge/schema/simple-query/request/query/query.gql view
@@ -0,0 +1,8 @@+query {+  id+  type {+    id+    name+    age+  }+}
+ test/merge/schema/simple-query/request/query/response.json view
@@ -0,0 +1,10 @@+{+  "data": {+    "id": "id from ext",+    "type": {+      "id": "id from ext",+      "name": "name from ext",+      "age": 23+    }+  }+}