module ParseMail
    ( startWith
    , getAddrs
    , parseSubject
    , parseMimeText
    , parseMail
    , prettyField
    , Message(..)
    )
    where

import Text.Estraier.Misc (estIconv)

import QDBM.Cabin

import Text.ParserCombinators.Parsec
import Text.PrettyPrint.HughesPJ hiding (char)

import Data.Char (isPrint)
import Data.Maybe



data Message = SinglePart [(String, String)] String
             | MultiPart [(String, String)] [Message]

iconvert (str, enc) = estIconv str enc "UTF-8"

startWith s1 s2 = (take (length s2) s1) == s2

parseMimeText (headers, body)
    | isJust ctype && fromJust ctype `startWith` "multipart/related" =
        MultiPart headers $ maybe [] (map (parseMimeText . mimeBreak) . mimeParts body) boundary
    | isNothing ctype
      || isJust ctype
             && ( fromJust ctype `startWith` "text/"
               || fromJust ctype `startWith` "message/rfc822") =
      let b1 = decoder body
      in SinglePart headers $ maybe b1 (\enc -> iconvert (b1, enc)) bodyEnc
    | otherwise = SinglePart headers ""
    where ctype = lookup "TYPE" headers
          boundary = lookup "BOUNDARY" headers
          tenc = lookup "content-transfer-encoding" headers
          bodyEnc = lookup "CHARSET" headers
          decoder
              | isJust tenc && fromJust tenc `startWith` "base64" =
                  b64Decode
              | isJust tenc && fromJust tenc `startWith` "quoted-printable" =
                  quoteDecode
              | otherwise = id

parseMail mail = parseMimeText (headers, body)
    where (headersRaw, body) = mimeBreak mail
          headers = map (\(f,v) -> (f, iconvert $ mimeDecode v)) headersRaw

parseSubject s = either (\_ -> []) id $ parse (many parseBracket) "" s

parseBracket = between (char '[') (char ']') (fmap concat (many1 inBracket))
    where inBracket = many1 (noneOf "[]")
                      <|> between (char '[') (char ']')
                            (fmap (\s -> '[':concat s++"]") (many1 inBracket))

getAddrs s
    | any (=='<') s = either (\_ -> []) id $ parse (many parseAngle) "" s
    | otherwise     = [s]
parseAngle = do skipMany $ noneOf "<"
                between (char '<') (char '>') (many $ noneOf ">")

prettyField f v enc = show (text (f ++ ":") <+>
                                     (fsep $ map (text.mime) $ words v))
    where mime s | all isPrint s = s
                 | otherwise     = mimeEncode s enc True