mbox 0.1 → 0.2
raw patch · 3 files changed
+159/−43 lines, 3 filesdep +textdep ~base
Dependencies added: text
Dependency ranges changed: base
Files
- Data/MBox.hs +64/−40
- Data/MBox/String.hs +92/−0
- mbox.cabal +3/−3
Data/MBox.hs view
@@ -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
+ Data/MBox/String.hs view
@@ -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 <http://www.qmail.org/man/man5/mbox.html>.++-}+-------------------------------------------------------------------------++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
mbox.cabal view
@@ -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