module Network.Wai.Middleware.ETag
( etag
, etagWithoutCache
, defaultETagContext
, ETagContext(..)
, MaxAge(..)
, ChecksumCache
) where
import Control.Concurrent.MVar (MVar, newMVar, readMVar, modifyMVar_)
import Control.Exception (SomeException, try)
import Control.Monad (liftM)
import qualified Crypto.Hash.MD5 as MD5 (hash)
import qualified Data.ByteString as BS (ByteString, readFile)
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, status304)
import Network.Wai (Middleware, requestHeaders,
responseLBS)
import Network.Wai.Internal (Request (..), Response (..))
import System.Posix.Types (EpochTime)
import System.PosixCompat.Files (fileSize, getFileStatus,
modificationTime)
etag :: ETagContext -> MaxAge -> Middleware
etag ctx age app req sendResponse =
app req $ \response -> case response of
rf@(ResponseFile _ _ path _) -> do
r <- hashFileCached ctx path
case (r, lookup "if-none-match" $ requestHeaders req) of
(Hash h, Just rh) | h == rh ->
sendResponse $ addCacheControl age $ responseLBS status304 [] ""
(Hash h, _) ->
respond age rf [("ETag", h)] >>= sendResponse
(FileNotFound, _) ->
sendResponse rf
(FileTooBig, _) -> do
modTime <- getModificationTimeIfExists path
case (fmap epochTimeToHTTPDate modTime, modifiedSince req) of
(Just mdate, Just lastSent) | mdate == lastSent ->
sendResponse $ addCacheControl age $ responseLBS status304 [] ""
(Just mdate, _) ->
respond age rf [("last-modified", formatHTTPDate mdate)] >>= sendResponse
(Nothing, _) ->
respond age rf [] >>= sendResponse
x ->
sendResponse x
etagWithoutCache :: MaxAge -> Middleware
etagWithoutCache age app req sendResponse =
defaultETagContext False >>= \ctx -> etag ctx age app req sendResponse
respond :: Monad m => MaxAge -> Response -> [Header] -> m Response
respond age res hs =
case res of
(ResponseFile st hs' path part) ->
return $ addCacheControl age $ ResponseFile st (hs ++ hs') path part
x ->
return x
addCacheControl :: MaxAge -> Response -> Response
addCacheControl age res =
case res of
(ResponseFile st hs path part) ->
ResponseFile st (modifyHeaders age hs) path part
(ResponseBuilder st hs b) ->
ResponseBuilder st (modifyHeaders age hs) b
(ResponseStream st hs body) ->
ResponseStream st (modifyHeaders age hs) body
(ResponseRaw bs f) ->
ResponseRaw bs f
where
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 ->
headerCacheControl (MaxAgeSeconds (60 * 60 * 24 * 365 * 100))
headerExpires maxage = case maxage of
NoMaxAge ->
id
MaxAgeSeconds i ->
(:) ("Expires", formatHTTPDate $ epochTimeToHTTPDate $ fromIntegral i)
MaxAgeForever ->
headerExpires (MaxAgeSeconds (60 * 60 * 24 * 365 * 100))
modifiedSince :: Request -> Maybe HTTPDate
modifiedSince req =
lookup "if-modified-since" (requestHeaders req) >>= parseHTTPDate
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
hashFile :: FilePath -> Integer -> IO HashResult
hashFile fp size = do
fs <- liftM fileSize (getFileStatus fp)
if fs <= fromIntegral size
then do
res <- try $ liftM (B64.encode . MD5.hash) (BS.readFile fp)
return $ case res of
Left (_ :: SomeException) ->
FileNotFound
Right x ->
Hash x
else
return FileTooBig
getModificationTimeIfExists :: FilePath -> IO (Maybe EpochTime)
getModificationTimeIfExists fp = do
res <- try $ liftM modificationTime (getFileStatus fp)
return $ case res of
Left (_ :: SomeException) -> Nothing
Right x -> Just x
defaultETagContext :: Bool -> IO ETagContext
defaultETagContext useCache =
liftM (ETagContext useCache (1024 * 1024 * 16)) (newMVar M.empty)
data MaxAge
= NoMaxAge
| MaxAgeSeconds Int
| MaxAgeForever
deriving (Show, Eq, Ord, Read)
data HashResult
= Hash BS.ByteString
| FileTooBig
| FileNotFound
deriving (Show, Eq, Ord, Read)
type ChecksumCache = MVar (M.HashMap FilePath BS.ByteString)
data ETagContext = ETagContext
{ etagCtxUseCache :: !Bool
, etagCtxMaxSize :: !Integer
, etagCtxCache :: !ChecksumCache
} deriving (Eq)