module Data.MBox.String (MBox, Message(..), Header, parseMBox, parseForward, parseDateHeader, showMessage, showMBox, getHeader, isID, isDate) where
import Prelude hiding (tail, init, last, minimum, maximum, foldr1, foldl1, (!!), read)
import Control.Arrow
import Data.List (isPrefixOf)
import Data.Char
import System.Locale
import Data.Time
import Safe
type MBox = [Message]
data Message = Message {fromLine :: String, headers :: [Header], body :: String} deriving (Read, Show)
type Header = (String, String)
parseDateHeader :: String -> Maybe UTCTime
parseDateHeader = parseTime defaultTimeLocale "%A, %B %e, %Y %l:%M %p"
parseForward :: Message -> Message
parseForward origMsg@(Message f _ b) =
case drop 1 $ dropWhile (/= "-----Original Message-----") (lines b) of
[] -> origMsg
xs -> headDef origMsg . parseMBox . unlines $ f:xs
parseMBox :: String -> MBox
parseMBox = go . lines
where
go [] = []
go (x:xs) = uncurry (:) . (readMsg x *** go) . break ("From " `isPrefixOf`) $ xs
readMsg :: String -> [String] -> Message
readMsg x xs = uncurry (Message x) . second (unlines . map unquoteFrom). readHeaders $ xs
readHeaders :: [String] -> ([Header], [String])
readHeaders [] = ([],[])
readHeaders (x:xs)
| null x || all isSpace x || not (any (==':') x) = ([],xs)
| otherwise = first ((second (killSpace . sanHeader . (++ headerCont) . drop 1) . break (==':') $ x):) $ readHeaders xs'
where (headerCont, xs') = first ((" " ++) . unlines . map killSpace) . break notCont $ xs
notCont [] = True
notCont (c:cs) = not (isSpace c) || (all isSpace cs)
unquoteFrom :: String -> String
unquoteFrom xs'@('>':xs) = if "From " `isPrefixOf` dropWhile (=='>') xs
then xs
else xs'
unquoteFrom xs = xs
sanHeader :: String -> String
sanHeader = map (\x -> if x == '\n' then ' ' else x)
showMBox :: MBox -> String
showMBox = concatMap showMessage
showMessage :: Message -> String
showMessage (Message f hs b) = unlines $ f : map (\(x,y) -> (x ++ ": " ++ y)) hs ++ ["\n"] ++ map unFrom (lines b)
where unFrom x
| isFrom x = '>':x
| otherwise = x
isFrom x = "From " `isPrefixOf` dropWhile (=='>') x
killSpace :: String -> String
killSpace = dropWhile isSpace . dropEndWhile isSpace
dropEndWhile :: (a -> Bool) -> [a] -> [a]
dropEndWhile p = foldr (\x xs -> if p x && null xs then [] else x:xs) []
isID :: Header -> Bool
isID (x, _y) = x == "Message-ID"
isDate :: Header -> Bool
isDate (x, _y) = x == "Date"
getHeader :: (Header -> Bool) -> Message -> String
getHeader p = snd . head . filter p . headers