module Network.Wai.Middleware.Cache (
CacheBackend,
CacheBackendError(..),
cache,
headerETag,
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 qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.ByteString.Lazy (empty)
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, responseSource)
import Network.HTTP.Types (status304)
type CacheBackend =
Application
-> Request
-> ResourceT IO (Maybe Response)
data CacheBackendError = CacheBackendError B.ByteString
deriving (Show, Eq, Typeable)
instance Exception CacheBackendError
cache ::
CacheBackend
-> Middleware
cache cacheBackend app req = do
res <- cacheBackend app req
return $ fromMaybe (responseLBS status304 [] empty) res
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 = ""
toHex :: B.ByteString -> B.ByteString
toHex =
B.concatMap word8ToHex
where
word8ToHex :: Word8 -> B.ByteString
word8ToHex w = B8.pack $ pad $ showHex w []
pad :: String -> String
pad [x] = ['0', x]
pad s = s
lookupETag :: Request -> Maybe B.ByteString
lookupETag = lookup "If-None-Match" . requestHeaders