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