{-# LANGUAGE TemplateHaskell #-}
module Polysemy.KVStore
(
KVStore (..)
, lookupKV
, lookupOrThrowKV
, existsKV
, writeKV
, deleteKV
, updateKV
, modifyKV
, runKVStoreAsState
, runKVStorePurely
, runKVStoreInRedis
) where
import Control.Monad
import Data.Binary (Binary)
import Data.ByteString (ByteString)
import qualified Data.Map as M
import Data.Maybe (isJust)
import qualified Database.Redis as R
import Polysemy
import Polysemy.Error
import Polysemy.Redis.Utils
import Polysemy.State
data KVStore k v m a where
LookupKV :: k -> KVStore k v m (Maybe v)
UpdateKV :: k -> Maybe v -> KVStore k v m ()
makeSem ''KVStore
writeKV :: Member (KVStore k v) r => k -> v -> Sem r ()
writeKV k = updateKV k . Just
{-# INLINE writeKV #-}
deleteKV :: Member (KVStore k v) r => k -> Sem r ()
deleteKV k = updateKV k Nothing
{-# INLINE deleteKV #-}
lookupOrThrowKV
:: Members '[ KVStore k v
, Error e
] r
=> (k -> e)
-> k
-> Sem r v
lookupOrThrowKV f k =
fromEither . maybe (Left $ f k) Right =<< lookupKV k
existsKV :: Member (KVStore k v) r => k -> Sem r Bool
existsKV = fmap isJust . lookupKV
modifyKV
:: Member (KVStore k v) r
=> v
-> (v -> v)
-> k
-> Sem r ()
modifyKV d f k =
lookupKV k >>= \case
Just v -> writeKV k $ f v
Nothing -> writeKV k $ f d
runKVStoreAsState :: Ord k => Sem (KVStore k v ': r) a -> Sem (State (M.Map k v) ': r) a
runKVStoreAsState = reinterpret $ \case
LookupKV k -> gets $ M.lookup k
UpdateKV k v -> modify $ M.alter (const v) k
{-# INLINE runKVStoreAsState #-}
runKVStorePurely
:: Ord k
=> M.Map k v
-> Sem (KVStore k v ': r) a
-> Sem r (M.Map k v, a)
runKVStorePurely m = runState m . runKVStoreAsState
{-# INLINE runKVStorePurely #-}
runKVStoreInRedis
:: ( Member (Embed R.Redis) r
, Member (Error R.Reply) r
, Binary k
, Binary v
)
=> (k -> ByteString)
-> Sem (KVStore k v ': r) a
-> Sem r a
runKVStoreInRedis pf = interpret $ \case
LookupKV k -> do
res <- fromEitherM $ R.hget (pf k) $ putForRedis k
pure $ fmap getFromRedis res
UpdateKV k Nothing ->
void . fromEitherM
. R.hdel (pf k)
. pure
$ putForRedis k
UpdateKV k (Just v) ->
void . fromEitherM
. R.hset (pf k) (putForRedis k)
$ putForRedis v
{-# INLINE runKVStoreInRedis #-}