wai-middleware-cache-redis 0.2.1 → 0.3.0

raw patch · 2 files changed

+69/−105 lines, 2 filesdep +binarydep −cerealdep −cryptohashdep −hexdep ~blaze-builder-conduitdep ~conduitdep ~hedis-pilePVP ok

version bump matches the API change (PVP)

Dependencies added: binary

Dependencies removed: cereal, cryptohash, hex, lifted-base

Dependency ranges changed: blaze-builder-conduit, conduit, hedis-pile, transformers, wai, wai-middleware-cache

API changes (from Hackage documentation)

Files

• src/Network/Wai/Middleware/Cache/Redis.hs +54/−87
• wai-middleware-cache-redis.cabal +15/−18

@@ -1,15 +1,19 @@-{-# LANGUAGE OverloadedStrings, DoAndIfThenElse #-} 
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-} 
 
 -- | Redis backend for "Network.Wai.Middleware.Cache".
 --
---   This backend uses "Database.Redis.Pile" for low-lewel operations.
+--   This backend uses "Database.Redis.Pile" for low-lewel operations. Main 
+--   drawback of this backend is the fact that whole response 
+--   will be consumed in memory.
 --
 -- > cache
 -- >     (redisBackend 
 -- >         -- use defaults, DB 0 and "myprefix" 
--- >         R.defaultConnectInfo 0 "myprefix"
--- >         (const Nothing)    -- no expiration
--- >         (const ["mytag"])  -- simply one tag "mytag"
+-- >         R.defaultConnectInfo 0 
+-- >         "myprefix"         -- prefix for caching
+-- >         Nothing            -- no expiration
+-- >         ["mytag"]          -- one cache tag
 -- >         (rawPathInfo)      -- URL path as key 
 -- >         lookupETag         -- And find "If-None-Match"
 -- >     ) app -- our app
@@ -17,127 +21,90 @@ 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 qualified Data.ByteString as B
-import qualified Data.ByteString.Char8 as BS8
+import Data.Maybe (fromMaybe)
+
+import Data.ByteString (ByteString)
 import Data.ByteString.Lazy (fromChunks)
-import Data.CaseInsensitive (original, mk)
-import qualified Data.Serialize as S
+import Data.CaseInsensitive (original, mk, CI(..))
 
-import Data.Conduit (ResourceT, runResourceT, resourceThrow, ($$), ($=), 
-                     Flush(..))
+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, CacheBackendError(..))
+import Network.Wai.Middleware.Cache (CacheBackend)
 import Network.HTTP.Types (Status(..))
 
 import qualified Database.Redis as R
 import Database.Redis.Pile (pile)
-import Control.Monad.Trans.Class (lift)
 
 -- | Redis backend for "Network.Wai.Middleware.Cache". 
---
---   This backend can't cache files. Use routing or catch 'CacheBackendError'
 redisBackend ::
        R.ConnectInfo
             -- ^ Redis connection info.
     -> Integer  
-            -- ^ Redis DB.
-    -> B.ByteString
+            -- ^ Redis DB Index.
+    -> 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)
+    -> Maybe Integer
+            -- ^ Cache TTL. Use 'Nothing' for no expiration.
+    -> [ByteString]
+            -- ^ Cache Tags. See "Database.Redis.Pile" for details.
+    -> (Request -> ByteString)
+            -- ^ Cache key extraction function.
+    -> (Request -> Maybe ByteString)
             -- ^ @ETag@ value extraction. To extract @If-None-Match@ header
             --   use 'lookupETag'. Use @(const Nothing)@ for block 
             --   @304@-responses.
-    -> (Request -> Bool)
-            -- ^ @ETag@ creation flag. If it 'True', backend adds @ETag@ to 
-            --   'Response' headers with hexed @SHA1@ as value
     -> CacheBackend
-redisBackend cInfo db cachePrefix 
-             ttlFn tagsFn keyFn 
-             eTagFn needEtagFn
-             app req = do
-    rawRes <- liftIO $  do
+redisBackend cInfo db cachePrefix ttl tags keyFn eTagFn app req = do
+    rawRes <- liftIO $ do
         conn <- R.connect cInfo
         R.runRedis conn $ do
             void $ R.select db
-            pile cachePrefix key eTag (Just "response") $ 
-                        liftIO $ runResourceT $ do
+            pile cachePrefix key eTag $ liftIO . runResourceT $ do
                 res <- app req
-                case res of
-                    (ResponseFile _ _ fp part) -> lift $ 
-                        resourceThrow $ CacheBackendError $ BS8.pack $
-                            "Can't cache files : " ++ fp ++ ":" ++ show part  
-                    _ -> do 
-                        d <- parseResponse needEtag res
-                        return (d, ttl, tags)
-    case buildResponse rawRes of
-        Left e -> lift $ resourceThrow $ CacheBackendError e
-        Right r -> return r
+                (h, d) <- buildCachedResponse res
+                return (d, h, tags, ttl)
+    parseCachedResponse rawRes
   where
-    (ttl, tags, key, needEtag) = (ttlFn req, tagsFn req, 
-                                  keyFn req, needEtagFn 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
+    (key, eTag) = (keyFn req, eTagFn req)
 
 ----------------------------------------------------------------------------
 -- Internal
 ----------------------------------------------------------------------------
 
-buildResponse :: Maybe [(B.ByteString, B.ByteString)] 
-    -> Either B.ByteString (Maybe Response)
-buildResponse Nothing = Right Nothing
-buildResponse (Just raw) = decodeResp raw
-  where
-    decodeResp (("response", rawResp):[]) = case S.decode rawResp of
-        Left sm' -> Left $ BS8.pack sm'
-        Right (sc', sm', hs', bodyChunks) -> Right $ Just $
-            responseLBS (Status sc' sm') 
-                        (map (A.first mk) hs') 
-                        $ fromChunks bodyChunks
-    decodeResp _ = Left "Data error"
-        
-parseResponse :: Bool -> Response 
-    -> ResourceT IO [(B.ByteString, B.ByteString)]
-parseResponse needEtag res = do
-    bodyChunks <- b $= builderToByteStringFlush 
-                    $= CL.map fromChunk $$ CL.consume
-    let bodyHash = if needEtag 
-        then hex . SHA.finalize . foldl SHA.update SHA.init $ bodyChunks
-        else ""
-    return [("response", 
-                S.encode (sc, sm, map 
-                          (A.first original) (("ETag", bodyHash):hs), 
-                          bodyChunks)),
-            ("header:ETag", bodyHash)]  
+-- | Cached response
+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, b) = responseSource res
+    (Status sc sm, hs, bsrc) = responseSource res
     fromChunk (Chunk a) = a
     fromChunk Flush = ""
-    
+
+-- | Parse cached response
+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
+
+
+
     

@@ -1,5 +1,5 @@ name:           wai-middleware-cache-redis
-version:        0.2.1
+version:        0.3.0
 cabal-version:  >= 1.8
 build-type:     Simple
 stability:      Experimental
@@ -14,27 +14,24 @@ maintainer:     Alexander Dorofeev <aka.spin@gmail.com>
 
 source-repository head
-  type:         git
-  location:     git://github.com/akaspin/wai-middleware-cache-redis.git
+  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,
+  hs-source-dirs:   src
+  build-depends:    base >= 4 && < 5,
+                   binary,
+                   blaze-builder-conduit >= 0.4,
                    bytestring >= 0.9 && < 0.10,
                    case-insensitive >= 0.2,
-                   cereal >= 0.3.1.0,
-                   conduit >= 0.2 && < 0.3,
-                   cryptohash,
+                   conduit >= 0.4 && < 0.5,
                    hedis >= 0.4 && < 0.5,
-                   hedis-pile >= 0.4,
-                   hex,
+                   hedis-pile >= 0.5.1,
                    http-types >= 0.6 && < 0.7,
-                   transformers >= 0.2 && < 0.3,
-                   wai >= 1.1,
-                   wai-middleware-cache >= 0.2,
-                   lifted-base
-  ghc-options:     -Wall
-  exposed-modules: Network.Wai.Middleware.Cache.Redis
+                   transformers >= 0.2 && < 0.4,
+                   wai >= 1.2,
+                   wai-middleware-cache >= 0.3
+  ghc-options:      -Wall
+  exposed-modules:  Network.Wai.Middleware.Cache.Redis
+