{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE ExistentialQuantification #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE PackageImports #-}{-# LANGUAGE ScopedTypeVariables #-}moduleSnap.Util.GZip(withCompression,withCompression')whereimportBlaze.ByteString.BuilderimportqualifiedCodec.Compression.GZipasGZipimportqualifiedCodec.Compression.ZlibasZlibimportControl.ConcurrentimportControl.Applicativehiding(many)importControl.ExceptionimportControl.MonadimportControl.Monad.TransimportData.Attoparsec.Char8hiding(Done)importqualifiedData.ByteString.Lazy.Char8asLimportData.ByteString.Char8(ByteString)importData.MaybeimportqualifiedData.SetasSetimportData.Set(Set)importData.TypeableimportPreludehiding(catch,takeWhile)----------------------------------------------------------------------------importSnap.Internal.DebugimportSnap.Internal.ParsingimportSnap.IterateeimportqualifiedSnap.IterateeasIimportSnap.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::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=getHeader"Content-Type"respdebug$"withCompression', content-type is "++showmbCtcasembCtof(Justct)->when(Set.memberctmimeTable)chkAcceptEncoding_->return$!()getResponse>>=finishWithwherechkAcceptEncoding=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::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-------------------------------------------------------------------------------- FIXME: use zlib-bindingsgcompress::foralla.EnumeratorBuilderIOa->EnumeratorBuilderIOagcompress=compressEnumeratorGZip.compress------------------------------------------------------------------------------ccompress::foralla.EnumeratorBuilderIOa->EnumeratorBuilderIOaccompress=compressEnumeratorZlib.compress------------------------------------------------------------------------------compressEnumerator::foralla.(L.ByteString->L.ByteString)->EnumeratorBuilderIOa->EnumeratorBuilderIOacompressEnumeratorcompFuncenum'origStep=doletiter=joinI$I.mapfromByteStringorigStepstep<-lift$runIterateeiterwriteEnd<-liftIO$newChanreadEnd<-liftIO$newChantid<-liftIO$forkIO$threadProcreadEndwriteEndletenum=mapEnumfromByteStringtoByteStringenum'letoutEnum=enum(freadEndwriteEndtidstep)mapItertoByteStringfromByteStringoutEnumwhere--------------------------------------------------------------------------streamFinished::StreamByteString->BoolstreamFinishedEOF=TruestreamFinished(Chunks_)=False--------------------------------------------------------------------------consumeSomeOutput::Chan(EitherSomeException(StreamByteString))->StepByteStringIOa->IterateeByteStringIO(StepByteStringIOa)consumeSomeOutputwriteEndstep=doe<-lift$isEmptyChanwriteEndifethenreturnstepelsedoech<-lift$readChanwriteEndeitherthrowError(\ch->dostep'<-checkDone(\k->lift$runIteratee$kch)stepconsumeSomeOutputwriteEndstep')ech--------------------------------------------------------------------------consumeRest::Chan(EitherSomeException(StreamByteString))->StepByteStringIOa->IterateeByteStringIOaconsumeRestwriteEndstep=doech<-lift$readChanwriteEndeitherthrowError(\ch->dostep'<-checkDone(\k->lift$runIteratee$kch)stepif(streamFinishedch)thenreturnIstep'elseconsumeRestwriteEndstep')ech--------------------------------------------------------------------------f___(Errore)=Erroref___(Yieldx_)=YieldxEOFfreadEndwriteEndtidst@(Continuek)=Continue$\ch->casechofEOF->dolift$writeChanreadEndNothingx<-consumeRestwriteEndstlift$killThreadtidreturnx(Chunksxs)->domapM_(lift.writeChanreadEnd.Just)xsstep'<-consumeSomeOutputwriteEnd(Continuek)returnI$freadEndwriteEndtidstep'--------------------------------------------------------------------------threadProc::Chan(MaybeByteString)->Chan(EitherSomeException(StreamByteString))->IO()threadProcreadEndwriteEnd=dostream<-getChanContentsreadEndletbs=L.fromChunks$streamToChunksstreamletoutput=L.toChunks$compFuncbsrunItoutput`catch`\(e::SomeException)->writeChanwriteEnd$LeftewhererunIt(x:xs)=dowriteChanwriteEnd(toChunkx)>>runItxsrunIt[]=dowriteChanwriteEnd$RightEOF--------------------------------------------------------------------------streamToChunks[]=[]streamToChunks(Nothing:_)=[]streamToChunks((Justx):xs)=x:(streamToChunksxs)--------------------------------------------------------------------------toChunk=Right.Chunks.(:[])-------------------------------------------------------------------------------- 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