{-# 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 :: 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' :: Set ByteString -> m a -> m ()
withCompression' Set ByteString
mimeTable m a
action = do
    a
_    <- m a
action
    Response
resp <- m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse

    -- If a content-encoding is already set, do nothing. This prevents
    -- "withCompression $ withCompression m" from ruining your day.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Maybe ByteString -> Bool
forall a. Maybe a -> Bool
isJust (Maybe ByteString -> Bool) -> Maybe ByteString -> Bool
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-Encoding" Response
resp) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
       let mbCt :: Maybe ByteString
mbCt = (ByteString -> ByteString) -> Maybe ByteString -> Maybe ByteString
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

       String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"withCompression', content-type is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> String
forall a. Show a => a -> String
show Maybe ByteString
mbCt

       case Maybe ByteString
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 (m :: * -> *) a. Monad m => a -> m a
return (() -> m ()) -> () -> m ()
forall a b. (a -> b) -> a -> b
$! ()


    m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse m Response -> (Response -> m ()) -> m ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Response -> m ()
forall (m :: * -> *) a. MonadSnap m => Response -> m a
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
        Request
req <- m Request
forall (m :: * -> *). MonadSnap m => m Request
getRequest
        String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"checking accept-encoding"
        let mbAcc :: Maybe ByteString
mbAcc = CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader CI ByteString
"Accept-Encoding" Request
req
        String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ String
"accept-encoding is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe ByteString -> String
forall a. Show a => a -> String
show Maybe ByteString
mbAcc
        let s :: ByteString
s = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"" Maybe ByteString
mbAcc

        [ByteString]
types <- IO [ByteString] -> m [ByteString]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [ByteString] -> m [ByteString])
-> IO [ByteString] -> m [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString -> IO [ByteString]
parseAcceptEncoding ByteString
s

        Maybe (m ()) -> [ByteString] -> m ()
forall (m :: * -> *) a.
(Eq a, IsString a, MonadSnap m) =>
Maybe (m ()) -> [a] -> m ()
chooseType Maybe (m ())
forall a. Maybe a
Nothing [ByteString]
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 (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 (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 (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 :: 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 :: 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 :: 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 (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 (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
    [ByteString]
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ([ByteString] -> Parser [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> Parser [ByteString])
-> [ByteString] -> Parser [ByteString]
forall a b. (a -> b) -> a -> b
$! [])
    [ByteString]
ys <- Parser ByteString ByteString -> Parser [ByteString]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many (Char -> Parser Char
char Char
',' Parser Char
-> Parser ByteString ByteString -> Parser ByteString ByteString
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ByteString ByteString
encoding)
    Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput
    [ByteString] -> Parser [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return ([ByteString] -> Parser [ByteString])
-> [ByteString] -> Parser [ByteString]
forall a b. (a -> b) -> a -> b
$! [ByteString]
xs [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ [ByteString]
ys
  where
    encoding :: Parser ByteString ByteString
encoding = Parser ByteString ()
skipSpace Parser ByteString ()
-> Parser ByteString ByteString -> Parser ByteString ByteString
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 (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ()
skipSpace

    c :: Parser ByteString ByteString
c = do
        ByteString
x <- Parser ByteString ByteString
coding
        Parser ByteString ()
qvalue Parser ByteString ()
-> Parser ByteString () -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (() -> Parser ByteString ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Parser ByteString ()) -> () -> Parser ByteString ()
forall a b. (a -> b) -> a -> b
$! ())
        ByteString -> Parser ByteString ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
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 (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 (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 (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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (() -> Parser ByteString ()
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 (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (() -> Parser ByteString ()
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 -> String
show BadAcceptEncodingException
BadAcceptEncodingException = String
"bad 'accept-encoding' header"


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


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