{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
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)
withCompression :: MonadSnap m
=> m a
-> 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
withCompression' :: MonadSnap m
=> Set ByteString
-> m a
-> m ()
withCompression' :: Set ByteString -> m a -> m ()
withCompression' mimeTable :: Set ByteString
mimeTable action :: m a
action = do
a
_ <- m a
action
Response
resp <- m Response
forall (m :: * -> *). MonadSnap m => m Response
getResponse
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 "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 "Content-Type" Response
resp
String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "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 ct :: 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
_ -> () -> 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 (\c :: Char
c -> Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ';' 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
$ "checking accept-encoding"
let mbAcc :: Maybe ByteString
mbAcc = CI ByteString -> Request -> Maybe ByteString
forall a. HasHeaders a => CI ByteString -> a -> Maybe ByteString
getHeader "Accept-Encoding" Request
req
String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
debug (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ "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 "" 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 ())
_ ("gzip":_) = ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
gzipCompression "gzip"
chooseType !Maybe (m ())
m ("deflate":xs :: [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 "deflate")) [a]
xs
chooseType !Maybe (m ())
_ ("x-gzip":_) = ByteString -> m ()
forall (m :: * -> *). MonadSnap m => ByteString -> m ()
gzipCompression "x-gzip"
chooseType !Maybe (m ())
m ("x-deflate":xs :: [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 "x-deflate")) [a]
xs
chooseType !Maybe (m ())
m (_:xs :: [a]
xs) = Maybe (m ()) -> [a] -> m ()
chooseType Maybe (m ())
m [a]
xs
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 "Content-Encoding" "identity"
compressibleMimeTypes :: Set ByteString
compressibleMimeTypes :: Set ByteString
compressibleMimeTypes = [ByteString] -> Set ByteString
forall a. Ord a => [a] -> Set a
Set.fromList [ "application/x-font-truetype"
, "application/x-javascript"
, "application/json"
, "text/css"
, "text/html"
, "text/javascript"
, "text/plain"
, "text/xml" ]
gzipCompression :: MonadSnap m => ByteString -> m ()
gzipCompression :: ByteString -> m ()
gzipCompression ce :: ByteString
ce = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse Response -> Response
f
where
f :: Response -> Response
f r :: Response
r = CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader "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 "Vary" "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 ce :: ByteString
ce = (Response -> Response) -> m ()
forall (m :: * -> *). MonadSnap m => (Response -> Response) -> m ()
modifyResponse Response -> Response
f
where
f :: Response -> Response
f r :: Response
r = CI ByteString -> ByteString -> Response -> Response
forall a. HasHeaders a => CI ByteString -> ByteString -> a -> a
setHeader "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 "Vary" "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 body :: OutputStream Builder -> IO (OutputStream Builder)
body stream :: OutputStream Builder
stream = CompressionLevel
-> OutputStream Builder -> IO (OutputStream Builder)
Streams.gzipBuilder 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 body :: OutputStream Builder -> IO (OutputStream Builder)
body stream :: OutputStream Builder
stream = CompressionLevel
-> OutputStream Builder -> IO (OutputStream Builder)
Streams.compressBuilder 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
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 ',' 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 ';'
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 '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 '='
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 "*" 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 ch :: 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
== '-' Bool -> Bool -> Bool
|| Char
ch Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '_'
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 '.' 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
$! ())
data BadAcceptEncodingException = BadAcceptEncodingException
deriving (Typeable)
instance Show BadAcceptEncodingException where
show :: BadAcceptEncodingException -> String
show BadAcceptEncodingException = "bad 'accept-encoding' header"
instance Exception BadAcceptEncodingException
parseAcceptEncoding :: ByteString -> IO [ByteString]
parseAcceptEncoding :: ByteString -> IO [ByteString]
parseAcceptEncoding s :: ByteString
s =
case Either String [ByteString]
r of
Left _ -> BadAcceptEncodingException -> IO [ByteString]
forall e a. Exception e => e -> IO a
throwIO BadAcceptEncodingException
BadAcceptEncodingException
Right x :: [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