diff --git a/src/Network/Wai/Middleware/ETag.hs b/src/Network/Wai/Middleware/ETag.hs --- a/src/Network/Wai/Middleware/ETag.hs +++ b/src/Network/Wai/Middleware/ETag.hs @@ -11,19 +11,26 @@ -- -- WAI ETag middleware for static files. -module Network.Wai.Middleware.ETag where +module Network.Wai.Middleware.ETag + ( etag + , etagWithoutCache + , defaultETagContext + , ETagContext(..) + , MaxAge(..) + , ChecksumCache + ) where -import Control.Concurrent.MVar (MVar, newMVar, takeMVar) +import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_) import Control.Exception (SomeException, try) import Control.Monad (liftM) -import Crypto.Hash.MD5 as MD5 +import qualified Crypto.Hash.MD5 as MD5 (hash) import qualified Data.ByteString as BS (ByteString, readFile) -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Char8 as BS8 -import qualified Data.HashMap.Strict as M +import qualified Data.ByteString.Base64 as B64 (encode) +import qualified Data.ByteString.Char8 as BS8 (append, pack) +import qualified Data.HashMap.Strict as M (HashMap, empty, insert, lookup) import Network.HTTP.Date (HTTPDate, epochTimeToHTTPDate, formatHTTPDate, parseHTTPDate) -import Network.HTTP.Types (Header, ResponseHeaders, status304) +import Network.HTTP.Types (Header, status304) import Network.Wai (Middleware, requestHeaders, responseLBS) import Network.Wai.Internal (Request (..), Response (..)) @@ -31,42 +38,41 @@ import System.PosixCompat.Files (fileSize, getFileStatus, modificationTime) --- | Attaches the middleware. Enable caching if the first argument is 'True'. -etag :: Bool -> MaxAge -> Middleware -etag useCache age app req = do - c <- liftM (ETagContext useCache) (newMVar M.empty) - etag' c age app req - -- | Attaches the middleware with a provided context. -etag' :: ETagContext -> MaxAge -> Middleware -etag' cache age app req = - app req >>= \response -> case response of +etag :: ETagContext -> MaxAge -> Middleware +etag ctx age app req sendResponse = + app req $ \response -> case response of rf@(ResponseFile _ _ path _) -> do - r <- hashFileCached cache path + r <- hashFileCached ctx path case (r, lookup "if-none-match" $ requestHeaders req) of (Hash h, Just rh) | h == rh -> - return $ addCacheControl age $ responseLBS status304 [] "" + sendResponse $ addCacheControl age $ responseLBS status304 [] "" (Hash h, _) -> - respond age rf [("ETag", h)] + respond age rf [("ETag", h)] >>= sendResponse (FileNotFound, _) -> - return rf + sendResponse rf (FileTooBig, _) -> do modTime <- getModificationTimeIfExists path case (fmap epochTimeToHTTPDate modTime, modifiedSince req) of (Just mdate, Just lastSent) | mdate == lastSent -> - return $ addCacheControl age $ responseLBS status304 [] "" + sendResponse $ addCacheControl age $ responseLBS status304 [] "" (Just mdate, _) -> - respond age rf [("last-modified", formatHTTPDate mdate)] + respond age rf [("last-modified", formatHTTPDate mdate)] >>= sendResponse (Nothing, _) -> - respond age rf [] + respond age rf [] >>= sendResponse x -> - return x + sendResponse x +-- | Attaches the middleware without caching the calculated ETags. +etagWithoutCache :: MaxAge -> Middleware +etagWithoutCache age app req sendResponse = + defaultETagContext False >>= \ctx -> etag ctx age app req sendResponse + -- | Finalize the response by attaching a cache-control header based on age. respond :: Monad m => MaxAge -> Response -> [Header] -> m Response respond age res hs = @@ -81,59 +87,61 @@ addCacheControl age res = case res of (ResponseFile st hs path part) -> - ResponseFile st (cacheControl age hs) path part + ResponseFile st (modifyHeaders age hs) path part (ResponseBuilder st hs b) -> - ResponseBuilder st (cacheControl age hs) b - (ResponseSource st hs s) -> - ResponseSource st (cacheControl age hs) s - --- | Determine if-modified-since tag from the http request if present. -modifiedSince :: Request -> Maybe HTTPDate -modifiedSince req = - lookup "if-modified-since" (requestHeaders req) >>= parseHTTPDate - --- | Determine the hash of a provided file located at 'path'. --- If caching is enabled, use the cached checksum, otherwise --- always re-calculate. -hashFileCached :: ETagContext -> FilePath -> IO HashResult -hashFileCached ctx path = - if etagCtxUseCache ctx - then - liftM (M.lookup path) (takeMVar $ etagCtxCache ctx) >>= \r-> case r of - Just cachedHash -> - return $ Hash cachedHash - Nothing -> - hashFile path - else - hashFile path - --- | Add cache-control to the provided response-headears. -cacheControl :: MaxAge -> ResponseHeaders -> ResponseHeaders -cacheControl maxage = - headerCacheControl . headerExpires + ResponseBuilder st (modifyHeaders age hs) b + (ResponseStream st hs body) -> + ResponseStream st (modifyHeaders age hs) body + (ResponseRaw bs f) -> + ResponseRaw bs f where - headerCacheControl = case maxage of + modifyHeaders maxage = + headerCacheControl maxage . headerExpires maxage + + headerCacheControl maxage = case maxage of NoMaxAge -> id MaxAgeSeconds i -> (:) ("Cache-Control", BS8.append "public, max-age=" $ BS8.pack $ show i) MaxAgeForever -> - cacheControl (MaxAgeSeconds (60 * 60 * 24 * 365)) + headerCacheControl (MaxAgeSeconds (60 * 60 * 24 * 365 * 100)) - headerExpires = case maxage of + headerExpires maxage = case maxage of NoMaxAge -> id - MaxAgeSeconds _ -> - id -- FIXME + MaxAgeSeconds i -> + (:) ("Expires", formatHTTPDate $ epochTimeToHTTPDate $ fromIntegral i) MaxAgeForever -> - (:) ("Expires", "Thu, 31 Dec 2037 23:55:55 GMT") + headerExpires (MaxAgeSeconds (60 * 60 * 24 * 365 * 100)) +-- | Determine if-modified-since tag from the http request if present. +modifiedSince :: Request -> Maybe HTTPDate +modifiedSince req = + lookup "if-modified-since" (requestHeaders req) >>= parseHTTPDate + +-- | Determine the hash of a provided file located at 'path'. +-- If caching is enabled, use the cached checksum, otherwise +-- always re-calculate. +hashFileCached :: ETagContext -> FilePath -> IO HashResult +hashFileCached (ETagContext False size _) path = hashFile path size +hashFileCached (ETagContext True size cache) path = + liftM (M.lookup path) (readMVar cache) >>= \r -> case r of + Just cachedHash -> + return $ Hash cachedHash + Nothing -> + hashFile path size >>= \hr -> case hr of + Hash h -> do + modifyMVar_ cache (return . M.insert path h) + return hr + _ -> + return hr + -- | Hash the file with MD5 located at 'fp'. -hashFile :: FilePath -> IO HashResult -hashFile fp = do - size <- liftM fileSize (getFileStatus fp) +hashFile :: FilePath -> Integer -> IO HashResult +hashFile fp size = do + fs <- liftM fileSize (getFileStatus fp) - if size < 1024 * 1024 + if fs <= fromIntegral size then do res <- try $ liftM (B64.encode . MD5.hash) (BS.readFile fp) @@ -153,6 +161,11 @@ Left (_ :: SomeException) -> Nothing Right x -> Just x +-- | Create an empty 'ETagContext'. +defaultETagContext :: Bool -> IO ETagContext +defaultETagContext useCache = + liftM (ETagContext useCache (1024 * 1024 * 16)) (newMVar M.empty) + -- | Maximum age that will be attached to all file-resources -- processed by the middleware. data MaxAge @@ -168,10 +181,15 @@ | FileNotFound deriving (Show, Eq, Ord, Read) +type ChecksumCache = MVar (M.HashMap FilePath BS.ByteString) + -- | The configuration context of the middleware. data ETagContext = ETagContext { etagCtxUseCache :: !Bool - -- ^ Set to false to disable the cache - , etagCtxCache :: !(MVar (M.HashMap FilePath BS.ByteString)) - -- ^ The underlying store mapping filepaths to calculated checksums + -- ^ Set to false to disable the cache. + , etagCtxMaxSize :: !Integer + -- ^ File size in bytes. If files are bigger than 'etagCtxMaxSize', + -- no etag will be calculated. + , etagCtxCache :: !ChecksumCache + -- ^ The underlying store mapping filepaths to calculated checksums. } deriving (Eq) diff --git a/wai-middleware-etag.cabal b/wai-middleware-etag.cabal --- a/wai-middleware-etag.cabal +++ b/wai-middleware-etag.cabal @@ -1,5 +1,5 @@ name: wai-middleware-etag -version: 0.1.0.0 +version: 0.1.1.1 synopsis: WAI ETag middleware for static files homepage: https://github.com/ameingast/wai-middleware-etag Bug-reports: https://github.com/ameingast/wai-middleware-etag/issues @@ -11,23 +11,28 @@ stability: experimental build-type: Simple cabal-version: >= 1.8 -description: WAI middleware that attaches ETags to responses for static files - if they exist. +description: WAI middleware that attaches ETags to responses for static files. + . - Caveats: + Caveats: . If caching is turned on, the middleware caches calculated checksums - aggressively in a synchronized hashmap; checksums are calculated only - once, so changes on the file-system are not reflected until the server - is restarted. + aggressively in a synchronized hashmap; checksums are calculated only + once, so changes on the file-system are not reflected until the server + is restarted. . This middleware only calculates ETag checksums for file smaller than 1MB, otherwise it attaches a last-modified tag to the response. . + The package is heavily influenced by wai-app-static. + . [WAI] + . + [wai-app-static] + extra-source-files: src/Network/Wai/Middleware/ETag.hs - + source-repository head type: git location: git://github.com/ameingast/wai-middleware-etag.git @@ -37,14 +42,14 @@ hs-source-dirs: src ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns extensions: OverloadedStrings - build-depends: + build-depends: base >= 4.6 && < 5, base64-bytestring >= 1.0 && < 1.1, bytestring >= 0.10 && < 0.11, cryptohash >= 0.11 && < 0.12, - filepath >= 1.3 && < 1.4, + filepath >= 1.3 && < 1.5, http-date >= 0.0.4 && < 0.1, http-types >= 0.8 && < 0.9, unix-compat >= 0.4 && < 0.5, unordered-containers >= 0.2 && < 0.3, - wai >= 2.0.0 && < 2.1 + wai >= 3.0 && < 3.1