{- |
Module : MIME.Parse
Copyright : (c) 2006-2007 Galois Inc.
Maintainer : tse-dev-team@galois.com
Stability : unstable
Portability : GHC
Parsing MIME content.
-}moduleCodec.MIME.Parse(parseMIMEBody,parseMIMEType)whereimportCodec.MIME.TypeimportCodec.MIME.DecodeimportData.CharimportData.MaybeimportData.ListimportDebug.Trace(trace)parseMIMEBody::[(String,String)]->String->MIMEValueparseMIMEBodyheaders_inbody=casemimeTypemtyofMultipart{}->fst(parseMultipartmtybody)Message{}->fst(parseMultipartmtybody)_->MIMEValuemty(parseContentDispheaders)(Single(processBodyheadersbody))whereheaders=[(maptoLowerk,v)|(k,v)<-headers_in]mty=fromMaybedefaultType(parseContentType=<<lookupField"content-type"headers)defaultType::TypedefaultType=Type{mimeType=Text"plain",mimeParams=[("charset","us-ascii")]}parseContentDisp::[(String,String)]->MaybeDispositionparseContentDispheaders=(processDisp.dropFoldingWSP)=<<lookupField"content-disposition"headerswhereprocessDisp""=NothingprocessDispxs=Just$casebreak(\ch->isSpacech||ch==';')xsof(as,"")->Disposition{dispType=toDispType(maptoLoweras),dispParams=[]}(as,bs)->Disposition{dispType=toDispType(maptoLoweras),dispParams=processParams(parseParamsbs)}processParams=mapprocPwhereprocP(as,val)|"name"==asl=Nameval|"filename"==asl=Filenameval|"creation-date"==asl=CreationDateval|"modification-date"==asl=ModDateval|"read-date"==asl=ReadDateval|"size"==asl=Sizeval|otherwise=OtherParam(maptoLoweras)valwhereasl=maptoLowerastoDispTypet=casetof"inline"->DispInline"attachment"->DispAttachment"form-data"->DispFormData_->DispOthertprocessBody::[(String,String)]->String->StringprocessBodyheadersbody=caselookupField"content-transfer-encoding"headersofNothing->bodyJustv->decodeBodyvbodyparseMIMEMessage::String->MIMEValueparseMIMEMessageentity=caseparseHeadersentityof(as,bs)->parseMIMEBodyasbsparseHeaders::String->([(String,String)],String)parseHeadersstr=casefindFieldName""strofLeft(nm,rs)->parseFieldValuenm(dropFoldingWSPrs)Rightbody->([],body)wherefindFieldName_acc""=Right""findFieldName_acc('\r':'\n':xs)=RightxsfindFieldNameacc(':':xs)=Left(reverse(dropWhileisHSpaceacc),xs)findFieldNameacc(x:xs)=findFieldName(x:acc)xsparseFieldValuenmxs=casetakeUntilCRLFxsof(as,"")->([(nm,as)],"")(as,bs)->let(zs,ys)=parseHeadersbsin((nm,as):zs,ys)parseMultipart::Type->String->(MIMEValue,String)parseMultipartmtybody=caselookupField"boundary"(mimeParamsmty)ofNothing->trace("Multipart mime type, "++showTypemty++", has no required boundary parameter. Defaulting to text/plain")$(MIMEValuedefaultTypeNothing(Singlebody),"")Justbnd->(MIMEValuemtyNothing(Multivals),rs)where(vals,rs)=splitMultibndbodysplitMulti::String->String->([MIMEValue],String)splitMultibndbody_in=-- Note: we insert a CRLF if it looks as if the boundary string starts-- right off the bat. No harm done if this turns out to be incorrect.letbody=casebody_inof'-':'-':_->('\r':'\n':body_in)_->body_inincaseuntilMatchdashBoundarybodyofNothing->([],"")Just('-':'-':xs)->([],xs)Justxs->splitMulti1(dropTrailerxs)wheredashBoundary=("\r\n--"++bnd)splitMulti1xs=casematchUntildashBoundaryxsof("","")->([],"")(as,"")->([parseMIMEMessageas],"")(as,'-':'-':bs)->([parseMIMEMessageas],dropTrailerbs)(as,bs)->let(zs,ys)=splitMulti1(dropTrailerbs)in((parseMIMEMessageas):zs,ys)dropTrailerxs=casedropWhileisHSpacexsof'\r':'\n':xs1->xs1xs1->xs1-- hmm, flag an error?parseMIMEType::String->MaybeTypeparseMIMEType=parseContentTypeparseContentType::String->MaybeTypeparseContentTypestr=casebreak(=='/')(dropFoldingWSPstr)of(maj,_:minor)->casebreak(\ch->isHSpacech||isTSpecialch)minorof(as,bs)->JustType{mimeType=toTypemajas,mimeParams=parseParams(dropWhileisHSpacebs)}_->trace("unable to parse content-type: "++showstr)$NothingwheretoTypeab=caselookupField(maptoLowera)mediaTypesofJustctor->ctorb_->OtherabparseParams::String->[(String,String)]parseParams""=[]parseParams(';':xs)=casebreak(=='=')(dropFoldingWSPxs)of(_,[])->[](nm_raw,_:vs)->casevsof'"':vs1->casebreak(=='"')vs1of(val,"")->[(nm,val)](val,_:zs)->(nm,val):parseParams(dropWhileisHSpacezs)_->casebreak(\ch->isHSpacech||isTSpecialch)vsof(val,zs)->(nm,val):parseParams(dropWhileisHSpacezs)wherenm=maptoLowernm_rawparseParamscs=trace("Codec.MIME.Parse.parseParams: curious param value -- "++showcs)[]mediaTypes::[(String,String->MIMEType)]mediaTypes=[("multipart",(Multipart.toMultipart)),("application",Application),("audio",Audio),("image",Image),("message",Message),("model",Model),("text",Text),("video",Video)]wheretoMultipartb=fromMaybeother(lookupField(maptoLowerb)multipartTypes)whereother=casebof'x':'-':_->Extensionb_->OtherMultibmultipartTypes::[(String,Multipart)]multipartTypes=[("alternative",Alternative),("byteranges",Byteranges),("digest",Digest),("encrypted",Encrypted),("form-data",FormData),("mixed",Mixed),("parallel",Parallel),("related",Related),("signed",Signed)]untilMatch::String->String->MaybeStringuntilMatchstrxs=gostrxswherego""rs=Justrsgo_""=Nothinggo(a:as)(b:bs)=ifa==bthengoasbselsegostrbsmatchUntil::String->String->(String,String)matchUntil_""=("","")matchUntilstrxs-- slow, but it'll do for now.|str`isPrefixOf`xs=("",drop(lengthstr)xs)matchUntilstr(x:xs)=let(as,bs)=matchUntilstrxsin(x:as,bs)isHSpace::Char->BoolisHSpacec=c==' '||c=='\t'isTSpecial::Char->BoolisTSpecialx=x`elem`"()<>@,;:\\\"/[]?="dropFoldingWSP::String->StringdropFoldingWSP""=""dropFoldingWSP(x:xs)|isHSpacex=dropFoldingWSPxsdropFoldingWSP('\r':'\n':x:xs)|isHSpacex=dropFoldingWSPxsdropFoldingWSP(x:xs)=x:xstakeUntilCRLF::String->(String,String)takeUntilCRLFstr=go""strwheregoacc""=(reverse(dropWhileisHSpaceacc),"")goacc('\r':'\n':x:xs)|isHSpacex=go(' ':acc)xs|otherwise=(reverse(dropWhileisHSpaceacc),x:xs)goacc(x:xs)=go(x:acc)xs-- case in-sensitive lookup of field names or attributes\/parameters.lookupField::String->[(String,a)]->MaybealookupFieldnns=-- assume that inputs have been mostly normalized already -- (i.e., lower-cased), but should the lookup fail fall back-- to a second try where we do normalize before giving up.caselookupnnsofx@Just{}->xNothing->letnl=maptoLowernincasefind(\(y,_)->nl==maptoLowery)nsofNothing->NothingJust(_,x)->Justx