diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Network/Wai/Middleware/Cache/Redis.hs b/src/Network/Wai/Middleware/Cache/Redis.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Cache/Redis.hs @@ -0,0 +1,125 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Redis backend for "Network.Wai.Middleware.Cache". +-- +-- This backend uses "Database.Redis.Pile" for low-lewel operations. +-- +-- > cache +-- > (redisBackend +-- > -- use defaults, DB 0 and "myprefix" +-- > R.defaultConnectInfo 0 "myprefix" +-- > (const Nothing) -- no expiration +-- > (const ["mytag"]) -- simply one tag "mytag" +-- > (rawPathInfo) -- URL path as key +-- > lookupETag -- And find "If-None-Match" +-- > ) app -- our app + +module Network.Wai.Middleware.Cache.Redis ( + -- * Cache backend + redisBackend, + -- * Helpers + lookupETag +) where + +import Control.Monad (void) +import Control.Monad.IO.Class (liftIO) +import qualified Control.Arrow as A (first) + +import Data.Maybe (fromJust) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BS8 +import Data.ByteString.Lazy (fromChunks) +import Data.CaseInsensitive (original, mk) +import qualified Data.Serialize as S + +import Data.Conduit (ResourceT, runResourceT, ($$), ($=), Flush(..)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Blaze (builderToByteStringFlush) + +import qualified Crypto.Hash.SHA1 as SHA +import Data.Hex (hex) + +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) + +-- | Redis backend for "Network.Wai.Middleware.Cache". +-- +-- Except caching, this backend always adds @ETag@ to 'Response' headers +-- with hexed @SHA1@ as value. +redisBackend :: + R.ConnectInfo + -- ^ Redis connection info. + -> Integer + -- ^ Redis DB. + -> B.ByteString + -- ^ Cache prefix for key and tags. + -- See "Database.Redis.Pile" for details. + -> (Request -> Maybe Integer) + -- ^ TTL extraction. Use 'Nothing' for no expiration. + -> (Request -> [B.ByteString]) + -- ^ Tags extraction. + -- See "Database.Redis.Pile" for details. + -> (Request -> B.ByteString) + -- ^ Key extraction. + -> (Request -> Maybe B.ByteString) + -- ^ @ETag@ value extraction. To extract @If-None-Match@ header + -- use 'lookupETag'. Use @(const Nothing)@ for block + -- @304@-responses. + -> CacheBackend +redisBackend cInfo db cachePrefix ttlFn tagsFn keyFn eTagFn app req = do + rawRes <- liftIO $ do + conn <- R.connect cInfo + R.runRedis conn $ do + void $ R.select db + pile cachePrefix key eTag $ runResourceT $ do + res <- app req + case res of + ResponseFile{} -> undefined + _ -> do + d <- parseResponse res + return (d, ttl, tags) + return $ buildResponse rawRes + where + (ttl, tags, key) = (ttlFn req, tagsFn req, keyFn req) + eTag = case eTagFn req of + Nothing -> Nothing + Just v -> Just ("header:ETag", v) + +-- | Helper for extract @If-None-Match@ header from 'Request'. +lookupETag :: Request -> Maybe B.ByteString +lookupETag = lookup "If-None-Match" . requestHeaders + +---------------------------------------------------------------------------- +-- Internal +---------------------------------------------------------------------------- + +buildResponse :: Maybe [(B.ByteString, B.ByteString)] -> Maybe Response +buildResponse Nothing = Nothing +buildResponse (Just raw) = + Just $ responseLBS (Status sc sm) hs body + where + rawResp = fromJust . lookup "response" $ raw + (sc, sm, hs, body) = case S.decode rawResp of + Left sm' -> (500, BS8.pack sm', [], "") + Right (sc', sm', hs', bodyChunks) -> + (sc', sm', map (A.first mk) hs', fromChunks bodyChunks) + + +parseResponse :: Response -> ResourceT IO [(B.ByteString, B.ByteString)] +parseResponse res = do + bodyChunks <- b $= builderToByteStringFlush + $= CL.map fromChunk $$ CL.consume + let bodyHash = hex . SHA.finalize . foldl SHA.update SHA.init $ bodyChunks + return [("response", + S.encode (sc, sm, map (A.first original) hs, bodyChunks)), + ("header:ETag", bodyHash)] + where + (Status sc sm, hs, b) = responseSource res + fromChunk (Chunk a) = a + fromChunk Flush = "" + + diff --git a/wai-middleware-cache-redis.cabal b/wai-middleware-cache-redis.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-cache-redis.cabal @@ -0,0 +1,39 @@ +name: wai-middleware-cache-redis +version: 0.1.0 +cabal-version: >= 1.8 +build-type: Simple +stability: Experimental +author: Alexander Dorofeev +synopsis: Redis backend for wai-middleware-cache +description: This package provides Redis backend for wai-middleware-cache +homepage: https://github.com/akaspin/wai-middleware-cache-redis +bug-reports: https://github.com/akaspin/wai-middleware-cache-redis/issues +category: Database, Web +license: BSD3 +license-file: LICENSE +maintainer: Alexander Dorofeev + +source-repository head + type: git + location: git://github.com/akaspin/wai-middleware-cache-redis.git + +library + hs-source-dirs: src + build-depends: + base >= 4 && < 5, + blaze-builder-conduit >= 0.2, + bytestring >= 0.9 && < 0.10, + case-insensitive >= 0.2, + cereal >= 0.3.1.0, + conduit >= 0.2 && < 0.3, + cryptohash, + hedis >= 0.3 && < 0.4, + hedis-pile >= 0.2.1, + hex, + http-types >= 0.6 && < 0.7, + transformers >= 0.2 && < 0.3, + wai >= 1.1, + wai-middleware-cache >= 0.1 + ghc-options: -Wall + exposed-modules: Network.Wai.Middleware.Cache.Redis +