module Data.MBox (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.Char
import Data.Time
import Safe
import qualified Data.Text.Lazy as T
import qualified Data.Time.Locale.Compat as LC
type MBox = [Message]
data Message = Message {fromLine :: T.Text, headers :: [Header], body :: T.Text} deriving (Read, Show)
type Header = (T.Text, T.Text)
parseDateHeader :: T.Text -> Maybe UTCTime
parseDateHeader = parseTime LC.defaultTimeLocale "%A, %B %e, %Y %l:%M %p" . T.unpack
parseForward :: Message -> Message
parseForward origMsg@(Message f _ b) =
case drop 1 $ dropWhile (/= T.pack "-----Original Message-----") (T.lines b) of
[] -> origMsg
xs -> headDef origMsg . parseMBox . T.unlines $ f:xs
parseMBox :: T.Text -> MBox
parseMBox = go . T.lines
where
go [] = []
go (x:xs) = uncurry (:) . (readMsg x *** go) . break ((T.pack "From ") `T.isPrefixOf`) $ xs
readMsg :: T.Text -> [T.Text] -> Message
readMsg x xs = uncurry (Message x) . second (T.unlines . map unquoteFrom). readHeaders $ xs
readHeaders :: [T.Text] -> ([Header], [T.Text])
readHeaders [] = ([],[])
readHeaders (x:xs)
| T.null x || T.all isSpace x || not (T.any (==':') x) = ([],xs)
| otherwise = first ((second (T.strip . sanHeader . (`T.append` headerCont) . T.drop 1) . T.break (==':') $ x):) $ readHeaders xs'
where (headerCont, xs') = first ((T.pack " " `T.append`) . T.unlines . map T.strip) . break notCont $ xs
notCont :: T.Text -> Bool
notCont s = doesNotStartSpace s || allSpace s
allSpace = T.all isSpace
doesNotStartSpace s = case T.length s of
0 -> True
_ -> not (isSpace $ T.head s)
unquoteFrom :: T.Text -> T.Text
unquoteFrom xs'@(T.stripPrefix (T.pack ">") -> Just suf) = if (T.pack "From ") `T.isPrefixOf` T.dropWhile (=='>') suf
then suf
else xs'
unquoteFrom xs = xs
sanHeader :: T.Text -> T.Text
sanHeader = T.replace (T.pack "\n") (T.pack " ")
showMBox :: MBox -> T.Text
showMBox = T.concat . map showMessage
showMessage :: Message -> T.Text
showMessage (Message f hs b) = T.unlines $ f : formatHeaders hs ++ [(T.pack "\n")] ++ formatBody b
where
formatHeaders = map (\(x,y) -> x `T.append` (T.pack ": ") `T.append` y)
formatBody = map unFrom . T.lines
unFrom x
| isFrom x = '>' `T.cons` x
| otherwise = x
isFrom x = (T.pack "From ") `T.isPrefixOf` T.dropWhile (=='>') x
isID :: Header -> Bool
isID (x, _) = x == T.pack "Message-ID"
isDate :: Header -> Bool
isDate (x, _) = x == T.pack "Date"
getHeader :: (Header -> Bool) -> Message -> T.Text
getHeader predFunc = snd . head . filter predFunc . headers