module Darcs.UI.Email
    ( makeEmail
    , readEmail
    , formatHeader
    -- just for testing
    , prop_qp_roundtrip
    ) where

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 :: Int
lineMax  = Int
78
qlineMax :: Int
qlineMax = Int
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 :: String -> String -> ByteString
formatHeader String
headerName String
headerValue =
    ByteString -> ByteString -> ByteString
B.append ByteString
nameColon ByteString
encodedValue
  where nameColon :: ByteString
nameColon = [Word8] -> ByteString
B.pack ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
B.c2w (String
headerName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":")) -- space for folding
        encodedValue :: ByteString
encodedValue = String -> Int -> Bool -> Bool -> ByteString
foldAndEncode (Char
' 'Char -> String -> String
forall a. a -> [a] -> [a]
:String
headerValue)
                                       (ByteString -> Int
B.length ByteString
nameColon) Bool
False Bool
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 :: String -> Int -> Bool -> Bool -> ByteString
foldAndEncode [] Int
_ Bool
_               Bool
_         = ByteString
B.empty
foldAndEncode String
s  Int
p Bool
lastWordEncoded Bool
inMidWord =
  let newline :: ByteString
newline  = Word8 -> ByteString
B.singleton Word8
10
      space :: ByteString
space    = Word8 -> ByteString
B.singleton Word8
32
      s2bs :: String -> ByteString
s2bs     = [Word8] -> ByteString
B.pack ([Word8] -> ByteString)
-> (String -> [Word8]) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
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 :: Int
safeEncChunkLength = (Int
qlineMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
encodedWordStart
                                      Int -> Int -> Int
forall a. Num a => a -> a -> a
- ByteString -> Int
B.length ByteString
encodedWordEnd) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
12
      (String
curSpace, String
afterCurSpace) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
s
      (String
curWord,  String
afterCurWord)  = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') String
afterCurSpace
      qEncWord :: ByteString
qEncWord | Bool
lastWordEncoded = String -> ByteString
qEncode (String
curSpace String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
curWord)
               | Bool
otherwise       = String -> ByteString
qEncode String
curWord
      mustEncode :: Bool
mustEncode = Bool
inMidWord
                   Bool -> Bool -> Bool
|| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Char
c -> Bool -> Bool
not (Char -> Bool
isPrint Char
c) Bool -> Bool -> Bool
|| Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
127) String
curWord
                   Bool -> Bool -> Bool
|| String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curWord Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                   Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf String
"=?" String
curWord
      mustFold :: Bool
mustFold
        | Bool
mustEncode Bool -> Bool -> Bool
&& Bool
lastWordEncoded
            = Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
qEncWord Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineMax
        | Bool
mustEncode
            = Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
qEncWord Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineMax
        | Bool
otherwise
            = Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curSpace Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curWord Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineMax
      mustSplit :: Bool
mustSplit = (ByteString -> Int
B.length ByteString
qEncWord Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
qlineMax Bool -> Bool -> Bool
&& Bool
mustEncode)
                  Bool -> Bool -> Bool
|| String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
curWord Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
lineMax Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
      spaceToInsert :: ByteString
spaceToInsert | Bool
mustEncode Bool -> Bool -> Bool
&& Bool
lastWordEncoded = ByteString
space
                    | Bool
otherwise                     = String -> ByteString
s2bs String
curSpace
      wordToInsert :: ByteString
wordToInsert
        | Bool
mustEncode Bool -> Bool -> Bool
&& Bool
mustSplit = String -> ByteString
qEncode (Int -> String -> String
forall a. Int -> [a] -> [a]
take Int
safeEncChunkLength String
curWord)
        | Bool
mustEncode = ByteString
qEncWord
        | Bool
otherwise  = String -> ByteString
s2bs String
curWord
      doneChunk :: ByteString
doneChunk | Bool
mustFold  = [ByteString] -> ByteString
B.concat [ByteString
newline, ByteString
spaceToInsert, ByteString
wordToInsert]
                | Bool
otherwise = [ByteString] -> ByteString
B.concat [ByteString
spaceToInsert, ByteString
wordToInsert]
      (String
rest, Int
nextP)
        | Bool
mustSplit
            = (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
safeEncChunkLength String
curWord String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
afterCurWord, Int
qlineMax Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
        | Bool
mustEncode Bool -> Bool -> Bool
&& Bool
mustFold
            = (String
afterCurWord, ByteString -> Int
B.length ByteString
spaceToInsert Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
wordToInsert)
        | Bool
otherwise
            = (String
afterCurWord, Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ByteString -> Int
B.length ByteString
doneChunk)
  in ByteString -> ByteString -> ByteString
B.append ByteString
doneChunk (String -> Int -> Bool -> Bool -> ByteString
foldAndEncode String
rest Int
nextP Bool
mustEncode Bool
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 :: String -> ByteString
qEncode String
s = [ByteString] -> ByteString
B.concat [ByteString
encodedWordStart,
                      ByteString
encodedString,
                      ByteString
encodedWordEnd]
  where encodedString :: ByteString
encodedString =  [ByteString] -> ByteString
B.concat ((Char -> ByteString) -> String -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Char -> ByteString
qEncodeChar String
s)

encodedWordStart, encodedWordEnd :: B.ByteString
encodedWordStart :: ByteString
encodedWordStart = [Word8] -> ByteString
B.pack ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
B.c2w String
"=?UTF-8?Q?")
encodedWordEnd :: ByteString
encodedWordEnd   = [Word8] -> ByteString
B.pack ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
B.c2w String
"?=")

-- 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 :: Char -> ByteString
qEncodeChar Char
c
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' '                          = Char -> ByteString
c2bs Char
'_'
    | Char -> Bool
isPrint Char
c
      Bool -> Bool -> Bool
&& Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` String
"?=_"
      Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
128                    = Char -> ByteString
c2bs Char
c
    | Bool
otherwise                         = [ByteString] -> ByteString
B.concat
                                            ((Word8 -> ByteString) -> [Word8] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Word8 -> ByteString
qbyte
                                              (ByteString -> [Word8]
B.unpack
                                                (String -> ByteString
packStringToUTF8 [Char
c])))
  where c2bs :: Char -> ByteString
c2bs = Word8 -> ByteString
B.singleton (Word8 -> ByteString) -> (Char -> Word8) -> Char -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Word8
B.c2w
        -- qbyte turns a byte into its q-encoded "=hh" representation
        qbyte :: Word8 -> ByteString
qbyte Word8
b = [Word8] -> ByteString
B.pack ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
B.c2w [Char
'='
                                    ,Word8 -> Char
word8ToUDigit (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` Word8
16)
                                    ,Word8 -> Char
word8ToUDigit (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` Word8
16)
                                    ])
        word8ToUDigit :: Word8 -> Char
        word8ToUDigit :: Word8 -> Char
word8ToUDigit = Char -> Char
toUpper (Char -> Char) -> (Word8 -> Char) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
intToDigit (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
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 :: ByteString -> ByteString
qpencode ByteString
s = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO
           -- Really only (3 + 2/75) * length or something in the worst case
           (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Word8 -> IO Int) -> IO ByteString
B.createAndTrim (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ByteString -> Int
B.length ByteString
s) (\Ptr Word8
buf -> ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
s Int
qlineMax Ptr Word8
buf Int
0)

encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode :: ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps Int
_ Ptr Word8
_ Int
bufi | ByteString -> Bool
B.null ByteString
ps = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bufi
encode ByteString
ps Int
n Ptr Word8
buf Int
bufi = case ByteString -> Word8
B.head ByteString
ps of
  Word8
c | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
newline ->
        do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
newline
           ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps' Int
qlineMax Ptr Word8
buf (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 ->
        do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
equals
           Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Word8
newline
           ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps Int
qlineMax Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2)
    | Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
tab Bool -> Bool -> Bool
|| Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
space ->
        if ByteString -> Bool
B.null ByteString
ps' Bool -> Bool -> Bool
|| ByteString -> Word8
B.head ByteString
ps' Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
newline
        then do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
c
                Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Word8
equals
                Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) Word8
newline
                ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps' Int
qlineMax Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
        else do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
c
                ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
bang Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
equals Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
period Bool -> Bool -> Bool
&& Word8
c Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
tilde ->
        do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
c
           ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
3 ->
        ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps Int
0 Ptr Word8
buf Int
bufi
    | Bool
otherwise ->
        do let (Word8
x, Word8
y) = Word8
c Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` Word8
16
               h1 :: Word8
h1 = Word8 -> Word8
intToUDigit Word8
x
               h2 :: Word8
h2 = Word8 -> Word8
intToUDigit Word8
y
           Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
equals
           Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)) Word8
h1
           Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
2)) Word8
h2
           ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps' (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
3) Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3)
    where ps' :: ByteString
ps' = ByteString -> ByteString
B.tail ByteString
ps
          newline :: Word8
newline = Char -> Word8
B.c2w Char
'\n'
          tab :: Word8
tab     = Char -> Word8
B.c2w Char
'\t'
          space :: Word8
space   = Char -> Word8
B.c2w Char
' '
          bang :: Word8
bang    = Char -> Word8
B.c2w Char
'!'
          tilde :: Word8
tilde   = Char -> Word8
B.c2w Char
'~'
          equals :: Word8
equals  = Char -> Word8
B.c2w Char
'='
          period :: Word8
period  = Char -> Word8
B.c2w Char
'.'
          intToUDigit :: Word8 -> Word8
intToUDigit Word8
i
            | Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0  Bool -> Bool -> Bool
&& Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
9  = Char -> Word8
B.c2w Char
'0' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
i
            | Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
10 Bool -> Bool -> Bool
&& Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= Word8
15 = Char -> Word8
B.c2w Char
'A' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
i Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- Word8
10
            | Bool
otherwise = String -> Word8
forall a. HasCallStack => String -> a
error (String -> Word8) -> String -> Word8
forall a b. (a -> b) -> a -> b
$ String
"intToUDigit: '"String -> String -> String
forall a. [a] -> [a] -> [a]
++Word8 -> String
forall a. Show a => a -> String
show Word8
iString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"'not a digit"

qpdecode :: B.ByteString -> B.ByteString
qpdecode :: ByteString -> ByteString
qpdecode ByteString
s = IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO
             -- Add 1 as linesPS "\n" -> ["", ""] -> "\n\n"
           (IO ByteString -> ByteString) -> IO ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Int -> (Ptr Word8 -> IO Int) -> IO ByteString
B.createAndTrim (ByteString -> Int
B.length ByteString
s Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (\Ptr Word8
buf -> [ByteString] -> Ptr Word8 -> Int -> IO Int
decode (ByteString -> [ByteString]
linesPS ByteString
s) Ptr Word8
buf Int
0)

decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int
decode :: [ByteString] -> Ptr Word8 -> Int -> IO Int
decode [] Ptr Word8
_ Int
bufi = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bufi
decode (ByteString
ps:[ByteString]
pss) Ptr Word8
buf Int
bufi
 | ByteString -> Bool
B.null (ByteString -> ByteString
dropSpace ByteString
ps)
    = do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) Word8
newline
         [ByteString] -> Ptr Word8 -> Int -> IO Int
decode [ByteString]
pss Ptr Word8
buf (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
 | Bool
is_equals Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
3 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
c1 Bool -> Bool -> Bool
&& Char -> Bool
isHexDigit Char
c2
    = do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi)
              (Int -> Word8
toWord8 (Int -> Word8) -> Int -> Word8
forall a b. (a -> b) -> a -> b
$ Char -> Int
digitToInt Char
c1 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
16 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Char -> Int
digitToInt Char
c2)
         [ByteString] -> Ptr Word8 -> Int -> IO Int
decode (Int -> ByteString -> ByteString
B.drop Int
3 ByteString
psByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
pss) Ptr Word8
buf (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
 | Bool
is_equals Bool -> Bool -> Bool
&& ByteString -> Bool
B.null (ByteString -> ByteString
dropSpace (ByteString -> ByteString
B.tail ByteString
ps)) = [ByteString] -> Ptr Word8 -> Int -> IO Int
decode [ByteString]
pss Ptr Word8
buf Int
bufi
 | Bool
otherwise = do Ptr Word8 -> Word8 -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke (Ptr Word8
buf Ptr Word8 -> Int -> Ptr Word8
forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
bufi) (ByteString -> Word8
B.head ByteString
ps)
                  [ByteString] -> Ptr Word8 -> Int -> IO Int
decode (ByteString -> ByteString
B.tail ByteString
psByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
pss) Ptr Word8
buf (Int
bufiInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    where is_equals :: Bool
is_equals = ByteString -> Char
BC.head ByteString
ps Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'='
          c1 :: Char
c1 = ByteString -> Int -> Char
BC.index ByteString
ps Int
1
          c2 :: Char
c2 = ByteString -> Int -> Char
BC.index ByteString
ps Int
2
          newline :: Word8
newline = Char -> Word8
B.c2w Char
'\n'
          toWord8 :: Int -> Word8
          toWord8 :: Int -> Word8
toWord8 = Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral

makeEmail :: String -> [(String, String)] -> Maybe Doc -> Maybe String -> Doc -> Maybe String -> Doc
makeEmail :: String
-> [(String, String)]
-> Maybe Doc
-> Maybe String
-> Doc
-> Maybe String
-> Doc
makeEmail String
repodir [(String, String)]
headers Maybe Doc
mcontents Maybe String
mcharset Doc
bundle Maybe String
mfilename =
    String -> Doc
text String
"DarcsURL:" Doc -> Doc -> Doc
<+> String -> Doc
text String
repodir
 Doc -> Doc -> Doc
$$ (Doc -> (String, String) -> Doc)
-> Doc -> [(String, String)] -> Doc
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Doc
m (String
h,String
v) -> Doc
m Doc -> Doc -> Doc
$$ (String -> Doc
text (String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
":") Doc -> Doc -> Doc
<+> String -> Doc
text String
v)) Doc
empty [(String, String)]
headers
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"MIME-Version: 1.0"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Type: multipart/mixed; boundary=\"=_\""
 Doc -> Doc -> Doc
$$ String -> Doc
text String
""
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"--=_"
 Doc -> Doc -> Doc
$$ (case Maybe Doc
mcontents of
       Just Doc
contents ->
            String -> Doc
text (String
"Content-Type: text/plain; charset=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"x-unknown" Maybe String
mcharset String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\"")
         Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Transfer-Encoding: quoted-printable"
         Doc -> Doc -> Doc
$$ String -> Doc
text String
""
         Doc -> Doc -> Doc
$$ ByteString -> Doc
packedString (ByteString -> ByteString
qpencode (Doc -> ByteString
renderPS Doc
contents))
         Doc -> Doc -> Doc
$$ String -> Doc
text String
""
         Doc -> Doc -> Doc
$$ String -> Doc
text String
"--=_"
       Maybe Doc
Nothing -> Doc
empty)
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Disposition: inline"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Transfer-Encoding: quoted-printable"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Description: Patch preview"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
""
 Doc -> Doc -> Doc
$$ (case ByteString -> ByteString -> ByteString -> Maybe ByteString
betweenLinesPS (String -> ByteString
BC.pack String
"New patches:") (String -> ByteString
BC.pack String
"Context:") (Doc -> ByteString
renderPS Doc
bundle) of
     Just ByteString
s -> ByteString -> Doc
packedString (ByteString -> Doc) -> ByteString -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
qpencode ByteString
s
     -- this should not happen, but in case it does, keep everything
     Maybe ByteString
Nothing -> ByteString -> Doc
packedString (ByteString -> Doc) -> ByteString -> Doc
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
qpencode (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Doc -> ByteString
renderPS Doc
bundle)
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"--=_"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Type: application/x-darcs-patch" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
      (case Maybe String
mfilename of
         Just String
filename -> String -> Doc
text String
"; name=\"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
filename Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text String
"\""
         Maybe String
Nothing -> Doc
empty)
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Transfer-Encoding: quoted-printable"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Disposition: attachment"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"Content-Description: A darcs patch for your repository!"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
""
 Doc -> Doc -> Doc
$$ ByteString -> Doc
packedString (ByteString -> ByteString
qpencode (Doc -> ByteString
renderPS Doc
bundle))
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"--=_--"
 Doc -> Doc -> Doc
$$ String -> Doc
text String
""
 Doc -> Doc -> Doc
$$ String -> Doc
text String
"."
 Doc -> Doc -> Doc
$$ String -> Doc
text String
""
 Doc -> Doc -> Doc
$$ String -> Doc
text String
""

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

-- note: qpdecode appends an extra '\n'
prop_qp_roundtrip :: B.ByteString -> Bool
prop_qp_roundtrip :: ByteString -> Bool
prop_qp_roundtrip ByteString
s = ByteString -> Word8 -> ByteString
B.snoc ByteString
s Word8
10 ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== (ByteString -> ByteString
qpdecode (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
qpencode) ByteString
s