{-# LANGUAGE NoMonomorphismRestriction, FlexibleContexts #-}-- | Filter for compressing the 'Response' body.moduleHappstack.Server.Internal.Compression(compressedResponseFilter,compressWithFilter,gzipFilter,deflateFilter,encodings)whereimportHappstack.Server.SimpleHTTPimportText.ParserCombinators.ParsecimportControl.MonadimportData.MaybeimportData.ListimportqualifiedData.ByteString.Char8asBSimportqualifiedData.ByteString.Lazy.Char8asLimportqualifiedCodec.Compression.GZipasGZimportqualifiedCodec.Compression.ZlibasZ-- | reads the @Accept-Encoding@ header. Then, if possible-- will compress the response body with methods @gzip@ or @deflate@.---- > main = -- > simpleHTTP nullConf $ -- > do str <- compressedResponseFilter-- > return $ toResponse ("This response compressed using: " ++ str)compressedResponseFilter::(FilterMonadResponsem,MonadPlusm,WebMonadResponsem,ServerMonadm)=>mString-- ^ name of the encoding chosencompressedResponseFilter=dogetHeaderM"Accept-Encoding">>=(maybe(return"identity")installHandler)wherebadEncoding="Encoding returned not in the list of known encodings"installHandleraccept=doleteEncoding=bestEncodingallEncodings$BS.unpackaccept(coding,identityAllowed,action)<-caseeEncodingofLeft_->dosetResponseCode406finishWith$toResponse""Rightencs@(a:_)->return(a,"identity"`elem`encs,fromMaybe(failbadEncoding)(lookupaallEncodingHandlers))actioncodingidentityAllowedreturncoding-- | 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::(FilterMonadResponsem)=>String-- ^ encoding to use for Content-Encoding header->Bool-- ^ fallback to identity for SendFile->m()gzipFilter=compressWithFilterGZ.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::(FilterMonadResponsem)=>String-- ^ encoding to use for Content-Encoding header->Bool-- ^ fallback to identity for SendFile->m()deflateFilter=compressWithFilterZ.compress-- | 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' and 'defaultFilter'compressWithFilter::(FilterMonadResponsem)=>(L.ByteString->L.ByteString)-- ^ function to compress the body->String-- ^ encoding to use for Content-Encoding header->Bool-- ^ fallback to identity for SendFile->m()compressWithFiltercompressorencodingidentityAllowed=composeFilter$\r->caserofResponse{}->setHeader"Content-Encoding"encoding$r{rsBody=compressor$rsBodyr}_|identityAllowed->r|otherwise->(toResponse""){rsCode=406}-- | based on the rules describe in rfc2616 sec. 14.3bestEncoding::[String]->String->EitherString[String]bestEncodingavailableEncodingsencs=doencList<-either(Left.show)(Right)$parseencodings""encscaseacceptableencListof[]->Left"no encoding found"a->Right$awhere-- first intersect with the list of encodings we know how to deal with at allknownEncodings::[(String,MaybeDouble)]->[(String,MaybeDouble)]knownEncodingsm=intersectBy(\xy->fstx==fsty)m(map(\x->(x,Nothing))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,MaybeDouble)]->[(String,MaybeDouble)]knownEncodings'm=filterdropZero$deleteBy(\(a,_)(b,_)->a==b)("*",Nothing)$caselookup"*"(knownEncodingsm)ofNothing->addIdent$knownEncodingsmJust(Justa)|a>0->addIdent$knownEncodingsm|otherwise->knownEncodingsmJust(Nothing)->addIdent$knownEncodingsmdropZero(_,Justa)|a==0=False|otherwise=TruedropZero(_,Nothing)=TrueaddIdent::[(String,MaybeDouble)]->[(String,MaybeDouble)]addIdentm=ifisNothing$lookup"identity"mthenm++[("identity",Nothing)]elsem-- finally we sort the list of available encodings.acceptable::[(String,MaybeDouble)]->[String]acceptablel=mapfst$sortBy(flipcmp)$knownEncodings'l-- let the client choose but break ties with gzipencOrder=reverse$zip(reverseavailableEncodings)[1..]m0=maybe(0.0::Double)idcmp(s,mI)(t,mJ)|m0mI==m0mJ=compare(m0$lookupsencOrder)(m0$lookuptencOrder)|otherwise=compare(m0mI)(m0mJ)allEncodingHandlers::(FilterMonadResponsem)=>[(String,String->Bool->m())]allEncodingHandlers=zipallEncodingshandlersallEncodings::[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::(FilterMonadResponsem)=>[String->Bool->m()]handlers=[gzipFilter,gzipFilter-- ,compressFilter-- ,compressFilter,deflateFilter,\encoding_->setHeaderM"Accept-Encoding"encoding,const$fail"chose * as content encoding"]-- | a parser for the Accept-Encoding headerencodings::GenParserCharst[([Char],MaybeDouble)]encodings=ws>>(encoding1`sepBy`trysep)>>=(\x->ws>>eof>>returnx)wherews::GenParserCharst()ws=manyspace>>return()sep::GenParserCharst()sep=dows_<-char','wsencoding1::GenParserCharst([Char],MaybeDouble)encoding1=doencoding<-many1(alphaNum<|>char'-')<|>string"*"wsquality<-optionMaybequalreturn(encoding,fmapreadquality)qual::GenParserCharstStringqual=dochar';'>>ws>>char'q'>>ws>>char'='>>wsq<-floatreturnqint::GenParserCharstStringint=many1digitfloat::GenParserCharstStringfloat=dowholePart<-many1digitfractionalPart<-option""fractionreturn$wholePart++fractionalPart<|>dofractionalPart<-fractionreturnfractionalPartfraction::GenParserCharstStringfraction=do_<-char'.'fractionalPart<-option""intreturn$'.':fractionalPart