module Network.Wai.Middleware.Gzip
( gzip
, GzipSettings
, gzipFiles
, GzipFiles (..)
, gzipCheckMime
, def
, defaultCheckMime
) where
import Network.Wai
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString as S
import Data.Default
import Network.HTTP.Types (Status, Header)
import Control.Monad.IO.Class (liftIO)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import qualified Data.Conduit as C
import qualified Data.Conduit.Zlib as CZ
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.Blaze (builderToByteStringFlush)
import Blaze.ByteString.Builder (fromByteString)
import Control.Exception (try, SomeException)
import qualified Data.Set as Set
data GzipSettings = GzipSettings
{ gzipFiles :: GzipFiles
, gzipCheckMime :: S.ByteString -> Bool
}
data GzipFiles = GzipIgnore | GzipCompress | GzipCacheFolder FilePath
deriving (Show, Eq, Read)
instance Default GzipSettings where
def = GzipSettings GzipIgnore defaultCheckMime
defaultCheckMime :: S.ByteString -> Bool
defaultCheckMime bs =
S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress
where
bs' = fst $ S.breakByte 59 bs
toCompress = Set.fromList
[ "application/json"
, "application/javascript"
, "application/ecmascript"
]
gzip :: GzipSettings -> Middleware
gzip set app env = do
res <- app env
case res of
ResponseFile{} | gzipFiles set == GzipIgnore -> return res
_ -> if "gzip" `elem` enc && not isMSIE6
then
case (res, gzipFiles set) of
(ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
case lookup "content-type" hs of
Just m
| gzipCheckMime set m -> liftIO $ compressFile s hs file cache
_ -> return res
_ -> return $ compressE set res
else return res
where
enc = fromMaybe [] $ (splitCommas . S8.unpack)
`fmap` lookup "Accept-Encoding" (requestHeaders env)
ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env
isMSIE6 = "MSIE 6" `S.isInfixOf` ua
compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response
compressFile s hs file cache = do
e <- doesFileExist tmpfile
if e
then onSucc
else do
createDirectoryIfMissing True cache
x <-
try $ C.runResourceT $ CB.sourceFile file
C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile
either onErr (const onSucc) x
where
onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing
onErr :: SomeException -> IO Response
onErr = const $ return $ ResponseFile s hs file Nothing
tmpfile = cache ++ '/' : map safe file
safe c
| 'A' <= c && c <= 'Z' = c
| 'a' <= c && c <= 'z' = c
| '0' <= c && c <= '9' = c
safe '-' = '-'
safe '_' = '_'
safe _ = '_'
compressE :: GzipSettings
-> Response
-> Response
compressE set res =
case lookup "content-type" hs of
Just m | gzipCheckMime set m ->
let hs' = fixHeaders hs
in ResponseSource s hs' $ b C.$= builderToByteStringFlush
C.$= CZ.compressFlush 1 (CZ.WindowBits 31)
C.$= CL.map (fmap fromByteString)
_ -> res
where
(s, hs, b) = responseSource res
fixHeaders :: [Header] -> [Header]
fixHeaders =
(("Content-Encoding", "gzip") :) . filter notLength
where
notLength (x, _) = x /= "content-length"
splitCommas :: String -> [String]
splitCommas [] = []
splitCommas x =
let (y, z) = break (== ',') x
in y : splitCommas (dropWhile (== ' ') $ drop 1 z)