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 Author name here 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/Cache.hs b/src/Network/Wai/Middleware/Cache.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Cache.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.Cache + ( cache + , cacheNoBody + , CacheBackend(..) + , responseToLBS + ) where + +import Blaze.ByteString.Builder (Builder, toLazyByteString) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LZ +import Data.IORef +import Network.Wai (Middleware, Request, Response, + requestBody, responseToStream, + mapResponseHeaders) + +-------------------------------------------------------------------------------- +-- | The data structure that should contains everything you need to create +-- a cache backend +data CacheBackend cacheContainer cacheKey cacheVal = + CacheBackend { + keyFromReq :: Request -> ByteString -> IO cacheKey -- ^ Get cacheKey from request and its body + , toCache :: Request -> ByteString -> IO Bool -- ^ Function to check whether cache or not + , addToCache :: cacheContainer -> cacheKey -> cacheVal -> IO () -- ^ Adding to cache + , actionOnCache :: Request -> Response -> IO () -- ^ Action to perform before each caching request + , actionOnCacheMiss :: Request -> Response -> IO () -- ^ Action to perfom before each cache miss + , responseToCacheVal :: Response -> IO cacheVal -- ^ Transform response to cached value + , cacheValToResponse :: cacheVal -> Response -- ^ Transform cached value to response + , lookupCache :: cacheContainer -> cacheKey -> IO (Maybe cacheVal) -- ^ cache lookup + , cacheContainer :: cacheContainer -- ^ A cache container + } + +-------------------------------------------------------------------------------- +-- Cache Backend Agnostic Cache Middleware +-- This version duplicate the body of the request making it quite far less efficient +-- than the cacheNoBody function +cache :: CacheBackend cc ck cv -- ^ A cache backend + -> Middleware +cache cb app req sendResponse = do + (req',body) <- getRequestBody req + caching <- toCache cb req' body + if not caching + then app req' sendResponse + else do + (req'',_) <- getRequestBody req' + cacheKey <- keyFromReq cb req'' body + found <- lookupCache cb (cacheContainer cb) cacheKey + maybe (app req'' (addToCacheAndRespond cb sendResponse req cacheKey)) + (respondFromCache cb sendResponse req'') + found + +-------------------------------------------------------------------------------- +-- Cache Backend Agnostic Cache Middleware +-- This version don't provide the request body for create key or deciding +-- whether to cache. But it should be more efficient +cacheNoBody :: CacheBackend cc ck cv -- ^ A cache backend + -> Middleware +cacheNoBody cb app req sendResponse = do + caching <- toCache cb req S8.empty + if not caching + then app req sendResponse + else do + cacheKey <- keyFromReq cb req S8.empty + found <- lookupCache cb (cacheContainer cb) cacheKey + maybe (app req (addToCacheAndRespond cb sendResponse req cacheKey)) + (respondFromCache cb sendResponse req) + found + +addXCacheHeader :: Response -> Response +addXCacheHeader = mapResponseHeaders (("X-Cached","true"):) + +respondFromCache :: CacheBackend cc ck cv + -> (Response -> IO b) + -> Request + -> cv + -> IO b +respondFromCache cb sendResponse r cachedVal = do + let response = cacheValToResponse cb cachedVal + actionOnCache cb r response + sendResponse (addXCacheHeader response) + +addToCacheAndRespond :: CacheBackend cc ck cv + -> (Response -> IO b) + -> Request + -> ck + -> Response + -> IO b +addToCacheAndRespond cb sendResponse req key r = do + cacheVal <- responseToCacheVal cb r + addToCache cb (cacheContainer cb) key cacheVal + actionOnCacheMiss cb req r + sendResponse (cacheValToResponse cb cacheVal) + +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 + -- + -- 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', S8.concat body) + +-- | Helper for your cache backend +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) 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.cabal b/wai-middleware-caching.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-caching.cabal @@ -0,0 +1,36 @@ +name: wai-middleware-caching +version: 0.1.0.0 +synopsis: WAI Middleware to cache things +description: Please see README.md +homepage: http://github.com/yogsototh/wai-middleware-caching/tree/master/wai-middleware-caching#readme +license: BSD3 +license-file: LICENSE +author: Yann Esposito +maintainer: yann.esposito@gmail.com +copyright: 2015 Yann Esposito +category: Web +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.Wai.Middleware.Cache + build-depends: base >= 4.7 && < 5 + , blaze-builder + , bytestring + , wai + default-language: Haskell2010 + +test-suite wai-middleware-caching-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , wai-middleware-caching + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/yogsototh/wai-middleware-caching