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/LRUCache.hs b/src/Network/Wai/Middleware/LRUCache.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/LRUCache.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.LRUCache + ( 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 Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LZ +import Data.Cache.LRU (LRU, newLRU) +import qualified Data.Cache.LRU as LRU +import Data.IORef +import Data.Text (Text) +import Network.HTTP.Types.Header (ResponseHeaders) +import Network.HTTP.Types.Status (Status) +import Network.Wai (Middleware, Request, Response, + requestBody, pathInfo, requestMethod, + rawQueryString, responseLBS, + responseHeaders, responseStatus, + responseToStream) +import qualified Data.ByteString.Char8 as S8 + +-------------------------------------------------------------------------------- +data CacheKey = CacheKey { _pathInfo :: [Text] + , _reqBody :: ByteString + , _rawQueryString :: ByteString + } deriving (Show, Eq, Ord) + +data CacheValue = CacheValue { _body :: LZ.ByteString + , _headers :: ResponseHeaders + , _status :: Status + } deriving (Show) + +type CacheContainer = IORef (LRU CacheKey CacheValue) + +type LRUCacheBackend = CacheBackend CacheContainer CacheKey CacheValue + +newCacheContainer :: Maybe Integer -> IO CacheContainer +newCacheContainer size = newIORef (newLRU size) + +-- | Cache Backend which cache all GET requests with at most 10k different queries +-- You should use `cacheNoBody` instead of `cache` +defaultCacheBackend :: IO LRUCacheBackend +defaultCacheBackend = newCacheBackend (Just 10000) + (\r _ -> return (requestMethod r == "GET")) + (\_ _ -> return ()) + (\_ _ -> return ()) + +newCacheBackend :: Maybe Integer + -> (Request -> ByteString -> IO Bool) + -> (Request -> Response -> IO ()) + -> (Request -> Response -> IO ()) + -> IO LRUCacheBackend +newCacheBackend size toCacheF actionOnCacheF actionOnCacheMissF = do + cacheContainer <- newCacheContainer size + return CacheBackend { + keyFromReq = keyFromReqF + , toCache = toCacheF + , addToCache = addToCacheF + , actionOnCache = actionOnCacheF + , actionOnCacheMiss = actionOnCacheMissF + , responseToCacheVal = respToCacheValue + , cacheValToResponse = cacheValToResponseF + , lookupCache = lookupCacheF + , cacheContainer = cacheContainer + } + +keyFromReqF req body = return (CacheKey (pathInfo req) body (rawQueryString req)) + +cacheValToResponseF cv = responseLBS (_status cv) (_headers cv) (_body cv) + +lookupCacheF cacheContainer cacheKey = do + cc <- readIORef cacheContainer + return (snd (LRU.lookup cacheKey cc)) + +respToCacheValue :: Response -> IO CacheValue +respToCacheValue resp = do + bodyLBS <- responseToLBS resp + return (CacheValue bodyLBS (responseHeaders resp) (responseStatus resp)) + +addToCacheF :: CacheContainer -> CacheKey -> CacheValue -> IO () +addToCacheF cc ckey resp = atomicModifyIORef' cc (\c -> (LRU.insert ckey resp c,())) + +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) + +cache :: LRUCacheBackend -> Middleware +cache = Cache.cache + +cacheNoBody :: LRUCacheBackend -> 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-lru.cabal b/wai-middleware-caching-lru.cabal new file mode 100644 --- /dev/null +++ b/wai-middleware-caching-lru.cabal @@ -0,0 +1,40 @@ +name: wai-middleware-caching-lru +version: 0.1.0.0 +synopsis: Initial project template from stack +description: Please see README.md +homepage: http://github.com/yogsototh/wai-middleware-caching/tree/master/wai-middleware-caching-lru#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.LRUCache + build-depends: base >= 4.7 && < 5 + , blaze-builder + , bytestring + , http-types + , lrucache + , text + , wai-middleware-caching + , wai + default-language: Haskell2010 + +test-suite wai-middleware-caching-lru-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , wai-middleware-caching-lru + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/yogsototh/wai-middleware-caching