diff --git a/Data/MBox.hs b/Data/MBox.hs --- a/Data/MBox.hs +++ b/Data/MBox.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE ViewPatterns #-} ----------------------------------------------------------------------------- {- | Module : Data.MBox -Copyright : (c) Gershom Bazerman, 2009 +Copyright : (c) Gershom Bazerman, 2009; ported to Text by Alexander Jerneck, 2012 License : BSD 3 Clause Maintainer : gershomb@gmail.com Stability : experimental @@ -12,66 +13,89 @@ -} ------------------------------------------------------------------------- -module Data.MBox (MBox, Message(..), Header, parseMBox, parseForward, parseDateHeader, showMessage, showMBox) where -import Prelude hiding (tail, init, head, last, minimum, maximum, foldr1, foldl1, (!!), read) +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.List(isPrefixOf) import Data.Char import System.Locale import Data.Time import Safe +import qualified Data.Text as T type MBox = [Message] -data Message = Message {fromLine :: String, headers :: [Header], body :: String} deriving (Read, Show) -type Header = (String, String) +data Message = Message {fromLine :: T.Text, headers :: [Header], body :: T.Text} deriving (Read, Show) +type Header = (T.Text, T.Text) -- | Reads a date header as a UTCTime -parseDateHeader :: String -> Maybe UTCTime -parseDateHeader = parseTime defaultTimeLocale "%A, %B %e, %Y %l:%M %p" +parseDateHeader :: T.Text -> Maybe UTCTime +parseDateHeader = parseTime defaultTimeLocale "%A, %B %e, %Y %l:%M %p" . T.unpack -- | Attempts to retrieve the contents of a forwarded message from an enclosing message. parseForward :: Message -> Message parseForward origMsg@(Message f _ b) = - case drop 1 $ dropWhile (/= "-----Original Message-----") (lines b) of + case drop 1 $ dropWhile (/= T.pack "-----Original Message-----") (T.lines b) of [] -> origMsg - xs -> headDef origMsg . parseMBox . unlines $ f:xs + xs -> headDef origMsg . parseMBox . T.unlines $ f:xs --- | Reads a string as an mbox file. -parseMBox :: String -> MBox -parseMBox = go . lines +-- | Parses Text as an mbox file. +parseMBox :: T.Text -> MBox +parseMBox = go . T.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]) + 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) - | null x || all isSpace x || not (any (==':') x) = ([],xs) - | otherwise = first ((second (killSpace . (++ 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' + | T.null x || T.all isSpace x || not (T.any (==':') x) = ([],xs) + | otherwise = first ((second (killSpace . sanHeader . (`T.append` headerCont) . T.drop 1) . T.break (==':') $ x):) $ readHeaders xs' + where (headerCont, xs') = first ((T.pack " " `T.append`) . T.unlines . map killSpace) . 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 --- | Renders an MBox into a String -showMBox :: MBox -> String -showMBox = concatMap showMessage +sanHeader :: T.Text -> T.Text +sanHeader = T.replace (T.pack "\n") (T.pack " ") --- | Renders an individual message into a String. -showMessage :: Message -> String -showMessage (Message f hs b) = unlines $ f : map (\(x,y) -> (x ++ ": " ++ y)) hs ++ 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 +-- | Renders an MBox into Text +showMBox :: MBox -> T.Text +showMBox = T.concat . map showMessage -dropEndWhile :: (a -> Bool) -> [a] -> [a] -dropEndWhile p = foldr (\x xs -> if p x && null xs then [] else x:xs) [] +-- | Renders an individual message into Text. +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 + +killSpace :: T.Text -> T.Text +killSpace = T.strip + +-- | Return True if header is a Message-ID header. +isID :: Header -> Bool +isID (x, _) = x == T.pack "Message-ID" + +-- | Return True if header is a Date header. +isDate :: Header -> Bool +isDate (x, _) = x == T.pack "Date" + +-- | Return the values of headers for which predicate is True +getHeader :: (Header -> Bool) -> Message -> T.Text +getHeader predFunc = snd . head . filter predFunc . headers diff --git a/Data/MBox/String.hs b/Data/MBox/String.hs new file mode 100644 --- /dev/null +++ b/Data/MBox/String.hs @@ -0,0 +1,92 @@ + +----------------------------------------------------------------------------- +{- | +Module : Data.MBox +Copyright : (c) Gershom Bazerman, 2009 +License : BSD 3 Clause +Maintainer : gershomb@gmail.com +Stability : experimental + +Reads and writes mboxrd files as per . + +-} +------------------------------------------------------------------------- + +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) + +-- | Reads a date header as a UTCTime +parseDateHeader :: String -> Maybe UTCTime +parseDateHeader = parseTime defaultTimeLocale "%A, %B %e, %Y %l:%M %p" + +-- | Attempts to retrieve the contents of a forwarded message from an enclosing message. +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 + +-- | Reads a string as an mbox file. +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) + +-- | Renders an MBox into a String +showMBox :: MBox -> String +showMBox = concatMap showMessage + +-- | Renders an individual message into a String. +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) [] + + +-- | Header accessors + +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 diff --git a/mbox.cabal b/mbox.cabal --- a/mbox.cabal +++ b/mbox.cabal @@ -1,5 +1,5 @@ name: mbox -version: 0.1 +version: 0.2 synopsis: Read and write standard mailbox files. description: Read and write standard mailbox (mboxrd) files. category: system, text, data @@ -12,8 +12,8 @@ Cabal-Version: >= 1.6 library - build-depends: base >= 4, base < 5, safe, time, old-locale - exposed-modules: Data.MBox + build-depends: base >= 4, base < 6, safe, time, old-locale, text + exposed-modules: Data.MBox, Data.MBox.String ghc-options: -Wall source-repository head