{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-} module Happstack.Server.Parts( compressedResponseFilter ,gzipFilter ,deflateFilter ,encodings ) where import Happstack.Server.SimpleHTTP import Text.ParserCombinators.Parsec import Control.Monad import Data.Maybe import Data.List import qualified Data.ByteString.Char8 as BS 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" -- -- Returns the name of the coding chosen compressedResponseFilter:: (FilterMonad Response m, MonadPlus m, WebMonad Response m, ServerMonad m) => m String compressedResponseFilter = do getHeaderM "Accept-Encoding" >>= (maybe (return "identity") installHandler) where badEncoding = "Encoding returned not in the list of known encodings" installHandler accept = do let eEncoding = bestEncoding $ BS.unpack accept (coding,action) <- case eEncoding of Left _ -> do setResponseCode 406 finishWith $ toResponse "" Right a -> return (a, fromMaybe (fail badEncoding) (lookup a allEncodingHandlers)) setHeaderM "Content-Encoding" coding action return coding -- | compresses the body of the response with gzip. -- does not set any headers. gzipFilter::(FilterMonad Response m) => m() gzipFilter = do composeFilter (\r -> r{rsBody = GZ.compress $ rsBody r}) -- | compresses the body of the response with zlib's -- deflate method -- does not set any headers. deflateFilter::(FilterMonad Response m) => m() deflateFilter = do composeFilter (\r -> r{rsBody = Z.compress $ rsBody r}) -- | based on the rules describe in rfc2616 sec. 14.3 bestEncoding :: String -> Either String String bestEncoding encs = do encList<-either (Left . show) (Right) $ parse encodings "" encs case acceptable encList of [] -> Left "no encoding found" a -> Right $ head 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 m = intersectBy (\x y->fst x == fst y) m (map (\x -> (x,Nothing)) allEncodings) -- 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' m = filter dropZero $ deleteBy (\(a,_) (b,_)->a==b) ("*",Nothing) $ case lookup "*" (knownEncodings m) of Nothing -> addIdent $ knownEncodings m Just (Just a) | a>0 -> addIdent $ knownEncodings m | otherwise -> knownEncodings m Just (Nothing) -> addIdent $ knownEncodings m dropZero (_, Just a) | a==0 = False | otherwise = True dropZero (_, Nothing) = True addIdent:: [(String,Maybe Double)] -> [(String, Maybe Double)] addIdent m = if isNothing $ lookup "identity" m then m ++ [("identity",Nothing)] else m -- finally we sort the list of available encodings. acceptable:: [(String,Maybe Double)] -> [String] acceptable l = map fst $ sortBy (flip cmp) $ knownEncodings' l -- let the client choose but break ties with gzip encOrder = reverse $ zip (reverse allEncodings) [1..] m0 = maybe (0.0::Double) id cmp (s,mI) (t,mJ) | m0 mI == m0 mJ = compare (m0 $ lookup s encOrder) (m0 $ lookup t encOrder) | otherwise = compare (m0 mI) (m0 mJ) allEncodingHandlers:: (FilterMonad Response m) => [(String, m ())] allEncodingHandlers = zip allEncodings handlers allEncodings :: [String] allEncodings = ["gzip" ,"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 ,"deflate" ,"identity" ,"*" ] handlers::(FilterMonad Response m) => [m ()] handlers = [gzipFilter ,gzipFilter -- ,compressFilter -- ,compressFilter ,deflateFilter ,return () ,fail "chose * as content encoding" ] -- | unsupported: a parser for the Accept-Encoding header encodings :: GenParser Char st [([Char], Maybe Double)] encodings = ws >> (encoding1 `sepBy` try sep) >>= (\x -> ws >> eof >> return x) where ws = many space sep = do ws char ',' ws encoding1 :: GenParser Char st ([Char], Maybe Double) encoding1 = do encoding <- many1 (alphaNum <|> char '-') <|> string "*" ws quality<-optionMaybe qual return (encoding, fmap read quality) qual = do char ';' >> ws >> char 'q' >> ws >> char '=' >> ws q<-float return q int = many1 digit float = do wholePart<-many1 digit fractionalPart<-option "" fraction return $ wholePart ++ fractionalPart <|> do fractionalPart<-fraction return fractionalPart fraction :: GenParser Char st String fraction = do char '.' fractionalPart<-option "" int return $ '.':fractionalPart