{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE 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 Control.Exception (SomeException, throwIO, try)
import Control.Monad (unless)
import qualified Data.ByteString as S
import Data.ByteString.Builder (byteString)
import qualified Data.ByteString.Builder.Extra as Blaze (flush)
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Lazy.Internal (defaultChunkSize)
import Data.Default.Class (Default (..))
import Data.Function (fix)
import Data.Maybe (isJust)
import qualified Data.Set as Set
import qualified Data.Streaming.ByteString.Builder as B
import qualified Data.Streaming.Zlib as Z
import Data.Word8 (_comma, _semicolon, _space)
import Network.HTTP.Types (
    Header,
    Status,
    hContentEncoding,
    hContentLength,
    hContentType,
    hUserAgent,
 )
import Network.HTTP.Types.Header (hAcceptEncoding, hVary)
import Network.Wai
import Network.Wai.Internal (Response (..))
import System.Directory (createDirectoryIfMissing, doesFileExist)
import qualified System.IO as IO

import Network.Wai.Header (contentLength)

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
req Response -> IO ResponseReceived
sendResponse'
    | Bool
skipCompress = Application
app Request
req Response -> IO ResponseReceived
sendResponse
    | Bool
otherwise = Application
app Request
req ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> ((Response -> IO ResponseReceived)
    -> Response -> IO ResponseReceived)
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
checkCompress ((Response -> IO ResponseReceived) -> IO ResponseReceived)
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \Response
res ->
        let runAction :: (Response, GzipFiles) -> IO ResponseReceived
runAction (Response, GzipFiles)
x = case (Response, GzipFiles)
x of
                (ResponseRaw{}, GzipFiles
_) -> Response -> IO ResponseReceived
sendResponse Response
res
                -- Always skip if 'GzipIgnore'
                (ResponseFile {}, GzipFiles
GzipIgnore) -> Response -> IO ResponseReceived
sendResponse Response
res
                -- If there's a compressed version of the file, we send that.
                (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)
                -- Skip if it's not a MIME type we want to compress
                (Response, GzipFiles)
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Bool
isCorrectMime (Response -> ResponseHeaders
responseHeaders Response
res) -> Response -> IO ResponseReceived
sendResponse Response
res
                -- Use static caching logic
                (ResponseFile Status
s ResponseHeaders
hs String
file Maybe FilePart
Nothing, GzipCacheFolder String
cache) ->
                    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
                -- Use streaming logic
                (Response, GzipFiles)
_ -> Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
compressE Response
res Response -> IO ResponseReceived
sendResponse
        in (Response, GzipFiles) -> IO ResponseReceived
runAction (Response
res, GzipSettings -> GzipFiles
gzipFiles GzipSettings
set)
  where
    isCorrectMime :: ResponseHeaders -> Bool
isCorrectMime =
        Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (GzipSettings -> ByteString -> Bool
gzipCheckMime GzipSettings
set) (Maybe ByteString -> Bool)
-> (ResponseHeaders -> Maybe ByteString) -> ResponseHeaders -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType
    sendResponse :: Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse' (Response -> IO ResponseReceived)
-> (Response -> Response) -> Response -> IO ResponseReceived
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders ((HeaderName, ByteString)
vary(HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
:)
    vary :: (HeaderName, ByteString)
vary = (HeaderName
hVary, ByteString
"Accept-Encoding")

    -- Can we skip from just looking at the 'Request'?
    skipCompress :: Bool
skipCompress =
        Bool -> Bool
not Bool
acceptsGZipEncoding Bool -> Bool -> Bool
|| Bool
isMSIE6
      where
        reqHdrs :: ResponseHeaders
reqHdrs = Request -> ResponseHeaders
requestHeaders Request
req
        acceptsGZipEncoding :: Bool
acceptsGZipEncoding =
            Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ByteString
"gzip" ([ByteString] -> Bool)
-> (ByteString -> [ByteString]) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
splitCommas) (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderName
hAcceptEncoding HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ResponseHeaders
reqHdrs
        isMSIE6 :: Bool
isMSIE6 =
            Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString
"MSIE 6" ByteString -> ByteString -> Bool
`S.isInfixOf`) (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderName
hUserAgent HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ResponseHeaders
reqHdrs

    -- Can we skip just by looking at the current 'Response'?
    checkCompress :: (Response -> IO ResponseReceived) -> Response -> IO ResponseReceived
    checkCompress :: (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
checkCompress Response -> IO ResponseReceived
f Response
res =
        if Bool
isEncodedAlready Bool -> Bool -> Bool
|| Bool
notBigEnough
            then Response -> IO ResponseReceived
sendResponse Response
res
            else Response -> IO ResponseReceived
f Response
res
      where
        resHdrs :: ResponseHeaders
resHdrs = Response -> ResponseHeaders
responseHeaders Response
res
        isEncodedAlready :: Bool
isEncodedAlready = Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
forall a b. (a -> b) -> a -> b
$ HeaderName
hContentEncoding HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ResponseHeaders
resHdrs
        notBigEnough :: Bool
notBigEnough =
            Bool -> (Integer -> Bool) -> Maybe Integer -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                Bool
False -- This could be a streaming case
                (Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
minimumLength)
                (Maybe Integer -> Bool) -> Maybe Integer -> Bool
forall a b. (a -> b) -> a -> b
$ ResponseHeaders -> Maybe Integer
contentLength ResponseHeaders
resHdrs

-- 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
minimumLength = Integer
860

-- TODO: Add ETag functionality
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 :: Response
          -> (Response -> IO ResponseReceived)
          -> IO ResponseReceived
compressE :: Response
-> (Response -> IO ResponseReceived) -> IO ResponseReceived
compressE Response
res Response -> IO ResponseReceived
sendResponse =
    (StreamingBody -> IO ResponseReceived) -> IO ResponseReceived
forall a. (StreamingBody -> IO a) -> IO a
wb ((StreamingBody -> IO ResponseReceived) -> IO ResponseReceived)
-> (StreamingBody -> IO ResponseReceived) -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ \StreamingBody
body -> Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s (ResponseHeaders -> ResponseHeaders
fixHeaders 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
  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 :: S.ByteString -> [S.ByteString]
splitCommas :: ByteString -> [ByteString]
splitCommas = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ((Word8 -> Bool) -> ByteString -> ByteString
S.dropWhile (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
_space)) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> ByteString -> [ByteString]
S.split Word8
_comma