src/Darcs/Email.hs

   1 {-# OPTIONS_GHC -cpp #-}
   2 {-# LANGUAGE CPP #-}
   3 module Darcs.Email ( make_email, read_email ) where
   4
   5 import Data.Char ( digitToInt, isHexDigit )
   6 import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)
   7
   8 import ByteStringUtils (dropSpace, linesPS, betweenLinesPS )
   9 import qualified Data.ByteString          as B  (ByteString, length, null, tail, drop, head)
  10 import qualified Data.ByteString.Char8    as BC (index, head, pack)
  11 #if __GLASGOW_HASKELL__ > 606
  12 import Data.ByteString.Internal as B (c2w, createAndTrim)
  13 #else
  14 import Data.ByteString.Base as B (c2w, createAndTrim)
  15 #endif
  16 import System.IO.Unsafe ( unsafePerformIO )
  17 import Foreign.Ptr ( Ptr, plusPtr )
  18 import Foreign.Storable ( poke )
  19 import Data.Word ( Word8 )
  20
  21 line_max :: Int
  22 line_max = 75
  23
  24 -- TODO is this doing mime encoding??
  25 qpencode :: B.ByteString -> B.ByteString
  26 qpencode s = unsafePerformIO
  27            -- Really only (3 + 2/75) * length or something in the worst case
  28            $ B.createAndTrim (4 * B.length s) (\buf -> encode s line_max buf 0)
  29
  30 encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int
  31 encode ps _ _ bufi | B.null ps = return bufi
  32 encode ps n buf bufi = case B.head ps of
  33   c | c == newline ->
  34         do poke (buf `plusPtr` bufi) newline
  35            encode ps' line_max buf (bufi+1)
  36     | n == 0 && B.length ps > 1 ->
  37         do poke (buf `plusPtr` bufi) equals
  38            poke (buf `plusPtr` (bufi+1)) newline
  39            encode ps line_max buf (bufi + 2)
  40     | (c == tab || c == space) ->
  41         if B.null ps' || B.head ps' == newline
  42         then do poke (buf `plusPtr` bufi) c
  43                 poke (buf `plusPtr` (bufi+1)) equals
  44                 poke (buf `plusPtr` (bufi+2)) newline
  45                 encode ps' line_max buf (bufi + 3)
  46         else do poke (buf `plusPtr` bufi) c
  47                 encode ps' (n - 1) buf (bufi + 1)
  48     | (c >= bang && c /= equals && c <= tilde) ->
  49         do poke (buf `plusPtr` bufi) c
  50            encode ps' (n - 1) buf (bufi + 1)
  51     | n < 3 ->
  52         encode ps 0 buf bufi
  53     | otherwise ->
  54         do let (x, y) = c `divMod` 16
  55                h1 = intToUDigit x
  56                h2 = intToUDigit y
  57            poke (buf `plusPtr` bufi) equals
  58            poke (buf `plusPtr` (bufi+1)) h1
  59            poke (buf `plusPtr` (bufi+2)) h2
  60            encode ps' (n - 3) buf (bufi + 3)
  61     where ps' = B.tail ps
  62           newline = B.c2w '\n'
  63           tab     = B.c2w '\t'
  64           space   = B.c2w ' '
  65           bang    = B.c2w '!'
  66           tilde   = B.c2w '~'
  67           equals  = B.c2w '='
  68           intToUDigit i
  69             | i >= 0  && i <= 9  = B.c2w '0' + i
  70             | i >= 10 && i <= 15 = B.c2w 'A' + i - 10
  71             | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"
  72
  73 qpdecode :: B.ByteString -> B.ByteString
  74 qpdecode s = unsafePerformIO
  75              -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"
  76            $ B.createAndTrim (B.length s + 1) (\buf -> decode (linesPS s) buf 0)
  77
  78 decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int
  79 decode [] _ bufi = return bufi
  80 decode (ps:pss) buf bufi
  81  | B.null (dropSpace ps)
  82     = do poke (buf `plusPtr` bufi) newline
  83          decode pss buf (bufi+1)
  84  | is_equals && B.length ps >= 3 && isHexDigit c1 && isHexDigit c2
  85     = do poke (buf `plusPtr` bufi)
  86               (toWord8 $ digitToInt c1 * 16 + digitToInt c2)
  87          decode (B.drop 3 ps:pss) buf (bufi+1)
  88  | is_equals && B.null (dropSpace (B.tail ps)) = decode pss buf bufi
  89  | otherwise = do poke (buf `plusPtr` bufi) (B.head ps)
  90                   decode (B.tail ps:pss) buf (bufi+1)
  91     where is_equals = BC.head ps == '='
  92           c1 = BC.index ps 1
  93           c2 = BC.index ps 2
  94           newline = B.c2w '\n'
  95           toWord8 :: Int -> Word8
  96           toWord8 = fromIntegral
  97
  98 make_email :: String -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc
  99 make_email repodir mcontents bundle mfilename =
 100     text "DarcsURL:" <+> text repodir
 101  $$ text "MIME-Version: 1.0"
 102  $$ text "Content-Type: multipart/mixed; boundary=\"=_\""
 103  $$ text ""
 104  $$ text "--=_"
 105  $$ (case mcontents of
 106        Just contents ->
 107             text "Content-Type: text/plain"
 108          $$ text "Content-Transfer-Encoding: quoted-printable"
 109          $$ text ""
 110          $$ packedString (qpencode (renderPS contents))
 111          $$ text ""
 112          $$ text "--=_"
 113        Nothing -> empty)
 114  $$ text "Content-Type: text/x-darcs-patch" <>
 115       (case mfilename of
 116          Just filename -> text "; name=\"" <> text filename <> text "\""
 117          Nothing -> empty)
 118  $$ text "Content-Transfer-Encoding: quoted-printable"
 119  $$ text "Content-Description: A darcs patch for your repository!"
 120  $$ text ""
 121  $$ packedString (qpencode (renderPS bundle))
 122  $$ text "--=_--"
 123  $$ text ""
 124  $$ text "."
 125  $$ text ""
 126  $$ text ""
 127
 128 read_email :: B.ByteString -> B.ByteString
 129 read_email s =
 130     case betweenLinesPS
 131          (BC.pack "Content-Description: A darcs patch for your repository!")
 132          (BC.pack "--=_--") s of
 133     Nothing -> s -- if it wasn't an email in the first place, just pass along.
 134     Just s' -> qpdecode s'
 135