module Network.Wai.Middleware.Cache.Redis (
redisBackend,
) where
import Control.Monad.IO.Class (liftIO)
import qualified Control.Arrow as A (first)
import Data.Maybe (fromMaybe)
import Data.ByteString (ByteString)
import Data.ByteString.Lazy (fromChunks)
import Data.CaseInsensitive (original, mk, CI(..))
import Data.Conduit (ResourceT, runResourceT, ($$), ($=), Flush(..))
import qualified Data.Conduit.List as CL
import Data.Conduit.Blaze (builderToByteStringFlush)
import Network.Wai (Request(..), Response(..), responseSource, responseLBS)
import Network.Wai.Middleware.Cache (CacheBackend)
import Network.HTTP.Types (Status(..))
import qualified Database.Redis as R
import Database.Redis.Pile (pile)
redisBackend ::
R.ConnectInfo
-> Integer
-> ByteString
-> Integer
-> [ByteString]
-> (Request -> ByteString)
-> (Request -> Maybe ByteString)
-> CacheBackend
redisBackend cInfo db cachePrefix ttl tags keyFn eTagFn app req = do
cachedResponse <- liftIO $ do
conn <- R.connect cInfo
R.runRedis conn $ do
_ <- R.select db
pile cachePrefix key eTag $ liftIO . runResourceT $ do
res <- app req
(h, d) <- buildCachedResponse res
return (d, h, tags, ttl)
parseCachedResponse cachedResponse
where
(key, eTag) = (keyFn req, eTagFn req)
type CachedResponse = (Int, ByteString,
[(ByteString, ByteString)], [ByteString])
buildCachedResponse :: Response -> ResourceT IO (ByteString, CachedResponse)
buildCachedResponse res = do
bodyChunks <- bsrc $= builderToByteStringFlush
$= CL.map fromChunk $$ CL.consume
let bodyHash = fromMaybe "" $ lookup "etag" hs
let stripHeaders = map (A.first original) hs
return (bodyHash, (sc, sm, stripHeaders, bodyChunks))
where
(Status sc sm, hs, bsrc) = responseSource res
fromChunk (Chunk a) = a
fromChunk Flush = ""
parseCachedResponse :: Maybe CachedResponse -> ResourceT IO (Maybe Response)
parseCachedResponse Nothing = return Nothing
parseCachedResponse (Just (sc, sm, hs, bodyChunks)) = do
let wrappedHeaders = map (A.first mk) hs
return $ Just $ responseLBS (Status sc sm)
wrappedHeaders $ fromChunks bodyChunks