File: Email.hs

package info (click to toggle)
darcs 2.12.4-2
  • links: PTS, VCS
  • area: main
  • in suites: stretch
  • size: 5,748 kB
  • sloc: haskell: 42,936; sh: 11,086; ansic: 837; perl: 129; makefile: 8
file content (259 lines) | stat: -rw-r--r-- 11,143 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
{-# LANGUAGE CPP #-}
module Darcs.UI.Email
    ( makeEmail
    , readEmail
    , formatHeader
    ) 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
    , RenderMode(..)
    )

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
                                                )
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

-- TODO is this doing mime encoding??
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 Standard 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 Standard bundle) of
     Just s -> packedString $ qpencode s
     -- this should not happen, but in case it does, keep everything
     Nothing -> packedString $ qpencode $ renderPS Standard 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 Standard 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'