~ubuntu-branches/ubuntu/saucy/haskell-wai-extra/saucy-proposed
» Revision
6
: Network/Wai/Middleware/Gzip.hs
« back to all changes in this revision
Viewing changes to Network/Wai/Middleware/Gzip.hs
- browse files at revision 6
- compare with another revision
- download diff
- download tarball
- view history from revision 6
- Committer: Package Import Robot
- Author(s): Clint Adams
- Date: 2012-03-09 14:12:00 UTC
- mfrom: (2.1.6 sid)
- Revision ID: package-import@ubuntu.com-20120309141200-pwnlh5b9fme9ps47
Tags: 1.1.0.1-2
Add missing build dependencies on ansi-terminal. closes: #663242.
- files added:
- Network/Wai/Middleware/RequestLogger.hs
- test/requests
- files removed:
- Network/Wai/Middleware/Debug.hs
- files modified:
- Network/Wai/Handler/CGI.hs
added
removed
Network/Wai/Middleware/Gzip.hs
14
14
-- Automatic gzip compression of responses.
15
15
--
16
16
---------------------------------------------------------
17
module Network.Wai.Middleware.Gzip (gzip) where
17
module Network.Wai.Middleware.Gzip
18
( gzip
19
, GzipSettings
20
, gzipFiles
21
, GzipFiles (..)
22
, def
23
, defaultCheckMime
24
) where
18
25
19
26
import Network.Wai
20
import Network.Wai.Zlib
21
27
import Data.Maybe (fromMaybe)
22
import Data.Enumerator (($$), joinI)
23
28
import qualified Data.ByteString.Char8 as S8
24
29
import qualified Data.ByteString as S
30
import Data.Default
31
import Network.HTTP.Types (Status, Header)
32
import Control.Monad.IO.Class (liftIO)
33
import System.Directory (doesFileExist, createDirectoryIfMissing)
34
import qualified Data.Conduit as C
35
import qualified Data.Conduit.Zlib as CZ
36
import qualified Data.Conduit.Binary as CB
37
import qualified Data.Conduit.List as CL
38
import Data.Conduit.Blaze (builderToByteStringFlush)
39
import Blaze.ByteString.Builder (fromByteString)
40
import Control.Exception (try, SomeException)
41
42
data GzipSettings = GzipSettings
43
{ gzipFiles :: GzipFiles
44
, gzipCheckMime :: S.ByteString -> Bool
45
}
46
47
data GzipFiles = GzipIgnore | GzipCompress | GzipCacheFolder FilePath
48
deriving (Show, Eq, Read)
49
50
instance Default GzipSettings where
51
def = GzipSettings GzipIgnore defaultCheckMime
52
53
defaultCheckMime :: S.ByteString -> Bool
54
defaultCheckMime = S8.isPrefixOf "text/"
25
55
26
56
-- | Use gzip to compress the body of the response.
27
57
--
31
61
-- Possible future enhancements:
32
62
--
33
63
-- * Only compress if the response is above a certain size.
34
--
35
gzip :: Bool -- ^ should we gzip files?
36
-> Middleware
37
gzip files app env = do
64
gzip :: GzipSettings -> Middleware
65
gzip set app env = do
38
66
res <- app env
39
return $
40
case res of
41
ResponseFile{} | not files -> res
42
_ -> if "gzip" `elem` enc && not isMSIE6
43
then ResponseEnumerator $ compressE $ responseEnumerator res
44
else res
67
case res of
68
ResponseFile{} | gzipFiles set == GzipIgnore -> return res
69
_ -> if "gzip" `elem` enc && not isMSIE6
70
then
71
case (res, gzipFiles set) of
72
(ResponseFile s hs file Nothing, GzipCacheFolder cache) ->
73
case lookup "content-type" hs of
74
Just m
75
| gzipCheckMime set m -> liftIO $ compressFile s hs file cache
76
_ -> return res
77
_ -> return $ compressE set res
78
else return res
45
79
where
46
80
enc = fromMaybe [] $ (splitCommas . S8.unpack)
47
81
`fmap` lookup "Accept-Encoding" (requestHeaders env)
48
82
ua = fromMaybe "" $ lookup "user-agent" $ requestHeaders env
49
83
isMSIE6 = "MSIE 6" `S.isInfixOf` ua
50
84
51
compressE :: (forall a. ResponseEnumerator a)
52
-> (forall a. ResponseEnumerator a)
53
compressE re f =
54
re f'
55
--e s hs'
56
where
57
f' s hs =
58
joinI $ compress $$ f s hs'
59
where
60
-- Remove Content-Length header, since we will certainly have a
61
-- different length after gzip compression.
62
hs' = ("Content-Encoding", "gzip") : filter notLength hs
63
notLength (x, _) = x /= "content-length"
85
compressFile :: Status -> [Header] -> FilePath -> FilePath -> IO Response
86
compressFile s hs file cache = do
87
e <- doesFileExist tmpfile
88
if e
89
then onSucc
90
else do
91
createDirectoryIfMissing True cache
92
x <-
93
try $ C.runResourceT $ CB.sourceFile file
94
C.$$ CZ.gzip C.=$ CB.sinkFile tmpfile
95
either onErr (const onSucc) x
96
where
97
onSucc = return $ ResponseFile s (fixHeaders hs) tmpfile Nothing
98
99
onErr :: SomeException -> IO Response
100
onErr = const $ return $ ResponseFile s hs file Nothing -- FIXME log the error message
101
102
tmpfile = cache ++ '/' : map safe file
103
safe c
104
| 'A' <= c && c <= 'Z' = c
105
| 'a' <= c && c <= 'z' = c
106
| '0' <= c && c <= '9' = c
107
safe '-' = '-'
108
safe '_' = '_'
109
safe _ = '_'
110
111
compressE :: GzipSettings
112
-> Response
113
-> Response
114
compressE set res =
115
case lookup "content-type" hs of
116
Just m | gzipCheckMime set m ->
117
let hs' = fixHeaders hs
118
in ResponseSource s hs' $ b C.$= builderToByteStringFlush
119
C.$= CZ.compressFlush 1 (CZ.WindowBits 31)
120
C.$= CL.map (fmap fromByteString)
121
_ -> res
122
where
123
(s, hs, b) = responseSource res
124
125
-- Remove Content-Length header, since we will certainly have a
126
-- different length after gzip compression.
127
fixHeaders :: [Header] -> [Header]
128
fixHeaders =
129
(("Content-Encoding", "gzip") :) . filter notLength
130
where
131
notLength (x, _) = x /= "content-length"
64
132
65
133
splitCommas :: String -> [String]
66
134
splitCommas [] = []
Loggerhead is a web-based interface for Breezy
Version: 2.0.1