---------------------------------------------------------
-- |
-- 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
    ( -- * How to use this module
      -- $howto

      -- ** The Middleware
      -- $gzip
      gzip

      -- ** The Settings
      -- $settings
    , GzipSettings
    , gzipFiles
    , gzipCheckMime
    , gzipSizeThreshold

      -- ** How to handle file responses
    , GzipFiles (..)

      -- ** Miscellaneous
      -- $miscellaneous
    , defaultCheckMime
    , def
    ) where

import Control.Exception (IOException, SomeException, fromException, 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 as W8 (toLower, _semicolon)
import Network.HTTP.Types (
    Header,
    Status (statusCode),
    hContentEncoding,
    hContentLength,
    hContentType,
    hUserAgent,
 )
import Network.HTTP.Types.Header (hAcceptEncoding, hETag, 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, parseQValueList, replaceHeader)
import Network.Wai.Util (splitCommas, trimWS)

-- $howto
--
-- This 'Middleware' adds @gzip encoding@ to an application.
-- Its use is pretty straightforward, but it's good to know
-- how and when it decides to encode the response body.
--
-- A few things to keep in mind when using this middleware:
--
-- * It is advised to put any 'Middleware's that change the
--   response behind this one, because it bases a lot of its
--   decisions on the returned response.
-- * Enabling compression may counteract zero-copy response
--   optimizations on some platforms.
-- * This middleware is applied to every response by default.
--   If it should only encode certain paths,
--   "Network.Wai.Middleware.Routed" might be helpful.

-- $gzip
--
-- There are a good amount of requirements that should be
-- fulfilled before a response will actually be @gzip encoded@
-- by this 'Middleware', so here's a short summary.
--
-- Request requirements:
--
-- * The request needs to accept \"gzip\" in the \"Accept-Encoding\" header.
-- * Requests from Internet Explorer 6 will not be encoded.
--   (i.e. if the request's \"User-Agent\" header contains \"MSIE 6\")
--
-- Response requirements:
--
-- * The response isn't already encoded. (i.e. shouldn't already
--   have a \"Content-Encoding\" header)
-- * The response isn't a @206 Partial Content@ (partial content
--   should never be compressed)
-- * If the response contains a \"Content-Length\" header, it
--   should be larger than the 'gzipSizeThreshold'.
-- * The \"Content-Type\" response header's value should
--   evaluate to 'True' when applied to 'gzipCheckMime'
--   (though 'GzipPreCompressed' will use the \".gz\" file regardless
--   of MIME type on any 'ResponseFile' response)
--


-- $settings
--
-- If you would like to use the default settings, using just 'def' is enough.
-- The default settings don't compress file responses, only builder and stream
-- responses, and only if the response passes the MIME and length checks. (cf.
-- 'defaultCheckMime' and 'gzipSizeThreshold')
--
-- To customize your own settings, use the 'def' method and set the
-- fields you would like to change as follows:
--
-- @
-- myGzipSettings :: 'GzipSettings'
-- myGzipSettings =
--   'def'
--     { 'gzipFiles' = 'GzipCompress'
--     , 'gzipCheckMime' = myMimeCheckFunction
--     , 'gzipSizeThreshold' = 860
--     }
-- @

data GzipSettings = GzipSettings
    { -- | Gzip behavior for files
      --
      -- Only applies to 'ResponseFile' ('responseFile') responses.
      -- So any streamed data will be compressed based solely on the
      -- response headers having the right \"Content-Type\" and
      -- \"Content-Length\". (which are checked with 'gzipCheckMime'
      -- and 'gzipSizeThreshold', respectively)
      GzipSettings -> GzipFiles
gzipFiles :: GzipFiles
      -- | Decide which files to compress based on MIME type
      --
      -- The 'S.ByteString' is the value of the \"Content-Type\" response
      -- header and will default to 'False' if the header is missing.
      --
      -- E.g. if you'd only want to compress @json@ data, you might
      -- define your own function as follows:
      --
      -- > myCheckMime mime = mime == "application/json"
    , GzipSettings -> ByteString -> Bool
gzipCheckMime :: S.ByteString -> Bool
      -- | Skip compression when the size of the response body is
      -- below this amount of bytes (default: 860.)
      --
      -- /Setting this option to less than 150 will actually increase/
      -- /the size of outgoing data if its original size is less than 150 bytes/.
      --
      -- This will only skip compression if the response includes a
      -- \"Content-Length\" header /AND/ the length is less than this
      -- threshold.
    , GzipSettings -> Integer
gzipSizeThreshold :: Integer
    }

-- | Gzip behavior for files.
data GzipFiles
    = -- | Do not compress file ('ResponseFile') responses.
      -- Any 'ResponseBuilder' or 'ResponseStream' might still be compressed.
      GzipIgnore
    | -- | Compress files. Note that this may counteract
      -- zero-copy response optimizations on some platforms.
      GzipCompress
    | -- | Compress files, caching the compressed version in the given directory.
      GzipCacheFolder FilePath
    | -- | Takes the ETag response header into consideration when caching
      -- files in the given folder. If there's no ETag header,
      -- this setting is equivalent to 'GzipCacheFolder'.
      --
      -- N.B. Make sure the 'gzip' middleware is applied before
      -- any 'Middleware' that will set the ETag header.
      --
      -- @since 3.1.12
      GzipCacheETag FilePath
    | -- | 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
      GzipPreCompressed GzipFiles
    deriving (Int -> GzipFiles -> ShowS
[GzipFiles] -> ShowS
GzipFiles -> String
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
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]
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)

-- $miscellaneous
--
-- 'def' is re-exported for convenience sake, and 'defaultCheckMime'
-- is exported in case anyone wants to use it in defining their own
-- 'gzipCheckMime' function.

-- | Use default MIME settings; /do not/ compress files; skip
-- compression on data smaller than 860 bytes.
instance Default GzipSettings where
    def :: GzipSettings
def = GzipFiles -> (ByteString -> Bool) -> Integer -> GzipSettings
GzipSettings GzipFiles
GzipIgnore ByteString -> Bool
defaultCheckMime Integer
minimumLength

-- | 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' forall a. Ord a => a -> Set a -> Bool
`Set.member` Set ByteString
toCompress
  where
    bs' :: ByteString
bs' = forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> (ByteString, ByteString)
S.break (forall a. Eq a => a -> a -> Bool
== Word8
_semicolon) ByteString
bs
    toCompress :: Set ByteString
toCompress = 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.
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
checkCompress 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 forall a. [a] -> [a] -> [a]
++ String
".gz"
                    in String -> IO Bool
doesFileExist String
compressedVersion forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
y ->
                        if Bool
y
                            then Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
ResponseFile Status
s (ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hs) String
compressedVersion forall a. Maybe a
Nothing
                            else (Response, GzipFiles) -> IO ResponseReceived
runAction (Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
ResponseFile Status
s ResponseHeaders
hs String
file forall a. Maybe a
Nothing, GzipFiles
nextAction)
                -- Skip if it's not a MIME type we want to compress
                (Response, GzipFiles)
_ | Bool -> Bool
not 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) ->
                    forall a.
Status
-> ResponseHeaders
-> String
-> Maybe ByteString
-> String
-> (Response -> IO a)
-> IO a
compressFile Status
s ResponseHeaders
hs String
file forall a. Maybe a
Nothing String
cache Response -> IO ResponseReceived
sendResponse
                -- Use static caching logic with "ETag" signatures
                (ResponseFile Status
s ResponseHeaders
hs String
file Maybe FilePart
Nothing, GzipCacheETag String
cache) ->
                    let mETag :: Maybe ByteString
mETag = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hETag ResponseHeaders
hs
                     in forall a.
Status
-> ResponseHeaders
-> String
-> Maybe ByteString
-> String
-> (Response -> IO a)
-> IO a
compressFile Status
s ResponseHeaders
hs String
file Maybe ByteString
mETag 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 =
        forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (GzipSettings -> ByteString -> Bool
gzipCheckMime GzipSettings
set) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType
    sendResponse :: Response -> IO ResponseReceived
sendResponse = Response -> IO ResponseReceived
sendResponse' forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseHeaders -> ResponseHeaders) -> Response -> Response
mapResponseHeaders ResponseHeaders -> ResponseHeaders
mAddVary
    acceptEncoding :: ByteString
acceptEncoding   = ByteString
"Accept-Encoding"
    acceptEncodingLC :: ByteString
acceptEncodingLC = ByteString
"accept-encoding"
    -- Instead of just adding a header willy-nilly, we check if
    -- "Vary" is already present, and add to it if not already included.
    mAddVary :: ResponseHeaders -> ResponseHeaders
mAddVary [] = [(HeaderName
hVary, ByteString
acceptEncoding)]
    mAddVary (h :: (HeaderName, ByteString)
h@(HeaderName
nm, ByteString
val) : ResponseHeaders
hs)
        | HeaderName
nm forall a. Eq a => a -> a -> Bool
== HeaderName
hVary =
            let vals :: [ByteString]
vals = ByteString -> [ByteString]
splitCommas ByteString
val
                lowercase :: ByteString -> ByteString
lowercase = (Word8 -> Word8) -> ByteString -> ByteString
S.map Word8 -> Word8
W8.toLower
                -- Field names are case-insensitive, so we lowercase to match
                hasAccEnc :: Bool
hasAccEnc = ByteString
acceptEncodingLC forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
lowercase [ByteString]
vals
                newH :: (HeaderName, ByteString)
newH | Bool
hasAccEnc = (HeaderName, ByteString)
h
                     | Bool
otherwise = (HeaderName
hVary, ByteString
acceptEncoding forall a. Semigroup a => a -> a -> a
<> ByteString
", " forall a. Semigroup a => a -> a -> a
<> ByteString
val)
             in (HeaderName, ByteString)
newH forall a. a -> [a] -> [a]
: ResponseHeaders
hs
        | Bool
otherwise = (HeaderName, ByteString)
h forall a. a -> [a] -> [a]
: ResponseHeaders -> ResponseHeaders
mAddVary ResponseHeaders
hs

    -- 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 =
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall {a} {a}.
(IsString a, Eq a, Eq a, Num a) =>
(a, Maybe a) -> Bool
isGzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, Maybe Int)]
parseQValueList) forall a b. (a -> b) -> a -> b
$ HeaderName
hAcceptEncoding forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ResponseHeaders
reqHdrs
        isGzip :: (a, Maybe a) -> Bool
isGzip (a
bs, Maybe a
q) =
            -- We skip if 'q' = Nothing, because it is malformed,
            -- or if it is 0, because that is an explicit "DO NOT USE GZIP"
            a
bs forall a. Eq a => a -> a -> Bool
== a
"gzip" Bool -> Bool -> Bool
&& forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (forall a. Eq a => a -> a -> Bool
/= a
0) Maybe a
q
        isMSIE6 :: Bool
isMSIE6 =
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (ByteString
"MSIE 6" ByteString -> ByteString -> Bool
`S.isInfixOf`) forall a b. (a -> b) -> a -> b
$ HeaderName
hUserAgent 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
continue Response
res =
        if Bool
isEncodedAlready Bool -> Bool -> Bool
|| Bool
isPartial Bool -> Bool -> Bool
|| Bool
tooSmall
            then Response -> IO ResponseReceived
sendResponse Response
res
            else Response -> IO ResponseReceived
continue Response
res
      where
        resHdrs :: ResponseHeaders
resHdrs = Response -> ResponseHeaders
responseHeaders Response
res
        -- Partial content should NEVER be compressed.
        isPartial :: Bool
isPartial = Status -> Int
statusCode (Response -> Status
responseStatus Response
res) forall a. Eq a => a -> a -> Bool
== Int
206
        isEncodedAlready :: Bool
isEncodedAlready = forall a. Maybe a -> Bool
isJust forall a b. (a -> b) -> a -> b
$ HeaderName
hContentEncoding forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` ResponseHeaders
resHdrs
        tooSmall :: Bool
tooSmall =
            forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                Bool
False -- This could be a streaming case
                (forall a. Ord a => a -> a -> Bool
< GzipSettings -> Integer
gzipSizeThreshold GzipSettings
set)
                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

compressFile :: Status -> [Header] -> FilePath -> Maybe S.ByteString -> FilePath -> (Response -> IO a) -> IO a
compressFile :: forall a.
Status
-> ResponseHeaders
-> String
-> Maybe ByteString
-> String
-> (Response -> IO a)
-> IO a
compressFile Status
s ResponseHeaders
hs String
file Maybe ByteString
mETag 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 <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$
                 forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withBinaryFile String
file IOMode
IO.ReadMode forall a b. (a -> b) -> a -> b
$ \Handle
inH ->
                 forall r. String -> IOMode -> (Handle -> IO r) -> IO r
IO.withBinaryFile String
tmpfile IOMode
IO.WriteMode forall a b. (a -> b) -> a -> b
$ \Handle
outH -> do
                    Deflate
deflate <- Int -> WindowBits -> IO Deflate
Z.initDeflate Int
7 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 = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                            PopperRes
res <- IO PopperRes
popper
                            case PopperRes
res of
                                PopperRes
Z.PRDone -> 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 -> forall e a. Exception e => e -> IO a
throwIO ZlibException
ex
                    forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                        ByteString
bs <- Handle -> Int -> IO ByteString
S.hGetSome Handle
inH Int
defaultChunkSize
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) forall a b. (a -> b) -> a -> b
$ do
                            Deflate -> ByteString -> IO (IO PopperRes)
Z.feedDeflate Deflate
deflate ByteString
bs forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO PopperRes -> IO ()
goPopper
                            IO ()
loop
                    IO PopperRes -> IO ()
goPopper forall a b. (a -> b) -> a -> b
$ Deflate -> IO PopperRes
Z.finishDeflate Deflate
deflate
            forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either SomeException -> IO a
onErr (forall a b. a -> b -> a
const IO a
onSucc) (Either SomeException ()
x :: Either SomeException ())
  where
    onSucc :: IO a
onSucc = Response -> IO a
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Status
s (ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hs) String
tmpfile forall a. Maybe a
Nothing
    reportError :: String -> IO ()
reportError String
err =
        Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr forall a b. (a -> b) -> a -> b
$
            String
"Network.Wai.Middleware.Gzip: compression failed: " forall a. Semigroup a => a -> a -> a
<> String
err
    onErr :: SomeException -> IO a
onErr SomeException
e
        -- Catching IOExceptions for file system / hardware oopsies
        | Just IOException
ioe <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
            String -> IO ()
reportError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (IOException
ioe :: IOException)
            Response -> IO a
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Status
s ResponseHeaders
hs String
file forall a. Maybe a
Nothing
        -- Catching ZlibExceptions for compression oopsies
        | Just ZlibException
zlibe <- forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
            String -> IO ()
reportError forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (ZlibException
zlibe :: Z.ZlibException)
            Response -> IO a
sendResponse forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> String -> Maybe FilePart -> Response
responseFile Status
s ResponseHeaders
hs String
file forall a. Maybe a
Nothing
        | Bool
otherwise = forall e a. Exception e => e -> IO a
throwIO SomeException
e

    -- If there's an ETag, use it as the suffix of the cached file.
    eTag :: String
eTag = forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" (forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
safe forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
trimWS) Maybe ByteString
mETag
    tmpfile :: String
tmpfile = String
cache forall a. [a] -> [a] -> [a]
++ Char
'/' forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
safe String
file forall a. [a] -> [a] -> [a]
++ String
eTag

    safe :: Char -> Char
safe Char
c
        | Char
'A' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'Z' = Char
c
        | Char
'a' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c forall a. Ord a => a -> a -> Bool
<= Char
'z' = Char
c
        | Char
'0' forall a. Ord a => a -> a -> Bool
<= Char
c Bool -> Bool -> Bool
&& Char
c 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 =
    forall {a}. (StreamingBody -> IO a) -> IO a
wb forall a b. (a -> b) -> a -> b
$ \StreamingBody
body -> Response -> IO ResponseReceived
sendResponse forall a b. (a -> b) -> a -> b
$
        Status -> ResponseHeaders -> StreamingBody -> Response
responseStream Status
s (ResponseHeaders -> ResponseHeaders
fixHeaders ResponseHeaders
hs) 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
                    forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                        ByteString
bs <- IO ByteString
popper
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
bs) 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 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 forall a b. (a -> b) -> a -> b
$ Deflate -> IO PopperRes
Z.flushDeflate Deflate
deflate
                    IO ()
flush
                deflatePopper :: IO PopperRes -> IO ()
deflatePopper IO PopperRes
popper = forall a. (a -> a) -> a
fix forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> do
                    PopperRes
result <- IO PopperRes
popper
                    case PopperRes
result of
                        PopperRes
Z.PRDone -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        Z.PRNext ByteString
bs' -> do
                            Builder -> IO ()
sendChunk forall a b. (a -> b) -> a -> b
$ ByteString -> Builder
byteString ByteString
bs'
                            IO ()
loop
                        Z.PRError ZlibException
e -> 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 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) = 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 -> ByteString -> ResponseHeaders -> ResponseHeaders
replaceHeader HeaderName
hContentEncoding ByteString
"gzip" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter forall {b}. (HeaderName, b) -> Bool
notLength
  where
    notLength :: (HeaderName, b) -> Bool
notLength (HeaderName
x, b
_) = HeaderName
x forall a. Eq a => a -> a -> Bool
/= HeaderName
hContentLength