diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Yann Esposito (c) 2015 + +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. + + * Neither the name of Yann Esposito nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"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 +OWNER OR CONTRIBUTORS 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/RedisCache.hs b/src/Network/Wai/Middleware/RedisCache.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/RedisCache.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} +module Network.Wai.Middleware.RedisCache + ( cache + , cacheNoBody + , newCacheBackend + , defaultCacheBackend + ) where + +import Network.Wai.Middleware.Cache (CacheBackend(..)) +import qualified Network.Wai.Middleware.Cache as Cache + +import Blaze.ByteString.Builder (Builder, toLazyByteString) +import Control.Monad (void) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LZ +import Data.IORef +import Data.Text (Text) +import Database.Redis (ConnectInfo, Connection, connect, + get, runRedis, set, defaultConnectInfo) +import Network.HTTP.Types.Header (ResponseHeaders) +import Network.HTTP.Types.Status (Status (..)) +import Network.Wai (Middleware, Request, Response, + pathInfo, requestMethod, rawQueryString, + requestBody, responseHeaders, + responseLBS, responseStatus, + responseToStream) + +-------------------------------------------------------------------------------- +data CacheKey = CacheKey { _pathInfo :: [Text] + , _reqBody :: ByteString + , _rawQueryString :: ByteString + } deriving (Show, Eq, Ord) + +deriving instance Read Status + +data CacheValue = CacheValue { _body :: LZ.ByteString + , _headers :: ResponseHeaders + , _status :: Status + } deriving (Show,Read) + + +type CacheContainer = Connection +type RedisCacheBackend = CacheBackend CacheContainer CacheKey CacheValue + +newCacheContainer :: Maybe ConnectInfo -> IO CacheContainer +newCacheContainer m_info = case m_info of + Nothing -> connect defaultConnectInfo + Just info -> connect info + + +newCacheBackend :: Maybe ConnectInfo + -> (Request -> ByteString -> IO Bool) + -> (Request -> Response -> IO ()) + -> (Request -> Response -> IO ()) + -> IO RedisCacheBackend +newCacheBackend connectInfo toCacheF actionOnCacheF actionOnCacheMissF = do + cacheContainer <- newCacheContainer connectInfo + return CacheBackend { + keyFromReq = keyFromReqF + , toCache = toCacheF + , addToCache = addToCacheF + , actionOnCache = actionOnCacheF + , actionOnCacheMiss = actionOnCacheMissF + , responseToCacheVal = respToCacheValue + , cacheValToResponse = cacheValToResponseF + , lookupCache = lookupCacheF + , cacheContainer = cacheContainer + } + +-- | Cache Backend which cache all GET requests using local redis on standard port +-- You should use `cacheNoBody` instead of `cache` +defaultCacheBackend :: IO RedisCacheBackend +defaultCacheBackend = newCacheBackend Nothing + (\r _ -> return (requestMethod r == "GET")) + (\_ _ -> return ()) + (\_ _ -> return ()) + +respToCacheValue :: Response -> IO CacheValue +respToCacheValue resp = do + bodyLBS <- responseToLBS resp + return (CacheValue bodyLBS (responseHeaders resp) (responseStatus resp)) + + +keyFromReqF :: Request -> ByteString -> IO CacheKey +keyFromReqF req body = return (CacheKey (pathInfo req) body (rawQueryString req)) + +cacheValToResponseF :: CacheValue -> Response +cacheValToResponseF cv = responseLBS (_status cv) (_headers cv) (_body cv) + +addToCacheF :: CacheContainer -> CacheKey -> CacheValue -> IO () +addToCacheF cc ckey resp = void $ runRedis cc $ + set (S8.pack (show ckey)) (S8.pack (show resp)) + +getRequestBody :: Request -> IO (Request, [S8.ByteString]) +getRequestBody req = do + let loop front = do + bs <- requestBody req + if S8.null bs + then return $ front [] + else loop $ front . (bs:) + body <- loop id + -- logging the body here consumes it, so fill it back up + -- obviously not efficient, but this is the development logger + -- + -- Note: previously, we simply used CL.sourceList. However, + -- that meant that you could read the request body in twice. + -- While that in itself is not a problem, the issue is that, + -- in production, you wouldn't be able to do this, and + -- therefore some bugs wouldn't show up during testing. This + -- implementation ensures that each chunk is only returned + -- once. + ichunks <- newIORef body + let rbody = atomicModifyIORef ichunks $ \chunks -> + case chunks of + [] -> ([], S8.empty) + x:y -> (y, x) + let req' = req { requestBody = rbody } + return (req', body) + +responseToLBS :: Response -> IO LZ.ByteString +responseToLBS response = do + let (_,_,f) = responseToStream response + f $ \streamingBody -> do + builderRef <- newIORef mempty + let add :: Builder -> IO () + add b = atomicModifyIORef builderRef $ \builder -> (builder `mappend` b,()) + flush :: IO () + flush = return () + streamingBody add flush + fmap toLazyByteString (readIORef builderRef) + +readMaybe :: (Read a) => ByteString -> Maybe a +readMaybe bs = + case reads (S8.unpack bs) of + [(x,"")] -> Just x + _ -> Nothing + +lookupCacheF :: CacheContainer -> CacheKey -> IO (Maybe CacheValue) +lookupCacheF cc cacheKey = do + res <- runRedis cc $ get bsCacheKey + return $ either (const Nothing) bsToMCacheVal res + where + bsToMCacheVal (Just bs) = readMaybe bs + bsToMCacheVal Nothing = Nothing + bsCacheKey = (S8.pack . show) cacheKey + +cache :: RedisCacheBackend -> Middleware +cache = Cache.cache + +cacheNoBody :: RedisCacheBackend -> Middleware +cacheNoBody = Cache.cacheNoBody diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented" diff --git a/wai-middleware-caching-redis.cabal b/wai-middleware-caching-redis.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-caching-redis.cabal @@ -0,0 +1,40 @@ +name: wai-middleware-caching-redis +version: 0.1.0.0 +synopsis: Cache Wai Middleware using Redis backend +description: Please see README.md +homepage: http://github.com/yogsototh/wai-middleware-caching/tree/master/wai-middleware-caching-redis#readme +license: BSD3 +license-file: LICENSE +author: Yann Esposito +maintainer: yann.esposito@gmail.com +copyright: Yann Esposito © 2015 +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.Wai.Middleware.RedisCache + build-depends: base >= 4.7 && < 5 + , wai-middleware-caching + , hedis >= 0.6 + , blaze-builder + , bytestring + , text + , http-types + , wai >= 3.0 + default-language: Haskell2010 + +test-suite wai-middleware-caching-redis-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , wai-middleware-caching-redis + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/yogsototh/wai-middleware-caching