{-# LANGUAGE CPP,NoMonomorphismRestriction, FlexibleContexts #-}
-- | Filter for compressing the 'Response' body.
module Happstack.Server.Internal.Compression
    ( compressedResponseFilter
    , compressedResponseFilter'
    , compressWithFilter
    , gzipFilter
    , deflateFilter
    , identityFilter
    , starFilter
    , encodings
    , standardEncodingHandlers
    ) where
import Happstack.Server.SimpleHTTP
import Text.ParserCombinators.Parsec
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail (MonadFail)
#endif
import Data.Maybe
import Data.List
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Codec.Compression.GZip as GZ
import qualified Codec.Compression.Zlib as Z

-- | reads the @Accept-Encoding@ header.  Then, if possible
-- will compress the response body with methods @gzip@ or @deflate@.
--
-- This function uses 'standardEncodingHandlers'. If you want to
-- provide alternative handers (perhaps to change compression levels),
-- see 'compressedResponseFilter''
--
-- > main =
-- >   simpleHTTP nullConf $
-- >      do str <- compressedResponseFilter
-- >         return $ toResponse ("This response compressed using: " ++ str)
compressedResponseFilter :: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m) =>
                            m String -- ^ name of the encoding chosen
compressedResponseFilter :: m String
compressedResponseFilter = [(String, String -> Bool -> m ())] -> m String
forall (m :: * -> *).
(FilterMonad Response m, MonadPlus m, WebMonad Response m,
 ServerMonad m, MonadFail m) =>
[(String, String -> Bool -> m ())] -> m String
compressedResponseFilter' [(String, String -> Bool -> m ())]
forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
[(String, String -> Bool -> m ())]
standardEncodingHandlers

-- | reads the @Accept-Encoding@ header.  Then, if possible
-- will compress the response body using one of the supplied filters.
--
-- A filter function takes two arguments. The first is a 'String' with
-- the value to be used as the 'Content-Encoding' header. The second
-- is 'Bool' which indicates if the compression filter is allowed to
-- fallback to @identity@.
--
-- This is important if the resource being sent using sendfile, since
-- sendfile does not provide a compression option. If @identity@ is
-- allowed, then the file can be sent uncompressed using sendfile. But
-- if @identity@ is not allowed, then the filter will need to return
-- error 406.
--
-- You should probably always include the @identity@ and @*@ encodings
-- as acceptable.
--
-- > myFilters :: (FilterMonad Response m) => [(String, String -> Bool -> m ()]
-- > myFilters = [ ("gzip"    , gzipFilter)
-- >             , ("identity", identityFilter)
-- >             , ("*"       , starFilter)
-- >             ]
-- >
-- > main =
-- >   simpleHTTP nullConf $
-- >      do let filters =
-- > str <- compressedResponseFilter'
-- >         return $ toResponse ("This response compressed using: " ++ str)
compressedResponseFilter' ::
    (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m, MonadFail m)
    => [(String, String -> Bool -> m ())]  -- ^ compression filter assoc list
    -> m String                            -- ^ name of the encoding chosen
compressedResponseFilter' :: [(String, String -> Bool -> m ())] -> m String
compressedResponseFilter' [(String, String -> Bool -> m ())]
encodingHandlers = do
    String -> m (Maybe ByteString)
forall (m :: * -> *).
ServerMonad m =>
String -> m (Maybe ByteString)
getHeaderM String
"Accept-Encoding" m (Maybe ByteString) -> (Maybe ByteString -> m String) -> m String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
        (m String
-> (ByteString -> m String) -> Maybe ByteString -> m String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
"identity") ByteString -> m String
installHandler)

  where
    badEncoding :: String
badEncoding = String
"Encoding returned not in the list of known encodings"

    installHandler :: ByteString -> m String
installHandler ByteString
accept = do
      let eEncoding :: Either String [String]
eEncoding = [String] -> String -> Either String [String]
bestEncoding (((String, String -> Bool -> m ()) -> String)
-> [(String, String -> Bool -> m ())] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, String -> Bool -> m ()) -> String
forall a b. (a, b) -> a
fst [(String, String -> Bool -> m ())]
encodingHandlers) (String -> Either String [String])
-> String -> Either String [String]
forall a b. (a -> b) -> a -> b
$ ByteString -> String
BS.unpack ByteString
accept
      (String
coding, Bool
identityAllowed, String -> Bool -> m ()
action) <- case Either String [String]
eEncoding of
          Left String
_ -> do
            Int -> m ()
forall (m :: * -> *). FilterMonad Response m => Int -> m ()
setResponseCode Int
406
            Response -> m (String, Bool, String -> Bool -> m ())
forall a (m :: * -> *) b. WebMonad a m => a -> m b
finishWith (Response -> m (String, Bool, String -> Bool -> m ()))
-> Response -> m (String, Bool, String -> Bool -> m ())
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse String
""

          Right encs :: [String]
encs@(String
a:[String]
_) -> (String, Bool, String -> Bool -> m ())
-> m (String, Bool, String -> Bool -> m ())
forall (m :: * -> *) a. Monad m => a -> m a
return (String
a
                                     , String
"identity" String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
encs
                                     , (String -> Bool -> m ())
-> Maybe (String -> Bool -> m ()) -> String -> Bool -> m ()
forall a. a -> Maybe a -> a
fromMaybe (\ String
_ Bool
_ -> String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
badEncoding)
                                          (String
-> [(String, String -> Bool -> m ())]
-> Maybe (String -> Bool -> m ())
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
a [(String, String -> Bool -> m ())]
encodingHandlers)
                                     )
          Right [] -> String -> m (String, Bool, String -> Bool -> m ())
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
badEncoding
      String -> Bool -> m ()
action String
coding Bool
identityAllowed
      String -> m String
forall (m :: * -> *) a. Monad m => a -> m a
return String
coding

-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response with @gzip@.
--
-- calls 'compressWithFilter' using 'GZ.compress'.
--
-- see also: 'compressedResponseFilter'
gzipFilter::(FilterMonad Response m) =>
            String -- ^ encoding to use for Content-Encoding header
          -> Bool   -- ^ fallback to identity for SendFile
          -> m ()
gzipFilter :: String -> Bool -> m ()
gzipFilter = (ByteString -> ByteString) -> String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
GZ.compress

-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt compress the body of the response with zlib's
-- @deflate@ method
--
-- calls 'compressWithFilter' using 'Z.compress'.
--
-- see also: 'compressedResponseFilter'
deflateFilter::(FilterMonad Response m) =>
               String -- ^ encoding to use for Content-Encoding header
             -> Bool   -- ^ fallback to identity for SendFile
             -> m ()
deflateFilter :: String -> Bool -> m ()
deflateFilter = (ByteString -> ByteString) -> String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
Z.compress

-- | compression filter for the identity encoding (aka, do nothing)
--
-- see also: 'compressedResponseFilter'
identityFilter :: (FilterMonad Response m) =>
                  String  -- ^ encoding to use for Content-Encoding header
               -> Bool    -- ^ fallback to identity for SendFile (irrelavant for this filter)
               -> m ()
identityFilter :: String -> Bool -> m ()
identityFilter = (ByteString -> ByteString) -> String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
(ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
forall a. a -> a
id

-- | compression filter for the * encoding
--
-- This filter always fails.
starFilter :: (FilterMonad Response m, MonadFail m) =>
              String  -- ^ encoding to use for Content-Encoding header
           -> Bool    -- ^ fallback to identity for SendFile (irrelavant for this filter)
           -> m ()
starFilter :: String -> Bool -> m ()
starFilter String
_ Bool
_ = String -> m ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"chose * as content encoding"

-- | Ignore the @Accept-Encoding@ header in the 'Request' and attempt to compress the body of the response using the supplied compressor.
--
-- We can not compress files being transfered using 'SendFile'. If
-- @identity@ is an allowed encoding, then just return the 'Response'
-- unmodified. Otherwise we return @406 Not Acceptable@.
--
-- see also: 'gzipFilter', 'deflateFilter', 'identityFilter', 'starFilter', 'compressedResponseFilter''
compressWithFilter :: (FilterMonad Response m) =>
                      (L.ByteString -> L.ByteString) -- ^ function to compress the body
                   -> String -- ^ encoding to use for Content-Encoding header
                   -> Bool   -- ^ fallback to identity for SendFile
                   -> m ()
compressWithFilter :: (ByteString -> ByteString) -> String -> Bool -> m ()
compressWithFilter ByteString -> ByteString
compressor String
encoding Bool
identityAllowed =
    (Response -> Response) -> m ()
forall a (m :: * -> *). FilterMonad a m => (a -> a) -> m ()
composeFilter ((Response -> Response) -> m ()) -> (Response -> Response) -> m ()
forall a b. (a -> b) -> a -> b
$ \Response
r ->
        case Response
r of
          Response{} -> String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Content-Encoding" String
encoding          (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
                        String -> String -> Response -> Response
forall r. HasHeaders r => String -> String -> r -> r
setHeader String
"Vary"             String
"Accept-Encoding" (Response -> Response) -> Response -> Response
forall a b. (a -> b) -> a -> b
$
                         Response
r {rsBody :: ByteString
rsBody = ByteString -> ByteString
compressor (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Response -> ByteString
rsBody Response
r}
          Response
_ | Bool
identityAllowed -> Response
r
            | Bool
otherwise       -> (String -> Response
forall a. ToMessage a => a -> Response
toResponse String
"") { rsCode :: Int
rsCode = Int
406 }

-- | based on the rules describe in rfc2616 sec. 14.3
bestEncoding :: [String] -> String -> Either String [String]
bestEncoding :: [String] -> String -> Either String [String]
bestEncoding [String]
availableEncodings String
encs = do
        [(String, Maybe Double)]
encList<-(ParseError -> Either String [(String, Maybe Double)])
-> ([(String, Maybe Double)]
    -> Either String [(String, Maybe Double)])
-> Either ParseError [(String, Maybe Double)]
-> Either String [(String, Maybe Double)]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String [(String, Maybe Double)]
forall a b. a -> Either a b
Left (String -> Either String [(String, Maybe Double)])
-> (ParseError -> String)
-> ParseError
-> Either String [(String, Maybe Double)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseError -> String
forall a. Show a => a -> String
show) ([(String, Maybe Double)] -> Either String [(String, Maybe Double)]
forall a b. b -> Either a b
Right) (Either ParseError [(String, Maybe Double)]
 -> Either String [(String, Maybe Double)])
-> Either ParseError [(String, Maybe Double)]
-> Either String [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$ Parsec String () [(String, Maybe Double)]
-> String -> String -> Either ParseError [(String, Maybe Double)]
forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse Parsec String () [(String, Maybe Double)]
forall st. GenParser Char st [(String, Maybe Double)]
encodings String
"" String
encs
        case [(String, Maybe Double)] -> [String]
acceptable [(String, Maybe Double)]
encList of
            [] -> String -> Either String [String]
forall a b. a -> Either a b
Left String
"no encoding found"
            [String]
a -> [String] -> Either String [String]
forall a b. b -> Either a b
Right ([String] -> Either String [String])
-> [String] -> Either String [String]
forall a b. (a -> b) -> a -> b
$ [String]
a
    where
        -- first intersect with the list of encodings we know how to deal with at all
        knownEncodings:: [(String,Maybe Double)] -> [(String, Maybe Double)]
        knownEncodings :: [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m = ((String, Maybe Double) -> (String, Maybe Double) -> Bool)
-> [(String, Maybe Double)]
-> [(String, Maybe Double)]
-> [(String, Maybe Double)]
forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
intersectBy (\(String, Maybe Double)
x (String, Maybe Double)
y->(String, Maybe Double) -> String
forall a b. (a, b) -> a
fst (String, Maybe Double)
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== (String, Maybe Double) -> String
forall a b. (a, b) -> a
fst (String, Maybe Double)
y) [(String, Maybe Double)]
m ((String -> (String, Maybe Double))
-> [String] -> [(String, Maybe Double)]
forall a b. (a -> b) -> [a] -> [b]
map (\String
x -> (String
x,Maybe Double
forall a. Maybe a
Nothing)) [String]
availableEncodings)
        -- this expands the wildcard, by figuring out if we need to include "identity" in the list
        -- Then it deletes the wildcard entry, drops all the "q=0" entries (which aren't allowed).
        --
        -- note this implementation is a little conservative.  if someone were to specify "*"
        -- without a "q" value, it would be this server is willing to accept any format at all.
        -- We pretty much assume we can't send them /any/ format and that they really
        -- meant just "identity" this seems safe to me.
        knownEncodings':: [(String,Maybe Double)] -> [(String, Maybe Double)]
        knownEncodings' :: [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings' [(String, Maybe Double)]
m = ((String, Maybe Double) -> Bool)
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String, Maybe Double) -> Bool
forall a a. (Eq a, Num a) => (a, Maybe a) -> Bool
dropZero ([(String, Maybe Double)] -> [(String, Maybe Double)])
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$ ((String, Maybe Double) -> (String, Maybe Double) -> Bool)
-> (String, Maybe Double)
-> [(String, Maybe Double)]
-> [(String, Maybe Double)]
forall a. (a -> a -> Bool) -> a -> [a] -> [a]
deleteBy (\(String
a,Maybe Double
_) (String
b,Maybe Double
_)->String
aString -> String -> Bool
forall a. Eq a => a -> a -> Bool
==String
b) (String
"*",Maybe Double
forall a. Maybe a
Nothing) ([(String, Maybe Double)] -> [(String, Maybe Double)])
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$
            case String -> [(String, Maybe Double)] -> Maybe (Maybe Double)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"*" ([(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m) of
                Maybe (Maybe Double)
Nothing -> [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent ([(String, Maybe Double)] -> [(String, Maybe Double)])
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$ [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
                Just (Just Double
a) | Double
aDouble -> Double -> Bool
forall a. Ord a => a -> a -> Bool
>Double
0 -> [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent ([(String, Maybe Double)] -> [(String, Maybe Double)])
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$ [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
                              | Bool
otherwise -> [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
                Just (Maybe Double
Nothing) -> [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent ([(String, Maybe Double)] -> [(String, Maybe Double)])
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$ [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings [(String, Maybe Double)]
m
        dropZero :: (a, Maybe a) -> Bool
dropZero (a
_, Just a
a) | a
aa -> a -> Bool
forall a. Eq a => a -> a -> Bool
==a
0      = Bool
False
                             | Bool
otherwise = Bool
True
        dropZero (a
_, Maybe a
Nothing) = Bool
True
        addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)]
        addIdent :: [(String, Maybe Double)] -> [(String, Maybe Double)]
addIdent [(String, Maybe Double)]
m = if Maybe (Maybe Double) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Maybe Double) -> Bool) -> Maybe (Maybe Double) -> Bool
forall a b. (a -> b) -> a -> b
$ String -> [(String, Maybe Double)] -> Maybe (Maybe Double)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"identity" [(String, Maybe Double)]
m
            then [(String, Maybe Double)]
m [(String, Maybe Double)]
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a. [a] -> [a] -> [a]
++ [(String
"identity",Maybe Double
forall a. Maybe a
Nothing)]
            else [(String, Maybe Double)]
m
        -- finally we sort the list of available encodings.
        acceptable:: [(String,Maybe Double)] -> [String]
        acceptable :: [(String, Maybe Double)] -> [String]
acceptable [(String, Maybe Double)]
l = ((String, Maybe Double) -> String)
-> [(String, Maybe Double)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, Maybe Double) -> String
forall a b. (a, b) -> a
fst ([(String, Maybe Double)] -> [String])
-> [(String, Maybe Double)] -> [String]
forall a b. (a -> b) -> a -> b
$ ((String, Maybe Double) -> (String, Maybe Double) -> Ordering)
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((String, Maybe Double) -> (String, Maybe Double) -> Ordering)
-> (String, Maybe Double) -> (String, Maybe Double) -> Ordering
forall a b c. (a -> b -> c) -> b -> a -> c
flip (String, Maybe Double) -> (String, Maybe Double) -> Ordering
cmp) ([(String, Maybe Double)] -> [(String, Maybe Double)])
-> [(String, Maybe Double)] -> [(String, Maybe Double)]
forall a b. (a -> b) -> a -> b
$  [(String, Maybe Double)] -> [(String, Maybe Double)]
knownEncodings'  [(String, Maybe Double)]
l
        -- let the client choose but break ties with gzip
        encOrder :: [(String, b)]
encOrder = [(String, b)] -> [(String, b)]
forall a. [a] -> [a]
reverse ([(String, b)] -> [(String, b)]) -> [(String, b)] -> [(String, b)]
forall a b. (a -> b) -> a -> b
$ [String] -> [b] -> [(String, b)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([String] -> [String]
forall a. [a] -> [a]
reverse [String]
availableEncodings) [b
1..]
        m0 :: Maybe Double -> Double
m0 = Double -> (Double -> Double) -> Maybe Double -> Double
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Double
0.0::Double) Double -> Double
forall a. a -> a
id
        cmp :: (String, Maybe Double) -> (String, Maybe Double) -> Ordering
cmp (String
s,Maybe Double
mI) (String
t,Maybe Double
mJ) | Maybe Double -> Double
m0 Maybe Double
mI Double -> Double -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Double -> Double
m0 Maybe Double
mJ
            = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Maybe Double -> Double
m0 (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ String -> [(String, Double)] -> Maybe Double
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
s [(String, Double)]
forall b. (Num b, Enum b) => [(String, b)]
encOrder) (Maybe Double -> Double
m0 (Maybe Double -> Double) -> Maybe Double -> Double
forall a b. (a -> b) -> a -> b
$ String -> [(String, Double)] -> Maybe Double
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
t [(String, Double)]
forall b. (Num b, Enum b) => [(String, b)]
encOrder)
                          | Bool
otherwise = Double -> Double -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Maybe Double -> Double
m0 Maybe Double
mI) (Maybe Double -> Double
m0 Maybe Double
mJ)


-- | an assoc list of encodings and their corresponding compression
-- functions.
--
-- e.g.
--
-- > [("gzip", gzipFilter), ("identity", identityFilter), ("*",starFilter)]
standardEncodingHandlers :: (FilterMonad Response m, MonadFail m) =>
                            [(String, String -> Bool -> m ())]
standardEncodingHandlers :: [(String, String -> Bool -> m ())]
standardEncodingHandlers = [String]
-> [String -> Bool -> m ()] -> [(String, String -> Bool -> m ())]
forall a b. [a] -> [b] -> [(a, b)]
zip [String]
standardEncodings [String -> Bool -> m ()]
forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
[String -> Bool -> m ()]
handlers

standardEncodings :: [String]
standardEncodings :: [String]
standardEncodings =
    [String
"gzip"
    ,String
"x-gzip"
--    ,"compress" -- as far as I can tell there is no haskell library that supports this
--    ,"x-compress" -- as far as I can tell, there is no haskell library that supports this
    ,String
"deflate"
    ,String
"identity"
    ,String
"*"
    ]

handlers::(FilterMonad Response m, MonadFail m) => [String -> Bool -> m ()]
handlers :: [String -> Bool -> m ()]
handlers =
    [ String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
gzipFilter
    , String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
gzipFilter
--    ,compressFilter
--    ,compressFilter
    , String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
deflateFilter
    , String -> Bool -> m ()
forall (m :: * -> *).
FilterMonad Response m =>
String -> Bool -> m ()
identityFilter
    , String -> Bool -> m ()
forall (m :: * -> *).
(FilterMonad Response m, MonadFail m) =>
String -> Bool -> m ()
starFilter
    ]

-- | a parser for the Accept-Encoding header
encodings :: GenParser Char st [(String, Maybe Double)]
encodings :: GenParser Char st [(String, Maybe Double)]
encodings = GenParser Char st ()
forall st. GenParser Char st ()
ws GenParser Char st ()
-> GenParser Char st [(String, Maybe Double)]
-> GenParser Char st [(String, Maybe Double)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (GenParser Char st (String, Maybe Double)
forall st. GenParser Char st (String, Maybe Double)
encoding1 GenParser Char st (String, Maybe Double)
-> GenParser Char st ()
-> GenParser Char st [(String, Maybe Double)]
forall s (m :: * -> *) t u a sep.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m sep -> ParsecT s u m [a]
`sepBy` GenParser Char st () -> GenParser Char st ()
forall tok st a. GenParser tok st a -> GenParser tok st a
try GenParser Char st ()
forall st. GenParser Char st ()
sep) GenParser Char st [(String, Maybe Double)]
-> ([(String, Maybe Double)]
    -> GenParser Char st [(String, Maybe Double)])
-> GenParser Char st [(String, Maybe Double)]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (\[(String, Maybe Double)]
x -> GenParser Char st ()
forall st. GenParser Char st ()
ws GenParser Char st ()
-> GenParser Char st () -> GenParser Char st ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> GenParser Char st ()
forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof GenParser Char st ()
-> GenParser Char st [(String, Maybe Double)]
-> GenParser Char st [(String, Maybe Double)]
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(String, Maybe Double)]
-> GenParser Char st [(String, Maybe Double)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(String, Maybe Double)]
x)
    where
        ws :: GenParser Char st ()
        ws :: GenParser Char st ()
ws = ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s u (m :: * -> *) a. ParsecT s u m a -> ParsecT s u m [a]
many ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
space ParsecT String st Identity String
-> GenParser Char st () -> GenParser Char st ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> () -> GenParser Char st ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        sep :: GenParser Char st ()
        sep :: GenParser Char st ()
sep = do
            GenParser Char st ()
forall st. GenParser Char st ()
ws
            Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
','
            GenParser Char st ()
forall st. GenParser Char st ()
ws

        encoding1 :: GenParser Char st ([Char], Maybe Double)
        encoding1 :: GenParser Char st (String, Maybe Double)
encoding1 = do
            String
encoding <- ParsecT String st Identity Char
-> ParsecT String st Identity String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 (ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
alphaNum ParsecT String st Identity Char
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'-') ParsecT String st Identity String
-> ParsecT String st Identity String
-> ParsecT String st Identity String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|> String -> ParsecT String st Identity String
forall s (m :: * -> *) u.
Stream s m Char =>
String -> ParsecT s u m String
string String
"*"
            GenParser Char st ()
forall st. GenParser Char st ()
ws
            Maybe String
quality<-ParsecT String st Identity String
-> ParsecT String st Identity (Maybe String)
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m (Maybe a)
optionMaybe ParsecT String st Identity String
forall st. GenParser Char st String
qual
            (String, Maybe Double) -> GenParser Char st (String, Maybe Double)
forall (m :: * -> *) a. Monad m => a -> m a
return (String
encoding, (String -> Double) -> Maybe String -> Maybe Double
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Double
forall a. Read a => String -> a
read Maybe String
quality)

        qual :: GenParser Char st String
        qual :: GenParser Char st String
qual = do
            Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
';' ParsecT String st Identity Char
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity ()
forall st. GenParser Char st ()
ws ParsecT String st Identity ()
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'q' ParsecT String st Identity Char
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity ()
forall st. GenParser Char st ()
ws ParsecT String st Identity ()
-> ParsecT String st Identity Char
-> ParsecT String st Identity Char
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'=' ParsecT String st Identity Char
-> ParsecT String st Identity () -> ParsecT String st Identity ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ParsecT String st Identity ()
forall st. GenParser Char st ()
ws
            String
q<-GenParser Char st String
forall st. GenParser Char st String
float
            String -> GenParser Char st String
forall (m :: * -> *) a. Monad m => a -> m a
return String
q

        int :: GenParser Char st String
        int :: GenParser Char st String
int = ParsecT String st Identity Char -> GenParser Char st String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit

        float :: GenParser Char st String
        float :: GenParser Char st String
float = do
                String
wholePart<-ParsecT String st Identity Char -> GenParser Char st String
forall s (m :: * -> *) t u a.
Stream s m t =>
ParsecT s u m a -> ParsecT s u m [a]
many1 ParsecT String st Identity Char
forall s (m :: * -> *) u. Stream s m Char => ParsecT s u m Char
digit
                String
fractionalPart<-String -> GenParser Char st String -> GenParser Char st String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" GenParser Char st String
forall st. GenParser Char st String
fraction
                String -> GenParser Char st String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ String
wholePart String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fractionalPart
            GenParser Char st String
-> GenParser Char st String -> GenParser Char st String
forall s u (m :: * -> *) a.
ParsecT s u m a -> ParsecT s u m a -> ParsecT s u m a
<|>
                do
                String
fractionalPart<-GenParser Char st String
forall st. GenParser Char st String
fraction
                String -> GenParser Char st String
forall (m :: * -> *) a. Monad m => a -> m a
return String
fractionalPart
        fraction :: GenParser Char st String
        fraction :: GenParser Char st String
fraction = do
            Char
_ <- Char -> ParsecT String st Identity Char
forall s (m :: * -> *) u.
Stream s m Char =>
Char -> ParsecT s u m Char
char Char
'.'
            String
fractionalPart<-String -> GenParser Char st String -> GenParser Char st String
forall s (m :: * -> *) t a u.
Stream s m t =>
a -> ParsecT s u m a -> ParsecT s u m a
option String
"" GenParser Char st String
forall st. GenParser Char st String
int
            String -> GenParser Char st String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> GenParser Char st String)
-> String -> GenParser Char st String
forall a b. (a -> b) -> a -> b
$ Char
'.'Char -> String -> String
forall a. a -> [a] -> [a]
:String
fractionalPart