module Snap.Util.GZip
( withCompression
, withCompression'
, noCompression ) where
import Blaze.ByteString.Builder
import qualified Codec.Zlib.Enum as Z
import Control.Applicative hiding (many)
import Control.Exception
import Control.Monad
import Control.Monad.Trans
import Data.Attoparsec.Char8 hiding (Done)
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as S
import qualified Data.Char as Char
import Data.Maybe
import Data.Monoid
import qualified Data.Set as Set
import Data.Set (Set)
import Data.Typeable
import Prelude hiding (catch, takeWhile)
import Snap.Core
import Snap.Internal.Debug
import Snap.Internal.Parsing
import Snap.Iteratee
import qualified Snap.Iteratee as I
withCompression :: MonadSnap m
=> m a
-> m ()
withCompression = withCompression' compressibleMimeTypes
withCompression' :: MonadSnap m
=> Set ByteString
-> m a
-> m ()
withCompression' mimeTable action = do
_ <- action
resp <- getResponse
when (not $ isJust $ getHeader "Content-Encoding" resp) $ do
let mbCt = fmap chop $ getHeader "Content-Type" resp
debug $ "withCompression', content-type is " ++ show mbCt
case mbCt of
(Just ct) -> when (Set.member ct mimeTable) chkAcceptEncoding
_ -> return $! ()
getResponse >>= finishWith
where
chop = S.takeWhile (\c -> c /= ';' && not (Char.isSpace c))
chkAcceptEncoding = do
req <- getRequest
debug $ "checking accept-encoding"
let mbAcc = getHeader "Accept-Encoding" req
debug $ "accept-encoding is " ++ show mbAcc
let s = fromMaybe "" mbAcc
types <- liftIO $ parseAcceptEncoding s
chooseType types
chooseType [] = return $! ()
chooseType ("gzip":_) = gzipCompression "gzip"
chooseType ("compress":_) = compressCompression "compress"
chooseType ("x-gzip":_) = gzipCompression "x-gzip"
chooseType ("x-compress":_) = compressCompression "x-compress"
chooseType (_:xs) = chooseType xs
noCompression :: MonadSnap m => m ()
noCompression = modifyResponse $ setHeader "Content-Encoding" "identity"
compressibleMimeTypes :: Set ByteString
compressibleMimeTypes = Set.fromList [ "application/x-font-truetype"
, "application/x-javascript"
, "text/css"
, "text/html"
, "text/javascript"
, "text/plain"
, "text/xml" ]
gzipCompression :: MonadSnap m => ByteString -> m ()
gzipCompression ce = modifyResponse f
where
f = setHeader "Content-Encoding" ce .
setHeader "Vary" "Accept-Encoding" .
clearContentLength .
modifyResponseBody gcompress
compressCompression :: MonadSnap m => ByteString -> m ()
compressCompression ce = modifyResponse f
where
f = setHeader "Content-Encoding" ce .
setHeader "Vary" "Accept-Encoding" .
clearContentLength .
modifyResponseBody ccompress
gcompress :: forall a . Enumerator Builder IO a
-> Enumerator Builder IO a
gcompress e st = e $$ iFinal
where
i0 = returnI st
iB = mapFlush =$ i0
iZ = Z.gzip =$ iB
iFinal = enumBuilderToByteString =$ iZ
mapFlush :: Monad m => Enumeratee ByteString Builder m b
mapFlush = I.map ((`mappend` flush) . fromByteString)
ccompress :: forall a . Enumerator Builder IO a
-> Enumerator Builder IO a
ccompress e st = e $$ iFinal
where
i0 = returnI st
iB = mapFlush =$ i0
iZ = Z.compress 5 Z.defaultWindowBits =$ iB
iFinal = enumBuilderToByteString =$ iZ
mapFlush :: Monad m => Enumeratee ByteString Builder m b
mapFlush = I.map ((`mappend` flush) . fromByteString)
acceptParser :: Parser [ByteString]
acceptParser = do
xs <- option [] $ (:[]) <$> encoding
ys <- many (char ',' *> encoding)
endOfInput
return $ xs ++ ys
where
encoding = skipSpace *> c <* skipSpace
c = do
x <- coding
option () qvalue
return x
qvalue = do
skipSpace
char ';'
skipSpace
char 'q'
skipSpace
char '='
float
return ()
coding = string "*" <|> takeWhile isCodingChar
isCodingChar ch = isDigit ch || isAlpha_ascii ch || ch == '-' || ch == '_'
float = takeWhile isDigit >>
option () (char '.' >> takeWhile isDigit >> pure ())
data BadAcceptEncodingException = BadAcceptEncodingException
deriving (Typeable)
instance Show BadAcceptEncodingException where
show BadAcceptEncodingException = "bad 'accept-encoding' header"
instance Exception BadAcceptEncodingException
parseAcceptEncoding :: ByteString -> IO [ByteString]
parseAcceptEncoding s =
case r of
Left _ -> throwIO BadAcceptEncodingException
Right x -> return x
where
r = fullyParse s acceptParser