{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE NoImplicitPrelude #-} module Data.Morpheus.App.Internal.Resolving.Cache ( CacheKey (..), CacheStore (..), printSelectionKey, useCached, isCached, withDebug, cacheResolverValues, cacheValue, CacheValue (..), CacheT, ) where import Control.Monad.Except import Data.ByteString.Lazy.Char8 (unpack) import qualified Data.HashMap.Lazy as HM import Data.Morpheus.App.Internal.Resolving.ResolverState import Data.Morpheus.App.Internal.Resolving.Types (ResolverValue) import Data.Morpheus.App.Internal.Resolving.Utils (ResolverMonad) import Data.Morpheus.Core (Config (debug), RenderGQL, render) import Data.Morpheus.Internal.Utils ( Empty (..), IsMap (..), ) import Data.Morpheus.Types.Internal.AST ( Msg (msg), SelectionContent, TypeName, VALID, ValidValue, internal, ) import Debug.Trace (trace) import Relude hiding (Show, empty, show, trace) import Prelude (Show (show)) type CacheT m = (StateT (CacheStore m) m) printSelectionKey :: RenderGQL a => a -> String printSelectionKey :: forall a. RenderGQL a => a -> String printSelectionKey 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 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) data CacheValue m = CachedValue ValidValue | CachedResolver (ResolverValue m) instance Show (CacheValue m) where show :: CacheValue m -> String show (CachedValue ValidValue v) = ByteString -> String unpack (forall a. RenderGQL a => a -> ByteString render ValidValue v) show (CachedResolver ResolverValue m v) = forall a. Show a => a -> String show ResolverValue m v instance Show CacheKey where show :: CacheKey -> String show (CacheKey SelectionContent VALID sel TypeName typename ValidValue dep) = forall a. RenderGQL a => a -> String printSelectionKey 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) newtype CacheStore m = CacheStore {forall (m :: * -> *). CacheStore m -> HashMap CacheKey (CacheValue m) _unpackStore :: HashMap CacheKey (CacheValue m)} instance Show (CacheStore m) where show :: CacheStore m -> String show (CacheStore HashMap CacheKey (CacheValue m) cache) = 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, Show a) => (a, a) -> String printKeyValue forall a b. (a -> b) -> a -> b $ forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)] toAssoc HashMap CacheKey (CacheValue m) cache) forall a. Semigroup a => a -> a -> a <> String "\n" 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 <> forall a. Show a => a -> String show a v instance Empty (CacheStore m) where empty :: CacheStore m empty = forall (m :: * -> *). HashMap CacheKey (CacheValue m) -> CacheStore m CacheStore forall coll. Empty coll => coll empty cacheResolverValues :: ResolverMonad m => [(CacheKey, ResolverValue m)] -> CacheT m () cacheResolverValues :: forall (m :: * -> *). ResolverMonad m => [(CacheKey, ResolverValue m)] -> CacheT m () cacheResolverValues [(CacheKey, ResolverValue m)] pres = do CacheStore HashMap CacheKey (CacheValue m) oldCache <- forall s (m :: * -> *). MonadState s m => m s get let updates :: HashMap CacheKey (CacheValue m) updates = forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a unsafeFromList (forall a b. (a -> b) -> [a] -> [b] map (forall (p :: * -> * -> *) b c a. Bifunctor p => (b -> c) -> p a b -> p a c second forall (m :: * -> *). ResolverValue m -> CacheValue m CachedResolver) [(CacheKey, ResolverValue m)] pres) CacheStore m cache <- forall a (m :: * -> *). (Show a, MonadReader ResolverContext m) => String -> a -> m a labeledDebug String "\nUPDATE|>" forall a b. (a -> b) -> a -> b $ forall (m :: * -> *). HashMap CacheKey (CacheValue m) -> CacheStore m CacheStore forall a b. (a -> b) -> a -> b $ HashMap CacheKey (CacheValue m) updates forall a. Semigroup a => a -> a -> a <> HashMap CacheKey (CacheValue m) oldCache forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify (forall a b. a -> b -> a const CacheStore m cache) useCached :: ResolverMonad m => CacheKey -> CacheT m (CacheValue m) useCached :: forall (m :: * -> *). ResolverMonad m => CacheKey -> CacheT m (CacheValue m) useCached CacheKey v = do CacheStore m cache <- forall s (m :: * -> *). MonadState s m => m s get forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= forall a (m :: * -> *). (Show a, MonadReader ResolverContext m) => String -> a -> m a labeledDebug String "\nUSE|>" case forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a lookup CacheKey v (forall (m :: * -> *). CacheStore m -> HashMap CacheKey (CacheValue m) _unpackStore CacheStore m cache) of Just CacheValue m x -> forall (f :: * -> *) a. Applicative f => a -> f a pure CacheValue m x Maybe (CacheValue m) 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 CacheKey v :: String)) isCached :: Monad m => CacheKey -> CacheT m Bool isCached :: forall (m :: * -> *). Monad m => CacheKey -> CacheT m Bool isCached CacheKey key = forall a. Maybe a -> Bool isJust forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a lookup CacheKey key forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). CacheStore m -> HashMap CacheKey (CacheValue m) _unpackStore forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall s (m :: * -> *). MonadState s m => m s get setValue :: (CacheKey, ValidValue) -> CacheStore m -> CacheStore m setValue :: forall (m :: * -> *). (CacheKey, ValidValue) -> CacheStore m -> CacheStore m setValue (CacheKey key, ValidValue value) = forall (m :: * -> *). HashMap CacheKey (CacheValue m) -> CacheStore m CacheStore forall b c a. (b -> c) -> (a -> b) -> a -> c . forall k v. (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v HM.insert CacheKey key (forall (m :: * -> *). ValidValue -> CacheValue m CachedValue ValidValue value) forall b c a. (b -> c) -> (a -> b) -> a -> c . forall (m :: * -> *). CacheStore m -> HashMap CacheKey (CacheValue m) _unpackStore labeledDebug :: (Show a, MonadReader ResolverContext m) => String -> a -> m a labeledDebug :: forall a (m :: * -> *). (Show a, MonadReader ResolverContext m) => String -> a -> m a labeledDebug String label a v = Bool -> a showValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a asks (Config -> Bool debug forall b c a. (b -> c) -> (a -> b) -> a -> c . ResolverContext -> Config config) where showValue :: Bool -> a showValue Bool enabled | Bool enabled = forall a. String -> a -> a trace (String label forall a. Semigroup a => a -> a -> a <> forall a. Show a => a -> String show a v) a v | Bool otherwise = a v withDebug :: (Show a, MonadReader ResolverContext m) => a -> m a withDebug :: forall a (m :: * -> *). (Show a, MonadReader ResolverContext m) => a -> m a withDebug = forall a (m :: * -> *). (Show a, MonadReader ResolverContext m) => String -> a -> m a labeledDebug String "" cacheValue :: Monad m => CacheKey -> ValidValue -> CacheT m ValidValue cacheValue :: forall (m :: * -> *). Monad m => CacheKey -> ValidValue -> CacheT m ValidValue cacheValue CacheKey key ValidValue value = forall s (m :: * -> *). MonadState s m => (s -> s) -> m () modify (forall (m :: * -> *). (CacheKey, ValidValue) -> CacheStore m -> CacheStore m setValue (CacheKey key, ValidValue value)) forall (f :: * -> *) a b. Functor f => f a -> b -> f b $> ValidValue value