    {-# LANGUAGE BangPatterns              #-}
    {-# LANGUAGE CPP                       #-}
    {-# LANGUAGE DeriveDataTypeable        #-}
    {-# LANGUAGE ExistentialQuantification #-}
    {-# LANGUAGE OverloadedStrings         #-}
    {-# LANGUAGE ScopedTypeVariables       #-}

    --------------------------------------------------------------------------------
    -- | Helpers for running a 'Snap' web handler with compression.

    module Snap.Util.GZip
      ( withCompression
      , withCompression'
      , noCompression
      , BadAcceptEncodingException
      , compressibleMimeTypes
      ) where

    import           Control.Applicative              (Alternative ((<|>), many), Applicative ((*>), (<*), pure), (<$>))
    import           Control.Exception                (Exception, throwIO)
    import           Control.Monad                    (Functor (fmap), Monad ((>>), (>>=), return), MonadPlus (mplus), void, when)
    import           Control.Monad.IO.Class           (MonadIO (liftIO))
    import           Data.Attoparsec.ByteString.Char8 (Parser, char, endOfInput, isAlpha_ascii, isDigit, skipSpace, string, takeWhile, takeWhile1)
    import           Data.ByteString.Builder          (Builder)
    import           Data.ByteString.Char8            (ByteString)
    import qualified Data.ByteString.Char8            as S (takeWhile)
    import qualified Data.Char                        as Char (isSpace)
    import           Data.Maybe                       (Maybe (Just, Nothing), fromMaybe, isJust, maybe)
    import           Data.Set                         (Set)
    import qualified Data.Set                         as Set (fromList, member)
    import           Data.Typeable                    (Typeable)
    import           Prelude                          (Either (..), Eq (..), IO, Show (show), id, not, ($), ($!), (&&), (++), (||))
    import           Snap.Core                        (MonadSnap, clearContentLength, finishWith, getHeader, getRequest, getResponse, modifyResponse, modifyResponseBody, setHeader)
    import           Snap.Internal.Debug              (debug)
    import           Snap.Internal.Parsing            (fullyParse)
    import           System.IO.Streams                (OutputStream)
    import qualified System.IO.Streams                as Streams (compressBuilder, gzipBuilder)

    ------------------------------------------------------------------------------
    -- | Runs a 'Snap' web handler with compression if available.
    --
    -- If the client has indicated support for @gzip@ or @deflate@ in its
    -- @Accept-Encoding@ header, and the @Content-Type@ in the response is one of
    -- the following types:
    --
    --   * @application/x-javascript@
    --
    --   * @application/json@
    --
    --   * @text/css@
    --
    --   * @text/html@
    --
    --   * @text/javascript@
    --
    --   * @text/plain@
    --
    --   * @text/xml@
    --
    --   * @application/x-font-truetype@
    --
    -- Then the given handler's output stream will be compressed,
    -- @Content-Encoding@ will be set in the output headers, and the
    -- @Content-Length@ will be cleared if it was set. (We can't process the
    -- stream in O(1) space if the length is known beforehand.)
    --
    -- The wrapped handler will be run to completion, and then the 'Response'
    -- that's contained within the 'Snap' monad state will be passed to
    -- 'finishWith' to prevent further processing.
    --
    --
    -- Example:
    --
    -- @
    -- ghci> :set -XOverloadedStrings
    -- ghci> import qualified "Data.Map" as M
    -- ghci> import qualified "Snap.Test" as T
    -- ghci> let r = T.get \"/\" M.empty >> T.addHeader \"Accept-Encoding\" \"gzip,deflate\"
    -- ghci> let h = 'Snap.Core.modifyResponse' ('Snap.Core.setContentType' \"text\/plain\") >> 'Snap.Core.writeBS' \"some text\"
    -- ghci> T.runHandler r h
    -- HTTP\/1.1 200 OK
    -- content-type: text\/plain
    -- server: Snap\/test
    -- date: Fri, 08 Aug 2014 15:40:45 GMT
    --
    -- some text
    -- ghci> T.runHandler r ('withCompression' h)
    -- HTTP\/1.1 200 OK
    -- content-type: text\/plain
    -- vary: Accept-Encoding
    -- content-encoding: gzip
    -- server: Snap\/test
    -- date: Fri, 08 Aug 2014 15:40:10 GMT
    --
    --
    -- @
    withCompression :: MonadSnap m
                    => m a   -- ^ the web handler to run
                    -> m ()
    withCompression :: forall (m :: * -> *) a. MonadSnap m => m a -> m ()
    withCompression = Set ByteString -> m a -> m ()
    forall (m :: * -> *) a.
    MonadSnap m =>
    Set ByteString -> m a -> m ()
    withCompression' Set ByteString
    compressibleMimeTypes

    ------------------------------------------------------------------------------
    -- | The same as 'withCompression', with control over which MIME types to
    -- compress.
    withCompression' :: MonadSnap m
                     => Set ByteString
                        -- ^ set of compressible MIME types
                     -> m a
                        -- ^ the web handler to run
                     -> m ()
    withCompression' :: forall (m :: * -> *) a.
    MonadSnap m =>
    Set ByteString -> m a -> m ()
    withCompression' Set ByteString
    mimeTable m a
    action = do
        _    <- m a
    action
        resp <- getResponse

        -- If a content-encoding is already set, do nothing. This prevents
        -- "withCompression $ withCompression m" from ruining your day.
        when (not $ isJust $ getHeader "Content-Encoding" resp) $ do
           let mbCt = (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap ByteString -> ByteString
    chop (Maybe ByteString -> Maybe ByteString)
    -> Maybe ByteString -> Maybe ByteString
    forall a b. (a -> b) -> a -> b
    $ CI ByteString -> Response -> Maybe ByteString
    forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
    getHeader CI ByteString
    "Content-Type" Response
    resp

           debug $ "withCompression', content-type is " ++ show mbCt

           case mbCt of
             (Just ByteString
    ct) -> Bool -> m () -> m ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    when (ByteString -> Set ByteString -> Bool
    forall a. Ord a => a -> Set a -> Bool
    Set.member ByteString
    ct Set ByteString
    mimeTable) m ()
    chkAcceptEncoding
             Maybe ByteString
    _         -> () -> m ()
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> m ()) -> () -> m ()
    forall a b. (a -> b) -> a -> b
    $! ()

        getResponse >>= finishWith

      where
        chop :: ByteString -> ByteString
    chop = (Char -> Bool) -> ByteString -> ByteString
    S.takeWhile (\Char
    c -> Char
    c Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    /= Char
    ';' Bool -> Bool -> Bool
    && Bool -> Bool
    not (Char -> Bool
    Char.isSpace Char
    c))

        chkAcceptEncoding :: m ()
    chkAcceptEncoding = do
            req <- m Request
    forall (m :: * -> *). MonadSnap m => m Request
    getRequest
            debug $ "checking accept-encoding"
            let mbAcc = CI ByteString -> Request -> Maybe ByteString
    forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
    getHeader CI ByteString
    "Accept-Encoding" Request
    req
            debug $ "accept-encoding is " ++ show mbAcc
            let s = ByteString -> Maybe ByteString -> ByteString
    forall a. a -> Maybe a -> a
    fromMaybe ByteString
    "" Maybe ByteString
    mbAcc

            types <- liftIO $ parseAcceptEncoding s

            chooseType Nothing types

        chooseType :: Maybe (m ()) -> [a] -> m ()
    chooseType !Maybe (m ())
    m []               = m () -> (m () -> m ()) -> Maybe (m ()) -> m ()
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe (() -> m ()
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> m ()) -> () -> m ()
    forall a b. (a -> b) -> a -> b
    $! ()) m () -> m ()
    forall a. a -> a
    id Maybe (m ())
    m
        chooseType !Maybe (m ())
    _ (a
    "gzip":[a]
    _)       = ByteString -> m ()
    forall (m :: * -> *). MonadSnap m => ByteString -> m ()
    gzipCompression ByteString
    "gzip"
        chooseType !Maybe (m ())
    m (a
    "deflate":[a]
    xs)   =
            Maybe (m ()) -> [a] -> m ()
    chooseType (Maybe (m ())
    m Maybe (m ()) -> Maybe (m ()) -> Maybe (m ())
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` m () -> Maybe (m ())
    forall a. a -> Maybe a
    Just (ByteString -> m ()
    forall (m :: * -> *). MonadSnap m => ByteString -> m ()
    compressCompression ByteString
    "deflate")) [a]
    xs

        chooseType !Maybe (m ())
    _ (a
    "x-gzip":[a]
    _)     = ByteString -> m ()
    forall (m :: * -> *). MonadSnap m => ByteString -> m ()
    gzipCompression ByteString
    "x-gzip"
        chooseType !Maybe (m ())
    m (a
    "x-deflate":[a]
    xs) =
            Maybe (m ()) -> [a] -> m ()
    chooseType (Maybe (m ())
    m Maybe (m ()) -> Maybe (m ()) -> Maybe (m ())
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
    `mplus` m () -> Maybe (m ())
    forall a. a -> Maybe a
    Just (ByteString -> m ()
    forall (m :: * -> *). MonadSnap m => ByteString -> m ()
    compressCompression ByteString
    "x-deflate")) [a]
    xs
        chooseType !Maybe (m ())
    m (a
    _:[a]
    xs)           = Maybe (m ()) -> [a] -> m ()
    chooseType Maybe (m ())
    m [a]
    xs

    ------------------------------------------------------------------------------
    -- | Turn off compression by setting \"Content-Encoding: identity\" in the
    -- response headers. 'withCompression' is a no-op when a content-encoding is
    -- already set.
    noCompression :: MonadSnap m => m ()
    noCompression :: forall (m :: * -> *). MonadSnap m => m ()
    noCompression = (Response -> Response) -> m ()
    forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
    modifyResponse ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
    forall a b. (a -> b) -> a -> b
    $ CI ByteString -> ByteString -> Response -> Response
    forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
    setHeader CI ByteString
    "Content-Encoding" ByteString
    "identity"

    ------------------------------------------------------------------------------
    -- private following
    ------------------------------------------------------------------------------

    ------------------------------------------------------------------------------
    compressibleMimeTypes :: Set ByteString
    compressibleMimeTypes :: Set ByteString
    compressibleMimeTypes = [ByteString] -> Set ByteString
    forall a. Ord a => [a] -> Set a
    Set.fromList [ ByteString
    "application/x-font-truetype"
                                         , ByteString
    "application/x-javascript"
                                         , ByteString
    "application/json"
                                         , ByteString
    "text/css"
                                         , ByteString
    "text/html"
                                         , ByteString
    "text/javascript"
                                         , ByteString
    "text/plain"
                                         , ByteString
    "text/xml" ]

    ------------------------------------------------------------------------------
    gzipCompression :: MonadSnap m => ByteString -> m ()
    gzipCompression :: forall (m :: * -> *). MonadSnap m => ByteString -> m ()
    gzipCompression ByteString
    ce = (Response -> Response) -> m ()
    forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
    modifyResponse Response -> Response
    f
      where
        f :: Response -> Response
    f Response
    r = CI ByteString -> ByteString -> Response -> Response
    forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
    setHeader CI ByteString
    "Content-Encoding" ByteString
    ce    (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $
              CI ByteString -> ByteString -> Response -> Response
    forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
    setHeader CI ByteString
    "Vary" ByteString
    "Accept-Encoding" (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $
              Response -> Response
    clearContentLength                 (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $
              ((OutputStream Builder -> IO (OutputStream Builder))
     -> OutputStream Builder -> IO (OutputStream Builder))
    -> Response -> Response
    modifyResponseBody (OutputStream Builder -> IO (OutputStream Builder))
    -> OutputStream Builder -> IO (OutputStream Builder)
    gcompress Response
    r

    ------------------------------------------------------------------------------
    compressCompression :: MonadSnap m => ByteString -> m ()
    compressCompression :: forall (m :: * -> *). MonadSnap m => ByteString -> m ()
    compressCompression ByteString
    ce = (Response -> Response) -> m ()
    forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
    modifyResponse Response -> Response
    f
      where
        f :: Response -> Response
    f Response
    r = CI ByteString -> ByteString -> Response -> Response
    forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
    setHeader CI ByteString
    "Content-Encoding" ByteString
    ce    (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $
              CI ByteString -> ByteString -> Response -> Response
    forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
    setHeader CI ByteString
    "Vary" ByteString
    "Accept-Encoding" (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $
              Response -> Response
    clearContentLength                 (Response -> Response) -> Response -> Response
    forall a b. (a -> b) -> a -> b
    $
              ((OutputStream Builder -> IO (OutputStream Builder))
     -> OutputStream Builder -> IO (OutputStream Builder))
    -> Response -> Response
    modifyResponseBody (OutputStream Builder -> IO (OutputStream Builder))
    -> OutputStream Builder -> IO (OutputStream Builder)
    ccompress Response
    r

    ------------------------------------------------------------------------------
    gcompress :: (OutputStream Builder -> IO (OutputStream Builder))
              -> OutputStream Builder
              -> IO (OutputStream Builder)
    gcompress :: (OutputStream Builder -> IO (OutputStream Builder))
    -> OutputStream Builder -> IO (OutputStream Builder)
    gcompress OutputStream Builder -> IO (OutputStream Builder)
    body OutputStream Builder
    stream = CompressionLevel
    -> OutputStream Builder -> IO (OutputStream Builder)
    Streams.gzipBuilder CompressionLevel
    5 OutputStream Builder
    stream IO (OutputStream Builder)
    -> (OutputStream Builder -> IO (OutputStream Builder))
    -> IO (OutputStream Builder)
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= OutputStream Builder -> IO (OutputStream Builder)
    body

    ------------------------------------------------------------------------------
    ccompress :: (OutputStream Builder -> IO (OutputStream Builder))
              -> OutputStream Builder
              -> IO (OutputStream Builder)
    ccompress :: (OutputStream Builder -> IO (OutputStream Builder))
    -> OutputStream Builder -> IO (OutputStream Builder)
    ccompress OutputStream Builder -> IO (OutputStream Builder)
    body OutputStream Builder
    stream = CompressionLevel
    -> OutputStream Builder -> IO (OutputStream Builder)
    Streams.compressBuilder CompressionLevel
    5 OutputStream Builder
    stream IO (OutputStream Builder)
    -> (OutputStream Builder -> IO (OutputStream Builder))
    -> IO (OutputStream Builder)
    forall a b. IO a -> (a -> IO b) -> IO b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= OutputStream Builder -> IO (OutputStream Builder)
    body

    ------------------------------------------------------------------------------
    -- We're not gonna bother with quality values; we'll do gzip or compress in
    -- that order.
    acceptParser :: Parser [ByteString]
    acceptParser :: Parser [ByteString]
    acceptParser = do
        xs <- ((ByteString -> [ByteString] -> [ByteString]
    forall a. a -> [a] -> [a]
    :[]) (ByteString -> [ByteString])
    -> Parser ByteString ByteString -> Parser [ByteString]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> Parser ByteString ByteString
    encoding) Parser [ByteString] -> Parser [ByteString] -> Parser [ByteString]
    forall a.
    Parser ByteString a -> Parser ByteString a -> Parser ByteString a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> ([ByteString] -> Parser [ByteString]
    forall a. a -> Parser ByteString a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([ByteString] -> Parser [ByteString])
    -> [ByteString] -> Parser [ByteString]
    forall a b. (a -> b) -> a -> b
    $! [])
        ys <- many (char ',' *> encoding)
        endOfInput
        return $! xs ++ ys
      where
        encoding :: Parser ByteString ByteString
    encoding = Parser ByteString ()
    skipSpace Parser ByteString ()
    -> Parser ByteString ByteString -> Parser ByteString ByteString
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
    *> Parser ByteString ByteString
    c Parser ByteString ByteString
    -> Parser ByteString () -> Parser ByteString ByteString
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString a
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
    <* Parser ByteString ()
    skipSpace

        c :: Parser ByteString ByteString
    c = do
            x <- Parser ByteString ByteString
    coding
            qvalue <|> (return $! ())
            return x

        qvalue :: Parser ByteString ()
    qvalue = do
            Parser ByteString ()
    skipSpace
            Parser Char -> Parser ByteString ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (Parser Char -> Parser ByteString ())
    -> Parser Char -> Parser ByteString ()
    forall a b. (a -> b) -> a -> b
    $! Char -> Parser Char
    char Char
    ';'
            Parser ByteString ()
    skipSpace
            Parser Char -> Parser ByteString ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (Parser Char -> Parser ByteString ())
    -> Parser Char -> Parser ByteString ()
    forall a b. (a -> b) -> a -> b
    $! Char -> Parser Char
    char Char
    'q'
            Parser ByteString ()
    skipSpace
            Parser Char -> Parser ByteString ()
    forall (f :: * -> *) a. Functor f => f a -> f ()
    void (Parser Char -> Parser ByteString ())
    -> Parser Char -> Parser ByteString ()
    forall a b. (a -> b) -> a -> b
    $! Char -> Parser Char
    char Char
    '='
            Parser ByteString ()
    float
            () -> Parser ByteString ()
    forall a. a -> Parser ByteString a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (() -> Parser ByteString ()) -> () -> Parser ByteString ()
    forall a b. (a -> b) -> a -> b
    $! ()

        coding :: Parser ByteString ByteString
    coding = ByteString -> Parser ByteString ByteString
    string ByteString
    "*" Parser ByteString ByteString
    -> Parser ByteString ByteString -> Parser ByteString ByteString
    forall a.
    Parser ByteString a -> Parser ByteString a -> Parser ByteString a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> (Char -> Bool) -> Parser ByteString ByteString
    takeWhile1 Char -> Bool
    isCodingChar

        isCodingChar :: Char -> Bool
    isCodingChar Char
    ch = Char -> Bool
    isDigit Char
    ch Bool -> Bool -> Bool
    || Char -> Bool
    isAlpha_ascii Char
    ch Bool -> Bool -> Bool
    || Char
    ch Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '-' Bool -> Bool -> Bool
    || Char
    ch Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '_'

        float :: Parser ByteString ()
    float = (Char -> Bool) -> Parser ByteString ByteString
    takeWhile Char -> Bool
    isDigit Parser ByteString ByteString
    -> Parser ByteString () -> Parser ByteString ()
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >>
                (Char -> Parser Char
    char Char
    '.' Parser Char
    -> Parser ByteString ByteString -> Parser ByteString ByteString
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (Char -> Bool) -> Parser ByteString ByteString
    takeWhile Char -> Bool
    isDigit Parser ByteString ByteString
    -> Parser ByteString () -> Parser ByteString ()
    forall a b.
    Parser ByteString a -> Parser ByteString b -> Parser ByteString b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> (() -> Parser ByteString ()
    forall a. a -> Parser ByteString a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (() -> Parser ByteString ()) -> () -> Parser ByteString ()
    forall a b. (a -> b) -> a -> b
    $! ())) Parser ByteString ()
    -> Parser ByteString () -> Parser ByteString ()
    forall a.
    Parser ByteString a -> Parser ByteString a -> Parser ByteString a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> (() -> Parser ByteString ()
    forall a. a -> Parser ByteString a
    forall (f :: * -> *) a. Applicative f => a -> f a
    pure (() -> Parser ByteString ()) -> () -> Parser ByteString ()
    forall a b. (a -> b) -> a -> b
    $! ())

    ------------------------------------------------------------------------------
    -- | Thrown when the 'Accept-Encoding' request header has invalid format.
    data BadAcceptEncodingException = BadAcceptEncodingException
       deriving (Typeable)

    ------------------------------------------------------------------------------
    instance Show BadAcceptEncodingException where
        show :: BadAcceptEncodingException -> [Char]
    show BadAcceptEncodingException
    BadAcceptEncodingException = [Char]
    "bad 'accept-encoding' header"

    ------------------------------------------------------------------------------
    instance Exception BadAcceptEncodingException

    ------------------------------------------------------------------------------
    parseAcceptEncoding :: ByteString -> IO [ByteString]
    parseAcceptEncoding :: ByteString -> IO [ByteString]
    parseAcceptEncoding ByteString
    s =
        case Either [Char] [ByteString]
    r of
          Left [Char]
    _ -> BadAcceptEncodingException -> IO [ByteString]
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO BadAcceptEncodingException
    BadAcceptEncodingException
          Right [ByteString]
    x -> [ByteString] -> IO [ByteString]
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ByteString]
    x
      where
        r :: Either [Char] [ByteString]
    r = ByteString -> Parser [ByteString] -> Either [Char] [ByteString]
    forall a. ByteString -> Parser a -> Either [Char] a
    fullyParse ByteString
    s Parser [ByteString]
    acceptParser