{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE PackageImports #-}{-# LANGUAGE ScopedTypeVariables #-}moduleSnap.Util.GZip(withCompression,withCompression',noCompression)whereimportBlaze.ByteString.BuilderimportqualifiedCodec.Zlib.EnumasZimportControl.Applicativehiding(many)importControl.ExceptionimportControl.MonadimportControl.Monad.TransimportData.Attoparsec.Char8hiding(Done)importData.ByteString.Char8(ByteString)importqualifiedData.ByteString.Char8asSimportqualifiedData.CharasCharimportData.MaybeimportData.MonoidimportqualifiedData.SetasSetimportData.Set(Set)importData.TypeableimportPreludehiding(catch,takeWhile)----------------------------------------------------------------------------importSnap.CoreimportSnap.Internal.DebugimportSnap.Internal.ParsingimportSnap.IterateeimportqualifiedSnap.IterateeasI-------------------------------------------------------------------------------- | Runs a 'Snap' web handler with compression if available.---- If the client has indicated support for @gzip@ or @compress@ in its-- @Accept-Encoding@ header, and the @Content-Type@ in the response is one of-- the following types:---- * @application/x-javascript@---- * @text/css@---- * @text/html@---- * @text/javascript@---- * @text/plain@---- * @text/xml@---- * @application/x-font-truetype@---- Then the given handler's output stream will be compressed,-- @Content-Encoding@ will be set in the output headers, and the-- @Content-Length@ will be cleared if it was set. (We can't process the-- stream in O(1) space if the length is known beforehand.)---- The wrapped handler will be run to completion, and then the 'Response'-- that's contained within the 'Snap' monad state will be passed to-- 'finishWith' to prevent further processing.--withCompression::MonadSnapm=>ma-- ^ the web handler to run->m()withCompression=withCompression'compressibleMimeTypes-------------------------------------------------------------------------------- | The same as 'withCompression', with control over which MIME types to-- compress.withCompression'::MonadSnapm=>SetByteString-- ^ set of compressible MIME types->ma-- ^ the web handler to run->m()withCompression'mimeTableaction=do_<-actionresp<-getResponse-- If a content-encoding is already set, do nothing. This prevents-- "withCompression $ withCompression m" from ruining your day.when(not$isJust$getHeader"Content-Encoding"resp)$doletmbCt=fmapchop$getHeader"Content-Type"respdebug$"withCompression', content-type is "++showmbCtcasembCtof(Justct)->when(Set.memberctmimeTable)chkAcceptEncoding_->return$!()getResponse>>=finishWithwherechop=S.takeWhile(\c->c/=';'&&not(Char.isSpacec))chkAcceptEncoding=doreq<-getRequestdebug$"checking accept-encoding"letmbAcc=getHeader"Accept-Encoding"reqdebug$"accept-encoding is "++showmbAcclets=fromMaybe""mbAcctypes<-liftIO$parseAcceptEncodingschooseTypetypeschooseType[]=return$!()chooseType("gzip":_)=gzipCompression"gzip"chooseType("compress":_)=compressCompression"compress"chooseType("x-gzip":_)=gzipCompression"x-gzip"chooseType("x-compress":_)=compressCompression"x-compress"chooseType(_:xs)=chooseTypexs-------------------------------------------------------------------------------- | Turn off compression by setting \"Content-Encoding: identity\" in the-- response headers.noCompression::MonadSnapm=>m()noCompression=modifyResponse$setHeader"Content-Encoding""identity"-------------------------------------------------------------------------------- private following------------------------------------------------------------------------------------------------------------------------------------------------------------compressibleMimeTypes::SetByteStringcompressibleMimeTypes=Set.fromList["application/x-font-truetype","application/x-javascript","text/css","text/html","text/javascript","text/plain","text/xml"]------------------------------------------------------------------------------gzipCompression::MonadSnapm=>ByteString->m()gzipCompressionce=modifyResponsefwheref=setHeader"Content-Encoding"ce.setHeader"Vary""Accept-Encoding".clearContentLength.modifyResponseBodygcompress------------------------------------------------------------------------------compressCompression::MonadSnapm=>ByteString->m()compressCompressionce=modifyResponsefwheref=setHeader"Content-Encoding"ce.setHeader"Vary""Accept-Encoding".clearContentLength.modifyResponseBodyccompress------------------------------------------------------------------------------gcompress::foralla.EnumeratorBuilderIOa->EnumeratorBuilderIOagcompressest=e$$iFinalwherei0=returnIstiB=mapFlush=$i0iZ=Z.gzip=$iBiFinal=enumBuilderToByteString=$iZmapFlush::Monadm=>EnumerateeByteStringBuildermbmapFlush=I.map((`mappend`flush).fromByteString)------------------------------------------------------------------------------ccompress::foralla.EnumeratorBuilderIOa->EnumeratorBuilderIOaccompressest=e$$iFinalwherei0=returnIstiB=mapFlush=$i0iZ=Z.compress5Z.defaultWindowBits=$iBiFinal=enumBuilderToByteString=$iZmapFlush::Monadm=>EnumerateeByteStringBuildermbmapFlush=I.map((`mappend`flush).fromByteString)-------------------------------------------------------------------------------- We're not gonna bother with quality values; we'll do gzip or compress in-- that order.acceptParser::Parser[ByteString]acceptParser=doxs<-option[]$(:[])<$>encodingys<-many(char','*>encoding)endOfInputreturn$xs++yswhereencoding=skipSpace*>c<*skipSpacec=dox<-codingoption()qvaluereturnxqvalue=doskipSpacechar';'skipSpacechar'q'skipSpacechar'='floatreturn()coding=string"*"<|>takeWhileisCodingCharisCodingCharch=isDigitch||isAlpha_asciich||ch=='-'||ch=='_'float=takeWhileisDigit>>option()(char'.'>>takeWhileisDigit>>pure())------------------------------------------------------------------------------dataBadAcceptEncodingException=BadAcceptEncodingExceptionderiving(Typeable)------------------------------------------------------------------------------instanceShowBadAcceptEncodingExceptionwhereshowBadAcceptEncodingException="bad 'accept-encoding' header"------------------------------------------------------------------------------instanceExceptionBadAcceptEncodingException------------------------------------------------------------------------------parseAcceptEncoding::ByteString->IO[ByteString]parseAcceptEncodings=caserofLeft_->throwIOBadAcceptEncodingExceptionRightx->returnxwherer=fullyParsesacceptParser