Browse Source

initial commit

master
Yann Esposito 6 years ago
commit
96155a3cb4
  1. 10
      .gitignore
  2. 9
      README.md
  3. 10
      wai-middleware-caching-lru/.gitignore
  4. 30
      wai-middleware-caching-lru/LICENSE
  5. 3
      wai-middleware-caching-lru/README.md
  6. 2
      wai-middleware-caching-lru/Setup.hs
  7. 105
      wai-middleware-caching-lru/src/Network/Wai/Middleware/LRUCache.hs
  8. 33
      wai-middleware-caching-lru/stack.yaml
  9. 2
      wai-middleware-caching-lru/test/Spec.hs
  10. 40
      wai-middleware-caching-lru/wai-middleware-caching-lru.cabal
  11. 10
      wai-middleware-caching-redis/.gitignore
  12. 30
      wai-middleware-caching-redis/LICENSE
  13. 3
      wai-middleware-caching-redis/README.md
  14. 2
      wai-middleware-caching-redis/Setup.hs
  15. 153
      wai-middleware-caching-redis/src/Network/Wai/Middleware/RedisCache.hs
  16. 33
      wai-middleware-caching-redis/stack.yaml
  17. 2
      wai-middleware-caching-redis/test/Spec.hs
  18. 40
      wai-middleware-caching-redis/wai-middleware-caching-redis.cabal
  19. 10
      wai-middleware-caching/.gitignore
  20. 30
      wai-middleware-caching/LICENSE
  21. 24
      wai-middleware-caching/README.md
  22. 2
      wai-middleware-caching/Setup.hs
  23. 128
      wai-middleware-caching/src/Network/Wai/Middleware/Cache.hs
  24. 32
      wai-middleware-caching/stack.yaml
  25. 2
      wai-middleware-caching/test/Spec.hs
  26. 36
      wai-middleware-caching/wai-middleware-caching.cabal

10
.gitignore

@ -0,0 +1,10 @@
.cabal-sandbox
cabal.sandbox.config
dist
*.log
*.swp
*~
.ghci
.stack-work
container/.DS_Store
TAGS

9
README.md

@ -0,0 +1,9 @@
# Caching Wai Middlewares
This repository provide WAI middlewares caching ability.
To minimize code dependency, there are three different packages.
- `wai-middleware-caching`: cache backend agnostic cache. You'll need to provide a `CacheBackend` value to make it works.
- `wai-middleware-caching-lru`: Use `lrucache` as backend (RAM only)
- `wai-middleware-caching-redis`: Use Redis as backend to cache requests.

10
wai-middleware-caching-lru/.gitignore

@ -0,0 +1,10 @@
.cabal-sandbox
cabal.sandbox.config
dist
*.log
*.swp
*~
.ghci
.stack-work
container/.DS_Store
TAGS

30
wai-middleware-caching-lru/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.

3
wai-middleware-caching-lru/README.md

@ -0,0 +1,3 @@
# Caching WAI Middleware using LRU
Cache WAI Middleware in RAM using LRU cache.

2
wai-middleware-caching-lru/Setup.hs

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

105
wai-middleware-caching-lru/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 (("X-Cached","true"):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

33
wai-middleware-caching-lru/stack.yaml

@ -0,0 +1,33 @@
# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-3.16
# Local packages, usually specified by relative directory name
packages:
- '.'
- '../wai-middleware-caching'
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 0.1.4.0
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]

2
wai-middleware-caching-lru/test/Spec.hs

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"

40
wai-middleware-caching-lru/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

10
wai-middleware-caching-redis/.gitignore

@ -0,0 +1,10 @@
.cabal-sandbox
cabal.sandbox.config
dist
*.log
*.swp
*~
.ghci
.stack-work
container/.DS_Store
TAGS

30
wai-middleware-caching-redis/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.

3
wai-middleware-caching-redis/README.md

@ -0,0 +1,3 @@
# Caching WAI Middleware using Redis
Cache WAI Middleware in RAM using Redis cache.

2
wai-middleware-caching-redis/Setup.hs

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

153
wai-middleware-caching-redis/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 (("X-Cached","true"):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

33
wai-middleware-caching-redis/stack.yaml

@ -0,0 +1,33 @@
# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-3.16
# Local packages, usually specified by relative directory name
packages:
- '.'
- '../wai-middleware-caching'
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 0.1.4.0
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]

2
wai-middleware-caching-redis/test/Spec.hs

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"

40
wai-middleware-caching-redis/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
, blaze-builder
, bytestring
, text
, http-types
, wai
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

10
wai-middleware-caching/.gitignore

@ -0,0 +1,10 @@
.cabal-sandbox
cabal.sandbox.config
dist
*.log
*.swp
*~
.ghci
.stack-work
container/.DS_Store
TAGS

30
wai-middleware-caching/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.

24
wai-middleware-caching/README.md

@ -0,0 +1,24 @@
# Caching WAI Middleware
This is a base to create caching WAI Middlewares
If you want to provide your own middleware you should provide a `CacheBackend`:
~~~~ {.haskell}
--------------------------------------------------------------------------------
-- | 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
}
~~~~

2
wai-middleware-caching/Setup.hs

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

128
wai-middleware-caching/src/Network/Wai/Middleware/Cache.hs

@ -0,0 +1,128 @@
{-# 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)
--------------------------------------------------------------------------------
-- | 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
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 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)

32
wai-middleware-caching/stack.yaml

@ -0,0 +1,32 @@
# For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md
# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2)
resolver: lts-3.16
# Local packages, usually specified by relative directory name
packages:
- '.'
# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3)
extra-deps: []
# Override default flag values for local packages and extra-deps
flags: {}
# Extra package databases containing global packages
extra-package-dbs: []
# Control whether we use the GHC we find on the path
# system-ghc: true
# Require a specific version of stack, using version ranges
# require-stack-version: -any # Default
# require-stack-version: >= 0.1.4.0
# Override the architecture used by stack, especially useful on Windows
# arch: i386
# arch: x86_64
# Extra directories used by stack for building
# extra-include-dirs: [/path/to/dir]
# extra-lib-dirs: [/path/to/dir]

2
wai-middleware-caching/test/Spec.hs

@ -0,0 +1,2 @@
main :: IO ()
main = putStrLn "Test suite not yet implemented"

36
wai-middleware-caching/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
Loading…
Cancel
Save