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.Maybe
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 txt = listToMaybe . catMaybes $ map tryParse formats where
header = T.unpack txt
tryParse f = parseTime LC.defaultTimeLocale f header
formats =
[ "%a, %_d %b %Y %T %z"
, "%a, %_d %b %Y %T %Z"
, "%a, %d %b %Y %T %z"
, "%a, %d %b %Y %T %Z"
, "%a, %_d %b %Y %T %z (%Z)"
, "%a, %_d %b %Y %T %z (GMT%:-z)"
, "%a, %_d %b %Y %T %z (UTC%:-z)"
, "%a, %_d %b %Y %T %z (GMT%:z)"
, "%a, %_d %b %Y %T %z (UTC%:z)"
, "%A, %B %e, %Y %l:%M %p"
, "%e %b %Y %T %z"
]
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 = map snd . filter predFunc . headers