{-# LANGUAGE DeriveDataTypeable    #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeFamilies          #-}

module Haxl.RedisCache
  ( cached
  , cached'
  , remove
  , removeAll
  , initRedisState
  ) where

import           Control.Concurrent.Async
import           Control.Concurrent.QSem
import qualified Control.Exception        (SomeException, bracket_, try)
import           Control.Monad            (void)
import           Data.Aeson               (FromJSON, ToJSON, decodeStrict,
                                           encode)
import           Data.ByteString          (ByteString)
import qualified Data.ByteString          as B (concat)
import           Data.ByteString.Lazy     (toStrict)
import           Data.Hashable            (Hashable (..))
import           Data.Typeable            (Typeable)
import           Database.Redis           (Connection, del, get, runRedis, set)
import           Haxl.Core                hiding (fetchReq)

newtype Conn = Conn Connection

instance Eq Conn where
  _ == :: Conn -> Conn -> Bool
== _ = Bool
True

instance Show Conn where
  show :: Conn -> String
show _ = "Conn"

genKey :: ByteString -> ByteString -> ByteString
genKey :: ByteString -> ByteString -> ByteString
genKey pref :: ByteString
pref k :: ByteString
k = [ByteString] -> ByteString
B.concat [ByteString
pref, ":", ByteString
k]

getData_ :: Connection -> ByteString -> IO (Maybe ByteString)
getData_ :: Connection -> ByteString -> IO (Maybe ByteString)
getData_ conn :: Connection
conn k :: ByteString
k = Connection -> Redis (Maybe ByteString) -> IO (Maybe ByteString)
forall a. Connection -> Redis a -> IO a
runRedis Connection
conn (Redis (Maybe ByteString) -> IO (Maybe ByteString))
-> Redis (Maybe ByteString) -> IO (Maybe ByteString)
forall a b. (a -> b) -> a -> b
$ (Reply -> Maybe ByteString)
-> (Maybe ByteString -> Maybe ByteString)
-> Either Reply (Maybe ByteString)
-> Maybe ByteString
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe ByteString -> Reply -> Maybe ByteString
forall a b. a -> b -> a
const Maybe ByteString
forall a. Maybe a
Nothing) Maybe ByteString -> Maybe ByteString
forall a. a -> a
id (Either Reply (Maybe ByteString) -> Maybe ByteString)
-> Redis (Either Reply (Maybe ByteString))
-> Redis (Maybe ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Redis (Either Reply (Maybe ByteString))
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> m (f (Maybe ByteString))
get ByteString
k

setData_ :: Connection -> ByteString -> ByteString -> IO ()
setData_ :: Connection -> ByteString -> ByteString -> IO ()
setData_ conn :: Connection
conn k :: ByteString
k = Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedis Connection
conn (Redis () -> IO ())
-> (ByteString -> Redis ()) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Redis (Either Reply Status) -> Redis ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Redis (Either Reply Status) -> Redis ())
-> (ByteString -> Redis (Either Reply Status))
-> ByteString
-> Redis ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString -> Redis (Either Reply Status)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
ByteString -> ByteString -> m (f Status)
set ByteString
k

delData_ :: Connection -> [ByteString] -> IO ()
delData_ :: Connection -> [ByteString] -> IO ()
delData_ conn :: Connection
conn ks :: [ByteString]
ks = Connection -> Redis () -> IO ()
forall a. Connection -> Redis a -> IO a
runRedis Connection
conn (Redis () -> IO ())
-> (Redis (Either Reply Integer) -> Redis ())
-> Redis (Either Reply Integer)
-> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Redis (Either Reply Integer) -> Redis ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Redis (Either Reply Integer) -> IO ())
-> Redis (Either Reply Integer) -> IO ()
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Redis (Either Reply Integer)
forall (m :: * -> *) (f :: * -> *).
RedisCtx m f =>
[ByteString] -> m (f Integer)
del [ByteString]
ks

-- Data source implementation.

data RedisReq a where
  GetData :: Conn -> ByteString -> RedisReq (Maybe ByteString)
  SetData :: Conn -> ByteString -> ByteString -> RedisReq ()
  DelData :: Conn -> [ByteString] -> RedisReq ()
  deriving (Typeable)

deriving instance Eq (RedisReq a)
instance Hashable (RedisReq a) where
  hashWithSalt :: Int -> RedisReq a -> Int
hashWithSalt s :: Int
s (GetData _ k :: ByteString
k)   = Int -> (Int, ByteString) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (1::Int, ByteString
k)
  hashWithSalt s :: Int
s (SetData _ k :: ByteString
k v :: ByteString
v) = Int -> (Int, ByteString, ByteString) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (2::Int, ByteString
k, ByteString
v)
  hashWithSalt s :: Int
s (DelData _ ks :: [ByteString]
ks)  = Int -> (Int, [ByteString]) -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (3::Int, [ByteString]
ks)

deriving instance Show (RedisReq a)
instance ShowP RedisReq where showp :: RedisReq a -> String
showp = RedisReq a -> String
forall a. Show a => a -> String
show

instance StateKey RedisReq where
  data State RedisReq = RedisState { State RedisReq -> Int
numThreads :: Int, State RedisReq -> ByteString
prefix :: ByteString }

instance DataSourceName RedisReq where
  dataSourceName :: Proxy RedisReq -> Text
dataSourceName _ = "RedisDataSource"

instance DataSource u RedisReq where
  fetch :: State RedisReq -> Flags -> u -> PerformFetch RedisReq
fetch = State RedisReq -> Flags -> u -> PerformFetch RedisReq
forall u. State RedisReq -> Flags -> u -> PerformFetch RedisReq
doFetch

doFetch
  :: State RedisReq
  -> Flags
  -> u
  -> PerformFetch RedisReq

doFetch :: State RedisReq -> Flags -> u -> PerformFetch RedisReq
doFetch _state :: State RedisReq
_state _flags :: Flags
_flags _ = ([BlockedFetch RedisReq] -> IO () -> IO ())
-> PerformFetch RedisReq
forall (req :: * -> *).
([BlockedFetch req] -> IO () -> IO ()) -> PerformFetch req
AsyncFetch (([BlockedFetch RedisReq] -> IO () -> IO ())
 -> PerformFetch RedisReq)
-> ([BlockedFetch RedisReq] -> IO () -> IO ())
-> PerformFetch RedisReq
forall a b. (a -> b) -> a -> b
$ \reqs :: [BlockedFetch RedisReq]
reqs inner :: IO ()
inner -> do
  QSem
sem <- Int -> IO QSem
newQSem (Int -> IO QSem) -> Int -> IO QSem
forall a b. (a -> b) -> a -> b
$ State RedisReq -> Int
numThreads State RedisReq
_state
  [Async ()]
asyncs <- (BlockedFetch RedisReq -> IO (Async ()))
-> [BlockedFetch RedisReq] -> IO [Async ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (QSem -> ByteString -> BlockedFetch RedisReq -> IO (Async ())
fetchAsync QSem
sem (State RedisReq -> ByteString
prefix State RedisReq
_state)) [BlockedFetch RedisReq]
reqs
  IO ()
inner
  (Async () -> IO ()) -> [Async ()] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async () -> IO ()
forall a. Async a -> IO a
wait [Async ()]
asyncs

fetchAsync :: QSem -> ByteString -> BlockedFetch RedisReq -> IO (Async ())
fetchAsync :: QSem -> ByteString -> BlockedFetch RedisReq -> IO (Async ())
fetchAsync sem :: QSem
sem pref :: ByteString
pref req :: BlockedFetch RedisReq
req = IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$
  IO () -> IO () -> IO () -> IO ()
forall a b c. IO a -> IO b -> IO c -> IO c
Control.Exception.bracket_ (QSem -> IO ()
waitQSem QSem
sem) (QSem -> IO ()
signalQSem QSem
sem) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> BlockedFetch RedisReq -> IO ()
fetchSync ByteString
pref BlockedFetch RedisReq
req

fetchSync :: ByteString -> BlockedFetch RedisReq -> IO ()
fetchSync :: ByteString -> BlockedFetch RedisReq -> IO ()
fetchSync pref :: ByteString
pref (BlockedFetch req :: RedisReq a
req rvar :: ResultVar a
rvar) = do
  Either SomeException a
e <- IO a -> IO (Either SomeException a)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (IO a -> IO (Either SomeException a))
-> IO a -> IO (Either SomeException a)
forall a b. (a -> b) -> a -> b
$ ByteString -> RedisReq a -> IO a
forall a. ByteString -> RedisReq a -> IO a
fetchReq ByteString
pref RedisReq a
req
  case Either SomeException a
e of
    Left ex :: SomeException
ex -> ResultVar a -> SomeException -> IO ()
forall e a. Exception e => ResultVar a -> e -> IO ()
putFailure ResultVar a
rvar (SomeException
ex :: Control.Exception.SomeException)
    Right a :: a
a -> ResultVar a -> a -> IO ()
forall a. ResultVar a -> a -> IO ()
putSuccess ResultVar a
rvar a
a

fetchReq :: ByteString -> RedisReq a -> IO a
fetchReq :: ByteString -> RedisReq a -> IO a
fetchReq pref :: ByteString
pref (GetData (Conn conn :: Connection
conn) k :: ByteString
k)   = Connection -> ByteString -> IO (Maybe ByteString)
getData_ Connection
conn (ByteString -> IO a) -> ByteString -> IO a
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> ByteString
genKey ByteString
pref ByteString
k
fetchReq pref :: ByteString
pref (SetData (Conn conn :: Connection
conn) k :: ByteString
k v :: ByteString
v) = Connection -> ByteString -> ByteString -> IO ()
setData_ Connection
conn (ByteString -> ByteString -> ByteString
genKey ByteString
pref ByteString
k) ByteString
v
fetchReq pref :: ByteString
pref (DelData (Conn conn :: Connection
conn) ks :: [ByteString]
ks)  = Connection -> [ByteString] -> IO ()
delData_ Connection
conn ([ByteString] -> IO a) -> [ByteString] -> IO a
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> ByteString -> ByteString
genKey ByteString
pref) [ByteString]
ks

initRedisState :: Int -> ByteString -> State RedisReq
initRedisState :: Int -> ByteString -> State RedisReq
initRedisState = Int -> ByteString -> State RedisReq
RedisState

getData :: FromJSON v => Connection -> ByteString -> GenHaxl u w (Maybe v)
getData :: Connection -> ByteString -> GenHaxl u w (Maybe v)
getData conn :: Connection
conn k :: ByteString
k = Maybe v -> (ByteString -> Maybe v) -> Maybe ByteString -> Maybe v
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe v
forall a. Maybe a
Nothing ByteString -> Maybe v
forall a. FromJSON a => ByteString -> Maybe a
decodeStrict (Maybe ByteString -> Maybe v)
-> GenHaxl u w (Maybe ByteString) -> GenHaxl u w (Maybe v)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RedisReq (Maybe ByteString) -> GenHaxl u w (Maybe ByteString)
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch (Conn -> ByteString -> RedisReq (Maybe ByteString)
GetData (Connection -> Conn
Conn Connection
conn) ByteString
k)

setData :: ToJSON v => Connection -> ByteString -> v -> GenHaxl u w ()
setData :: Connection -> ByteString -> v -> GenHaxl u w ()
setData conn :: Connection
conn k :: ByteString
k v :: v
v = RedisReq () -> GenHaxl u w ()
forall a u w (r :: * -> *).
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
uncachedRequest (RedisReq () -> GenHaxl u w ())
-> (ByteString -> RedisReq ()) -> ByteString -> GenHaxl u w ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> ByteString -> ByteString -> RedisReq ()
SetData (Connection -> Conn
Conn Connection
conn) ByteString
k (ByteString -> RedisReq ())
-> (ByteString -> ByteString) -> ByteString -> RedisReq ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
toStrict (ByteString -> GenHaxl u w ()) -> ByteString -> GenHaxl u w ()
forall a b. (a -> b) -> a -> b
$ v -> ByteString
forall a. ToJSON a => a -> ByteString
encode v
v

delData :: Connection -> [ByteString] -> GenHaxl u w ()
delData :: Connection -> [ByteString] -> GenHaxl u w ()
delData conn :: Connection
conn = RedisReq () -> GenHaxl u w ()
forall a u w (r :: * -> *).
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
uncachedRequest (RedisReq () -> GenHaxl u w ())
-> ([ByteString] -> RedisReq ()) -> [ByteString] -> GenHaxl u w ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Conn -> [ByteString] -> RedisReq ()
DelData (Connection -> Conn
Conn Connection
conn)

-- | Return the cached result of the action or, in the case of a cache
-- miss, execute the action and insert it in the cache.
cached :: (FromJSON v, ToJSON v) => (u -> Maybe Connection) -> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
cached :: (u -> Maybe Connection)
-> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
cached redis :: u -> Maybe Connection
redis k :: ByteString
k io :: GenHaxl u w (Maybe v)
io = do
  Maybe Connection
h <- u -> Maybe Connection
redis (u -> Maybe Connection)
-> GenHaxl u w u -> GenHaxl u w (Maybe Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env u w -> u) -> GenHaxl u w u
forall u w a. (Env u w -> a) -> GenHaxl u w a
env Env u w -> u
forall u w. Env u w -> u
userEnv
  Maybe Connection
-> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
forall v u w.
(FromJSON v, ToJSON v) =>
Maybe Connection
-> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
go Maybe Connection
h ByteString
k GenHaxl u w (Maybe v)
io

  where go :: (FromJSON v, ToJSON v) => Maybe Connection -> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
        go :: Maybe Connection
-> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)
go Nothing _ io0 :: GenHaxl u w (Maybe v)
io0 = GenHaxl u w (Maybe v)
io0
        go (Just conn :: Connection
conn) k0 :: ByteString
k0 io0 :: GenHaxl u w (Maybe v)
io0 = do
          Maybe v
res <- Connection -> ByteString -> GenHaxl u w (Maybe v)
forall v u w.
FromJSON v =>
Connection -> ByteString -> GenHaxl u w (Maybe v)
getData Connection
conn ByteString
k0
          case Maybe v
res of
            Just v :: v
v -> Maybe v -> GenHaxl u w (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return (v -> Maybe v
forall a. a -> Maybe a
Just v
v)
            Nothing -> do
              Maybe v
v <- GenHaxl u w (Maybe v)
io0
              case Maybe v
v of
                Nothing -> Maybe v -> GenHaxl u w (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
forall a. Maybe a
Nothing
                Just v0 :: v
v0 -> do
                  Connection -> ByteString -> v -> GenHaxl u w ()
forall v u w.
ToJSON v =>
Connection -> ByteString -> v -> GenHaxl u w ()
setData Connection
conn ByteString
k0 v
v0
                  Maybe v -> GenHaxl u w (Maybe v)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe v
v

cached' :: (FromJSON v, ToJSON v) => (u -> Maybe Connection) -> ByteString -> GenHaxl u w v -> GenHaxl u w v
cached' :: (u -> Maybe Connection)
-> ByteString -> GenHaxl u w v -> GenHaxl u w v
cached' redis :: u -> Maybe Connection
redis k :: ByteString
k io :: GenHaxl u w v
io = do
  Maybe Connection
h <- u -> Maybe Connection
redis (u -> Maybe Connection)
-> GenHaxl u w u -> GenHaxl u w (Maybe Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env u w -> u) -> GenHaxl u w u
forall u w a. (Env u w -> a) -> GenHaxl u w a
env Env u w -> u
forall u w. Env u w -> u
userEnv
  Maybe Connection -> ByteString -> GenHaxl u w v -> GenHaxl u w v
forall v u w.
(FromJSON v, ToJSON v) =>
Maybe Connection -> ByteString -> GenHaxl u w v -> GenHaxl u w v
go Maybe Connection
h ByteString
k GenHaxl u w v
io
  where go :: (FromJSON v, ToJSON v) => Maybe Connection -> ByteString -> GenHaxl u w v -> GenHaxl u w v
        go :: Maybe Connection -> ByteString -> GenHaxl u w v -> GenHaxl u w v
go Nothing _ io0 :: GenHaxl u w v
io0 = GenHaxl u w v
io0
        go (Just conn :: Connection
conn) k0 :: ByteString
k0 io0 :: GenHaxl u w v
io0 = do
          Maybe v
res <- Connection -> ByteString -> GenHaxl u w (Maybe v)
forall v u w.
FromJSON v =>
Connection -> ByteString -> GenHaxl u w (Maybe v)
getData Connection
conn ByteString
k0
          case Maybe v
res of
            Just v :: v
v -> v -> GenHaxl u w v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v
            Nothing -> do
              v
v <- GenHaxl u w v
io0
              Connection -> ByteString -> v -> GenHaxl u w ()
forall v u w.
ToJSON v =>
Connection -> ByteString -> v -> GenHaxl u w ()
setData Connection
conn ByteString
k0 v
v
              v -> GenHaxl u w v
forall (m :: * -> *) a. Monad m => a -> m a
return v
v

remove :: (u -> Maybe Connection) -> ByteString -> GenHaxl u w ()
remove :: (u -> Maybe Connection) -> ByteString -> GenHaxl u w ()
remove redis :: u -> Maybe Connection
redis k :: ByteString
k = (u -> Maybe Connection) -> [ByteString] -> GenHaxl u w ()
forall u w.
(u -> Maybe Connection) -> [ByteString] -> GenHaxl u w ()
removeAll u -> Maybe Connection
redis [ByteString
k]

removeAll :: (u -> Maybe Connection) -> [ByteString] -> GenHaxl u w ()
removeAll :: (u -> Maybe Connection) -> [ByteString] -> GenHaxl u w ()
removeAll redis :: u -> Maybe Connection
redis k :: [ByteString]
k = do
  Maybe Connection
h <- u -> Maybe Connection
redis (u -> Maybe Connection)
-> GenHaxl u w u -> GenHaxl u w (Maybe Connection)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Env u w -> u) -> GenHaxl u w u
forall u w a. (Env u w -> a) -> GenHaxl u w a
env Env u w -> u
forall u w. Env u w -> u
userEnv
  case Maybe Connection
h of
    Nothing   -> () -> GenHaxl u w ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just conn :: Connection
conn -> Connection -> [ByteString] -> GenHaxl u w ()
forall u w. Connection -> [ByteString] -> GenHaxl u w ()
delData Connection
conn [ByteString]
k