{-# LANGUAGE Rank2Types, ScopedTypeVariables #-}
---------------------------------------------------------
-- |
-- 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, hContentEncoding, hUserAgent
                          , hContentType, hContentLength)
import System.Directory (doesFileExist, createDirectoryIfMissing)
import Data.ByteString.Builder (byteString)
import qualified Data.ByteString.Builder.Extra as Blaze (flush)
import Control.Exception (try, SomeException)
import qualified Data.Set as Set
import Network.Wai.Header
import Network.Wai.Internal
import qualified Data.Streaming.ByteString.Builder as B
import qualified Data.Streaming.Zlib as Z
import Control.Monad (unless)
import Data.Function (fix)
import Control.Exception (throwIO)
import qualified System.IO as IO
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import Data.Word8 (_semicolon)

data GzipSettings = GzipSettings
    { GzipSettings -> GzipFiles
gzipFiles :: GzipFiles
    , GzipSettings -> ByteString -> Bool
gzipCheckMime :: S.ByteString -> Bool
    }

-- | Gzip behavior for files.
data GzipFiles
    = GzipIgnore -- ^ Do not compress file responses.
    | GzipCompress -- ^ Compress files. Note that this may counteract
                   -- zero-copy response optimizations on some
                   -- platforms.
    | GzipCacheFolder FilePath -- ^ Compress files, caching them in
                               -- some directory.
    | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz"
                                  -- appended to it, if the file is missing then try next action
                                  --
                                  -- @since 3.0.17
    deriving (Int -> GzipFiles -> ShowS
[GzipFiles] -> ShowS
GzipFiles -> String
(Int -> GzipFiles -> ShowS)
-> (GzipFiles -> String)
-> ([GzipFiles] -> ShowS)
-> Show GzipFiles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GzipFiles] -> ShowS
$cshowList :: [GzipFiles] -> ShowS
show :: GzipFiles -> String
$cshow :: GzipFiles -> String
showsPrec :: Int -> GzipFiles -> ShowS
$cshowsPrec :: Int -> GzipFiles -> ShowS
Show, GzipFiles -> GzipFiles -> Bool
(GzipFiles -> GzipFiles -> Bool)
-> (GzipFiles -> GzipFiles -> Bool) -> Eq GzipFiles
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GzipFiles -> GzipFiles -> Bool
$c/= :: GzipFiles -> GzipFiles -> Bool
== :: GzipFiles -> GzipFiles -> Bool
$c== :: GzipFiles -> GzipFiles -> Bool
Eq, ReadPrec [GzipFiles]
ReadPrec GzipFiles
Int -> ReadS GzipFiles
ReadS [GzipFiles]
(Int -> ReadS GzipFiles)
-> ReadS [GzipFiles]
-> ReadPrec GzipFiles
-> ReadPrec [GzipFiles]
-> Read GzipFiles
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [GzipFiles]
$creadListPrec :: ReadPrec [GzipFiles]
readPrec :: ReadPrec GzipFiles
$creadPrec :: ReadPrec GzipFiles
readList :: ReadS [GzipFiles]
$creadList :: ReadS [GzipFiles]
readsPrec :: Int -> ReadS GzipFiles
$creadsPrec :: Int -> ReadS GzipFiles
Read)

-- | Use default MIME settings; /do not/ compress files.
instance Default GzipSettings where
    def :: GzipSettings
def = GzipFiles -> (ByteString -> Bool) -> GzipSettings
GzipSettings GzipFiles
GzipIgnore ByteString -> Bool
defaultCheckMime

-- | MIME types that will be compressed by default:
-- @text/@ @*@, @application/json@, @application/javascript@,
-- @application/ecmascript@, @image/x-icon@.
defaultCheckMime :: S.ByteString -> Bool
defaultCheckMime :: ByteString -> Bool
defaultCheckMime ByteString
bs =
    ByteString -> ByteString -> Bool
S8.isPrefixOf ByteString
"text/" ByteString
bs Bool -> Bool -> Bool
|| ByteString
bs' ByteString -> Set ByteString -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ByteString
toCompress
  where
    bs' :: ByteString
bs' = (ByteString, ByteString) -> ByteString
forall a b. (a, b) -> a
fst ((ByteString, ByteString) -> ByteString)
-> (ByteString, ByteString) -> ByteString
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_semicolon) ByteString
bs
    toCompress :: Set ByteString
toCompress = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList
        [ ByteString
"application/json"
        , ByteString
"application/javascript"
        , ByteString
"application/ecmascript"
        , ByteString
"image/x-icon"
        ]

-- | Use gzip to compress the body of the response.
--
-- Analyzes the \"Accept-Encoding\" header from the client to determine
-- if gzip is supported.
--
-- File responses will be compressed according to the 'GzipFiles' setting.
--
-- Will only be applied based on the 'gzipCheckMime' setting. For default
-- behavior, see 'defaultCheckMime'.
gzip :: GzipSettings -> Middleware
gzip :: GzipSettings -> Middleware
gzip GzipSettings
set Application
app Request
env Response -> IO ResponseReceived
sendResponse = Application
app Request
env ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res ->
    case Response
res of
        ResponseRaw{} -> Response -> IO ResponseReceived
sendResponse Response
res
        ResponseFile{} | GzipSettings -> GzipFiles
gzipFiles GzipSettings
set GzipFiles -> GzipFiles -> Bool
forall a. Eq a => a -> a -> Bool
== GzipFiles
GzipIgnore -> Response -> IO ResponseReceived
sendResponse Response
res
        Response
_ -> if String
"gzip" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
enc Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
isMSIE6 Bool -> Bool -> Bool
&& Bool -> Bool
not (Response -> Bool
isEncoded Response
res) Bool -> Bool -> Bool
&& (Response -> Bool
bigEnough Response
res)
                then
                    let runAction :: (Response, GzipFiles) -> IO ResponseReceived
runAction (Response, GzipFiles)
x = case (Response, GzipFiles)
x of
                            (ResponseFile Status
s ResponseHeaders
hs String
file Maybe FilePart
Nothing, GzipPreCompressed GzipFiles
nextAction) ->
                                 let
                                    compressedVersion :: String
compressedVersion = String
file String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
".gz"
                                 in
                                    String -> IO Bool
doesFileExist String
compressedVersion IO Bool -> (Bool -> IO ResponseReceived) -> IO ResponseReceived
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
y ->
                                       if Bool
y
                                         then (Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
ResponseFile Status
s (ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hs) String
compressedVersion Maybe FilePart
forall a. Maybe a
Nothing)
                                         else ((Response, GzipFiles) -> IO ResponseReceived
runAction (Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
ResponseFile Status
s ResponseHeaders
hs String
file Maybe FilePart
forall a. Maybe a
Nothing, GzipFiles
nextAction))
                            (ResponseFile Status
s ResponseHeaders
hs String
file Maybe FilePart
Nothing, GzipCacheFolder String
cache) ->
                                case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ResponseHeaders
hs of
                                    Just ByteString
m
                                        | GzipSettings -> ByteString -> Bool
gzipCheckMime GzipSettings
set ByteString
m -> Status
-> ResponseHeaders
-> String
-> String
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a.
Status
-> ResponseHeaders
-> String
-> String
-> (Response -> IO a)
-> IO a
compressFile Status
s ResponseHeaders
hs String
file String
cache Response -> IO ResponseReceived
sendResponse
                                    Maybe ByteString
_ -> Response -> IO ResponseReceived
sendResponse Response
res
                            (ResponseFile {}, GzipFiles
GzipIgnore) -> Response -> IO ResponseReceived
sendResponse Response
res
                            (Response, GzipFiles)
_ -> GzipSettings
-> Response
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a. GzipSettings -> Response -> (Response -> IO a) -> IO a
compressE GzipSettings
set Response
res Response -> IO ResponseReceived
sendResponse
                    in (Response, GzipFiles) -> IO ResponseReceived
runAction (Response
res, GzipSettings -> GzipFiles
gzipFiles GzipSettings
set)
                else Response -> IO ResponseReceived
sendResponse Response
res
  where
    enc :: [String]
enc = [String] -> Maybe [String] -> [String]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [String] -> [String]) -> Maybe [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> [String]
splitCommas (String -> [String])
-> (ByteString -> String) -> ByteString -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack)
                    (ByteString -> [String]) -> Maybe ByteString -> Maybe [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"Accept-Encoding" (Request -> ResponseHeaders
requestHeaders Request
env)
    ua :: ByteString
ua = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hUserAgent (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> ResponseHeaders
requestHeaders Request
env
    isMSIE6 :: Bool
isMSIE6 = ByteString
"MSIE 6" ByteString -> ByteString -> Bool
`S.isInfixOf` ByteString
ua
    isEncoded :: Response -> Bool
isEncoded Response
res = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentEncoding (ResponseHeaders -> Maybe ByteString)
-> ResponseHeaders -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Response -> ResponseHeaders
responseHeaders Response
res

    bigEnough :: Response -> Bool
bigEnough Response
rsp = case ResponseHeaders -> Maybe Integer
contentLength (Response -> ResponseHeaders
responseHeaders Response
rsp) of
      Maybe Integer
Nothing -> Bool
True -- This could be a streaming case
      Just Integer
len -> Integer
len Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
minimumLength

    -- For a small enough response, gzipping will actually increase the size
    -- Potentially for anything less than 860 bytes gzipping could be a net loss
    -- The actual number is application specific though and may need to be adjusted
    -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits
    minimumLength :: Integer
minimumLength = Integer
860

compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a
compressFile :: Status
-> ResponseHeaders
-> String
-> String
-> (Response -> IO a)
-> IO a
compressFile Status
s ResponseHeaders
hs String
file String
cache Response -> IO a
sendResponse = do
    Bool
e <- String -> IO Bool
doesFileExist String
tmpfile
    if Bool
e
        then IO a
onSucc
        else do
            Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
cache
            Either SomeException ()
x <- IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
try (IO () -> IO (Either SomeException ()))
-> IO () -> IO (Either SomeException ())
forall a b. (a -> b) -> a -> b
$
                 String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withBinaryFile String
file IOMode
IO.ReadMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
inH ->
                 String -> IOMode -> (Handle -> IO ()) -> IO ()
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withBinaryFile String
tmpfile IOMode
IO.WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
outH -> do
                    Deflate
deflate <- Int -> WindowBits -> IO Deflate
Z.initDeflate Int
7 (WindowBits -> IO Deflate) -> WindowBits -> IO Deflate
forall a b. (a -> b) -> a -> b
$ Int -> WindowBits
Z.WindowBits Int
31
                    -- FIXME this code should write to a temporary file, then
                    -- rename to the final file
                    let goPopper :: IO PopperRes -> IO ()
goPopper IO PopperRes
popper = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                            PopperRes
res <- IO PopperRes
popper
                            case PopperRes
res of
                                PopperRes
Z.PRDone -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Z.PRNext ByteString
bs -> do
                                    Handle -> ByteString -> IO ()
S.hPut Handle
outH ByteString
bs
                                    IO ()
loop
                                Z.PRError ZlibException
ex -> ZlibException -> IO ()
forall e a. Exception e => e -> IO a
throwIO ZlibException
ex
                    (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                        ByteString
bs <- Handle -> Int -> IO ByteString
S.hGetSome Handle
inH Int
defaultChunkSize
                        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                            Deflate -> ByteString -> IO (IO PopperRes)
Z.feedDeflate Deflate
deflate ByteString
bs IO (IO PopperRes) -> (IO PopperRes -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO PopperRes -> IO ()
goPopper
                            IO ()
loop
                    IO PopperRes -> IO ()
goPopper (IO PopperRes -> IO ()) -> IO PopperRes -> IO ()
forall a b. (a -> b) -> a -> b
$ Deflate -> IO PopperRes
Z.finishDeflate Deflate
deflate
            (SomeException -> IO a)
-> (() -> IO a) -> Either SomeException () -> IO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO a
forall p. p -> IO a
onErr (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
onSucc) (Either SomeException ()
x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!
  where
    onSucc :: IO a
onSucc = Response -> IO a
sendResponse (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Status
s (ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hs) String
tmpfile Maybe FilePart
forall a. Maybe a
Nothing

    onErr :: p -> IO a
onErr p
_ = Response -> IO a
sendResponse (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Status
s ResponseHeaders
hs String
file Maybe FilePart
forall a. Maybe a
Nothing -- FIXME log the error message

    tmpfile :: String
tmpfile = String
cache String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char
'/' Char -> ShowS
forall a. a -> [a] -> [a]
: (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
safe String
file
    safe :: Char -> Char
safe Char
c
        | Char
'A' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Char
c
        | Char
'a' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'z' = Char
c
        | Char
'0' Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
<= Char
'9' = Char
c
    safe Char
'-' = Char
'-'
    safe Char
'_' = Char
'_'
    safe Char
_ = Char
'_'

compressE :: GzipSettings
          -> Response
          -> (Response -> IO a)
          -> IO a
compressE :: GzipSettings -> Response -> (Response -> IO a) -> IO a
compressE GzipSettings
set Response
res Response -> IO a
sendResponse =
    case HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ResponseHeaders
hs of
        Just ByteString
m | GzipSettings -> ByteString -> Bool
gzipCheckMime GzipSettings
set ByteString
m ->
            let hs' :: ResponseHeaders
hs' = ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hs
             in (StreamingBody -> IO a) -> IO a
forall a. (StreamingBody -> IO a) -> IO a
wb ((StreamingBody -> IO a) -> IO a)
-> (StreamingBody -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \StreamingBody
body -> Response -> IO a
sendResponse (Response -> IO a) -> Response -> IO a
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s ResponseHeaders
hs' (StreamingBody -> Response) -> StreamingBody -> Response
forall a b. (a -> b) -> a -> b
$ \Builder -> IO ()
sendChunk IO ()
flush -> do
                    (BuilderRecv
blazeRecv, BuilderFinish
_) <- BufferAllocStrategy -> IO (BuilderRecv, BuilderFinish)
B.newBuilderRecv BufferAllocStrategy
B.defaultStrategy
                    Deflate
deflate <- Int -> WindowBits -> IO Deflate
Z.initDeflate Int
1 (Int -> WindowBits
Z.WindowBits Int
31)
                    let sendBuilder :: Builder -> IO ()
sendBuilder Builder
builder = do
                            IO ByteString
popper <- BuilderRecv
blazeRecv Builder
builder
                            (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                                ByteString
bs <- IO ByteString
popper
                                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                                    ByteString -> IO ()
sendBS ByteString
bs
                                    IO ()
loop
                        sendBS :: ByteString -> IO ()
sendBS ByteString
bs = Deflate -> ByteString -> IO (IO PopperRes)
Z.feedDeflate Deflate
deflate ByteString
bs IO (IO PopperRes) -> (IO PopperRes -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO PopperRes -> IO ()
deflatePopper
                        flushBuilder :: IO ()
flushBuilder = do
                            Builder -> IO ()
sendBuilder Builder
Blaze.flush
                            IO PopperRes -> IO ()
deflatePopper (IO PopperRes -> IO ()) -> IO PopperRes -> IO ()
forall a b. (a -> b) -> a -> b
$ Deflate -> IO PopperRes
Z.flushDeflate Deflate
deflate
                            IO ()
flush
                        deflatePopper :: IO PopperRes -> IO ()
deflatePopper IO PopperRes
popper = (IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                            PopperRes
result <- IO PopperRes
popper
                            case PopperRes
result of
                                PopperRes
Z.PRDone -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                Z.PRNext ByteString
bs' -> do
                                    Builder -> IO ()
sendChunk (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs'
                                    IO ()
loop
                                Z.PRError ZlibException
e -> ZlibException -> IO ()
forall e a. Exception e => e -> IO a
throwIO ZlibException
e

                    StreamingBody
body Builder -> IO ()
sendBuilder IO ()
flushBuilder
                    Builder -> IO ()
sendBuilder Builder
Blaze.flush
                    IO PopperRes -> IO ()
deflatePopper (IO PopperRes -> IO ()) -> IO PopperRes -> IO ()
forall a b. (a -> b) -> a -> b
$ Deflate -> IO PopperRes
Z.finishDeflate Deflate
deflate
        Maybe ByteString
_ -> Response -> IO a
sendResponse Response
res
  where
    (Status
s, ResponseHeaders
hs, (StreamingBody -> IO a) -> IO a
wb) = Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
forall a.
Response
-> (Status, ResponseHeaders, (StreamingBody -> IO a) -> IO a)
responseToStream Response
res

-- Remove Content-Length header, since we will certainly have a
-- different length after gzip compression.
fixHeaders :: [Header] -> [Header]
fixHeaders :: ResponseHeaders -> ResponseHeaders
fixHeaders =
    ((HeaderName
hContentEncoding, ByteString
"gzip") (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:) (ResponseHeaders -> ResponseHeaders)
-> (ResponseHeaders -> ResponseHeaders)
-> ResponseHeaders
-> ResponseHeaders
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((HeaderName, ByteString) -> Bool)
-> ResponseHeaders -> ResponseHeaders
forall a. (a -> Bool) -> [a] -> [a]
filter (HeaderName, ByteString) -> Bool
forall b. (HeaderName, b) -> Bool
notLength
  where
    notLength :: (HeaderName, b) -> Bool
notLength (HeaderName
x, b
_) = HeaderName
x HeaderName -> HeaderName -> Bool
forall a. Eq a => a -> a -> Bool
/= HeaderName
hContentLength

splitCommas :: String -> [String]
splitCommas :: String -> [String]
splitCommas [] = []
splitCommas String
x =
    let (String
y, String
z) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
',') String
x
     in String
y String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> [String]
splitCommas ((Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop Int
1 String
z)