module Darcs.UI.Email
( makeEmail
, readEmail
, formatHeader
, prop_qp_roundtrip
) where
import Prelude ()
import Darcs.Prelude
import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper )
import Data.List ( isInfixOf )
import Darcs.Util.Printer
( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS )
import Darcs.Util.ByteString ( packStringToUTF8, dropSpace, linesPS, betweenLinesPS )
import qualified Data.ByteString as B (ByteString, length, null, tail
,drop, head, concat, singleton
,pack, append, empty, unpack, snoc
)
import qualified Data.ByteString.Char8 as BC (index, head, pack)
import Data.ByteString.Internal as B (c2w, createAndTrim)
import System.IO.Unsafe ( unsafePerformIO )
import Foreign.Ptr ( Ptr, plusPtr )
import Foreign.Storable ( poke )
import Data.Word ( Word8 )
import Data.Maybe ( fromMaybe )
lineMax, qlineMax :: Int
lineMax = 78
qlineMax = 75
formatHeader :: String -> String -> B.ByteString
formatHeader headerName headerValue =
B.append nameColon encodedValue
where nameColon = B.pack (map B.c2w (headerName ++ ":"))
encodedValue = foldAndEncode (' ':headerValue)
(B.length nameColon) False False
foldAndEncode :: String -> Int -> Bool -> Bool -> B.ByteString
foldAndEncode [] _ _ _ = B.empty
foldAndEncode s p lastWordEncoded inMidWord =
let newline = B.singleton 10
space = B.singleton 32
s2bs = B.pack . map B.c2w
safeEncChunkLength = (qlineMax B.length encodedWordStart
B.length encodedWordEnd) `div` 12
(curSpace, afterCurSpace) = span (== ' ') s
(curWord, afterCurWord) = break (== ' ') afterCurSpace
qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord)
| otherwise = qEncode curWord
mustEncode = inMidWord
|| any (\c -> not (isPrint c) || ord c > 127) curWord
|| length curWord > lineMax 1
|| isInfixOf "=?" curWord
mustFold
| mustEncode && lastWordEncoded
= p + 1 + B.length qEncWord > lineMax
| mustEncode
= p + length curSpace + B.length qEncWord > lineMax
| otherwise
= p + length curSpace + length curWord > lineMax
mustSplit = (B.length qEncWord > qlineMax && mustEncode)
|| length curWord > lineMax 1
spaceToInsert | mustEncode && lastWordEncoded = space
| otherwise = s2bs curSpace
wordToInsert
| mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord)
| mustEncode = qEncWord
| otherwise = s2bs curWord
doneChunk | mustFold = B.concat [newline, spaceToInsert, wordToInsert]
| otherwise = B.concat [spaceToInsert, wordToInsert]
(rest, nextP)
| mustSplit
= (drop safeEncChunkLength curWord ++ afterCurWord, qlineMax + 1)
| mustEncode && mustFold
= (afterCurWord, B.length spaceToInsert + B.length wordToInsert)
| otherwise
= (afterCurWord, p + B.length doneChunk)
in B.append doneChunk (foldAndEncode rest nextP mustEncode mustSplit)
qEncode :: String -> B.ByteString
qEncode s = B.concat [encodedWordStart,
encodedString,
encodedWordEnd]
where encodedString = B.concat (map qEncodeChar s)
encodedWordStart, encodedWordEnd :: B.ByteString
encodedWordStart = B.pack (map B.c2w "=?UTF-8?Q?")
encodedWordEnd = B.pack (map B.c2w "?=")
qEncodeChar :: Char -> B.ByteString
qEncodeChar c
| c == ' ' = c2bs '_'
| isPrint c
&& c `notElem` "?=_"
&& ord c < 128 = c2bs c
| otherwise = B.concat
(map qbyte
(B.unpack
(packStringToUTF8 [c])))
where c2bs = B.singleton . B.c2w
qbyte b = B.pack (map B.c2w ['='
,word8ToUDigit (b `div` 16)
,word8ToUDigit (b `mod` 16)
])
word8ToUDigit :: Word8 -> Char
word8ToUDigit = toUpper . intToDigit . fromIntegral
qpencode :: B.ByteString -> B.ByteString
qpencode s = unsafePerformIO
$ B.createAndTrim (4 * B.length s) (\buf -> encode s qlineMax buf 0)
encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ps _ _ bufi | B.null ps = return bufi
encode ps n buf bufi = case B.head ps of
c | c == newline ->
do poke (buf `plusPtr` bufi) newline
encode ps' qlineMax buf (bufi+1)
| n == 0 && B.length ps >= 1 ->
do poke (buf `plusPtr` bufi) equals
poke (buf `plusPtr` (bufi+1)) newline
encode ps qlineMax buf (bufi + 2)
| c == tab || c == space ->
if B.null ps' || B.head ps' == newline
then do poke (buf `plusPtr` bufi) c
poke (buf `plusPtr` (bufi+1)) equals
poke (buf `plusPtr` (bufi+2)) newline
encode ps' qlineMax buf (bufi + 3)
else do poke (buf `plusPtr` bufi) c
encode ps' (n 1) buf (bufi + 1)
| c >= bang && c /= equals && c /= period && c <= tilde ->
do poke (buf `plusPtr` bufi) c
encode ps' (n 1) buf (bufi + 1)
| n < 3 ->
encode ps 0 buf bufi
| otherwise ->
do let (x, y) = c `divMod` 16
h1 = intToUDigit x
h2 = intToUDigit y
poke (buf `plusPtr` bufi) equals
poke (buf `plusPtr` (bufi+1)) h1
poke (buf `plusPtr` (bufi+2)) h2
encode ps' (n 3) buf (bufi + 3)
where ps' = B.tail ps
newline = B.c2w '\n'
tab = B.c2w '\t'
space = B.c2w ' '
bang = B.c2w '!'
tilde = B.c2w '~'
equals = B.c2w '='
period = B.c2w '.'
intToUDigit i
| i >= 0 && i <= 9 = B.c2w '0' + i
| i >= 10 && i <= 15 = B.c2w 'A' + i 10
| otherwise = error $ "intToUDigit: '"++show i++"'not a digit"
qpdecode :: B.ByteString -> B.ByteString
qpdecode s = unsafePerformIO
$ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)
decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int
decode [] _ bufi = return bufi
decode (ps:pss) buf bufi
| B.null (dropSpace ps)
= do poke (buf `plusPtr` bufi) newline
decode pss buf (bufi+1)
| is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2
= do poke (buf `plusPtr` bufi)
(toWord8 $ digitToInt c1 * 16 + digitToInt c2)
decode (B.drop 3 ps:pss) buf (bufi+1)
| is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi
| otherwise = do poke (buf `plusPtr` bufi) (B.head ps)
decode (B.tail ps:pss) buf (bufi+1)
where is_equals = BC.head ps == '='
c1 = BC.index ps 1
c2 = BC.index ps 2
newline = B.c2w '\n'
toWord8 :: Int -> Word8
toWord8 = fromIntegral
makeEmail :: String -> [(String, String)] -> Maybe Doc -> Maybe String -> Doc -> Maybe String -> Doc
makeEmail repodir headers mcontents mcharset bundle mfilename =
text "DarcsURL:" <+> text repodir
$$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers
$$ text "MIME-Version: 1.0"
$$ text "Content-Type: multipart/mixed; boundary=\"=_\""
$$ text ""
$$ text "--=_"
$$ (case mcontents of
Just contents ->
text ("Content-Type: text/plain; charset=\"" ++
fromMaybe "x-unknown" mcharset ++ "\"")
$$ text "Content-Transfer-Encoding: quoted-printable"
$$ text ""
$$ packedString (qpencode (renderPS contents))
$$ 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 ""
$$ (case betweenLinesPS (BC.pack "New patches:") (BC.pack "Context:") (renderPS bundle) of
Just s -> packedString $ qpencode s
Nothing -> packedString $ qpencode $ renderPS bundle)
$$ text "--=_"
$$ text "Content-Type: application/x-darcs-patch" <>
(case mfilename of
Just filename -> text "; name=\"" <> text filename <> 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 (renderPS bundle))
$$ text "--=_--"
$$ text ""
$$ text "."
$$ text ""
$$ text ""
readEmail :: B.ByteString -> B.ByteString
readEmail s =
case betweenLinesPS
(BC.pack "Content-Description: A darcs patch for your repository!")
(BC.pack "--=_--") s of
Nothing -> s
Just s' -> qpdecode s'
prop_qp_roundtrip :: B.ByteString -> Bool
prop_qp_roundtrip s = B.snoc s 10 == (qpdecode . qpencode) s