diff --git a/src/Network/Wai/Middleware/Cache.hs b/src/Network/Wai/Middleware/Cache.hs --- a/src/Network/Wai/Middleware/Cache.hs +++ b/src/Network/Wai/Middleware/Cache.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} -- | Transparent front cache middleware for 'Network.Wai'. -- @@ -11,27 +12,44 @@ -- > ourFrivolousApplication module Network.Wai.Middleware.Cache ( - -- * Backend + -- * Middleware CacheBackend, CacheBackendError(..), - -- * Middleware - cache + cache, + headerETag, + + -- * Request helpers + lookupETag ) where +import Prelude hiding (concatMap) + import Control.Exception (Exception) +import Numeric (showHex) + +import Data.Word (Word8) import Data.Maybe (fromMaybe) import Data.Typeable (Typeable) -import Data.ByteString (ByteString) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 import Data.ByteString.Lazy (empty) -import Data.Conduit (ResourceT) +import Data.Digest.Pure.MD5 (MD5Digest) +import Data.Serialize (encode) + +import Data.Conduit (ResourceT, ($=), ($$), Flush(..)) +import qualified Data.Conduit.List as CL +import Data.Conduit.Blaze (builderToByteStringFlush) +import Crypto.Conduit (sinkHash) + import Network.Wai (Application, Middleware, Request(..), Response(..), - responseLBS) + responseLBS, responseSource) import Network.HTTP.Types (status304) -- | Abstract cache backend. Result may be 'Nothing' you need to respond --- wirh status @304 - Not Modified@. +-- with status @304 - Not Modified@. type CacheBackend = Application -- ^ Application -> Request -- ^ Request @@ -39,11 +57,12 @@ -- | Cache backend can throw errors. For handle this, use, for example, -- "Network.Wai.Middleware.Catch". -data CacheBackendError = CacheBackendError ByteString +data CacheBackendError = CacheBackendError B.ByteString deriving (Show, Eq, Typeable) instance Exception CacheBackendError --- | Cache middleware. Use it with conjuction with 'CacheBackend'. +-- | Cache middleware. Use it with conjuction with 'CacheBackend' and +-- 'headerETag'. -- -- > -- Simplest backend. Suggests @304 - Not Modified@ with site root. -- > rootBackend app req = do @@ -52,10 +71,54 @@ -- > _ -> do -- > res <- app req -- > return $ Just res +-- > app = responseLBS ok200 [] "someresponse" +-- > +-- > cachedApp = cache rootBackend $ headerETag $ app cache :: CacheBackend -- ^ Cache backend. -> Middleware cache cacheBackend app req = do res <- cacheBackend app req return $ fromMaybe (responseLBS status304 [] empty) res + +-- | Add \"ETag\" header to response if it not present. Value of header is +-- @MD5@ hash of response body. +headerETag :: Middleware +headerETag app req = do + res <- app req + let (rs, rh, rsrc) = responseSource res + case lookup "etag" rh of + (Just _) -> return res + Nothing -> do + digest <- rsrc $= builderToByteStringFlush $= + CL.map fromChunk $$ sinkHash + let hash = toHex . encode $ (digest :: MD5Digest) + return $ ResponseSource rs (("ETag", hash):rh) rsrc + where + fromChunk (Chunk a) = a + fromChunk Flush = "" + + -- | Convert to hex + toHex :: B.ByteString -> B.ByteString + toHex = + B.concatMap word8ToHex + where + word8ToHex :: Word8 -> B.ByteString + word8ToHex w = B8.pack $ pad $ showHex w [] + -- We know that the input will always be 1 or 2 characters long. + pad :: String -> String + pad [x] = ['0', x] + pad s = s + +---------------------------------------------------------------------------- +-- Request Helpers +---------------------------------------------------------------------------- + +-- | Helper for extract @If-None-Match@ header from 'Request'. Use this with +-- backends. +lookupETag :: Request -> Maybe B.ByteString +lookupETag = lookup "If-None-Match" . requestHeaders + + + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Test.Framework (defaultMain) +import Test.Framework.Providers.HUnit (testCase) +import Test.HUnit (Assertion) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL + +import Network.Wai (Application, responseLBS) +import Network.Wai.Test +import qualified Network.HTTP.Types as H + +import Network.Wai.Middleware.Cache + +main :: IO () +main = defaultMain [ + testCase "App without ETag" caseSimple, + testCase "App with Generated ETag" caseETag, + testCase "Generated ETag" caseEmbeddedEtag + ] + +-- | Just test simple app +caseSimple :: Assertion +caseSimple = flip runSession appSimple $ do + r <- defRequest + assertResponseBase r + assertNoHeader "etag" r + +caseETag :: Assertion +caseETag = flip runSession (headerETag appSimple) $ do + r <- defRequest + assertResponseBase r + assertHeader "etag" hashedData r + +caseEmbeddedEtag :: Assertion +caseEmbeddedEtag = flip runSession appWithETag $ do + r <- defRequest + assertResponseBase r + assertHeader "etag" "no-match" r + +defRequest :: Session SResponse +defRequest = request defaultRequest + +---------------------------------------------------------------------------- +-- Assertions +---------------------------------------------------------------------------- + +assertResponseBase :: SResponse -> Session () +assertResponseBase r = do + assertStatus 200 r + assertBody sourceData r + +---------------------------------------------------------------------------- +-- Applications +---------------------------------------------------------------------------- + +appSimple :: Application +appSimple _ = return $ responseLBS H.ok200 [] sourceData + +appWithETag :: Application +appWithETag _ = return $ responseLBS H.ok200 + [("ETag", "no-match")] sourceData + +---------------------------------------------------------------------------- +-- Data +---------------------------------------------------------------------------- + +sourceData :: BL.ByteString +sourceData = BL.fromChunks $ replicate 100000 "Hash response mock" + +hashedData :: B.ByteString +hashedData = "385765267c8bd0154b5303b894dc34e7" + diff --git a/wai-middleware-cache.cabal b/wai-middleware-cache.cabal --- a/wai-middleware-cache.cabal +++ b/wai-middleware-cache.cabal @@ -1,5 +1,5 @@ name: wai-middleware-cache -version: 0.2.0 +version: 0.3.0 cabal-version: >= 1.8 build-type: Simple stability: Stable @@ -8,25 +8,48 @@ synopsis: Caching middleware for WAI. homepage: https://github.com/akaspin/wai-middleware-cache bug-reports: https://github.com/akaspin/wai-middleware-cache/issues -description: - This package provides cache middleware and abstract type for +description: This package provides cache middleware and abstract type for creating cache backends. license: BSD3 license-file: LICENSE category: Web source-repository head - type: git - location: git://github.com/akaspin/wai-middleware-cache.git + type: git + location: git://github.com/akaspin/wai-middleware-cache.git library - hs-source-dirs: src + hs-source-dirs: src + build-depends: base >= 4 && < 5, + blaze-builder-conduit >= 0.4, + bytestring >= 0.9 && < 0.10, + cereal, + conduit >= 0.4 && < 0.5, + crypto-conduit, + http-types >= 0.6 && < 0.7, + pureMD5, + wai >= 1.2 + ghc-options: -Wall + exposed-modules: Network.Wai.Middleware.Cache + +test-suite test + type: exitcode-stdio-1.0 + x-uses-tf: true build-depends: - base >= 4 && < 5, - wai >= 1.1, + base >= 4, + HUnit >= 1.2 && < 2, + QuickCheck >= 2.4, + test-framework >= 0.4.1, + test-framework-quickcheck2, + test-framework-hunit, + + wai-middleware-cache, + + wai, bytestring >= 0.9 && < 0.10, - conduit >= 0.2 && < 0.3, - http-types >= 0.6 && < 0.7 - ghc-options: -Wall - exposed-modules: Network.Wai.Middleware.Cache + wai-test, + http-types + ghc-options: -Wall -rtsopts + hs-source-dirs: test + main-is: Main.hs