1{-# LANGUAGE Rank2Types, ScopedTypeVariables #-} 2--------------------------------------------------------- 3-- | 4-- Module : Network.Wai.Middleware.Gzip 5-- Copyright : Michael Snoyman 6-- License : BSD3 7-- 8-- Maintainer : Michael Snoyman <michael@snoyman.com> 9-- Stability : Unstable 10-- Portability : portable 11-- 12-- Automatic gzip compression of responses. 13-- 14--------------------------------------------------------- 15module Network.Wai.Middleware.Gzip 16 ( gzip 17 , GzipSettings 18 , gzipFiles 19 , GzipFiles (..) 20 , gzipCheckMime 21 , def 22 , defaultCheckMime 23 ) where 24 25import Network.Wai 26import Data.Maybe (fromMaybe, isJust) 27import qualified Data.ByteString.Char8 as S8 28import qualified Data.ByteString as S 29import Data.Default.Class 30import Network.HTTP.Types ( Status, Header, hContentEncoding, hUserAgent 31 , hContentType, hContentLength) 32import Network.HTTP.Types.Header (hVary) 33import System.Directory (doesFileExist, createDirectoryIfMissing) 34import Data.ByteString.Builder (byteString) 35import qualified Data.ByteString.Builder.Extra as Blaze (flush) 36import Control.Exception (try, SomeException) 37import qualified Data.Set as Set 38import Network.Wai.Header 39import Network.Wai.Internal 40import qualified Data.Streaming.ByteString.Builder as B 41import qualified Data.Streaming.Zlib as Z 42import Control.Monad (unless) 43import Data.Function (fix) 44import Control.Exception (throwIO) 45import qualified System.IO as IO 46import Data.ByteString.Lazy.Internal (defaultChunkSize) 47import Data.Word8 (_semicolon, _space, _comma) 48 49data GzipSettings = GzipSettings 50 { gzipFiles :: GzipFiles 51 , gzipCheckMime :: S.ByteString -> Bool 52 } 53 54-- | Gzip behavior for files. 55data GzipFiles 56 = GzipIgnore -- ^ Do not compress file responses. 57 | GzipCompress -- ^ Compress files. Note that this may counteract 58 -- zero-copy response optimizations on some 59 -- platforms. 60 | GzipCacheFolder FilePath -- ^ Compress files, caching them in 61 -- some directory. 62 | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz" 63 -- appended to it, if the file is missing then try next action 64 -- 65 -- @since 3.0.17 66 deriving (Show, Eq, Read) 67 68-- | Use default MIME settings; /do not/ compress files. 69instance Default GzipSettings where 70 def = GzipSettings GzipIgnore defaultCheckMime 71 72-- | MIME types that will be compressed by default: 73-- @text/@ @*@, @application/json@, @application/javascript@, 74-- @application/ecmascript@, @image/x-icon@. 75defaultCheckMime :: S.ByteString -> Bool 76defaultCheckMime bs = 77 S8.isPrefixOf "text/" bs || bs' `Set.member` toCompress 78 where 79 bs' = fst $ S.break (== _semicolon) bs 80 toCompress = Set.fromList 81 [ "application/json" 82 , "application/javascript" 83 , "application/ecmascript" 84 , "image/x-icon" 85 ] 86 87-- | Use gzip to compress the body of the response. 88-- 89-- Analyzes the \"Accept-Encoding\" header from the client to determine 90-- if gzip is supported. 91-- 92-- File responses will be compressed according to the 'GzipFiles' setting. 93-- 94-- Will only be applied based on the 'gzipCheckMime' setting. For default 95-- behavior, see 'defaultCheckMime'. 96gzip :: GzipSettings -> Middleware 97gzip set app env sendResponse' = app env $ \res -> 98 case res of 99 ResponseRaw{} -> sendResponse res 100 ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res 101 _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res) 102 then 103 let runAction x = case x of 104 (ResponseFile s hs file Nothing, GzipPreCompressed nextAction) -> 105 let 106 compressedVersion = file ++ ".gz" 107 in 108 doesFileExist compressedVersion >>= \y -> 109 if y 110 then (sendResponse $ ResponseFile s (fixHeaders hs) compressedVersion Nothing) 111 else (runAction (ResponseFile s hs file Nothing, nextAction)) 112 (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> 113 case lookup hContentType hs of 114 Just m 115 | gzipCheckMime set m -> compressFile s hs file cache sendResponse 116 _ -> sendResponse res 117 (ResponseFile {}, GzipIgnore) -> sendResponse res 118 _ -> compressE set res sendResponse 119 in runAction (res, gzipFiles set) 120 else sendResponse res 121 where 122 sendResponse = sendResponse' . mapResponseHeaders (vary:) 123 vary = (hVary, "Accept-Encoding") 124 enc = fromMaybe [] $ splitCommas 125 `fmap` lookup "Accept-Encoding" (requestHeaders env) 126 ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env 127 isMSIE6 = "MSIE 6" `S.isInfixOf` ua 128 isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res 129 130 bigEnough rsp = case contentLength (responseHeaders rsp) of 131 Nothing -> True -- This could be a streaming case 132 Just len -> len >= minimumLength 133 134 -- For a small enough response, gzipping will actually increase the size 135 -- Potentially for anything less than 860 bytes gzipping could be a net loss 136 -- The actual number is application specific though and may need to be adjusted 137 -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits 138 minimumLength = 860 139 140compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a 141compressFile s hs file cache sendResponse = do 142 e <- doesFileExist tmpfile 143 if e 144 then onSucc 145 else do 146 createDirectoryIfMissing True cache 147 x <- try $ 148 IO.withBinaryFile file IO.ReadMode $ \inH -> 149 IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do 150 deflate <- Z.initDeflate 7 $ Z.WindowBits 31 151 -- FIXME this code should write to a temporary file, then 152 -- rename to the final file 153 let goPopper popper = fix $ \loop -> do 154 res <- popper 155 case res of 156 Z.PRDone -> return () 157 Z.PRNext bs -> do 158 S.hPut outH bs 159 loop 160 Z.PRError ex -> throwIO ex 161 fix $ \loop -> do 162 bs <- S.hGetSome inH defaultChunkSize 163 unless (S.null bs) $ do 164 Z.feedDeflate deflate bs >>= goPopper 165 loop 166 goPopper $ Z.finishDeflate deflate 167 either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that! 168 where 169 onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing 170 171 onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message 172 173 tmpfile = cache ++ '/' : map safe file 174 safe c 175 | 'A' <= c && c <= 'Z' = c 176 | 'a' <= c && c <= 'z' = c 177 | '0' <= c && c <= '9' = c 178 safe '-' = '-' 179 safe '_' = '_' 180 safe _ = '_' 181 182compressE :: GzipSettings 183 -> Response 184 -> (Response -> IO a) 185 -> IO a 186compressE set res sendResponse = 187 case lookup hContentType hs of 188 Just m | gzipCheckMime set m -> 189 let hs' = fixHeaders hs 190 in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do 191 (blazeRecv, _) <- B.newBuilderRecv B.defaultStrategy 192 deflate <- Z.initDeflate 1 (Z.WindowBits 31) 193 let sendBuilder builder = do 194 popper <- blazeRecv builder 195 fix $ \loop -> do 196 bs <- popper 197 unless (S.null bs) $ do 198 sendBS bs 199 loop 200 sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper 201 flushBuilder = do 202 sendBuilder Blaze.flush 203 deflatePopper $ Z.flushDeflate deflate 204 flush 205 deflatePopper popper = fix $ \loop -> do 206 result <- popper 207 case result of 208 Z.PRDone -> return () 209 Z.PRNext bs' -> do 210 sendChunk $ byteString bs' 211 loop 212 Z.PRError e -> throwIO e 213 214 body sendBuilder flushBuilder 215 sendBuilder Blaze.flush 216 deflatePopper $ Z.finishDeflate deflate 217 _ -> sendResponse res 218 where 219 (s, hs, wb) = responseToStream res 220 221-- Remove Content-Length header, since we will certainly have a 222-- different length after gzip compression. 223fixHeaders :: [Header] -> [Header] 224fixHeaders = 225 ((hContentEncoding, "gzip") :) . filter notLength 226 where 227 notLength (x, _) = x /= hContentLength 228 229splitCommas :: S.ByteString -> [S.ByteString] 230splitCommas = map (S.dropWhile (== _space)) . S.split _comma 231