wai-middleware-cache-redis (empty) → 0.1.0

raw patch · 4 files changed

+191/−0 lines, 4 filesdep +basedep +blaze-builder-conduitdep +bytestringsetup-changed

Dependencies added: base, blaze-builder-conduit, bytestring, case-insensitive, cereal, conduit, cryptohash, hedis, hedis-pile, hex, http-types, transformers, wai, wai-middleware-cache

Files

LICENSE +25/−0
Setup.hs +2/−0
src/Network/Wai/Middleware/Cache/Redis.hs +125/−0
wai-middleware-cache-redis.cabal +39/−0

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple
+main = defaultMain

+ src/Network/Wai/Middleware/Cache/Redis.hs view

@@ -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 = ""
+    
+

+ wai-middleware-cache-redis.cabal view

@@ -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 <aka.spin@gmail.com>
+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 <aka.spin@gmail.com>
+
+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
+