module Darcs.Email ( make_email, read_email ) where

import Data.Char ( ord, digitToInt, isHexDigit )
import Printer ( Doc, ($$), (<+>), (<>), text, empty, packedString, renderPS)
import FastPackedString ( PackedString, tailPS, nullPS, dropWhitePS,
                          indexPSW, packString, headPS, indexPS,
                          lengthPS, generatePS, dropPS, linesPS,
                          betweenLinesPS )
import System.IO.Unsafe ( unsafePerformIO )
import Foreign.Ptr ( Ptr, plusPtr )
import Foreign.Storable ( poke )
import Data.Word ( Word8 )

line_max :: Int
line_max = 75

qpencode :: PackedString -> PackedString
qpencode s = unsafePerformIO
           -- Really only (3 + 2/75) * length or something in the worst case
           $ generatePS (4 * lengthPS s) (\buf -> encode s line_max buf 0)

encode :: PackedString -> Int -> Ptr Word8 -> Int -> IO Int
encode ps _ _ bufi | nullPS ps = return bufi
encode ps n buf bufi = case indexPSW ps 0 of
  c | c == newline ->
        do poke (buf `plusPtr` bufi) newline
           encode ps' line_max buf (bufi+1)
    | n == 0 && lengthPS ps > 1 ->
        do poke (buf `plusPtr` bufi) equals
           poke (buf `plusPtr` (bufi+1)) newline
           encode ps line_max buf (bufi + 2)
    | (c == tab || c == space) ->
        if nullPS ps' || indexPSW ps' 0 == newline
        then do poke (buf `plusPtr` bufi) c
                poke (buf `plusPtr` (bufi+1)) equals
                poke (buf `plusPtr` (bufi+2)) newline
                encode ps' line_max buf (bufi + 3)
        else do poke (buf `plusPtr` bufi) c
                encode ps' (n - 1) buf (bufi + 1)
    | (c >= bang && c /= equals && 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' = tailPS ps
          toWord8 :: Int -> Word8
          toWord8 = fromIntegral
          newline = toWord8 $ ord '\n'
          tab     = toWord8 $ ord '\t'
          space   = toWord8 $ ord ' '
          bang    = toWord8 $ ord '!'
          tilde   = toWord8 $ ord '~'
          equals  = toWord8 $ ord '='
          intToUDigit i
            | i >= 0 && i <= 9 = toWord8 (fromEnum '0') + i
            | i >= 10 && i <= 15 = toWord8 (fromEnum 'A') + i - 10
            | otherwise = error $ "intToUDigit: '"++show i++"'not a digit"

qpdecode :: PackedString -> PackedString
qpdecode s = unsafePerformIO
             -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"
           $ generatePS (lengthPS s + 1) (\buf -> decode (linesPS s) buf 0)

decode :: [PackedString] -> Ptr Word8 -> Int -> IO Int
decode [] _ bufi = return bufi
decode (ps:pss) buf bufi
 | nullPS (dropWhitePS ps)
    = do poke (buf `plusPtr` bufi) newline
         decode pss buf (bufi+1)
 | is_equals && lengthPS ps >= 3 && isHexDigit c1 && isHexDigit c2
    = do poke (buf `plusPtr` bufi)
              (toWord8 $ digitToInt c1 * 16 + digitToInt c2)
         decode (dropPS 3 ps:pss) buf (bufi+1)
 | is_equals && nullPS (dropWhitePS (tailPS ps)) = decode pss buf bufi
 | otherwise = do poke (buf `plusPtr` bufi) (indexPSW ps 0)
                  decode (tailPS ps:pss) buf (bufi+1)
    where is_equals = headPS ps == '='
          c1 = indexPS ps 1
          c2 = indexPS ps 2
          newline = toWord8 $ ord '\n'
          toWord8 :: Int -> Word8
          toWord8 = fromIntegral

make_email :: String -> (Maybe Doc) -> Doc -> (Maybe String) -> Doc
make_email repodir mcontents bundle mfilename =
    text "DarcsURL:" <+> text repodir
 $$ text "MIME-Version: 1.0"
 $$ text "Content-Type: multipart/mixed; boundary=\"=_\""
 $$ text ""
 $$ text "--=_"
 $$ (case mcontents of
       Just contents ->
            text "Content-Type: text/plain"
         $$ text "Content-Transfer-Encoding: quoted-printable"
         $$ text ""
         $$ packedString (qpencode (renderPS contents))
         $$ text ""
         $$ text "--=_"
       Nothing -> empty)
 $$ text "Content-Type: text/x-darcs-patch" <>
      (case mfilename of
         Just filename -> text "; name=\"" <> text filename <> text "\""
         Nothing -> empty)
 $$ text "Content-Transfer-Encoding: quoted-printable"
 $$ text "Content-Description: A darcs patch for your repository!"
 $$ text ""
 $$ packedString (qpencode (renderPS bundle))
 $$ text "--=_--"
 $$ text ""
 $$ text "."
 $$ text ""
 $$ text ""

read_email :: PackedString -> PackedString
read_email s =
    case betweenLinesPS
         (packString "Content-Description: A darcs patch for your repository!")
         (packString "--=_--") s of
    Nothing -> s -- if it wasn't an email in the first place, just pass along.
    Just s' -> qpdecode s'