Cache Comparison

Cache Comparison

This gist compares two implementations of a typed cache for an effects system, one in Run and one in MTL. This is a tricky effect, because:

1. The cache is typed: the key type determines the value type.
2. The cache key is polymorphic: users can define their own key types outside the module.
3. The cache is extensible: users can define multiple independent caches, each with their own implementation (such as being in-memory only, or backed by a database only, or a combination).

Both implementations preserve these properties and demonstrate how a user could implement their own key type and choose an implementation for it in their chosen effect system.

Monad.purs

module TypedCache where

import Prelude

import Control.Monad.Reader (class MonadAsk, ReaderT, ask, runReaderT)
import Data.Argonaut.Core as Argonaut
import Data.Argonaut.Parser as Argonaut.Parser
import Data.Codec.Argonaut (JsonCodec)
import Data.Codec.Argonaut as CA
import Data.Const (Const(..))
import Data.Either (Either(..))
import Data.Exists (Exists)
import Data.Exists as Exists
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap)
import Effect.Aff (Aff)
import Effect.Aff as Aff
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect)
import Node.Buffer (Buffer)
import Node.Encoding (Encoding(..))
import Node.FS.Aff as FS
import Node.FS.Aff as FS.Aff
import Node.Path (FilePath)
import Node.Path as Path

newtype Reply a b = Reply (Maybe a -> b)

data Ignore (a :: Type) (b :: Type) = Ignore

class MonadCache key m | key -> m where
  getCache :: forall a. key Reply a -> m a
  putCache :: (forall void. key Const void) -> m Unit
  deleteCache :: (forall void. key Ignore void) -> m Unit

type CacheKey :: ((Type -> Type -> Type) -> Type -> Type) -> Type -> Type
type CacheKey k a = forall c b. c a b -> k c b

get :: forall m k a. MonadCache k m => CacheKey k a -> m (Maybe a)
get key = getCache (key (Reply identity))

put :: forall m k a. MonadCache k m => CacheKey k a -> a -> m Unit
put key value = putCache (key (Const value))

delete :: forall m k a. MonadCache k m => CacheKey k a -> m Unit
delete key = deleteCache (key Ignore)

type FsCacheEnv key =
  { cacheDir :: FilePath
  , encoder :: FsEncoder key
  }

type FsEncoder key = forall b z. key z b -> Exists (FsEncoding z b)

data FsEncoding :: (Type -> Type -> Type) -> Type -> Type -> Type
data FsEncoding z b a
  = AsJson String (JsonCodec a) (z a b)
  | AsBuffer String (z Buffer b)

getFs :: forall key m r. MonadAff m => FsCacheEnv key -> key Reply r -> m r
getFs env key = Exists.runExists (getImpl env.cacheDir) (env.encoder key)
  where
  getImpl :: forall a b. FilePath -> FsEncoding Reply a b -> m a
  getImpl cacheDir = case _ of
    AsBuffer id (Reply reply) -> do
      let path = Path.concat [ cacheDir, id ]
      liftAff (Aff.attempt (FS.Aff.readFile path)) >>= case _ of
        Left _ -> pure $ reply Nothing
        Right buf -> pure $ reply $ Just buf

    AsJson id codec (Reply reply) -> do
      let path = Path.concat [ cacheDir, id ]
      liftAff (Aff.attempt (FS.Aff.readTextFile UTF8 path)) >>= case _ of
        Left _ -> pure $ reply Nothing
        Right content -> case Argonaut.Parser.jsonParser content of
          Left _ -> deletePathById cacheDir id *> pure (reply Nothing)
          Right jsonContent -> case CA.decode codec jsonContent of
            Left _ -> deletePathById cacheDir id *> pure (reply Nothing)
            Right entry -> pure $ reply $ Just entry

putFs :: forall key m. MonadAff m => FsCacheEnv key -> (forall void. key Const void) -> m Unit
putFs env key = Exists.runExists (putImpl env.cacheDir) (env.encoder key)
  where
  putImpl :: forall a b. FilePath -> FsEncoding Const a b -> m Unit
  putImpl cacheDir = case _ of
    AsBuffer id (Const value) -> do
      let path = Path.concat [ cacheDir, id ]
      liftAff (Aff.attempt (FS.Aff.writeFile path value)) >>= case _ of
        Left _ -> pure unit
        Right _ -> pure unit

    AsJson id codec (Const value) -> do
      let path = Path.concat [ cacheDir, id ]
      let encoded = Argonaut.stringify $ CA.encode codec value
      liftAff (Aff.attempt (FS.writeTextFile UTF8 path encoded)) >>= case _ of
        Left _ -> pure unit
        Right _ -> pure unit

deleteFs :: forall key m. MonadAff m => FsCacheEnv key -> (forall void. key Ignore void) -> m Unit
deleteFs env key = Exists.runExists (deleteImpl env.cacheDir) (env.encoder key)
  where
  deleteImpl :: forall a b. FilePath -> FsEncoding Ignore a b -> m Unit
  deleteImpl cacheDir = case _ of
    AsBuffer id Ignore ->
      deletePathById cacheDir id *> pure unit
    AsJson id _ Ignore ->
      deletePathById cacheDir id *> pure unit

deletePathById :: forall m. MonadAff m => FilePath -> String -> m Unit
deletePathById cacheDir id = do
  let path = Path.concat [ cacheDir, id ]
  liftAff (Aff.attempt (FS.Aff.unlink path)) >>= case _ of
    Left _ -> pure unit
    Right _ -> pure unit

----------
-- IN USE
----------

newtype Env = Env
  { cacheEnv :: FsCacheEnv MyCache
  }

newtype AppM a = AppM (ReaderT Env Aff a)

derive instance Newtype (AppM a) _

derive newtype instance Functor AppM
derive newtype instance Apply AppM
derive newtype instance Applicative AppM
derive newtype instance Bind AppM
derive newtype instance Monad AppM
derive newtype instance MonadEffect AppM
derive newtype instance MonadAff AppM
derive newtype instance MonadAsk Env AppM

data MyCache (c :: Type -> Type -> Type) a
  = Package String (c Buffer a)
  | Integer String (c Int a)

myFsEncoder :: FsEncoder MyCache
myFsEncoder = case _ of
  Package id next ->
    Exists.mkExists $ AsBuffer ("MyCache__" <> id) next
  Integer id next ->
    Exists.mkExists $ AsJson ("MyCache__" <> id) CA.int next

instance MonadCache MyCache AppM where
  getCache key = do
    Env env <- ask
    getFs env.cacheEnv key

  putCache key = do
    Env env <- ask
    putFs env.cacheEnv key

  deleteCache key = do
    Env env <- ask
    deleteFs env.cacheEnv key

program :: AppM (Maybe Buffer)
program = do
  put (Integer "1") 1
  put (Integer "2") 2
  t <- get (Package "run")
  pure t

run :: Aff (Maybe Buffer)
run = runReaderT (unwrap program) $ Env
  { cacheEnv: { cacheDir: "", encoder: myFsEncoder }
  }

Run.purs

module TypedCache where

import Prelude

import Data.Argonaut.Core as Argonaut
import Data.Argonaut.Parser as Argonaut.Parser
import Data.Codec.Argonaut (JsonCodec)
import Data.Codec.Argonaut as CA
import Data.Const (Const(..))
import Data.Either (Either(..))
import Data.Exists (Exists)
import Data.Exists as Exists
import Data.Maybe (Maybe(..))
import Data.Symbol (class IsSymbol)
import Effect.Aff (Aff)
import Effect.Aff as Aff
import Node.Buffer (Buffer)
import Node.Encoding (Encoding(..))
import Node.FS.Aff as FS
import Node.FS.Aff as FS.Aff
import Node.Path (FilePath)
import Node.Path as Path
import Prim.Row as Row
import Run (AFF, EFFECT, Run)
import Run as Run
import Type.Proxy (Proxy(..))
import Type.Row (type (+))

class Functor2 (c :: Type -> Type -> Type) where
  map2 :: forall a b z. (a -> b) -> c z a -> c z b

newtype Reply a b = Reply (Maybe a -> b)

instance Functor2 Reply where
  map2 k (Reply f) = Reply (map k f)

newtype Ignore :: forall k. k -> Type -> Type
newtype Ignore a b = Ignore b

instance Functor2 Ignore where
  map2 k (Ignore b) = Ignore (k b)

-- | An effect for caching values with an extensible key to support multiple
-- | independent caches.
data TypedCache key a
  = Get (key Reply a)
  | Put (forall void. key Const void) a
  | Delete (key Ignore a)

derive instance (Functor (key Reply), Functor (key Ignore)) => Functor (TypedCache key)

type CacheKey :: ((Type -> Type -> Type) -> Type -> Type) -> Type -> Type
type CacheKey k a = forall c b. c a b -> k c b

getCache :: forall k a. CacheKey k a -> TypedCache k (Maybe a)
getCache key = Get (key (Reply identity))

putCache :: forall k a. CacheKey k a -> a -> TypedCache k Unit
putCache key value = Put (key (Const value)) unit

deleteCache :: forall k a. CacheKey k a -> TypedCache k Unit
deleteCache key = Delete (key (Ignore unit))

runCacheAt
  :: forall s k a r t
   . IsSymbol s
  => Row.Cons s (TypedCache k) t r
  => Proxy s
  -> (TypedCache k ~> Run t)
  -> Run r a
  -> Run t a
runCacheAt sym handler = Run.interpret (Run.on sym handler Run.send)

-- | The environment for a filesystem-backed cache implementation, where values
-- | associated with the cache keys must be serializable to the file system.
type FsCacheEnv k =
  { encoder :: FsEncoder k
  , cacheDir :: FilePath
  }

-- | A mapping of key types to a unique cache identifier and codec for encoding
-- | and decoding the value as JSON. This uses an existential encoding, so you
-- | must use `Exists.mkExists` to hide the value's type.
type FsEncoder key = forall b z. key z b -> Exists (FsEncoding z b)

-- | A box used with `Exists` to capture the encoding associated with values
-- | of a particular key. Essentially, these are serialization formats:
-- | sometimes we want a cache backed by JSON, sometimes backed by a raw buffer.
-- | We can add more if we ever need them.
data FsEncoding :: (Type -> Type -> Type) -> Type -> Type -> Type
data FsEncoding z b a
  = AsJson String (JsonCodec a) (z a b)
  | AsBuffer String (z Buffer b)

handleCacheFs :: forall k r a. FsCacheEnv k -> TypedCache k a -> Run (AFF + EFFECT + r) a
handleCacheFs env = case _ of
  Get key -> Exists.runExists (getFsImpl env.cacheDir) (env.encoder key)
  Put key next -> Exists.runExists (putFsImpl env.cacheDir next) (env.encoder key)
  Delete key -> Exists.runExists (deleteFsImpl env.cacheDir) (env.encoder key)

getFsImpl :: forall a b r. FilePath -> FsEncoding Reply a b -> Run (AFF + r) a
getFsImpl cacheDir = case _ of
  AsBuffer id (Reply reply) -> do
    let path = Path.concat [ cacheDir, id ]
    Run.liftAff (Aff.attempt (FS.Aff.readFile path)) >>= case _ of
      Left _ -> pure $ reply Nothing
      Right buf -> pure $ reply $ Just buf

  AsJson id codec (Reply reply) -> do
    let path = Path.concat [ cacheDir, id ]
    Run.liftAff (Aff.attempt (FS.Aff.readTextFile UTF8 path)) >>= case _ of
      Left _ -> pure $ reply Nothing
      Right content -> case Argonaut.Parser.jsonParser content of
        Left _ -> deletePathById cacheDir id *> pure (reply Nothing)
        Right jsonContent -> case CA.decode codec jsonContent of
          Left _ -> deletePathById cacheDir id *> pure (reply Nothing)
          Right entry -> pure $ reply $ Just entry

putFsImpl :: forall a b r. FilePath -> a -> FsEncoding Const a b -> Run (AFF + r) a
putFsImpl cacheDir next = case _ of
  AsBuffer id (Const value) -> do
    let path = Path.concat [ cacheDir, id ]
    Run.liftAff (Aff.attempt (FS.Aff.writeFile path value)) >>= case _ of
      Left _ -> pure next
      Right _ -> pure next

  AsJson id codec (Const value) -> do
    let path = Path.concat [ cacheDir, id ]
    let encoded = Argonaut.stringify $ CA.encode codec value
    Run.liftAff (Aff.attempt (FS.writeTextFile UTF8 path encoded)) >>= case _ of
      Left _ -> pure next
      Right _ -> pure next

deleteFsImpl :: forall a b r. FilePath -> FsEncoding Ignore a b -> Run (AFF + r) a
deleteFsImpl cacheDir = case _ of
  AsBuffer id (Ignore next) ->
    deletePathById cacheDir id *> pure next
  AsJson id _ (Ignore next) ->
    deletePathById cacheDir id *> pure next

deletePathById :: forall r. FilePath -> String -> Run (AFF + r) Unit
deletePathById cacheDir id = do
  let path = Path.concat [ cacheDir, id ]
  Run.liftAff (Aff.attempt (FS.Aff.unlink path)) >>= case _ of
    Left _ -> pure unit
    Right _ -> pure unit

----------
-- IN USE
----------

data MyCache (c :: Type -> Type -> Type) a
  = Package String (c Buffer a)
  | Integer String (c Int a)

instance Functor2 c => Functor (MyCache c) where
  map k = case _ of
    Package id a -> Package id (map2 k a)
    Integer id a -> Integer id (map2 k a)

type MY_CACHE r = (myCache :: TypedCache MyCache | r)

_myCache :: Proxy "myCache"
_myCache = Proxy

getMyCache :: forall r a. CacheKey MyCache a -> Run (MY_CACHE + r) (Maybe a)
getMyCache key = Run.lift _myCache (getCache key)

putMyCache :: forall r a. CacheKey MyCache a -> a -> Run (MY_CACHE + r) Unit
putMyCache key value = Run.lift _myCache (putCache key value)

myFsEncoder :: FsEncoder MyCache
myFsEncoder = case _ of
  Package id next ->
    Exists.mkExists $ AsBuffer ("MyCache__" <> id) next
  Integer id next ->
    Exists.mkExists $ AsJson ("MyCache__" <> id) CA.int next

runMyCacheFs
  :: forall r a
   . { cacheDir :: FilePath }
  -> Run (MY_CACHE + AFF + EFFECT + r) a
  -> Run (AFF + EFFECT + r) a
runMyCacheFs { cacheDir } = runCacheAt _myCache (handleCacheFs { cacheDir, encoder: myFsEncoder })

program :: forall r. Run (MY_CACHE + r) (Maybe Buffer)
program = do
  putMyCache (Integer "1") 1
  putMyCache (Integer "2") 2
  getMyCache (Package "run")

run :: Aff (Maybe Buffer)
run = do
  program
    # runMyCacheFs { cacheDir: "" }
    # Run.runBaseAff'