module Darcs.UI.Email
    ( makeEmail
    , readEmail
    , formatHeader
    -- just for testing
    , prop_qp_roundtrip
    ) 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 )

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  = 78
qlineMax :: Int
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 :: String -> String -> ByteString
formatHeader headerName :: String
headerName headerValue :: 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]
++ ":")) -- space for folding
        encodedValue :: ByteString
encodedValue = String -> Int -> Bool -> Bool -> ByteString
foldAndEncode (' '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 [] _ _               _         = ByteString
B.empty
foldAndEncode s :: String
s  p :: Int
p lastWordEncoded :: Bool
lastWordEncoded inMidWord :: Bool
inMidWord =
  let newline :: ByteString
newline  = Word8 -> ByteString
B.singleton 10
      space :: ByteString
space    = Word8 -> ByteString
B.singleton 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` 12
      (curSpace :: String
curSpace, afterCurSpace :: 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
== ' ') String
s
      (curWord :: String
curWord,  afterCurWord :: 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
== ' ') 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 (\c :: 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
> 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
- 1
                   Bool -> Bool -> Bool
|| String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf "=?" String
curWord
      mustFold :: Bool
mustFold
        | Bool
mustEncode Bool -> Bool -> Bool
&& Bool
lastWordEncoded
            = Int
p Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
- 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]
      (rest :: String
rest, nextP :: 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
+ 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 s :: 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 "=?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 "?=")

-- 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 c :: Char
c
    | Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== ' '                          = Char -> ByteString
c2bs '_'
    | 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` "?=_"
      Bool -> Bool -> Bool
&& Char -> Int
ord Char
c Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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 b :: Word8
b = [Word8] -> ByteString
B.pack ((Char -> Word8) -> String -> [Word8]
forall a b. (a -> b) -> [a] -> [b]
map Char -> Word8
B.c2w ['='
                                    ,Word8 -> Char
word8ToUDigit (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`div` 16)
                                    ,Word8 -> Char
word8ToUDigit (Word8
b Word8 -> Word8 -> Word8
forall a. Integral a => a -> a -> a
`mod` 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 s :: 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 (4 Int -> Int -> Int
forall a. Num a => a -> a -> a
* ByteString -> Int
B.length ByteString
s) (\buf :: Ptr Word8
buf -> ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
s Int
qlineMax Ptr Word8
buf 0)

encode :: B.ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode :: ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ps :: ByteString
ps _ _ bufi :: Int
bufi | ByteString -> Bool
B.null ByteString
ps = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bufi
encode ps :: ByteString
ps n :: Int
n buf :: Ptr Word8
buf bufi :: Int
bufi = case ByteString -> Word8
B.head ByteString
ps of
  c :: 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
+1)
    | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0 Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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
+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
+ 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
+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
+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
+ 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
- 1) Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 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
- 1) Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1)
    | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 3 ->
        ByteString -> Int -> Ptr Word8 -> Int -> IO Int
encode ByteString
ps 0 Ptr Word8
buf Int
bufi
    | Bool
otherwise ->
        do let (x :: Word8
x, y :: Word8
y) = Word8
c Word8 -> Word8 -> (Word8, Word8)
forall a. Integral a => a -> a -> (a, a)
`divMod` 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
+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
+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
- 3) Ptr Word8
buf (Int
bufi Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 3)
    where ps' :: ByteString
ps' = ByteString -> ByteString
B.tail ByteString
ps
          newline :: Word8
newline = Char -> Word8
B.c2w '\n'
          tab :: Word8
tab     = Char -> Word8
B.c2w '\t'
          space :: Word8
space   = Char -> Word8
B.c2w ' '
          bang :: Word8
bang    = Char -> Word8
B.c2w '!'
          tilde :: Word8
tilde   = Char -> Word8
B.c2w '~'
          equals :: Word8
equals  = Char -> Word8
B.c2w '='
          period :: Word8
period  = Char -> Word8
B.c2w '.'
          intToUDigit :: Word8 -> Word8
intToUDigit i :: Word8
i
            | Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= 0  Bool -> Bool -> Bool
&& Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 9  = Char -> Word8
B.c2w '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
>= 10 Bool -> Bool -> Bool
&& Word8
i Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<= 15 = Char -> Word8
B.c2w 'A' Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
+ Word8
i Word8 -> Word8 -> Word8
forall a. Num a => a -> a -> a
- 10
            | Bool
otherwise = String -> Word8
forall a. HasCallStack => String -> a
error (String -> Word8) -> String -> Word8
forall a b. (a -> b) -> a -> b
$ "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]
++"'not a digit"

qpdecode :: B.ByteString -> B.ByteString
qpdecode :: ByteString -> ByteString
qpdecode s :: 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
+ 1) (\buf :: Ptr Word8
buf -> [ByteString] -> Ptr Word8 -> Int -> IO Int
decode (ByteString -> [ByteString]
linesPS ByteString
s) Ptr Word8
buf 0)

decode :: [B.ByteString] -> Ptr Word8 -> Int -> IO Int
decode :: [ByteString] -> Ptr Word8 -> Int -> IO Int
decode [] _ bufi :: Int
bufi = Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
bufi
decode (ps :: ByteString
ps:pss :: [ByteString]
pss) buf :: Ptr Word8
buf bufi :: 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
+1)
 | Bool
is_equals Bool -> Bool -> Bool
&& ByteString -> Int
B.length ByteString
ps Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 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
* 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 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
+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
+1)
    where is_equals :: Bool
is_equals = ByteString -> Char
BC.head ByteString
ps Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '='
          c1 :: Char
c1 = ByteString -> Int -> Char
BC.index ByteString
ps 1
          c2 :: Char
c2 = ByteString -> Int -> Char
BC.index ByteString
ps 2
          newline :: Word8
newline = Char -> Word8
B.c2w '\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 repodir :: String
repodir headers :: [(String, String)]
headers mcontents :: Maybe Doc
mcontents mcharset :: Maybe String
mcharset bundle :: Doc
bundle mfilename :: Maybe String
mfilename =
    String -> Doc
text "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 (\m :: Doc
m (h :: String
h,v :: String
v) -> Doc
m Doc -> Doc -> Doc
$$ (String -> Doc
text (String
h String -> String -> String
forall a. [a] -> [a] -> [a]
++ ":") Doc -> Doc -> Doc
<+> String -> Doc
text String
v)) Doc
empty [(String, String)]
headers
 Doc -> Doc -> Doc
$$ String -> Doc
text "MIME-Version: 1.0"
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Type: multipart/mixed; boundary=\"=_\""
 Doc -> Doc -> Doc
$$ String -> Doc
text ""
 Doc -> Doc -> Doc
$$ String -> Doc
text "--=_"
 Doc -> Doc -> Doc
$$ (case Maybe Doc
mcontents of
       Just contents :: Doc
contents ->
            String -> Doc
text ("Content-Type: text/plain; charset=\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++
              String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "x-unknown" Maybe String
mcharset String -> String -> String
forall a. [a] -> [a] -> [a]
++ "\"")
         Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Transfer-Encoding: quoted-printable"
         Doc -> Doc -> Doc
$$ String -> Doc
text ""
         Doc -> Doc -> Doc
$$ ByteString -> Doc
packedString (ByteString -> ByteString
qpencode (Doc -> ByteString
renderPS Doc
contents))
         Doc -> Doc -> Doc
$$ String -> Doc
text ""
         Doc -> Doc -> Doc
$$ String -> Doc
text "--=_"
       Nothing -> Doc
empty)
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Type: text/x-darcs-patch; name=\"patch-preview.txt\""
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Disposition: inline"
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Transfer-Encoding: quoted-printable"
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Description: Patch preview"
 Doc -> Doc -> Doc
$$ String -> Doc
text ""
 Doc -> Doc -> Doc
$$ (case ByteString -> ByteString -> ByteString -> Maybe ByteString
betweenLinesPS (String -> ByteString
BC.pack "New patches:") (String -> ByteString
BC.pack "Context:") (Doc -> ByteString
renderPS Doc
bundle) of
     Just s :: 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
     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 "--=_"
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Type: application/x-darcs-patch" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<>
      (case Maybe String
mfilename of
         Just filename :: String
filename -> String -> Doc
text "; 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 "\""
         Nothing -> Doc
empty)
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Transfer-Encoding: quoted-printable"
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Disposition: attachment"
 Doc -> Doc -> Doc
$$ String -> Doc
text "Content-Description: A darcs patch for your repository!"
 Doc -> Doc -> Doc
$$ String -> Doc
text ""
 Doc -> Doc -> Doc
$$ ByteString -> Doc
packedString (ByteString -> ByteString
qpencode (Doc -> ByteString
renderPS Doc
bundle))
 Doc -> Doc -> Doc
$$ String -> Doc
text "--=_--"
 Doc -> Doc -> Doc
$$ String -> Doc
text ""
 Doc -> Doc -> Doc
$$ String -> Doc
text "."
 Doc -> Doc -> Doc
$$ String -> Doc
text ""
 Doc -> Doc -> Doc
$$ String -> Doc
text ""

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