module Darcs.UI.Email ( makeEmail , readEmail , formatHeader -- just for testing , 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 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 :: Int lineMax = 78 qlineMax = 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.ByteString formatHeader headerName headerValue = B.append nameColon encodedValue where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding encodedValue = foldAndEncode (' ':headerValue) (B.length nameColon) False False -- 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.ByteString foldAndEncode [] _ _ _ = B.empty foldAndEncode s p lastWordEncoded inMidWord = let newline = B.singleton 10 space = B.singleton 32 s2bs = B.pack . map B.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 byte 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) -- | 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.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 "?=") -- 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.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 turns a byte into its q-encoded "=hh" representation qbyte b = B.pack (map B.c2w ['=' ,word8ToUDigit (b `div` 16) ,word8ToUDigit (b `mod` 16) ]) word8ToUDigit :: Word8 -> Char word8ToUDigit = toUpper . intToDigit . fromIntegral -- Encode a ByteString according to "Quoted Printable" defined by MIME -- (https://tools.ietf.org/html/rfc2045#section-6.7) qpencode :: B.ByteString -> B.ByteString qpencode s = unsafePerformIO -- Really only (3 + 2/75) * length or something in the worst case $ 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 -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n" $ 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 -- this should not happen, but in case it does, keep everything 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 -- if it wasn't an email in the first place, just pass along. Just s' -> qpdecode s' -- note: qpdecode appends an extra '\n' prop_qp_roundtrip :: B.ByteString -> Bool prop_qp_roundtrip s = B.snoc s 10 == (qpdecode . qpencode) s