module Email where

import Data.List (unfoldr, isPrefixOf, intersperse)
import Text.Parsers.Frisby
import Text.Parsers.Frisby.Char
import Data.Char



splitWhen :: ([a] -> Bool) -> [a] -> [[a]]
splitWhen f [] = []
splitWhen f (x:xs) = (x:a) : splitWhen f b  -- consume at least one element
    where
    (a,b) = biteWhen f xs

biteWhen :: ([a] -> Bool) -> [a] -> ([a],[a])
biteWhen f [] = ([], [])
biteWhen f xs@(y:ys)
    | f xs      = ([], xs)      -- seperator hit, terminate
    | otherwise = (y:a, b)      -- advance to next element
    where
    (a, b) = biteWhen f ys


splitOn :: Eq a => [a] -> [a] -> [[a]]
splitOn s = unfoldr g
    where
    g [] = Nothing
    g xs = Just (biteOn s xs)

biteOn :: Eq a => [a] -> [a] -> ([a],[a])
biteOn s [] = ([], [])
biteOn s xs@(y:ys)
    | s `isPrefixOf` xs = ([], drop n xs)
    | otherwise = (y:a, b)
    where
    n = length s
    (a,b) = biteOn s ys

injlines "" = []
injlines ('\n':s) = "\n" : injlines s
injlines [x] = [[x]]
injlines (x:s) = let (a:b) = injlines s in (x:a) : b


type Mbox = [Email]
type Email = ([Header], String)
type Header = (String, String)

header :: String -> Header
header = biteOn ":"

email :: String -> Email
email s = (headers, body)
    where
    (h, b) = biteWhen (isPrefixOf "\n\n") s
    headers = map header (splitheaders h)
    body = drop 2 b

unemail :: Email -> String
unemail (headers, body) = concatMap unheader headers ++ "\n" ++ body
    where
    unheader (k,v) = k ++ ":" ++ v ++ "\n"

splitheaders = map unlines . splitWhen ((/='\t').head.head) . lines
    where
    unlines = concat . intersperse "\n"

mbox :: String -> Mbox
mbox = map (email . concat . unformat) . splitWhen isfrom_ . injlines
    where
    isfrom_ (l:_) = "From " `isPrefixOf` l
    unformat = map unesc . droplast . drop 1
        where
        droplast ls = if null (last ls) then init ls else ls
        unesc ('>':xs) 
            | "From " `isPrefixOf` (dropWhile (=='>') xs) = xs
            | otherwise = '>':xs
        unesc xs = xs


data Emailaddress = Emailaddress String String String String deriving Show
                                 -- Name <user+arg@domain>

emailaddress :: String -> Emailaddress
emailaddress = runPeg p_emailaddress

emailaddresses :: String -> [Emailaddress]
emailaddresses = runPeg p_emailaddresses

p_emailaddress = do
    special    <- newRule $ oneOf "()<>,;:\\\"[]"
    atom_char  <- newRule $ dnm (special // space) ->> printable
    atom       <- newRule $ many1 atom_char
    qchar      <- newRule $ (char '\\' ->> anyChar) // noneOf "\"\\\n\r"
    quoted_str <- newRule $ char '"' ->> many qchar <<- char '"'
    word       <- newRule $ atom // quoted_str
    phrase     <- newRule $ many (many space <> word) ## mkphrase
    username   <- newRule $ many1 (dnm (oneOf "+-@") ->> atom_char)
    argument   <- newRule $ many (dnm (char '@') ->> atom_char)
    domain     <- newRule $ atom
    local_part <- newRule $ username <> option "" (oneOf "+-" ->> argument)
    addr_spec  <- newRule $ many space ->> local_part <> (char '@' ->> domain)
    named_addr <- newRule $ phrase <> (tok "<" ->> addr_spec <<- tok ">")
    mailbox    <- newRule $ (addr_spec ## curry mk "") // (named_addr ## mk)
    return mailbox
    where
    mk (n, ((u,a), d)) = Emailaddress n u a d
    mkphrase = dropWhile isSpace . concat . map (uncurry (++))
    dnm = doesNotMatch

tok s = many space ->> text s

p_emailaddresses = do
    addr  <- p_emailaddress
    comma <- newRule $ tok "," <<- many space
    addrs <- newRule $ addr <> many (comma ->> addr) ## uncurry (:)
    return addrs

addressees :: Email -> [Emailaddress]
addressees (headers, _) = to ++ cc
    where
    to = maybe [] emailaddresses (lookup "To" headers)
    cc = maybe [] emailaddresses (lookup "Cc" headers)


p_rfcdate = do
    day         <- newRule $ many (space // alpha) <<- char ','
    number      <- newRule $ many1 digit ## (read :: String -> Int)
    month       <- newRule $ choice (zipWith (\i m -> text m ##> i) [1..] months)
    date        <- newRule $ tok number <> tok month <> tok number
    hour        <- newRule $ tok number <> (char ':' ->> number)
                             <> option 0 (char ':' ->> number)
    civname     <- newRule $ choice (map (\(n,i) -> text n ##> i) zones)
    milname     <- newRule $ alpha ## (miltz . toUpper)
    zonename    <- newRule $ tok (civname // milname) ## \x -> (x,0)
    zonesign    <- newRule $ (char '-' ##> -1) // (char '+' ##> 1)
    zonenum     <- newRule $ (digit <> digit) ## \(x,y) -> read [x,y]
    zonediff    <- newRule $ tok zonesign <> zonenum <> zonenum ## mktz
    zone        <- newRule $ zonename // zonediff // unit (0,0)
    time        <- newRule $ hour <> zone
    date_time   <- newRule $ optional day ->> date <> time
    return (date_time ## mk)
    where
    tok p = many space ->> p
    months = ["Jan","Feb","Mar","Apr","May","Jun",
              "Jul","Aug","Sep","Oct","Nov","Dec"]
    mk (((d,m),y),(((h,min),s),(tzh,tzm))) = (y,m,d,h,min,s,tzh,tzm)
    mktz ((s,h),m) = (s*h,s*m)
    miltz c
        | c=='Z' = 0
        | c<'J'  = -1 - (fromEnum c - fromEnum 'A')
        | c=='J' = miltz 'I'
        | c<='M' = -12 - (fromEnum c - fromEnum 'M')
        | c>='N' = 1 + (fromEnum c - fromEnum 'N')
    zones = [ ("GMT",0), ("UT",0), ("UTC", 0)
            , ("EST",-5), ("EDT",-4)
            , ("CST",-6), ("CDT",-5)
            , ("MST",-7), ("MDT",-6)
            , ("PST",-8), ("PDT",-7) ]

read_rfcdate :: String -> (Int, Int, Int, Int, Int, Int, Int, Int)
                       -- year month day hours mins secs tzhour tzmin
read_rfcdate = runPeg p_rfcdate


type Mimepart = ([Header], String)
type Parameter = (String, String)
data Mimetype = Mimetype String String [Parameter] deriving Show

mimetype :: String -> Mimetype
mimetype = runPeg p_mimetype

p_mimetype = do
    ws          <- newRule $ many space
    tokenchar   <- newRule $ ascii `onlyIf` istokenchar
    token       <- newRule $ ws ->> many1 tokenchar
    itoken      <- newRule $ token ## map toLower  -- case ignorant
    semicolon   <- newRule $ ws ->> char ';'
    slash       <- newRule $ ws ->> char '/'
    equals      <- newRule $ ws ->> char '='
    quotpair    <- newRule $ char '\\' ->> anyChar
    quotchar    <- newRule $ noneOf "\"\\\n"
    quotstr     <- newRule $ many (quotpair // quotchar)
    quoted      <- newRule $ ws ->> between (char '"') (char '"') quotstr
    value       <- newRule $ token // quoted
    parameter   <- newRule $ itoken <> equals ->> value
    mtype       <- newRule $ itoken <> slash ->> itoken
    ctype       <- newRule $ mtype <> many (semicolon ->> parameter)
    return (ctype ## \((t,s), ps) -> Mimetype t s ps)
    where
    istokenchar c = isPrint c && not (isSpace c) && not (c `elem` specials)
    specials = "()<>@,;:\\\"/[]?="

mailtext :: Email -> String
mailtext email
    | null ts   = error "no text parts in message"
    | otherwise = case subtype of
        "alternative" -> decodetext (head ts)
        _ -> concatMap decodetext ts   -- default: treat like multipart/mixed
    where
    (subtype, ps) = mimeparts email
    ts = filter (istext . parttype subtype) ps
    istext (Mimetype t _ _) = t == "text"

parttype :: String -> Email -> Mimetype
parttype subtype (hs, _) = maybe d_ct mimetype (lookup "Content-Type" hs)
    where
    d_ct = case subtype of "digest" -> Mimetype "message" "rfc822" []
                           _        -> Mimetype "text" "plain" []

mailtype :: Email -> Mimetype
mailtype = parttype ""

istype :: String -> String -> Email -> Bool
istype tt st email = tt'==tt && st'==st
    where
    Mimetype tt' st' _ = mailtype email

decodetext :: Mimepart -> String
decodetext (hs,b) = b   -- TODO: decode according to charset

mimeparts :: Email -> (String, [Mimepart])
mimeparts email = (st, if null ps then [email] else ps)
    where (st,ps) = subparts email

subparts :: Email -> (String, [Mimepart])
subparts (headers, body)
    | tt == "multipart" = (st, (map topart . split . dropend . dropbeg) body)
    | otherwise         = ("", [])
    where
    Mimetype tt st ps = maybe d_ty mimetype (lookup "Content-Type" headers)
    bd                = maybe d_bd id       (lookup "boundary" ps)
    d_ty = Mimetype "text" "plain" []
    d_bd = error "missing boundary parameter on multipart message"

    dropbeg = snd . biteWhen isbd       -- drop stuff before first boundary
    dropend = fst . biteWhen islastbd   -- drop last boundary and beyond
    split   = splitWhen isbd            -- split at boundaries
    topart  = email . dropbd            -- drop boundary, parse part like email

    islastbd = isPrefixOf ("\n--" ++ bd ++ "--")
    isbd     = isPrefixOf ("\n--" ++ bd ++ "\n")
    dropbd   = drop (length bd + 4)


findparts :: String -> String -> Email -> [Mimepart]
findparts tt st email
    | istype tt st email = [email]
    | otherwise          = concatMap (findparts tt st) subs
    where
    (_, subs) = subparts email


-- find pgp-signed part and signature
findsigned email
    | null ps = Nothing  -- no multipart/signed found
    | length signed /= 2 = error "multipart/signed should have exactly 2 parts"
    | istype "application" "pgp-signature" sig = Just (unemail msg, unemail sig)
    | otherwise = Nothing  -- not a pgp signature
    where
    ps = findparts "multipart" "signed" email
    (_, signed) = subparts (head ps) 
    [msg,sig] = signed

-- find message/rfc822 part
findmessage email
    | null ps   = Nothing
    | otherwise = Just (head ps)
    where ps = findparts "message" "rfc822" email