morpheus-graphql-app 0.25.0 → 0.26.0

raw patch · 21 files changed

+435/−266 lines, 21 filesdep ~morpheus-graphql-coredep ~morpheus-graphql-testsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-core, morpheus-graphql-tests

API changes (from Hackage documentation)

Files

• morpheus-graphql-app.cabal +15/−7
• src/Data/Morpheus/App/Internal/Resolving/Batching.hs +144/−0
• src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs +59/−72
• src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs +3/−3
• src/Data/Morpheus/App/Internal/Resolving/Types.hs +0/−73
• src/Data/Morpheus/App/Internal/Resolving/Utils.hs +2/−0
• src/Data/Morpheus/App/NamedResolvers.hs +6/−0
• test/Batching.hs +72/−35
• test/batching/deities.gql +0/−14
• test/batching/deities/query.gql +0/−26
• test/batching/deities/response.json +0/−36
• test/batching/object-lists/batching.json +4/−0
• test/batching/object-lists/query.gql +6/−0
• test/batching/object-lists/response.json +14/−0
• test/batching/objects-fields/batching.json +4/−0
• test/batching/objects-fields/query.gql +16/−0
• test/batching/objects-fields/response.json +13/−0
• test/batching/objects-lists-fields/batching.json +4/−0
• test/batching/objects-lists-fields/query.gql +26/−0
• test/batching/objects-lists-fields/response.json +33/−0
• test/batching/schema.gql +14/−0

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-app-version:        0.25.0+version:        0.26.0 synopsis:       Morpheus GraphQL App description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -42,8 +42,10 @@     test/api/validation/input-coercion/list/list-single/query.gql     test/api/validation/input-coercion/list/schema.gql     test/api/validation/input-coercion/list/signle-value/query.gql-    test/batching/deities.gql-    test/batching/deities/query.gql+    test/batching/object-lists/query.gql+    test/batching/objects-fields/query.gql+    test/batching/objects-lists-fields/query.gql+    test/batching/schema.gql     test/merge/schema/query-subscription-mutation/app-1.gql     test/merge/schema/query-subscription-mutation/app-2.gql     test/merge/schema/query-subscription-mutation/mutation/query.gql@@ -88,7 +90,12 @@     test/api/validation/input-coercion/list/list-single/response.json     test/api/validation/input-coercion/list/resolvers.json     test/api/validation/input-coercion/list/signle-value/response.json-    test/batching/deities/response.json+    test/batching/object-lists/batching.json+    test/batching/object-lists/response.json+    test/batching/objects-fields/batching.json+    test/batching/objects-fields/response.json+    test/batching/objects-lists-fields/batching.json+    test/batching/objects-lists-fields/response.json     test/merge/schema/query-subscription-mutation/app-1.json     test/merge/schema/query-subscription-mutation/app-2.json     test/merge/schema/query-subscription-mutation/mutation/response.json@@ -120,6 +127,7 @@       Data.Morpheus.App.NamedResolvers       Data.Morpheus.Types.GQLWrapper   other-modules:+      Data.Morpheus.App.Internal.Resolving.Batching       Data.Morpheus.App.Internal.Resolving.Event       Data.Morpheus.App.Internal.Resolving.Resolver       Data.Morpheus.App.Internal.Resolving.ResolverState@@ -142,7 +150,7 @@     , containers >=0.4.2.1 && <0.7.0     , hashable >=1.0.0 && <2.0.0     , megaparsec >=7.0.0 && <10.0.0-    , morpheus-graphql-core >=0.25.0 && <0.26.0+    , morpheus-graphql-core >=0.26.0 && <0.27.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0@@ -174,8 +182,8 @@     , hashable >=1.0.0 && <2.0.0     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-app-    , morpheus-graphql-core >=0.25.0 && <0.26.0-    , morpheus-graphql-tests >=0.25.0 && <0.26.0+    , morpheus-graphql-core >=0.26.0 && <0.27.0+    , morpheus-graphql-tests >=0.26.0 && <0.27.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0

@@ -0,0 +1,144 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.App.Internal.Resolving.Batching+  ( CacheKey (..),+    LocalCache,+    useCached,+    buildCacheWith,+    ResolverMapContext (..),+    ResolverMapT (..),+    runResMapT,+  )+where++import Control.Monad.Except (MonadError (throwError))+import Data.ByteString.Lazy.Char8 (unpack)+import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.App.Internal.Resolving.Types (NamedResolverRef (..), ResolverMap)+import Data.Morpheus.Core (RenderGQL, render)+import Data.Morpheus.Types.Internal.AST+  ( GQLError,+    Msg (..),+    SelectionContent,+    TypeName,+    VALID,+    ValidValue,+    internal,+  )+import GHC.Show (Show (show))+import Relude hiding (show)++type LocalCache = HashMap CacheKey ValidValue++useCached :: (Eq k, Show k, Hashable k, MonadError GQLError f) => HashMap k a -> k -> f a+useCached mp v = case HM.lookup v mp of+  Just x -> pure x+  Nothing -> throwError (internal $ "cache value could not found for key" <> msg (show v :: String))++dumpCache :: Bool -> LocalCache -> a -> a+dumpCache enabled xs a+  | null xs || not enabled = a+  | otherwise = trace ("\nCACHE:\n" <> intercalate "\n" (map printKeyValue $ HM.toList xs) <> "\n") a+  where+    printKeyValue (key, v) = " " <> show key <> ": " <> unpack (render v)++printSel :: RenderGQL a => a -> [Char]+printSel sel = map replace $ filter ignoreSpaces $ unpack (render sel)+  where+    ignoreSpaces x = x /= ' '+    replace '\n' = ' '+    replace x = x++data BatchEntry = BatchEntry+  { batchedSelection :: SelectionContent VALID,+    batchedType :: TypeName,+    batchedArguments :: [ValidValue]+  }++instance Show BatchEntry where+  show BatchEntry {..} = printSel batchedSelection <> ":" <> toString batchedType <> ":" <> show (map (unpack . render) batchedArguments)++data CacheKey = CacheKey+  { cachedSel :: SelectionContent VALID,+    cachedTypeName :: TypeName,+    cachedArg :: ValidValue+  }+  deriving (Eq, Generic)++instance Show CacheKey where+  show (CacheKey sel typename dep) = printSel sel <> ":" <> toString typename <> ":" <> unpack (render dep)++instance Hashable CacheKey where+  hashWithSalt s (CacheKey sel tyName arg) = hashWithSalt s (sel, tyName, render arg)++uniq :: (Eq a, Hashable a) => [a] -> [a]+uniq = HM.keys . HM.fromList . map (,True)++buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]+buildBatches inputs =+  let entityTypes = uniq $ map (second resolverTypeName) inputs+   in mapMaybe (selectByEntity inputs) entityTypes++selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry+selectByEntity inputs (tSel, tName) = case filter areEq inputs of+  [] -> Nothing+  xs -> Just $ BatchEntry tSel tName (uniq $ concatMap (resolverArgument . snd) xs)+  where+    areEq (sel, v) = sel == tSel && tName == resolverTypeName v++type ResolverFun m = NamedResolverRef -> SelectionContent VALID -> m [ValidValue]++resolveBatched :: Monad m => ResolverFun m -> BatchEntry -> m LocalCache+resolveBatched f (BatchEntry sel name deps) = do+  res <- f (NamedResolverRef name deps) sel+  let keys = map (CacheKey sel name) deps+  let entries = zip keys res+  pure $ HM.fromList entries++updateCache :: (Monad m, Traversable t) => ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache+updateCache f cache entries = do+  caches <- traverse (resolveBatched f) entries+  let newCache = foldr (<>) cache caches+  pure $ dumpCache False newCache newCache++buildCacheWith :: Monad m => ResolverFun m -> LocalCache -> [(SelectionContent VALID, NamedResolverRef)] -> m LocalCache+buildCacheWith f cache entries = updateCache f cache (buildBatches entries)++data ResolverMapContext m = ResolverMapContext+  { localCache :: LocalCache,+    resolverMap :: ResolverMap m+  }++newtype ResolverMapT m a = ResolverMapT+  { _runResMapT :: ReaderT (ResolverMapContext m) m a+  }+  deriving+    ( Functor,+      Applicative,+      Monad,+      MonadReader (ResolverMapContext m)+    )++instance MonadTrans ResolverMapT where+  lift = ResolverMapT . lift++deriving instance MonadError GQLError m => MonadError GQLError (ResolverMapT m)++runResMapT :: ResolverMapT m a -> ResolverMapContext m -> m a+runResMapT (ResolverMapT x) = runReaderT x

@@ -9,31 +9,34 @@ module Data.Morpheus.App.Internal.Resolving.ResolveValue   ( resolveRef,     resolveObject,+    ResolverMapContext (..),   ) where  import Control.Monad.Except (MonadError (throwError)) import qualified Data.HashMap.Lazy as HM+import Data.Morpheus.App.Internal.Resolving.Batching+  ( CacheKey (..),+    ResolverMapContext (..),+    ResolverMapT,+    buildCacheWith,+    runResMapT,+    useCached,+  ) import Data.Morpheus.App.Internal.Resolving.ResolverState   ( ResolverContext (..),     askFieldTypeName,     updateCurrentType,   ) import Data.Morpheus.App.Internal.Resolving.Types-  ( BatchEntry (..),-    CacheKey (..),-    LocalCache,-    NamedResolver (..),+  ( NamedResolver (..),     NamedResolverRef (..),     NamedResolverResult (..),     ObjectTypeResolver (..),     ResolverMap,     ResolverValue (..),-    buildBatches,-    dumpCache,     mkEnum,     mkUnion,-    useCached,   ) import Data.Morpheus.Error (subfieldsNotSelected) import Data.Morpheus.Internal.Utils@@ -64,8 +67,6 @@   ) import Relude hiding (empty) -type ResolverMapContext m = (LocalCache, ResolverMap m)- scanRefs :: (MonadError GQLError m, MonadReader ResolverContext m) => SelectionContent VALID -> ResolverValue m -> m [(SelectionContent VALID, NamedResolverRef)] scanRefs sel (ResList xs) = concat <$> traverse (scanRefs sel) xs scanRefs sel (ResLazy x) = x >>= scanRefs sel@@ -104,53 +105,39 @@     MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  ResolverMapContext m ->   ResolverValue m ->   SelectionContent VALID ->-  m ValidValue-resolveSelection rmap res selection = do-  newRmap <- scanRefs selection res >>= buildCache rmap . buildBatches-  __resolveSelection newRmap res selection--buildCache :: (MonadError GQLError m, MonadReader ResolverContext m) => ResolverMapContext m -> [BatchEntry] -> m (LocalCache, ResolverMap m)-buildCache (cache, rmap) entries = do-  caches <- traverse (resolveCacheEntry (cache, rmap)) entries-  let newCache = foldr (<>) cache caches-  pure $ dumpCache False (newCache, rmap)+  ResolverMapT m ValidValue+resolveSelection res selection = do+  ctx <- ask+  newRmap <- lift (scanRefs selection res >>= buildCache ctx)+  local (const newRmap) (__resolveSelection res selection) -resolveCacheEntry :: (MonadError GQLError m, MonadReader ResolverContext m) => ResolverMapContext m -> BatchEntry -> m LocalCache-resolveCacheEntry rmap (BatchEntry sel name deps) = do-  res <- resolveRefsCached rmap (NamedResolverRef name deps) sel-  let keys = map (CacheKey sel name) deps-  let entries = zip keys res-  pure $ HM.fromList entries+buildCache :: (MonadError GQLError m, MonadReader ResolverContext m) => ResolverMapContext m -> [(SelectionContent VALID, NamedResolverRef)] -> m (ResolverMapContext m)+buildCache ctx@(ResolverMapContext cache rmap) entries = (`ResolverMapContext` rmap) <$> buildCacheWith (resolveRefsCached ctx) cache entries  __resolveSelection ::   ( Monad m,     MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  ResolverMapContext m ->   ResolverValue m ->   SelectionContent VALID ->-  m ValidValue-__resolveSelection rmap (ResLazy x) selection =-  x >>= flip (resolveSelection rmap) selection-__resolveSelection rmap (ResList xs) selection =-  List <$> traverse (flip (resolveSelection rmap) selection) xs--- Object ------------------__resolveSelection rmap (ResObject tyName obj) sel = withObject tyName (resolveObject rmap obj) sel--- ENUM-__resolveSelection _ (ResEnum name) SelectionField = pure $ Scalar $ String $ unpackName name-__resolveSelection rmap (ResEnum name) unionSel@UnionSelection {} =-  resolveSelection rmap (mkUnion name [(unitFieldName, pure $ mkEnum unitTypeName)]) unionSel-__resolveSelection _ ResEnum {} _ = throwError (internal "wrong selection on enum value")--- SCALARS-__resolveSelection _rmap ResNull _ = pure Null-__resolveSelection _rmap (ResScalar x) SelectionField = pure $ Scalar x-__resolveSelection _rmap ResScalar {} _ =-  throwError (internal "scalar Resolver should only receive SelectionField")-__resolveSelection rmap (ResRef ref) sel = ref >>= flip (resolveRef rmap) sel+  ResolverMapT m ValidValue+__resolveSelection (ResLazy x) selection = lift x >>= (`resolveSelection` selection)+__resolveSelection (ResList xs) selection = List <$> traverse (`resolveSelection` selection) xs+__resolveSelection (ResObject tyName obj) sel = do+  ctx <- ask+  lift $ withObject tyName (resolveObject ctx obj) sel+__resolveSelection (ResEnum name) SelectionField = pure $ Scalar $ String $ unpackName name+__resolveSelection (ResEnum name) unionSel@UnionSelection {} = resolveSelection (mkUnion name [(unitFieldName, pure $ mkEnum unitTypeName)]) unionSel+__resolveSelection ResEnum {} _ = throwError (internal "wrong selection on enum value")+__resolveSelection ResNull _ = pure Null+__resolveSelection (ResScalar x) SelectionField = pure $ Scalar x+__resolveSelection ResScalar {} _ = throwError (internal "scalar Resolver should only receive SelectionField")+__resolveSelection (ResRef ref) sel = do+  ctx <- ask+  lift (ref >>= flip (resolveRef ctx) sel)  withObject ::   ( MonadError GQLError m,@@ -170,7 +157,7 @@       where         fx (Just x) y = Just <$> (x <:> unionTagSelection y)         fx Nothing y = pure $ Just $ unionTagSelection y-    checkContent _ = noEmptySelection+    checkContent SelectionField = noEmptySelection  noEmptySelection :: (MonadError GQLError m, MonadReader ResolverContext m) => m value noEmptySelection = do@@ -181,15 +168,15 @@   ( MonadError GQLError m,     MonadReader ResolverContext m   ) =>-  (LocalCache, ResolverMap m) ->+  ResolverMapContext m ->   NamedResolverRef ->   SelectionContent VALID ->   m ValidValue resolveRef rmap ref selection = resolveRefsCached rmap ref selection >>= toOne -toOne :: (MonadError GQLError f) => [a] -> f a+toOne :: (MonadError GQLError f, Show a) => [a] -> f a toOne [x] = pure x-toOne _ = throwError (internal "TODO:")+toOne x = throwError (internal ("expected only one resolved value for " <> msg (show x :: String)))  resolveRefsCached ::   ( MonadError GQLError m,@@ -199,41 +186,42 @@   NamedResolverRef ->   SelectionContent VALID ->   m [ValidValue]-resolveRefsCached (cache, rmap) (NamedResolverRef name args) selection = do+resolveRefsCached ctx (NamedResolverRef name args) selection = do   let keys = map (CacheKey selection name) args   let cached = map resolveCached keys   let cachedMap = HM.fromList (mapMaybe unp cached)-  notCachedMap <- resolveUncached (cache, rmap) name selection $ map fst $ filter (isNothing . snd) cached+  notCachedMap <- runResMapT (resolveUncached name selection $ map fst $ filter (isNothing . snd) cached) ctx   traverse (useCached (cachedMap <> notCachedMap)) args   where     unp (_, Nothing) = Nothing     unp (x, Just y) = Just (x, y)-    resolveCached key = (cachedArg key, HM.lookup key cache)+    resolveCached key = (cachedArg key, HM.lookup key $ localCache ctx)  processResult ::   (MonadError GQLError m, MonadReader ResolverContext m) =>-  ResolverMapContext m ->   TypeName ->   SelectionContent VALID ->   NamedResolverResult m ->-  m ValidValue-processResult rmap typename selection (NamedObjectResolver res) = withObject (Just typename) (resolveObject rmap res) selection-processResult rmap _ selection (NamedUnionResolver unionRef) = resolveSelection rmap (ResRef $ pure unionRef) selection-processResult rmap _ selection (NamedEnumResolver value) = resolveSelection rmap (ResEnum value) selection-processResult rmap _ selection NamedNullResolver = resolveSelection rmap ResNull selection+  ResolverMapT m ValidValue+processResult typename selection (NamedObjectResolver res) = do+  ctx <- ask+  lift $ withObject (Just typename) (resolveObject ctx res) selection+processResult _ selection (NamedUnionResolver unionRef) = resolveSelection (ResRef $ pure unionRef) selection+processResult _ selection (NamedEnumResolver value) = resolveSelection (ResEnum value) selection+processResult _ selection NamedNullResolver = resolveSelection ResNull selection  resolveUncached ::   ( MonadError GQLError m,     MonadReader ResolverContext m   ) =>-  (LocalCache, ResolverMap m) ->   TypeName ->   SelectionContent VALID ->   [ValidValue] ->-  m (HashMap ValidValue ValidValue)-resolveUncached _ _ _ [] = pure empty-resolveUncached rmap typename selection xs = do-  vs <- getNamedResolverBy (NamedResolverRef typename xs) (snd rmap) >>= traverse (processResult rmap typename selection)+  ResolverMapT m (HashMap ValidValue ValidValue)+resolveUncached _ _ [] = pure empty+resolveUncached typename selection xs = do+  rmap <- asks resolverMap+  vs <- lift (getNamedResolverBy (NamedResolverRef typename xs) rmap) >>= traverse (processResult typename selection)   pure $ HM.fromList (zip xs vs)  getNamedResolverBy ::@@ -249,34 +237,33 @@   ( MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  (LocalCache, ResolverMap m) ->+  ResolverMapContext m ->   ObjectTypeResolver m ->   Maybe (SelectionSet VALID) ->   m ValidValue resolveObject rmap drv sel = do-  newCache <- objectRefs drv sel >>= buildCache rmap . buildBatches+  newCache <- objectRefs drv sel >>= buildCache rmap   Object <$> maybe (pure empty) (traverseCollection (resolver newCache)) sel   where-    resolver newCache currentSelection = do+    resolver cacheCTX currentSelection = do       t <- askFieldTypeName (selectionName currentSelection)       updateCurrentType t $         local (\ctx -> ctx {currentSelection}) $           ObjectEntry (keyOf currentSelection)-            <$> runFieldResolver newCache currentSelection drv+            <$> runResMapT (runFieldResolver currentSelection drv) cacheCTX  runFieldResolver ::   ( Monad m,     MonadReader ResolverContext m,     MonadError GQLError m   ) =>-  (LocalCache, ResolverMap m) ->   Selection VALID ->   ObjectTypeResolver m ->-  m ValidValue-runFieldResolver rmap Selection {selectionName, selectionContent}+  ResolverMapT m ValidValue+runFieldResolver Selection {selectionName, selectionContent}   | selectionName == "__typename" =-      const (Scalar . String . unpackName <$> asks (typeName . currentType))+      const (Scalar . String . unpackName <$> lift (asks (typeName . currentType)))   | otherwise =-      maybe (pure Null) (>>= \x -> resolveSelection rmap x selectionContent)+      maybe (pure Null) (lift >=> (`resolveSelection` selectionContent))         . HM.lookup selectionName         . objectFields

@@ -92,7 +92,7 @@   selection =     do       root <- runResolverStateT (toResolverStateT res) ctx-      runResolver channels (resolveObject mempty root (Just selection)) ctx+      runResolver channels (resolveObject (ResolverMapContext mempty mempty) root (Just selection)) ctx  runRootResolverValue :: Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID) runRootResolverValue@@ -118,7 +118,7 @@     where       selectByOperation Query = withIntrospection (\sel -> runResolver Nothing (resolvedValue sel) ctx) ctx         where-          resolvedValue selection = resolveRef (empty, queryResolverMap) (NamedResolverRef "Query" ["ROOT"]) (SelectionSet selection)+          resolvedValue selection = resolveRef (ResolverMapContext empty queryResolverMap) (NamedResolverRef "Query" ["ROOT"]) (SelectionSet selection)       selectByOperation _ = throwError "mutation and subscription is not supported for namedResolvers"  withIntrospection :: Monad m => (SelectionSet VALID -> ResponseStream event m ValidValue) -> ResolverContext -> ResponseStream event m ValidValue@@ -131,7 +131,7 @@     mergeRoot y x  introspection :: Monad m => SelectionSet VALID -> ResolverContext -> ResponseStream event m ValidValue-introspection selection ctx@ResolverContext {schema} = runResolver Nothing (resolveObject mempty (schemaAPI schema) (Just selection)) ctx+introspection selection ctx@ResolverContext {schema} = runResolver Nothing (resolveObject (ResolverMapContext mempty mempty) (schemaAPI schema) (Just selection)) ctx  mergeRoot :: MonadError GQLError m => ValidValue -> ValidValue -> m ValidValue mergeRoot (Object x) (Object y) = Object <$> merge x y

@@ -1,6 +1,5 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -9,7 +8,6 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -33,80 +31,24 @@     mkObjectMaybe,     mkUnion,     NamedResolverFun,-    buildBatches,-    Cache,-    CacheKey (..),-    BatchEntry (..),-    LocalCache,-    dumpCache,-    useCached,   ) where  import Control.Monad.Except (MonadError (throwError))-import Data.ByteString.Lazy.Char8 (unpack) import qualified Data.HashMap.Lazy as HM-import Data.Morpheus.Core (RenderGQL, render) import Data.Morpheus.Internal.Ext (Merge (..)) import Data.Morpheus.Internal.Utils (KeyOf (keyOf)) import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError,     ScalarValue (..),-    SelectionContent,     TypeName,-    VALID,     ValidValue,     internal,   ) import GHC.Show (Show (show)) import Relude hiding (show) -type LocalCache = HashMap CacheKey ValidValue--useCached :: (Eq k, Hashable k, MonadError GQLError f) => HashMap k a -> k -> f a-useCached mp v = case HM.lookup v mp of-  Just x -> pure x-  Nothing -> throwError (internal "TODO:")--dumpCache :: Bool -> (LocalCache, ResolverMap m) -> (LocalCache, ResolverMap m)-dumpCache enabled xs-  | null (fst xs) || not enabled = xs-  | otherwise = trace ("\nCACHE:\n" <> intercalate "\n" (map printKeyValue $ HM.toList $ fst xs) <> "\n") xs-  where-    printKeyValue (key, v) = " " <> show key <> ": " <> unpack (render v)--printSel :: RenderGQL a => a -> [Char]-printSel sel = map replace $ filter ignoreSpaces $ unpack (render sel)-  where-    ignoreSpaces x = x /= ' '-    replace '\n' = ' '-    replace x = x--data BatchEntry = BatchEntry-  { batchedSelection :: SelectionContent VALID,-    batchedType :: TypeName,-    batchedArguments :: [ValidValue]-  }--instance Show BatchEntry where-  show (BatchEntry sel typename dep) = printSel sel <> ":" <> toString typename <> ":" <> show (map (unpack . render) dep)--data CacheKey = CacheKey-  { cachedSel :: SelectionContent VALID,-    cachedTypeName :: TypeName,-    cachedArg :: ValidValue-  }-  deriving (Eq, Generic)--instance Show CacheKey where-  show (CacheKey sel typename dep) = printSel sel <> ":" <> toString typename <> ":" <> unpack (render dep)--instance Hashable CacheKey where-  hashWithSalt s (CacheKey sel tyName arg) = hashWithSalt s (sel, tyName, render arg)--type Cache m = HashMap CacheKey (NamedResolverResult m)- type ResolverMap (m :: Type -> Type) = HashMap TypeName (NamedResolver m)  type NamedResolverArg = [ValidValue]@@ -134,21 +76,6 @@     resolverArgument :: NamedResolverArg   }   deriving (Show)--uniq :: (Eq a, Hashable a) => [a] -> [a]-uniq = HM.keys . HM.fromList . map (,True)--buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry]-buildBatches inputs =-  let entityTypes = uniq $ map (second resolverTypeName) inputs-   in mapMaybe (selectByEntity inputs) entityTypes--selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry-selectByEntity inputs (tSel, tName) = case filter areEq inputs of-  [] -> Nothing-  xs -> Just $ BatchEntry tSel tName (uniq $ concatMap (resolverArgument . snd) xs)-  where-    areEq (sel, v) = sel == tSel && tName == resolverTypeName v  data NamedResolverResult (m :: Type -> Type)   = NamedObjectResolver (ObjectTypeResolver m)

@@ -22,6 +22,8 @@ import Control.Monad.Except (MonadError (throwError)) import qualified Data.Aeson as A import Data.Morpheus.App.Internal.Resolving.ResolverState+  ( ResolverContext (..),+  ) import Data.Morpheus.App.Internal.Resolving.Types   ( NamedResolverRef (..),     ObjectTypeResolver (..),

@@ -10,6 +10,7 @@     NamedResolverFunction,     RootResolverValue,     ResultBuilder,+    nullRes,   ) where @@ -57,6 +58,9 @@ variant :: (LiftOperation o, Monad m) => TypeName -> ValidValue -> Resolver o e m (ResultBuilder o e m) variant tName = pure . Union tName +nullRes :: (LiftOperation o, Monad m) => Resolver o e m (ResultBuilder o e m)+nullRes = pure Null+ queryResolvers :: Monad m => [(TypeName, NamedResolverFunction QUERY e m)] -> RootResolverValue e m queryResolvers = NamedResolversValue . mkResolverMap @@ -64,6 +68,7 @@ data ResultBuilder o e m   = Object [(FieldName, Resolver o e m (ResolverValue (Resolver o e m)))]   | Union TypeName ValidValue+  | Null  mkResolverMap :: (LiftOperation o, Monad m) => [(TypeName, NamedResolverFunction o e m)] -> ResolverMap (Resolver o e m) mkResolverMap = HM.fromList . map packRes@@ -73,3 +78,4 @@       where         mapValue (Object x) = NamedObjectResolver (ObjectTypeResolver $ HM.fromList x)         mapValue (Union name x) = NamedUnionResolver (NamedResolverRef name [x])+        mapValue Null = NamedNullResolver

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}  module Batching@@ -6,20 +7,24 @@   ) where -import Data.ByteString.Lazy.Char8 (unpack)+import Control.Monad.Except (MonadError (throwError))+import Data.Aeson (eitherDecode) import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.HashSet (fromList)+import Data.Map (lookup) import Data.Morpheus.App   ( App (..),     mkApp,     runApp,   )-import Data.Morpheus.App.Internal.Resolving (resultOr)+import Data.Morpheus.App.Internal.Resolving (ResolverValue, resultOr) import Data.Morpheus.App.NamedResolvers   ( NamedResolverFunction,     RootResolverValue,     enum,     getArgument,     list,+    nullRes,     object,     queryResolvers,     ref,@@ -27,67 +32,99 @@   ) import Data.Morpheus.Core   ( parseSchema,-    render,   ) import Data.Morpheus.Types.IO   ( GQLRequest (..),     GQLResponse,   )-import Data.Morpheus.Types.Internal.AST (QUERY, Schema, VALID)-import Relude hiding (ByteString)+import Data.Morpheus.Types.Internal.AST+  ( QUERY,+    Schema,+    TypeName,+    VALID,+    ValidValue,+    unpackName,+  )+import Relude hiding (ByteString, fromList) import Test.Morpheus   ( FileUrl,+    file,     testApi,   ) import Test.Tasty   ( TestTree,   ) --- DEITIES+type BatchedValues = (HashSet ValidValue) -debugArgs :: String -> NamedResolverFunction QUERY e m -> NamedResolverFunction QUERY e m-debugArgs name f args = trace (name <> ":: " <> intercalate ", " (map (unpack . render) args)) (f args)+type BatchingConstraints = Map Text BatchedValues +typeConstraint :: Monad m => BatchingConstraints -> (TypeName, NamedResolverFunction QUERY e m) -> (TypeName, NamedResolverFunction QUERY e m)+typeConstraint cons (name, f) = (name,) $ maybe f (require f) (lookup (unpackName name) cons)++require :: Monad m => NamedResolverFunction QUERY e m -> BatchedValues -> NamedResolverFunction QUERY e m+require f req args+  | fromList args == req = f args+  | otherwise = throwError ("was not batched! expected: " <> show req <> "got: " <> show args)++gods :: [ValidValue]+gods = ["poseidon", "morpheus", "zeus"]++getName :: ValidValue -> ResolverValue m+getName "zeus" = "Zeus"+getName "morpheus" = "Morpheus"+getName "poseidon" = "Zeus"+getName "cronos" = "Cronos"+getName _ = ""++getPowers :: ValidValue -> [ResolverValue m]+getPowers "zeus" = [enum "Thunderbolt"]+getPowers "morpheus" = [enum "Shapeshifting"]+getPowers _ = []+ deityResolver :: Monad m => NamedResolverFunction QUERY e m-deityResolver = debugArgs "DEITY" (traverse getDeity)+deityResolver = traverse getDeity   where-    getDeity "zeus" =-      object-        [ ("name", pure "Zeus"),-          ("power", pure $ list [])-        ]-    getDeity _ =-      object-        [ ("name", pure "Morpheus"),-          ("power", pure $ list [enum "Shapeshifting"])-        ]+    getDeity name+      | name `elem` gods =+          object+            [ ("name", pure $ getName name),+              ("power", pure $ list $ getPowers name)+            ]+      | otherwise = nullRes  resolveQuery :: Monad m => NamedResolverFunction QUERY e m-resolveQuery = debugArgs "QUERY" (traverse _resolveQuery)+resolveQuery = traverse getQuery   where-    _resolveQuery _ =+    getQuery _ =       object         [ ("deity", ref "Deity" <$> getArgument "id"),           ("deities", pure $ refs "Deity" ["zeus", "morpheus"])         ] -resolvers :: Monad m => RootResolverValue e m-resolvers =-  queryResolvers-    [ ("Query", resolveQuery),-      ("Deity", deityResolver)-    ]+resolvers :: Monad m => BatchingConstraints -> RootResolverValue e m+resolvers cons =+  queryResolvers $+    typeConstraint cons+      <$> [ ("Query", resolveQuery),+            ("Deity", deityResolver)+          ] -getSchema :: String -> IO (Schema VALID)-getSchema url = LBS.readFile url >>= resultOr (fail . show) pure . parseSchema+getSchema :: FileUrl -> IO (Schema VALID)+getSchema url = LBS.readFile (toString url) >>= resultOr (fail . show) pure . parseSchema -getApps :: FileUrl -> IO (App e IO)-getApps _ = do-  schemaDeities <- getSchema "test/named-resolvers/deities.gql"-  pure $ mkApp schemaDeities resolvers+getBatchingConstraint :: FileUrl -> IO BatchingConstraints+getBatchingConstraint url = LBS.readFile (toString (file url "batching.json")) >>= either (fail . show) pure . eitherDecode +getApps :: BatchingConstraints -> FileUrl -> IO (App e IO)+getApps con x = do+  schemaDeities <- getSchema (file x "schema.gql")+  pure $ mkApp schemaDeities (resolvers con)+ runBatchingTest :: FileUrl -> FileUrl -> TestTree-runBatchingTest url = testApi api+runBatchingTest url fileUrl = testApi api fileUrl   where     api :: GQLRequest -> IO GQLResponse-    api req = getApps url >>= (`runApp` req)+    api req = do+      constraints <- getBatchingConstraint fileUrl+      getApps constraints url >>= (`runApp` req)

@@ -1,14 +0,0 @@-enum Power {-  Shapeshifting-  Thunderbolt-}--type Deity {-  name: String!-  power: [String!]-}--type Query {-  deities: [Deity!]!-  deity(id: ID): Deity-}

@@ -1,26 +0,0 @@-query {-  deities {-    name-    power-  }--  heroes: deities {-    name-    power-  }--  cronos: deity(id: "cronos") {-    name-    power-  }--  poseidon: deity(id: "poseidon") {-    name-    power-  }--  morpheus: deity(id: "morpheus") {-    name-    power-  }-}

@@ -1,36 +0,0 @@-{-  "data": {-    "poseidon": {-      "name": "Morpheus",-      "power": ["Shapeshifting"]-    },-    "morpheus": {-      "name": "Morpheus",-      "power": ["Shapeshifting"]-    },-    "heroes": [-      {-        "name": "Zeus",-        "power": []-      },-      {-        "name": "Morpheus",-        "power": ["Shapeshifting"]-      }-    ],-    "cronos": {-      "name": "Morpheus",-      "power": ["Shapeshifting"]-    },-    "deities": [-      {-        "name": "Zeus",-        "power": []-      },-      {-        "name": "Morpheus",-        "power": ["Shapeshifting"]-      }-    ]-  }-}

@@ -0,0 +1,4 @@+{+  "Deity": ["morpheus", "zeus"],+  "Query": ["ROOT"]+}

@@ -0,0 +1,6 @@+query {+  deities {+    name+    power+  }+}

@@ -0,0 +1,14 @@+{+  "data": {+    "deities": [+      {+        "name": "Zeus",+        "power": ["Thunderbolt"]+      },+      {+        "name": "Morpheus",+        "power": ["Shapeshifting"]+      }+    ]+  }+}

@@ -0,0 +1,4 @@+{+  "Deity": ["cronos", "poseidon", "morpheus"],+  "Query": ["ROOT"]+}

@@ -0,0 +1,16 @@+query {+  cronos: deity(id: "cronos") {+    name+    power+  }++  poseidon: deity(id: "poseidon") {+    name+    power+  }++  morpheus: deity(id: "morpheus") {+    name+    power+  }+}

@@ -0,0 +1,13 @@+{+  "data": {+    "poseidon": {+      "name": "Zeus",+      "power": []+    },+    "morpheus": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    },+    "cronos": null+  }+}

@@ -0,0 +1,4 @@+{+  "Deity": ["cronos", "poseidon", "morpheus", "zeus"],+  "Query": ["ROOT"]+}

@@ -0,0 +1,26 @@+query {+  deities {+    name+    power+  }++  heroes: deities {+    name+    power+  }++  cronos: deity(id: "cronos") {+    name+    power+  }++  poseidon: deity(id: "poseidon") {+    name+    power+  }++  morpheus: deity(id: "morpheus") {+    name+    power+  }+}

@@ -0,0 +1,33 @@+{+  "data": {+    "poseidon": {+      "name": "Zeus",+      "power": []+    },+    "morpheus": {+      "name": "Morpheus",+      "power": ["Shapeshifting"]+    },+    "heroes": [+      {+        "name": "Zeus",+        "power": ["Thunderbolt"]+      },+      {+        "name": "Morpheus",+        "power": ["Shapeshifting"]+      }+    ],+    "cronos": null,+    "deities": [+      {+        "name": "Zeus",+        "power": ["Thunderbolt"]+      },+      {+        "name": "Morpheus",+        "power": ["Shapeshifting"]+      }+    ]+  }+}

@@ -0,0 +1,14 @@+enum Power {+  Shapeshifting+  Thunderbolt+}++type Deity {+  name: String!+  power: [String!]+}++type Query {+  deities: [Deity!]!+  deity(id: ID): Deity+}