{-# 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 :: forall k (f :: * -> *) a. (Eq k, Show k, Hashable k, MonadError GQLError f) => HashMap k a -> k -> f a useCached HashMap k a mp k v = case forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v HM.lookup k v HashMap k a mp of Just a x -> forall (f :: * -> *) a. Applicative f => a -> f a pure a x Maybe a Nothing -> forall e (m :: * -> *) a. MonadError e m => e -> m a throwError (GQLError -> GQLError internal forall a b. (a -> b) -> a -> b $ GQLError "cache value could not found for key" forall a. Semigroup a => a -> a -> a <> forall a. Msg a => a -> GQLError msg (forall a. Show a => a -> String show k v :: String)) dumpCache :: Bool -> LocalCache -> a -> a dumpCache :: forall a. Bool -> LocalCache -> a -> a dumpCache Bool enabled LocalCache xs a a | forall (t :: * -> *) a. Foldable t => t a -> Bool null LocalCache xs Bool -> Bool -> Bool || Bool -> Bool not Bool enabled = a a | Bool otherwise = forall a. String -> a -> a trace (String "\nCACHE:\n" forall a. Semigroup a => a -> a -> a <> forall a. [a] -> [[a]] -> [a] intercalate String "\n" (forall a b. (a -> b) -> [a] -> [b] map forall {a} {a}. (Show a, RenderGQL a) => (a, a) -> String printKeyValue forall a b. (a -> b) -> a -> b $ forall k v. HashMap k v -> [(k, v)] HM.toList LocalCache xs) forall a. Semigroup a => a -> a -> a <> String "\n") a a where printKeyValue :: (a, a) -> String printKeyValue (a key, a v) = String " " forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show a key forall a. Semigroup a => a -> a -> a <> String ": " forall a. Semigroup a => a -> a -> a <> ByteString -> String unpack (forall a. RenderGQL a => a -> ByteString render a v) printSel :: RenderGQL a => a -> [Char] printSel :: forall a. RenderGQL a => a -> String printSel a sel = forall a b. (a -> b) -> [a] -> [b] map Char -> Char replace forall a b. (a -> b) -> a -> b $ forall a. (a -> Bool) -> [a] -> [a] filter Char -> Bool ignoreSpaces forall a b. (a -> b) -> a -> b $ ByteString -> String unpack (forall a. RenderGQL a => a -> ByteString render a sel) where ignoreSpaces :: Char -> Bool ignoreSpaces Char x = Char x forall a. Eq a => a -> a -> Bool /= Char ' ' replace :: Char -> Char replace Char '\n' = Char ' ' replace Char x = Char x data BatchEntry = BatchEntry { BatchEntry -> SelectionContent VALID batchedSelection :: SelectionContent VALID, BatchEntry -> TypeName batchedType :: TypeName, BatchEntry -> [ValidValue] batchedArguments :: [ValidValue] } instance Show BatchEntry where show :: BatchEntry -> String show BatchEntry {[ValidValue] SelectionContent VALID TypeName batchedArguments :: [ValidValue] batchedType :: TypeName batchedSelection :: SelectionContent VALID batchedArguments :: BatchEntry -> [ValidValue] batchedType :: BatchEntry -> TypeName batchedSelection :: BatchEntry -> SelectionContent VALID ..} = forall a. RenderGQL a => a -> String printSel SelectionContent VALID batchedSelection forall a. Semigroup a => a -> a -> a <> String ":" forall a. Semigroup a => a -> a -> a <> forall a. ToString a => a -> String toString TypeName batchedType forall a. Semigroup a => a -> a -> a <> String ":" forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show (forall a b. (a -> b) -> [a] -> [b] map (ByteString -> String unpack forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a. RenderGQL a => a -> ByteString render) [ValidValue] batchedArguments) data CacheKey = CacheKey { CacheKey -> SelectionContent VALID cachedSel :: SelectionContent VALID, CacheKey -> TypeName cachedTypeName :: TypeName, CacheKey -> ValidValue cachedArg :: ValidValue } deriving (CacheKey -> CacheKey -> Bool forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: CacheKey -> CacheKey -> Bool $c/= :: CacheKey -> CacheKey -> Bool == :: CacheKey -> CacheKey -> Bool $c== :: CacheKey -> CacheKey -> Bool Eq, forall x. Rep CacheKey x -> CacheKey forall x. CacheKey -> Rep CacheKey x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep CacheKey x -> CacheKey $cfrom :: forall x. CacheKey -> Rep CacheKey x Generic) instance Show CacheKey where show :: CacheKey -> String show (CacheKey SelectionContent VALID sel TypeName typename ValidValue dep) = forall a. RenderGQL a => a -> String printSel SelectionContent VALID sel forall a. Semigroup a => a -> a -> a <> String ":" forall a. Semigroup a => a -> a -> a <> forall a. ToString a => a -> String toString TypeName typename forall a. Semigroup a => a -> a -> a <> String ":" forall a. Semigroup a => a -> a -> a <> ByteString -> String unpack (forall a. RenderGQL a => a -> ByteString render ValidValue dep) instance Hashable CacheKey where hashWithSalt :: Int -> CacheKey -> Int hashWithSalt Int s (CacheKey SelectionContent VALID sel TypeName tyName ValidValue arg) = forall a. Hashable a => Int -> a -> Int hashWithSalt Int s (SelectionContent VALID sel, TypeName tyName, forall a. RenderGQL a => a -> ByteString render ValidValue arg) uniq :: (Eq a, Hashable a) => [a] -> [a] uniq :: forall a. (Eq a, Hashable a) => [a] -> [a] uniq = forall k v. HashMap k v -> [k] HM.keys forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v HM.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a -> b) -> [a] -> [b] map (,Bool True) buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry] buildBatches :: [(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry] buildBatches [(SelectionContent VALID, NamedResolverRef)] inputs = let entityTypes :: [(SelectionContent VALID, TypeName)] entityTypes = forall a. (Eq a, Hashable a) => [a] -> [a] uniq forall a b. (a -> b) -> a -> b $ forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second NamedResolverRef -> TypeName resolverTypeName) [(SelectionContent VALID, NamedResolverRef)] inputs in forall a b. (a -> Maybe b) -> [a] -> [b] mapMaybe ([(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry selectByEntity [(SelectionContent VALID, NamedResolverRef)] inputs) [(SelectionContent VALID, TypeName)] entityTypes selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry selectByEntity :: [(SelectionContent VALID, NamedResolverRef)] -> (SelectionContent VALID, TypeName) -> Maybe BatchEntry selectByEntity [(SelectionContent VALID, NamedResolverRef)] inputs (SelectionContent VALID tSel, TypeName tName) = case forall a. (a -> Bool) -> [a] -> [a] filter (SelectionContent VALID, NamedResolverRef) -> Bool areEq [(SelectionContent VALID, NamedResolverRef)] inputs of [] -> forall a. Maybe a Nothing [(SelectionContent VALID, NamedResolverRef)] xs -> forall a. a -> Maybe a Just forall a b. (a -> b) -> a -> b $ SelectionContent VALID -> TypeName -> [ValidValue] -> BatchEntry BatchEntry SelectionContent VALID tSel TypeName tName (forall a. (Eq a, Hashable a) => [a] -> [a] uniq forall a b. (a -> b) -> a -> b $ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b] concatMap (NamedResolverRef -> [ValidValue] resolverArgument forall b c a. (b -> c) -> (a -> b) -> a -> c . forall a b. (a, b) -> b snd) [(SelectionContent VALID, NamedResolverRef)] xs) where areEq :: (SelectionContent VALID, NamedResolverRef) -> Bool areEq (SelectionContent VALID sel, NamedResolverRef v) = SelectionContent VALID sel forall a. Eq a => a -> a -> Bool == SelectionContent VALID tSel Bool -> Bool -> Bool && TypeName tName forall a. Eq a => a -> a -> Bool == NamedResolverRef -> TypeName resolverTypeName NamedResolverRef v type ResolverFun m = NamedResolverRef -> SelectionContent VALID -> m [ValidValue] resolveBatched :: Monad m => ResolverFun m -> BatchEntry -> m LocalCache resolveBatched :: forall (m :: * -> *). Monad m => ResolverFun m -> BatchEntry -> m LocalCache resolveBatched ResolverFun m f (BatchEntry SelectionContent VALID sel TypeName name [ValidValue] deps) = do [ValidValue] res <- ResolverFun m f (TypeName -> [ValidValue] -> NamedResolverRef NamedResolverRef TypeName name [ValidValue] deps) SelectionContent VALID sel let keys :: [CacheKey] keys = forall a b. (a -> b) -> [a] -> [b] map (SelectionContent VALID -> TypeName -> ValidValue -> CacheKey CacheKey SelectionContent VALID sel TypeName name) [ValidValue] deps let entries :: [(CacheKey, ValidValue)] entries = forall a b. [a] -> [b] -> [(a, b)] zip [CacheKey] keys [ValidValue] res forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v HM.fromList [(CacheKey, ValidValue)] entries updateCache :: (Monad m, Traversable t) => ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache updateCache :: forall (m :: * -> *) (t :: * -> *). (Monad m, Traversable t) => ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache updateCache ResolverFun m f LocalCache cache t BatchEntry entries = do t LocalCache caches <- forall (t :: * -> *) (f :: * -> *) a b. (Traversable t, Applicative f) => (a -> f b) -> t a -> f (t b) traverse (forall (m :: * -> *). Monad m => ResolverFun m -> BatchEntry -> m LocalCache resolveBatched ResolverFun m f) t BatchEntry entries let newCache :: LocalCache newCache = forall (t :: * -> *) a b. Foldable t => (a -> b -> b) -> b -> t a -> b foldr forall a. Semigroup a => a -> a -> a (<>) LocalCache cache t LocalCache caches forall (f :: * -> *) a. Applicative f => a -> f a pure forall a b. (a -> b) -> a -> b $ forall a. Bool -> LocalCache -> a -> a dumpCache Bool False LocalCache newCache LocalCache newCache buildCacheWith :: Monad m => ResolverFun m -> LocalCache -> [(SelectionContent VALID, NamedResolverRef)] -> m LocalCache buildCacheWith :: forall (m :: * -> *). Monad m => ResolverFun m -> LocalCache -> [(SelectionContent VALID, NamedResolverRef)] -> m LocalCache buildCacheWith ResolverFun m f LocalCache cache [(SelectionContent VALID, NamedResolverRef)] entries = forall (m :: * -> *) (t :: * -> *). (Monad m, Traversable t) => ResolverFun m -> LocalCache -> t BatchEntry -> m LocalCache updateCache ResolverFun m f LocalCache cache ([(SelectionContent VALID, NamedResolverRef)] -> [BatchEntry] buildBatches [(SelectionContent VALID, NamedResolverRef)] entries) data ResolverMapContext m = ResolverMapContext { forall (m :: * -> *). ResolverMapContext m -> LocalCache localCache :: LocalCache, forall (m :: * -> *). ResolverMapContext m -> ResolverMap m resolverMap :: ResolverMap m } newtype ResolverMapT m a = ResolverMapT { forall (m :: * -> *) a. ResolverMapT m a -> ReaderT (ResolverMapContext m) m a _runResMapT :: ReaderT (ResolverMapContext m) m a } deriving ( forall a b. a -> ResolverMapT m b -> ResolverMapT m a forall a b. (a -> b) -> ResolverMapT m a -> ResolverMapT m b forall (m :: * -> *) a b. Functor m => a -> ResolverMapT m b -> ResolverMapT m a forall (m :: * -> *) a b. Functor m => (a -> b) -> ResolverMapT m a -> ResolverMapT m b forall (f :: * -> *). (forall a b. (a -> b) -> f a -> f b) -> (forall a b. a -> f b -> f a) -> Functor f <$ :: forall a b. a -> ResolverMapT m b -> ResolverMapT m a $c<$ :: forall (m :: * -> *) a b. Functor m => a -> ResolverMapT m b -> ResolverMapT m a fmap :: forall a b. (a -> b) -> ResolverMapT m a -> ResolverMapT m b $cfmap :: forall (m :: * -> *) a b. Functor m => (a -> b) -> ResolverMapT m a -> ResolverMapT m b Functor, forall a. a -> ResolverMapT m a forall a b. ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a forall a b. ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b forall a b. ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b forall a b c. (a -> b -> c) -> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c forall (f :: * -> *). Functor f -> (forall a. a -> f a) -> (forall a b. f (a -> b) -> f a -> f b) -> (forall a b c. (a -> b -> c) -> f a -> f b -> f c) -> (forall a b. f a -> f b -> f b) -> (forall a b. f a -> f b -> f a) -> Applicative f forall {m :: * -> *}. Applicative m => Functor (ResolverMapT m) forall (m :: * -> *) a. Applicative m => a -> ResolverMapT m a forall (m :: * -> *) a b. Applicative m => ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a forall (m :: * -> *) a b. Applicative m => ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b forall (m :: * -> *) a b. Applicative m => ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b forall (m :: * -> *) a b c. Applicative m => (a -> b -> c) -> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c <* :: forall a b. ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a $c<* :: forall (m :: * -> *) a b. Applicative m => ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m a *> :: forall a b. ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b $c*> :: forall (m :: * -> *) a b. Applicative m => ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b liftA2 :: forall a b c. (a -> b -> c) -> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c $cliftA2 :: forall (m :: * -> *) a b c. Applicative m => (a -> b -> c) -> ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m c <*> :: forall a b. ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b $c<*> :: forall (m :: * -> *) a b. Applicative m => ResolverMapT m (a -> b) -> ResolverMapT m a -> ResolverMapT m b pure :: forall a. a -> ResolverMapT m a $cpure :: forall (m :: * -> *) a. Applicative m => a -> ResolverMapT m a Applicative, forall a. a -> ResolverMapT m a forall a b. ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b forall a b. ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b forall {m :: * -> *}. Monad m => Applicative (ResolverMapT m) forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a forall (m :: * -> *) a b. Monad m => ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b forall (m :: * -> *) a b. Monad m => ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b forall (m :: * -> *). Applicative m -> (forall a b. m a -> (a -> m b) -> m b) -> (forall a b. m a -> m b -> m b) -> (forall a. a -> m a) -> Monad m return :: forall a. a -> ResolverMapT m a $creturn :: forall (m :: * -> *) a. Monad m => a -> ResolverMapT m a >> :: forall a b. ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b $c>> :: forall (m :: * -> *) a b. Monad m => ResolverMapT m a -> ResolverMapT m b -> ResolverMapT m b >>= :: forall a b. ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b $c>>= :: forall (m :: * -> *) a b. Monad m => ResolverMapT m a -> (a -> ResolverMapT m b) -> ResolverMapT m b Monad, MonadReader (ResolverMapContext m) ) instance MonadTrans ResolverMapT where lift :: forall (m :: * -> *) a. Monad m => m a -> ResolverMapT m a lift = forall (m :: * -> *) a. ReaderT (ResolverMapContext m) m a -> ResolverMapT m a ResolverMapT forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (t :: (* -> *) -> * -> *) (m :: * -> *) a. (MonadTrans t, Monad m) => m a -> t m a lift deriving instance MonadError GQLError m => MonadError GQLError (ResolverMapT m) runResMapT :: ResolverMapT m a -> ResolverMapContext m -> m a runResMapT :: forall (m :: * -> *) a. ResolverMapT m a -> ResolverMapContext m -> m a runResMapT (ResolverMapT ReaderT (ResolverMapContext m) m a x) = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a runReaderT ReaderT (ResolverMapContext m) m a x