1 {-# OPTIONS_GHC -cpp #-} 2 {-# LANGUAGE CPP #-} 3 module Darcs.Email ( make_email, read_email, formatHeader ) where 4 5 import Data.Char ( digitToInt, isHexDigit, ord, intToDigit, isPrint, toUpper ) 6 import Data.List ( isInfixOf ) 7 import qualified Codec.Binary.UTF8.String as UTF8 ( encode ) 8 import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS) 9 10 import ByteStringUtils (dropSpace, linesPS, betweenLinesPS ) 11 import qualified Data.ByteString as B (ByteString, length, null, tail 12 ,drop, head, concat, singleton 13 ,pack, append, empty 14 ) 15 import qualified Data.ByteString.Char8 as BC (index, head, pack) 16 import Data.ByteString.Internal as B (c2w, createAndTrim) 17 import System.IO.Unsafe ( unsafePerformIO ) 18 import Foreign.Ptr ( Ptr, plusPtr ) 19 import Foreign.Storable ( poke ) 20 import Data.Word ( Word8 ) 21 22 -- line_max is maximum number of characters in an e-mail line excluding the CRLF 23 -- at the end. qline_max is the number of characters in a q-encoded or 24 -- quoted-printable-encoded line. 25 line_max, qline_max :: Int 26 line_max = 78 27 qline_max = 75 28 29 -- | Formats an e-mail header by encoding any non-ascii characters using UTF-8 30 -- and Q-encoding, and folding lines at appropriate points. It doesn't do 31 -- more than that, so the header name and header value should be 32 -- well-formatted give or take line length and encoding. So no non-ASCII 33 -- characters within quoted-string, quoted-pair, or atom; no semantically 34 -- meaningful signs in names; no non-ASCII characters in the header name; 35 -- etcetera. 36 formatHeader :: String -> String -> B.ByteString 37 formatHeader headerName headerValue = 38 B.append nameColon encodedValue 39 where nameColon = B.pack (map B.c2w (headerName ++ ":")) -- space for folding 40 encodedValue = fold_and_encode (' ':headerValue) 41 (B.length nameColon) False False 42 43 -- run through a string and encode non-ascii words and fold where appropriate. 44 -- the integer argument is the current position in the current line. 45 -- the string in the first argument must begin with whitespace, or be empty. 46 fold_and_encode :: String -> Int -> Bool -> Bool -> B.ByteString 47 fold_and_encode [] _ _ _ = B.empty 48 fold_and_encode s p lastWordEncoded inMidWord = 49 let newline = B.singleton 10 50 space = B.singleton 32 51 s2bs = B.pack . map B.c2w 52 -- the twelve there is the max number of ASCII chars to encode a single 53 -- character: 4 * 3, 4 UTF-8 bytes times 3 ASCII chars per byte 54 safeEncChunkLength = (qline_max - B.length encoded_word_start 55 - B.length encoded_word_end) `div` 12 56 (curSpace, afterCurSpace) = break (not . (== ' ')) s 57 (curWord, afterCurWord) = break (== ' ') afterCurSpace 58 qEncWord | lastWordEncoded = qEncode (curSpace ++ curWord) 59 | otherwise = qEncode curWord 60 mustEncode = inMidWord 61 || any (\c -> not (isPrint c) || (ord c) > 127) curWord 62 || length curWord > line_max - 1 63 || isInfixOf "=?" curWord 64 mustFold 65 | mustEncode && lastWordEncoded 66 = p + 1 + B.length qEncWord > line_max 67 | mustEncode 68 = p + length curSpace + B.length qEncWord > line_max 69 | otherwise 70 = p + length curSpace + length curWord > line_max 71 mustSplit = (B.length qEncWord > qline_max && mustEncode) 72 || length curWord > line_max - 1 73 spaceToInsert | mustEncode && lastWordEncoded = space 74 | otherwise = s2bs curSpace 75 wordToInsert 76 | mustEncode && mustSplit = qEncode (take safeEncChunkLength curWord) 77 | mustEncode = qEncWord 78 | otherwise = s2bs curWord 79 doneChunk | mustFold = B.concat [newline, spaceToInsert, wordToInsert] 80 | otherwise = B.concat [spaceToInsert, wordToInsert] 81 (rest, nextP) 82 | mustSplit 83 = (drop safeEncChunkLength curWord ++ afterCurWord, qline_max + 1) 84 | mustEncode && mustFold 85 = (afterCurWord, B.length spaceToInsert + B.length wordToInsert) 86 | otherwise 87 = (afterCurWord, p + B.length doneChunk) 88 in B.append doneChunk (fold_and_encode rest nextP mustEncode mustSplit) 89 90 -- | Turns a piece of string into a q-encoded block 91 -- Applies q-encoding, for use in e-mail header values, as defined in RFC 2047. 92 -- It just takes a string and builds an encoded-word from it, it does not check 93 -- length or necessity. 94 qEncode :: String -> B.ByteString 95 qEncode s = B.concat [encoded_word_start, 96 encodedString, 97 encoded_word_end] 98 where encodedString = B.concat (map q_encode_char s) 99 100 encoded_word_start, encoded_word_end :: B.ByteString 101 encoded_word_start = B.pack (map B.c2w "=?UTF-8?Q?") 102 encoded_word_end = B.pack (map B.c2w "?=") 103 104 -- turns a character into its q-encoded bytestring value. For most printable 105 -- ASCII characters, that's just the singleton bytestring with that char. 106 q_encode_char :: Char -> B.ByteString 107 q_encode_char c 108 | c == ' ' = c2bs '_' 109 | isPrint c 110 && not (c `elem` ['?', '=', '_']) 111 && ord c < 128 = c2bs c 112 | otherwise = B.concat (map qbyte (UTF8.encode [c])) 113 where c2bs = B.singleton . B.c2w 114 -- qbyte turns a byte into its q-encoded "=hh" representation 115 qbyte b = B.pack (map B.c2w ['=' 116 ,word8ToUDigit (b `div` 16) 117 ,word8ToUDigit (b `mod` 16) 118 ]) 119 word8ToUDigit :: Word8 -> Char 120 word8ToUDigit = toUpper . intToDigit . fromIntegral 121 122 -- TODO is this doing mime encoding?? 123 qpencode :: B.ByteString -> B.ByteString 124 qpencode s = unsafePerformIO 125 -- Really only (3 + 2/75) * length or something in the worst case 126 $ B.createAndTrim (4 * B.length s) (\buf -> encode s qline_max buf 0) 127 128 encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int 129 encode ps _ _ bufi | B.null ps = return bufi 130 encode ps n buf bufi = case B.head ps of 131 c | c == newline -> 132 do poke (buf `plusPtr` bufi) newline 133 encode ps' qline_max buf (bufi+1) 134 | n == 0 && B.length ps > 1 -> 135 do poke (buf `plusPtr` bufi) equals 136 poke (buf `plusPtr` (bufi+1)) newline 137 encode ps qline_max buf (bufi + 2) 138 | (c == tab || c == space) -> 139 if B.null ps' || B.head ps' == newline 140 then do poke (buf `plusPtr` bufi) c 141 poke (buf `plusPtr` (bufi+1)) equals 142 poke (buf `plusPtr` (bufi+2)) newline 143 encode ps' qline_max buf (bufi + 3) 144 else do poke (buf `plusPtr` bufi) c 145 encode ps' (n - 1) buf (bufi + 1) 146 | (c >= bang && c /= equals && c <= tilde) -> 147 do poke (buf `plusPtr` bufi) c 148 encode ps' (n - 1) buf (bufi + 1) 149 | n < 3 -> 150 encode ps 0 buf bufi 151 | otherwise -> 152 do let (x, y) = c `divMod` 16 153 h1 = intToUDigit x 154 h2 = intToUDigit y 155 poke (buf `plusPtr` bufi) equals 156 poke (buf `plusPtr` (bufi+1)) h1 157 poke (buf `plusPtr` (bufi+2)) h2 158 encode ps' (n - 3) buf (bufi + 3) 159 where ps' = B.tail ps 160 newline = B.c2w '\n' 161 tab = B.c2w '\t' 162 space = B.c2w ' ' 163 bang = B.c2w '!' 164 tilde = B.c2w '~' 165 equals = B.c2w '=' 166 intToUDigit i 167 | i >= 0 && i <= 9 = B.c2w '0' + i 168 | i >= 10 && i <= 15 = B.c2w 'A' + i - 10 169 | otherwise = error $ "intToUDigit: '"++show i++"'not a digit" 170 171 qpdecode :: B.ByteString -> B.ByteString 172 qpdecode s = unsafePerformIO 173 -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n" 174 $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0) 175 176 decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int 177 decode [] _ bufi = return bufi 178 decode (ps:pss) buf bufi 179 | B.null (dropSpace ps) 180 = do poke (buf `plusPtr` bufi) newline 181 decode pss buf (bufi+1) 182 | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2 183 = do poke (buf `plusPtr` bufi) 184 (toWord8 $ digitToInt c1 * 16 + digitToInt c2) 185 decode (B.drop 3 ps:pss) buf (bufi+1) 186 | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi 187 | otherwise = do poke (buf `plusPtr` bufi) (B.head ps) 188 decode (B.tail ps:pss) buf (bufi+1) 189 where is_equals = BC.head ps == '=' 190 c1 = BC.index ps 1 191 c2 = BC.index ps 2 192 newline = B.c2w '\n' 193 toWord8 :: Int -> Word8 194 toWord8 = fromIntegral 195 196 make_email :: String -> [(String, String)] -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc 197 make_email repodir headers mcontents bundle mfilename = 198 text "DarcsURL:" <+> text repodir 199 $$ foldl (\m (h,v) -> m $$ (text (h ++ ":") <+> text v)) empty headers 200 $$ text "MIME-Version: 1.0" 201 $$ text "Content-Type: multipart/mixed; boundary=\"=_\"" 202 $$ text "" 203 $$ text "--=_" 204 $$ (case mcontents of 205 Just contents -> 206 text "Content-Type: text/plain" 207 $$ text "Content-Transfer-Encoding: quoted-printable" 208 $$ text "" 209 $$ packedString (qpencode (renderPS contents)) 210 $$ text "" 211 $$ text "--=_" 212 Nothing -> empty) 213 $$ text "Content-Type: text/x-darcs-patch" <> 214 (case mfilename of 215 Just filename -> text "; name=\"" <> text filename <> text "\"" 216 Nothing -> empty) 217 $$ text "Content-Transfer-Encoding: quoted-printable" 218 $$ text "Content-Description: A darcs patch for your repository!" 219 $$ text "" 220 $$ packedString (qpencode (renderPS bundle)) 221 $$ text "--=_--" 222 $$ text "" 223 $$ text "." 224 $$ text "" 225 $$ text "" 226 227 read_email :: B.ByteString -> B.ByteString 228 read_email s = 229 case betweenLinesPS 230 (BC.pack "Content-Description: A darcs patch for your repository!") 231 (BC.pack "--=_--") s of 232 Nothing -> s -- if it wasn't an email in the first place, just pass along. 233 Just s' -> qpdecode s' 234