{-# LANGUAGE CPP #-}-- | Some helpers for parsing data out of a raw WAI 'Request'.moduleNetwork.Wai.Parse(parseQueryString,parseCookies,parseHttpAccept,parseRequestBody,Sink(..),lbsSink,tempFileSink,FileInfo(..)#if TEST,Bound(..),findBound,sinkTillBound#endif)whereimportqualifiedData.ByteStringasSimportqualifiedData.ByteString.LazyasLimportqualifiedData.ByteString.Char8asS8importData.Word(Word8)importData.BitsimportData.Maybe(fromMaybe)importData.List(sortBy)importData.Function(on)importSystem.Directory(removeFile,getTemporaryDirectory)importSystem.IO(hClose,openBinaryTempFile,Handle)importNetwork.Waiuncons::S.ByteString->Maybe(Word8,S.ByteString)unconss|S.nulls=Nothing|otherwise=Just(S.heads,S.tails)breakDiscard::Word8->S.ByteString->(S.ByteString,S.ByteString)breakDiscardws=let(x,y)=S.break(==w)sin(x,S.drop1y)-- | Split out the query string into a list of keys and values. A few-- importants points:---- * There is no way to distinguish between a parameter with no value and a-- parameter with an empty value. Eg, "foo=" and "foo" are the same.---- * The result returned is still bytestrings, since we perform no character-- decoding here. Most likely, you will want to use UTF-8 decoding, but this is-- left to the user of the library.---- * Percent decoding errors are ignored. In particular, "%Q" will be output as-- "%Q".parseQueryString::S.ByteString->[(S.ByteString,S.ByteString)]parseQueryString=parseQueryString'.dropQuestionwheredropQuestionq|S.nullq||S.headq/=63=qdropQuestionq|otherwise=S.tailqparseQueryString'q|S.nullq=[]parseQueryString'q=let(x,xs)=breakDiscard38q-- ampersandinparsePairx:parseQueryString'xswhereparsePairx=let(k,v)=breakDiscard61x-- equal signin(qsDecodek,qsDecodev)qsDecode::S.ByteString->S.ByteStringqsDecodez=fst$S.unfoldrN(S.lengthz)gozwheregobs=caseunconsbsofNothing->NothingJust(43,ws)->Just(32,ws)-- plus to spaceJust(37,ws)->Just$fromMaybe(37,ws)$do-- percent(x,xs)<-unconswsx'<-hexValx(y,ys)<-unconsxsy'<-hexValyJust$(combinex'y',ys)Just(w,ws)->Just(w,ws)hexValw|48<=w&&w<=57=Just$w-48-- 0 - 9|65<=w&&w<=70=Just$w-55-- A - F|97<=w&&w<=102=Just$w-87-- a - f|otherwise=Nothingcombine::Word8->Word8->Word8combineab=shiftLa4.|.b-- | Decode the value of an HTTP_COOKIE header into key/value pairs.parseCookies::S.ByteString->[(S.ByteString,S.ByteString)]parseCookiess|S.nulls=[]|otherwise=let(first,rest)=breakDiscard59s-- semicoloninparseCookiefirst:parseCookiesrestparseCookie::S.ByteString->(S.ByteString,S.ByteString)parseCookies=let(key,value)=breakDiscard61s-- equals signkey'=S.dropWhile(==32)key-- spacein(key',value)-- | Parse the HTTP accept string to determine supported content types.parseHttpAccept::S.ByteString->[S.ByteString]parseHttpAccept=mapfst.sortBy(rcompare`on`snd).mapgrabQ.S.split44-- commawherercompare::Double->Double->Orderingrcompare=flipcomparegrabQs=let(s',q)=breakDiscard59s-- semicolon(_,q')=breakDiscard61q-- equals signin(trimWhites',readQ$trimWhiteq')readQs=casereads$S8.unpacksof(x,_):_->x_->1.0trimWhite=S.dropWhile(==32)-- space-- | A destination for data, the opposite of a 'Source'.dataSinkxy=Sink{sinkInit::IOx,sinkAppend::x->S.ByteString->IOx,sinkClose::x->IOy,sinkFinalize::y->IO()}lbsSink::Sink([S.ByteString]->[S.ByteString])L.ByteStringlbsSink=Sink{sinkInit=returnid,sinkAppend=\frontbs->return$front.(:)bs,sinkClose=\front->return$L.fromChunks$front[],sinkFinalize=\_->return()}tempFileSink::Sink(FilePath,Handle)FilePathtempFileSink=Sink{sinkInit=dotempDir<-getTemporaryDirectoryopenBinaryTempFiletempDir"webenc.buf",sinkAppend=\(fp,h)bs->S.hPuthbs>>return(fp,h),sinkClose=\(fp,h)->dohClosehreturnfp,sinkFinalize=\fp->removeFilefp}-- | Information on an uploaded file.dataFileInfoc=FileInfo{fileName::S.ByteString,fileContentType::S.ByteString,fileContent::c}deriving(Eq,Show)typeParam=(S.ByteString,S.ByteString)typeFiley=(S.ByteString,FileInfoy)parseRequestBody::Sinkxy->Request->IO([Param],[Filey])parseRequestBodysinkreq=doletctype=doctype'<-lookupReqContentType$requestHeadersreqifurlenc`S.isPrefixOf`ctype'thenJustNothingelseifformBound`S.isPrefixOf`ctype'thenJust$Just$S.drop(S.lengthformBound)ctype'elseNothingcasectypeofNothing->return([],[])JustNothing->do-- url-encoded-- NOTE: in general, url-encoded data will be in a single chunk.-- Therefore, I'm optimizing for the usual case by sticking with-- strict byte strings here.bs<-sourceToBs$requestBodyreqreturn(parseQueryStringbs,[])Just(Justbound)->-- multi-partletbound'=S8.pack"--"`S.append`boundinparsePiecessinkbound'(S.empty,Just$requestBodyreq)whereurlenc=S8.pack"application/x-www-form-urlencoded"formBound=S8.pack"multipart/form-data; boundary="sourceToBs::Source->IOS.ByteStringsourceToBs=fmapS.concat.goidwheregofront(Sourcesrc)=dores<-srccaseresofNothing->return$front[]Just(bs,src')->go(front.(:)bs)src'typeSource'=(S.ByteString,MaybeSource)takeLine::Source'->IO(Maybe(S.ByteString,Source'))takeLine(s,msrc)|S.nulls=casemsrcofNothing->returnNothingJust(Sourcesrc)->dores<-srccaseresofNothing->returnNothingJust(x,y)->takeLine(x,Justy)takeLine(s,msrc)=let(x,y)=S.break(==10)s-- newlineinifS.nullythendocasemsrcofNothing->return$Just(x,(y,msrc))Just(Sourcesrc)->dores<-srccaseresofNothing->return$Just(x,(y,Nothing))Just(s',src')->takeLine(s`S.append`s',Justsrc')elsereturn$Just(killCarriagex,(S.drop1y,msrc))wherekillCarriagebs|S.nullbs=bs|S.lastbs==13=S.initbs-- carriage return|otherwise=bstakeLines::Source'->IO(Maybe([S.ByteString],Source'))takeLinessrc=dores<-takeLinesrccaseresofNothing->returnNothingJust(l,src')->ifS.nulllthenreturn$Just([],src')elsedores'<-takeLinessrc'caseres'ofNothing->return$Just([l],src')Just(ls,src'')->return$Just(l:ls,src'')parsePieces::Sinkxy->S.ByteString->Source'->IO([Param],[Filey])parsePiecessinkboundsrc=dores<-takeLinesrcsrc'<-caseresofNothing->return(S.empty,Nothing)Just(_bs,src')->returnsrc'res'<-takeLinessrc'caseres'ofNothing->return([],[])Just(ls,src'')->doletls'=mapparsePairlsletx=docd<-lookupcontDispls'ct<-lookupcontTypels'letattrs=parseAttrscdletnameBS=S8.pack"name"name<-lookupnameBSattrsletfnBS=S8.pack"filename"return(ct,name,lookupfnBSattrs)casexofJust(ct,name,Justfilename)->doseed<-sinkInitsink(seed',wasFound,msrc''')<-sinkTillBoundboundsrc''(sinkAppendsink)seedy<-sinkClosesinkseed'letfi=FileInfofilenamectylety'=(name,fi)(xs,ys)<-ifwasFoundthenparsePiecessinkboundmsrc'''elsereturn([],[])return(xs,y':ys)Just(_ct,name,Nothing)->doletseed=idletiterfrontbs=return$front.(:)bs(front,wasFound,msrc''')<-sinkTillBoundboundsrc''iterseedletbs=S.concat$front[]letx'=(name,qsDecodebs)(xs,ys)<-ifwasFoundthenparsePiecessinkboundmsrc'''elsereturn([],[])return(x':xs,ys)Nothing->do-- ignore this partletseed=()iter()_=return()((),wasFound,msrc''')<-sinkTillBoundboundsrc''iterseedifwasFoundthenparsePiecessinkboundmsrc'''elsereturn([],[])wherecontDisp=S8.pack"Content-Disposition"contType=S8.pack"Content-Type"parsePairs=let(x,y)=breakDiscard58s-- colonin(x,S.dropWhile(==32)y)-- spacedataBound=FoundBoundS.ByteStringS.ByteString|NoBound|PartialBoundderiving(Eq,Show)findBound::S.ByteString->S.ByteString->BoundfindBoundbbs=go[0..S.lengthbs-1]wherego[]=NoBoundgo(i:is)|mismatch[0..S.lengthb-1][i..S.lengthbs-1]=gois|otherwise=letendI=i+S.lengthbinifendI>S.lengthbsthenPartialBoundelseFoundBound(S.takeibs)(S.dropendIbs)mismatch[]_=Falsemismatch_[]=Falsemismatch(x:xs)(y:ys)|S.indexbx==S.indexbsy=mismatchxsys|otherwise=TruesinkTillBound::S.ByteString->Source'->(x->S.ByteString->IOx)->x->IO(x,Bool,Source')sinkTillBoundbound(bs,msrc)iterseed=docasefindBoundboundbsofNoBound->docasemsrcofNothing->doseed'<-iterseedbsreturn(seed',False,(S.empty,Nothing))Just(Sourcesrc)->dores<-srccaseresofNothing->doseed'<-iterseedbsreturn(seed',False,(S.empty,Nothing))Just(bs',src')->do-- this funny bit is to catch when there's a-- newline at the end of the previous chunk(seed',bs'')<-ifnot(S8.nullbs)&&S8.lastbs`elem`"\n\r"thendolet(front,back)=S.splitAt(S.lengthbs-2)bsseed'<-iterseedfrontreturn(seed',back`S.append`bs')elsedoseed'<-iterseedbsreturn(seed',bs')sinkTillBoundbound(bs'',Justsrc')iterseed'FoundBoundbeforeafter->doletbefore'=killCRLFbeforeseed'<-iterseedbefore'return(seed',True,(after,msrc))PartialBound->do-- not so efficient, but hopefully the unusual casecasemsrcofNothing->doseed'<-iterseedbsreturn(seed',False,(S.empty,Nothing))Just(Sourcesrc)->dores<-srccaseresofNothing->doseed'<-iterseedbsreturn(seed',False,(S.empty,Nothing))Just(bs',src')->doletbs''=bs`S.append`bs'sinkTillBoundbound(bs'',Justsrc')iterseedparseAttrs::S.ByteString->[(S.ByteString,S.ByteString)]parseAttrs=mapgo.S.split59-- semicolonwheretw=S.dropWhile(==32)-- spacedqs=ifS.lengths>2&&S.heads==34&&S.lasts==34-- quotethenS.tail$S.initselsesgos=let(x,y)=breakDiscard61s-- equals signin(twx,dq$twy)killCRLF::S.ByteString->S.ByteStringkillCRLFbs|S.nullbs||S8.lastbs/='\n'=bs|otherwise=killCR$S.initbskillCR::S.ByteString->S.ByteStringkillCRbs|S.nullbs||S8.lastbs/='\r'=bs|otherwise=S.initbs