1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
|
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
---------------------------------------------------------
-- |
-- Module : Network.Wai.Middleware.Gzip
-- Copyright : Michael Snoyman
-- License : BSD3
--
-- Maintainer : Michael Snoyman <michael@snoyman.com>
-- Stability : Unstable
-- Portability : portable
--
-- Automatic gzip compression of responses.
--
---------------------------------------------------------
module Network.Wai.Middleware.Gzip
( gzip
, GzipSettings
, gzipFiles
, GzipFiles (..)
, gzipCheckMime
, def
, defaultCheckMime
) where
import Network.Wai
import Data.Maybe (fromMaybe, isJust)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString as S
import Data.Default.Class
import Network.HTTP.Types (Status, Header)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Resource (runResourceT)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Blaze.ByteString.Builder (fromByteString)
import Control.Exception (try, SomeException)
import qualified Data.Set as Set
import Network.Wai.Internal
import qualified Data.Streaming.Blaze as B
import qualified Data.Streaming.Zlib as Z
import qualified Blaze.ByteString.Builder as Blaze
import Control.Monad (unless)
import Data.Function (fix)
import Control.Exception (throwIO)
import qualified System.IO as IO
import Data.ByteString.Lazy.Internal (defaultChunkSize)
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 -- semicolon
toCompress = Set.fromList
[ "application/json"
, "application/javascript"
, "application/ecmascript"
]
-- | Use gzip to compress the body of the response.
--
-- Analyzes the \"Accept-Encoding\" header from the client to determine
-- if gzip is supported.
--
-- Possible future enhancements:
--
-- * Only compress if the response is above a certain size.
gzip :: GzipSettings -> Middleware
gzip set app env sendResponse = app env $ \res ->
case res of
ResponseRaw{} -> sendResponse res
ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res
_ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res)
then
case (res, gzipFiles set) of
(ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
case lookup "content-type" hs of
Just m
| gzipCheckMime set m -> compressFile s hs file cache sendResponse
_ -> sendResponse res
_ -> compressE set res sendResponse
else sendResponse 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
isEncoded res = isJust $ lookup "Content-Encoding" $ responseHeaders res
compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a
compressFile s hs file cache sendResponse = do
e <- doesFileExist tmpfile
if e
then onSucc
else do
createDirectoryIfMissing True cache
x <- try $
IO.withBinaryFile file IO.ReadMode $ \inH ->
IO.withBinaryFile tmpfile IO.WriteMode $ \outH -> do
deflate <- Z.initDeflate 7 $ Z.WindowBits 31
-- FIXME this code should write to a temporary file, then
-- rename to the final file
let goPopper popper = fix $ \loop -> do
res <- popper
case res of
Z.PRDone -> return ()
Z.PRNext bs -> do
S.hPut outH bs
loop
Z.PRError e -> throwIO e
fix $ \loop -> do
bs <- S.hGetSome inH defaultChunkSize
unless (S.null bs) $ do
Z.feedDeflate deflate bs >>= goPopper
loop
goPopper $ Z.finishDeflate deflate
either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!
where
onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing
onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message
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 -> IO a)
-> IO a
compressE set res sendResponse =
case lookup "content-type" hs of
Just m | gzipCheckMime set m ->
let hs' = fixHeaders hs
in wb $ \body -> sendResponse $ responseStream s hs' $ \sendChunk flush -> do
(blazeRecv, blazeFinish) <- B.newBlazeRecv B.defaultStrategy
deflate <- Z.initDeflate 1 (Z.WindowBits 31)
let sendBuilder builder = do
popper <- blazeRecv builder
fix $ \loop -> do
bs <- popper
unless (S.null bs) $ do
sendBS bs
loop
sendBS bs = Z.feedDeflate deflate bs >>= deflatePopper
flushBuilder = do
sendBuilder Blaze.flush
deflatePopper $ Z.flushDeflate deflate
flush
deflatePopper popper = fix $ \loop -> do
res <- popper
case res of
Z.PRDone -> return ()
Z.PRNext bs' -> do
sendChunk $ fromByteString bs'
loop
Z.PRError e -> throwIO e
body sendBuilder flushBuilder
sendBuilder Blaze.flush
deflatePopper $ Z.finishDeflate deflate
_ -> sendResponse res
where
(s, hs, wb) = responseToStream res
-- Remove Content-Length header, since we will certainly have a
-- different length after gzip compression.
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)
|
