{-# LANGUAGE CPP #-}moduleDarcs.Email(makeEmail,readEmail,formatHeader)whereimportData.Char(digitToInt,isHexDigit,ord,intToDigit,isPrint,toUpper)importData.List(isInfixOf)importPrinter(Doc,($$),(<+>),(<>),text,empty,packedString,renderPS)importByteStringUtils(packStringToUTF8,dropSpace,linesPS,betweenLinesPS)importqualifiedData.ByteStringasB(ByteString,length,null,tail,drop,head,concat,singleton,pack,append,empty,unpack)importqualifiedData.ByteString.Char8asBC(index,head,pack)importData.ByteString.InternalasB(c2w,createAndTrim)importSystem.IO.Unsafe(unsafePerformIO)importForeign.Ptr(Ptr,plusPtr)importForeign.Storable(poke)importData.Word(Word8)importData.Maybe(fromMaybe)-- lineMax is maximum number of characters in an e-mail line excluding the CRLF-- at the end. qlineMax is the number of characters in a q-encoded or-- quoted-printable-encoded line.lineMax,qlineMax::IntlineMax=78qlineMax=75-- | Formats an e-mail header by encoding any non-ascii characters using UTF-8-- and Q-encoding, and folding lines at appropriate points. It doesn't do-- more than that, so the header name and header value should be-- well-formatted give or take line length and encoding. So no non-ASCII-- characters within quoted-string, quoted-pair, or atom; no semantically-- meaningful signs in names; no non-ASCII characters in the header name;-- etcetera.formatHeader::String->String->B.ByteStringformatHeaderheaderNameheaderValue=B.appendnameColonencodedValuewherenameColon=B.pack(mapB.c2w(headerName++":"))-- space for foldingencodedValue=foldAndEncode(' ':headerValue)(B.lengthnameColon)FalseFalse-- run through a string and encode non-ascii words and fold where appropriate.-- the integer argument is the current position in the current line.-- the string in the first argument must begin with whitespace, or be empty.foldAndEncode::String->Int->Bool->Bool->B.ByteStringfoldAndEncode[]___=B.emptyfoldAndEncodesplastWordEncodedinMidWord=letnewline=B.singleton10space=B.singleton32s2bs=B.pack.mapB.c2w-- the twelve there is the max number of ASCII chars to encode a single-- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per bytesafeEncChunkLength=(qlineMax-B.lengthencodedWordStart-B.lengthencodedWordEnd)`div`12(curSpace,afterCurSpace)=span(==' ')s(curWord,afterCurWord)=break(==' ')afterCurSpaceqEncWord|lastWordEncoded=qEncode(curSpace++curWord)|otherwise=qEncodecurWordmustEncode=inMidWord||any(\c->not(isPrintc)||(ordc)>127)curWord||lengthcurWord>lineMax-1||isInfixOf"=?"curWordmustFold|mustEncode&&lastWordEncoded=p+1+B.lengthqEncWord>lineMax|mustEncode=p+lengthcurSpace+B.lengthqEncWord>lineMax|otherwise=p+lengthcurSpace+lengthcurWord>lineMaxmustSplit=(B.lengthqEncWord>qlineMax&&mustEncode)||lengthcurWord>lineMax-1spaceToInsert|mustEncode&&lastWordEncoded=space|otherwise=s2bscurSpacewordToInsert|mustEncode&&mustSplit=qEncode(takesafeEncChunkLengthcurWord)|mustEncode=qEncWord|otherwise=s2bscurWorddoneChunk|mustFold=B.concat[newline,spaceToInsert,wordToInsert]|otherwise=B.concat[spaceToInsert,wordToInsert](rest,nextP)|mustSplit=(dropsafeEncChunkLengthcurWord++afterCurWord,qlineMax+1)|mustEncode&&mustFold=(afterCurWord,B.lengthspaceToInsert+B.lengthwordToInsert)|otherwise=(afterCurWord,p+B.lengthdoneChunk)inB.appenddoneChunk(foldAndEncoderestnextPmustEncodemustSplit)-- | Turns a piece of string into a q-encoded block-- Applies q-encoding, for use in e-mail header values, as defined in RFC 2047.-- It just takes a string and builds an encoded-word from it, it does not check-- length or necessity.qEncode::String->B.ByteStringqEncodes=B.concat[encodedWordStart,encodedString,encodedWordEnd]whereencodedString=B.concat(mapqEncodeChars)encodedWordStart,encodedWordEnd::B.ByteStringencodedWordStart=B.pack(mapB.c2w"=?UTF-8?Q?")encodedWordEnd=B.pack(mapB.c2w"?=")-- turns a character into its q-encoded bytestring value. For most printable-- ASCII characters, that's just the singleton bytestring with that char.qEncodeChar::Char->B.ByteStringqEncodeCharc|c==' '=c2bs'_'|isPrintc&&not(c`elem`['?','=','_'])&&ordc<128=c2bsc|otherwise=B.concat(mapqbyte(B.unpack(packStringToUTF8[c])))wherec2bs=B.singleton.B.c2w-- qbyte turns a byte into its q-encoded "=hh" representationqbyteb=B.pack(mapB.c2w['=',word8ToUDigit(b`div`16),word8ToUDigit(b`mod`16)])word8ToUDigit::Word8->Charword8ToUDigit=toUpper.intToDigit.fromIntegral-- TODO is this doing mime encoding??qpencode::B.ByteString->B.ByteStringqpencodes=unsafePerformIO-- Really only (3 + 2/75) * length or something in the worst case$B.createAndTrim(4*B.lengths)(\buf->encodesqlineMaxbuf0)encode::B.ByteString->Int->PtrWord8->Int->IOIntencodeps__bufi|B.nullps=returnbufiencodepsnbufbufi=caseB.headpsofc|c==newline->dopoke(buf`plusPtr`bufi)newlineencodeps'qlineMaxbuf(bufi+1)|n==0&&B.lengthps>1->dopoke(buf`plusPtr`bufi)equalspoke(buf`plusPtr`(bufi+1))newlineencodepsqlineMaxbuf(bufi+2)|(c==tab||c==space)->ifB.nullps'||B.headps'==newlinethendopoke(buf`plusPtr`bufi)cpoke(buf`plusPtr`(bufi+1))equalspoke(buf`plusPtr`(bufi+2))newlineencodeps'qlineMaxbuf(bufi+3)elsedopoke(buf`plusPtr`bufi)cencodeps'(n-1)buf(bufi+1)|(c>=bang&&c/=equals&&c<=tilde)->dopoke(buf`plusPtr`bufi)cencodeps'(n-1)buf(bufi+1)|n<3->encodeps0bufbufi|otherwise->dolet(x,y)=c`divMod`16h1=intToUDigitxh2=intToUDigitypoke(buf`plusPtr`bufi)equalspoke(buf`plusPtr`(bufi+1))h1poke(buf`plusPtr`(bufi+2))h2encodeps'(n-3)buf(bufi+3)whereps'=B.tailpsnewline=B.c2w'\n'tab=B.c2w'\t'space=B.c2w' 'bang=B.c2w'!'tilde=B.c2w'~'equals=B.c2w'='intToUDigiti|i>=0&&i<=9=B.c2w'0'+i|i>=10&&i<=15=B.c2w'A'+i-10|otherwise=error$"intToUDigit: '"++showi++"'not a digit"qpdecode::B.ByteString->B.ByteStringqpdecodes=unsafePerformIO-- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"$B.createAndTrim(B.lengths+1)(\buf->decode(linesPSs)buf0)decode::[B.ByteString]->PtrWord8->Int->IOIntdecode[]_bufi=returnbufidecode(ps:pss)bufbufi|B.null(dropSpaceps)=dopoke(buf`plusPtr`bufi)newlinedecodepssbuf(bufi+1)|is_equals&&B.lengthps>=3&&isHexDigitc1&&isHexDigitc2=dopoke(buf`plusPtr`bufi)(toWord8$digitToIntc1*16+digitToIntc2)decode(B.drop3ps:pss)buf(bufi+1)|is_equals&&B.null(dropSpace(B.tailps))=decodepssbufbufi|otherwise=dopoke(buf`plusPtr`bufi)(B.headps)decode(B.tailps:pss)buf(bufi+1)whereis_equals=BC.headps=='='c1=BC.indexps1c2=BC.indexps2newline=B.c2w'\n'toWord8::Int->Word8toWord8=fromIntegralmakeEmail::String->[(String,String)]->(MaybeDoc)->MaybeString->Doc->(MaybeString)->DocmakeEmailrepodirheadersmcontentsmcharsetbundlemfilename=text"DarcsURL:"<+>textrepodir$$foldl(\m(h,v)->m$$(text(h++":")<+>textv))emptyheaders$$text"MIME-Version: 1.0"$$text"Content-Type: multipart/mixed; boundary=\"=_\""$$text""$$text"--=_"$$(casemcontentsofJustcontents->text("Content-Type: text/plain; charset=\""++fromMaybe"x-unknown"mcharset++"\"")$$text"Content-Transfer-Encoding: quoted-printable"$$text""$$packedString(qpencode(renderPScontents))$$text""$$text"--=_"Nothing->empty)$$text"Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""$$text"Content-Disposition: inline"$$text"Content-Transfer-Encoding: quoted-printable"$$text"Content-Description: Patch preview"$$text""$$(casebetweenLinesPS(BC.pack"New patches:")(BC.pack"Context:")(renderPSbundle)ofJusts->packedString$qpencodes-- this should not happen, but in case it does, keep everythingNothing->packedString$qpencode$renderPSbundle)$$text"--=_"$$text"Content-Type: application/x-darcs-patch"<>(casemfilenameofJustfilename->text"; name=\""<>textfilename<>text"\""Nothing->empty)$$text"Content-Transfer-Encoding: quoted-printable"$$text"Content-Disposition: attachment"$$text"Content-Description: A darcs patch for your repository!"$$text""$$packedString(qpencode(renderPSbundle))$$text"--=_--"$$text""$$text"."$$text""$$text""readEmail::B.ByteString->B.ByteStringreadEmails=casebetweenLinesPS(BC.pack"Content-Description: A darcs patch for your repository!")(BC.pack"--=_--")sofNothing->s-- if it wasn't an email in the first place, just pass along.Justs'->qpdecodes'