{-# 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 = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
replace (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
filter Char -> Bool
ignoreSpaces (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> String
unpack (a -> ByteString
forall a. RenderGQL a => a -> ByteString
render a
sel)
  where
    ignoreSpaces :: Char -> Bool
ignoreSpaces Char
x = Char
x Char -> Char -> Bool
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
(CacheKey -> CacheKey -> Bool)
-> (CacheKey -> CacheKey -> Bool) -> Eq CacheKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CacheKey -> CacheKey -> Bool
== :: CacheKey -> CacheKey -> Bool
$c/= :: CacheKey -> CacheKey -> Bool
/= :: CacheKey -> CacheKey -> Bool
Eq, (forall x. CacheKey -> Rep CacheKey x)
-> (forall x. Rep CacheKey x -> CacheKey) -> Generic CacheKey
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
$cfrom :: forall x. CacheKey -> Rep CacheKey x
from :: forall x. CacheKey -> Rep CacheKey x
$cto :: forall x. Rep CacheKey x -> CacheKey
to :: forall x. Rep CacheKey x -> CacheKey
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 (ValidValue -> ByteString
forall a. RenderGQL a => a -> ByteString
render ValidValue
v)
  show (CachedResolver ResolverValue m
v) = ResolverValue m -> String
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) = SelectionContent VALID -> String
forall a. RenderGQL a => a -> String
printSelectionKey SelectionContent VALID
sel String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> TypeName -> String
forall a. ToString a => a -> String
toString TypeName
typename String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
unpack (ValidValue -> ByteString
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) = Int -> (SelectionContent VALID, TypeName, ByteString) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (SelectionContent VALID
sel, TypeName
tyName, ValidValue -> ByteString
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" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n" (((CacheKey, CacheValue m) -> String)
-> [(CacheKey, CacheValue m)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (CacheKey, CacheValue m) -> String
forall {a} {a}. (Show a, Show a) => (a, a) -> String
printKeyValue ([(CacheKey, CacheValue m)] -> [String])
-> [(CacheKey, CacheValue m)] -> [String]
forall a b. (a -> b) -> a -> b
$ HashMap CacheKey (CacheValue m) -> [(CacheKey, CacheValue m)]
forall a. HashMap CacheKey a -> [(CacheKey, a)]
forall k (m :: * -> *) a. IsMap k m => m a -> [(k, a)]
toAssoc HashMap CacheKey (CacheValue m)
cache) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\n"
    where
      printKeyValue :: (a, a) -> String
printKeyValue (a
key, a
v) = String
" " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
key String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
": " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Show a => a -> String
show a
v

instance Empty (CacheStore m) where
  empty :: CacheStore m
empty = HashMap CacheKey (CacheValue m) -> CacheStore m
forall (m :: * -> *).
HashMap CacheKey (CacheValue m) -> CacheStore m
CacheStore HashMap CacheKey (CacheValue m)
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 <- StateT (CacheStore m) m (CacheStore m)
forall s (m :: * -> *). MonadState s m => m s
get
  let updates :: HashMap CacheKey (CacheValue m)
updates = [(CacheKey, CacheValue m)] -> HashMap CacheKey (CacheValue m)
forall a. [(CacheKey, a)] -> HashMap CacheKey a
forall k (m :: * -> *) a. IsMap k m => [(k, a)] -> m a
unsafeFromList (((CacheKey, ResolverValue m) -> (CacheKey, CacheValue m))
-> [(CacheKey, ResolverValue m)] -> [(CacheKey, CacheValue m)]
forall a b. (a -> b) -> [a] -> [b]
map ((ResolverValue m -> CacheValue m)
-> (CacheKey, ResolverValue m) -> (CacheKey, CacheValue m)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ResolverValue m -> CacheValue m
forall (m :: * -> *). ResolverValue m -> CacheValue m
CachedResolver) [(CacheKey, ResolverValue m)]
pres)
  CacheStore m
cache <- String -> CacheStore m -> StateT (CacheStore m) m (CacheStore m)
forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
String -> a -> m a
labeledDebug String
"\nUPDATE|>" (CacheStore m -> StateT (CacheStore m) m (CacheStore m))
-> CacheStore m -> StateT (CacheStore m) m (CacheStore m)
forall a b. (a -> b) -> a -> b
$ HashMap CacheKey (CacheValue m) -> CacheStore m
forall (m :: * -> *).
HashMap CacheKey (CacheValue m) -> CacheStore m
CacheStore (HashMap CacheKey (CacheValue m) -> CacheStore m)
-> HashMap CacheKey (CacheValue m) -> CacheStore m
forall a b. (a -> b) -> a -> b
$ HashMap CacheKey (CacheValue m)
updates HashMap CacheKey (CacheValue m)
-> HashMap CacheKey (CacheValue m)
-> HashMap CacheKey (CacheValue m)
forall a. Semigroup a => a -> a -> a
<> HashMap CacheKey (CacheValue m)
oldCache
  (CacheStore m -> CacheStore m) -> CacheT m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify (CacheStore m -> CacheStore m -> CacheStore m
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 <- StateT (CacheStore m) m (CacheStore m)
forall s (m :: * -> *). MonadState s m => m s
get StateT (CacheStore m) m (CacheStore m)
-> (CacheStore m -> StateT (CacheStore m) m (CacheStore m))
-> StateT (CacheStore m) m (CacheStore m)
forall a b.
StateT (CacheStore m) m a
-> (a -> StateT (CacheStore m) m b) -> StateT (CacheStore m) m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= String -> CacheStore m -> StateT (CacheStore m) m (CacheStore m)
forall a (m :: * -> *).
(Show a, MonadReader ResolverContext m) =>
String -> a -> m a
labeledDebug String
"\nUSE|>"
  case CacheKey -> HashMap CacheKey (CacheValue m) -> Maybe (CacheValue m)
forall a. CacheKey -> HashMap CacheKey a -> Maybe a
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup CacheKey
v (CacheStore m -> HashMap CacheKey (CacheValue m)
forall (m :: * -> *).
CacheStore m -> HashMap CacheKey (CacheValue m)
_unpackStore CacheStore m
cache) of
    Just CacheValue m
x -> CacheValue m -> CacheT m (CacheValue m)
forall a. a -> StateT (CacheStore m) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CacheValue m
x
    Maybe (CacheValue m)
Nothing -> GQLError -> CacheT m (CacheValue m)
forall a. GQLError -> StateT (CacheStore m) m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (GQLError -> GQLError
internal (GQLError -> GQLError) -> GQLError -> GQLError
forall a b. (a -> b) -> a -> b
$ GQLError
"cache value could not found for key" GQLError -> GQLError -> GQLError
forall a. Semigroup a => a -> a -> a
<> String -> GQLError
forall a. Msg a => a -> GQLError
msg (CacheKey -> String
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 = Maybe (CacheValue m) -> Bool
forall a. Maybe a -> Bool
isJust (Maybe (CacheValue m) -> Bool)
-> (CacheStore m -> Maybe (CacheValue m)) -> CacheStore m -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey -> HashMap CacheKey (CacheValue m) -> Maybe (CacheValue m)
forall a. CacheKey -> HashMap CacheKey a -> Maybe a
forall k (m :: * -> *) a. IsMap k m => k -> m a -> Maybe a
lookup CacheKey
key (HashMap CacheKey (CacheValue m) -> Maybe (CacheValue m))
-> (CacheStore m -> HashMap CacheKey (CacheValue m))
-> CacheStore m
-> Maybe (CacheValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheStore m -> HashMap CacheKey (CacheValue m)
forall (m :: * -> *).
CacheStore m -> HashMap CacheKey (CacheValue m)
_unpackStore (CacheStore m -> Bool)
-> StateT (CacheStore m) m (CacheStore m)
-> StateT (CacheStore m) m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT (CacheStore m) m (CacheStore m)
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) = HashMap CacheKey (CacheValue m) -> CacheStore m
forall (m :: * -> *).
HashMap CacheKey (CacheValue m) -> CacheStore m
CacheStore (HashMap CacheKey (CacheValue m) -> CacheStore m)
-> (CacheStore m -> HashMap CacheKey (CacheValue m))
-> CacheStore m
-> CacheStore m
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheKey
-> CacheValue m
-> HashMap CacheKey (CacheValue m)
-> HashMap CacheKey (CacheValue m)
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert CacheKey
key (ValidValue -> CacheValue m
forall (m :: * -> *). ValidValue -> CacheValue m
CachedValue ValidValue
value) (HashMap CacheKey (CacheValue m)
 -> HashMap CacheKey (CacheValue m))
-> (CacheStore m -> HashMap CacheKey (CacheValue m))
-> CacheStore m
-> HashMap CacheKey (CacheValue m)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CacheStore m -> HashMap CacheKey (CacheValue m)
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 (Bool -> a) -> m Bool -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ResolverContext -> Bool) -> m Bool
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (Config -> Bool
debug (Config -> Bool)
-> (ResolverContext -> Config) -> ResolverContext -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ResolverContext -> Config
config)
  where
    showValue :: Bool -> a
showValue Bool
enabled
      | Bool
enabled = String -> a -> a
forall a. String -> a -> a
trace (String
label String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
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 = String -> a -> m a
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 = (CacheStore m -> CacheStore m) -> StateT (CacheStore m) m ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((CacheKey, ValidValue) -> CacheStore m -> CacheStore m
forall (m :: * -> *).
(CacheKey, ValidValue) -> CacheStore m -> CacheStore m
setValue (CacheKey
key, ValidValue
value)) StateT (CacheStore m) m ()
-> ValidValue -> StateT (CacheStore m) m ValidValue
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> ValidValue
value