{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE ScopedTypeVariables #-}moduleSnap.Util.GZip(withCompression,withCompression')whereimportqualifiedCodec.Compression.GZipasGZipimportqualifiedCodec.Compression.ZlibasZlibimportControl.ConcurrentimportControl.Applicativehiding(many)importControl.ExceptionimportControl.MonadimportControl.Monad.TransimportData.Attoparsec.Char8hiding(Done)importqualifiedData.Attoparsec.Char8asAttoimportqualifiedData.ByteString.Lazy.Char8asLimportData.ByteString.Char8(ByteString)importData.Iteratee.WrappedByteStringimportData.MaybeimportqualifiedData.SetasSetimportData.Set(Set)importData.TypeableimportPreludehiding(catch,takeWhile)------------------------------------------------------------------------------importSnap.Internal.DebugimportSnap.Iterateehiding(Enumerator)importSnap.Types-------------------------------------------------------------------------------- | 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::Snapa-- ^ the web handler to run->Snap()withCompression=withCompression'compressibleMimeTypes-------------------------------------------------------------------------------- | The same as 'withCompression', with control over which MIME types to-- compress.withCompression'::SetByteString-- ^ set of compressible MIME types->Snapa-- ^ the web handler to run->Snap()withCompression'mimeTableaction=do_<-actionresp<-getResponse-- If a content-encoding is already set, do nothing. This prevents-- "withCompression $ withCompression m" from ruining your day.ifisJust$getHeader"Content-Encoding"respthenreturn()elsedoletmbCt=getHeader"Content-Type"respdebug$"withCompression', content-type is "++showmbCtcasembCtof(Justct)->ifSet.memberctmimeTablethenchkAcceptEncodingelsereturn()_->return()getResponse>>=finishWithwherechkAcceptEncoding::Snap()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-------------------------------------------------------------------------------- private following------------------------------------------------------------------------------------------------------------------------------------------------------------compressibleMimeTypes::SetByteStringcompressibleMimeTypes=Set.fromList["application/x-font-truetype","application/x-javascript","text/css","text/html","text/javascript","text/plain","text/xml"]------------------------------------------------------------------------------gzipCompression::ByteString->Snap()gzipCompressionce=modifyResponsefwheref=setHeader"Content-Encoding"ce.setHeader"Vary""Accept-Encoding".clearContentLength.modifyResponseBodygcompress------------------------------------------------------------------------------compressCompression::ByteString->Snap()compressCompressionce=modifyResponsefwheref=setHeader"Content-Encoding"ce.setHeader"Vary""Accept-Encoding".clearContentLength.modifyResponseBodyccompress------------------------------------------------------------------------------gcompress::foralla.Enumeratora->Enumeratoragcompress=compressEnumeratorGZip.compress------------------------------------------------------------------------------ccompress::foralla.Enumeratora->Enumeratoraccompress=compressEnumeratorZlib.compress------------------------------------------------------------------------------compressEnumerator::foralla.(L.ByteString->L.ByteString)->Enumeratora->EnumeratoracompressEnumeratorcompFuncenumiteratee=dowriteEnd<-newChanreadEnd<-newChantid<-forkIO$threadProcreadEndwriteEndenum(IterateeG$freadEndwriteEndtiditeratee)where--------------------------------------------------------------------------streamFinished::Stream->BoolstreamFinished(EOF_)=TruestreamFinished(Chunk_)=False--------------------------------------------------------------------------consumeSomeOutput::ChanStream->IterateeIOa->IO(IterateeIOa)consumeSomeOutputwriteEnditer=doe<-isEmptyChanwriteEndifethenreturniterelsedoch<-readChanwriteEnditer'<-liftMliftI$runIteriterchif(streamFinishedch)thenreturniter'elseconsumeSomeOutputwriteEnditer'--------------------------------------------------------------------------consumeRest::ChanStream->IterateeIOa->IO(IterVIOa)consumeRestwriteEnditer=doch<-readChanwriteEndiv<-runIteriterchif(streamFinishedch)thenreturnivelseconsumeRestwriteEnd$liftIiv--------------------------------------------------------------------------freadEndwriteEndtidi(EOFNothing)=dowriteChanreadEndNothingx<-consumeRestwriteEndikillThreadtidreturnxf__tidich@(EOF(Just_))=dox<-runIterichkillThreadtidreturnxfreadEndwriteEndtidi(Chunks')=dolets=unWraps'writeChanreadEnd$Justsi'<-consumeSomeOutputwriteEndireturn$Cont(IterateeG$freadEndwriteEndtidi')Nothing--------------------------------------------------------------------------threadProc::Chan(MaybeByteString)->ChanStream->IO()threadProcreadEndwriteEnd=dostream<-getChanContentsreadEndletbs=L.fromChunks$streamToChunksstreamletoutput=L.toChunks$compFuncbsletrunIt=do--Prelude specified to work with iteratee-0.3.6Prelude.mapM_(writeChanwriteEnd.toChunk)outputwriteChanwriteEnd$EOFNothingrunIt`catch`\(e::SomeException)->writeChanwriteEnd$EOF(Just$Err$showe)--------------------------------------------------------------------------streamToChunks[]=[]streamToChunks(Nothing:_)=[]streamToChunks((Justx):xs)=x:(streamToChunksxs)--------------------------------------------------------------------------toChunk=Chunk.WrapBS------------------------------------------------------------------------------fullyParse::ByteString->Parsera->EitherStringafullyParsesp=caser'of(Fail__e)->Lefte(Partial_)->Left"parse failed"(Atto.Done_x)->Rightxwherer=parsepsr'=feedr""-------------------------------------------------------------------------------- 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