---------------------------------------------------------

---------------------------------------------------------

-- |
-- 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,
    defaultGzipSettings,
    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.Char (isAsciiLower, isAsciiUpper, isDigit)
import qualified Data.Default as Default (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, use 'defaultGzipSettings'.
-- 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 'defaultGzipSettings' and set the
-- fields you would like to change as follows:
--
-- @
-- myGzipSettings :: 'GzipSettings'
-- myGzipSettings =
--   'defaultGzipSettings'
--     { 'gzipFiles' = 'GzipCompress'
--     , 'gzipCheckMime' = myMimeCheckFunction
--     , 'gzipSizeThreshold' = 860
--     }
-- @

data GzipSettings = GzipSettings
    { GzipSettings -> GzipFiles
gzipFiles :: GzipFiles
    -- ^ 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 -> ByteString -> Bool
gzipCheckMime :: S.ByteString -> Bool
    -- ^ 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 -> Integer
gzipSizeThreshold :: Integer
    -- ^ 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.
    }

-- | 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
(Int -> GzipFiles -> ShowS)
-> (GzipFiles -> String)
-> ([GzipFiles] -> ShowS)
-> Show GzipFiles
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> GzipFiles -> ShowS
showsPrec :: Int -> GzipFiles -> ShowS
$cshow :: GzipFiles -> String
show :: GzipFiles -> String
$cshowList :: [GzipFiles] -> ShowS
showList :: [GzipFiles] -> ShowS
Show, GzipFiles -> GzipFiles -> Bool
(GzipFiles -> GzipFiles -> Bool)
-> (GzipFiles -> GzipFiles -> Bool) -> Eq GzipFiles
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GzipFiles -> GzipFiles -> Bool
== :: GzipFiles -> GzipFiles -> Bool
$c/= :: GzipFiles -> GzipFiles -> Bool
/= :: 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
$creadsPrec :: Int -> ReadS GzipFiles
readsPrec :: Int -> ReadS GzipFiles
$creadList :: ReadS [GzipFiles]
readList :: ReadS [GzipFiles]
$creadPrec :: ReadPrec GzipFiles
readPrec :: ReadPrec GzipFiles
$creadListPrec :: ReadPrec [GzipFiles]
readListPrec :: ReadPrec [GzipFiles]
Read)

-- $miscellaneous
--
-- 'defaultCheckMime' is exported in case anyone wants to use it in
-- defining their own 'gzipCheckMime' function.
-- 'def' has been re-exported for convenience sake, but its use is now
-- heavily discouraged. Please use the explicit 'defaultGzipSettings'.

-- | DO NOT USE THIS INSTANCE!
-- Please use 'defaultGzipSettings'.
--
-- This instance will be removed in a future major version.
instance Default.Default GzipSettings where
    def :: GzipSettings
def = GzipSettings
defaultGzipSettings

-- | Deprecated synonym for the 'defaultGzipSettings'.
def :: GzipSettings
def :: GzipSettings
def = GzipSettings
defaultGzipSettings
{-# Deprecated def "Please use 'defaultGzipSettings'. 'def' and the Default instance will be removed in a future major update." #-}

-- | Default settings for the 'gzip' middleware.
--
-- * Does not compress files.
-- * Uses 'defaultCheckMime'.
-- * Compession threshold set to 860 bytes.
--
-- @since 3.1.14.0
defaultGzipSettings :: GzipSettings
defaultGzipSettings :: GzipSettings
defaultGzipSettings = 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' 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.
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 a b. IO a -> (a -> IO b) -> IO b
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
-> Maybe ByteString
-> String
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
forall a.
Status
-> ResponseHeaders
-> String
-> Maybe ByteString
-> String
-> (Response -> IO a)
-> IO a
compressFile Status
s ResponseHeaders
hs String
file Maybe ByteString
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 = HeaderName -> ResponseHeaders -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hETag ResponseHeaders
hs
                     in Status
-> ResponseHeaders
-> String
-> Maybe ByteString
-> String
-> (Response -> IO ResponseReceived)
-> IO ResponseReceived
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 =
        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 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 HeaderName -> HeaderName -> Bool
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 ByteString -> [ByteString] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
", " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
val)
             in (HeaderName, ByteString)
newH (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
forall a. a -> [a] -> [a]
: ResponseHeaders
hs
        | Bool
otherwise = (HeaderName, ByteString)
h (HeaderName, ByteString) -> ResponseHeaders -> ResponseHeaders
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 =
            Bool -> (ByteString -> Bool) -> Maybe ByteString -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (((ByteString, Maybe Int) -> Bool)
-> [(ByteString, Maybe Int)] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ByteString, Maybe Int) -> Bool
forall {a} {a}.
(IsString a, Eq a, Eq a, Num a) =>
(a, Maybe a) -> Bool
isGzip ([(ByteString, Maybe Int)] -> Bool)
-> (ByteString -> [(ByteString, Maybe Int)]) -> ByteString -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [(ByteString, Maybe Int)]
parseQValueList) (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
        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 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
"gzip" Bool -> Bool -> Bool
&& Bool -> (a -> Bool) -> Maybe a -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (a -> a -> Bool
forall a. Eq a => a -> a -> Bool
/= a
0) Maybe a
q
        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
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) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
206
        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
        tooSmall :: Bool
tooSmall =
            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
< GzipSettings -> Integer
gzipSizeThreshold GzipSettings
set)
                (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

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 <- 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 a. a -> IO a
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 a b. IO a -> (a -> IO b) -> IO b
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
onErr (IO a -> () -> IO a
forall a b. a -> b -> a
const IO a
onSucc) (Either SomeException ()
x :: Either SomeException ())
  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
    reportError :: String -> IO ()
reportError String
err =
        Handle -> String -> IO ()
IO.hPutStrLn Handle
IO.stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
            String
"Network.Wai.Middleware.Gzip: compression failed: " String -> ShowS
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 <- SomeException -> Maybe IOException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
            String -> IO ()
reportError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ IOException -> String
forall a. Show a => a -> String
show (IOException
ioe :: IOException)
            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
        -- Catching ZlibExceptions for compression oopsies
        | Just ZlibException
zlibe <- SomeException -> Maybe ZlibException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e = do
            String -> IO ()
reportError (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ZlibException -> String
forall a. Show a => a -> String
show (ZlibException
zlibe :: Z.ZlibException)
            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
        | Bool
otherwise = SomeException -> IO a
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 = String -> (ByteString -> String) -> Maybe ByteString -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"" ((Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
safe ShowS -> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
S8.unpack (ByteString -> String)
-> (ByteString -> ByteString) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
trimWS) Maybe ByteString
mETag
    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 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
eTag

    safe :: Char -> Char
safe Char
c
        | Char -> Bool
isAsciiUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isAsciiLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c = 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 a b. IO a -> (a -> IO b) -> IO b
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 a. a -> IO a
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 -> ByteString -> ResponseHeaders -> ResponseHeaders
replaceHeader HeaderName
hContentEncoding ByteString
"gzip" (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