-----------------------------------------------------------------------------
{- |
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>.

This parser is written to be a streaming parser. Given a lazy source of data and a streaming consumer, you should be able to analyze arbitrary mbox files in constant space.

-}
-------------------------------------------------------------------------

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 Data.Maybe
import Data.Time
import Safe
import qualified Data.Time.Locale.Compat as LC

type MBox = [Message]
data Message = Message {Message -> String
fromLine :: String, Message -> [Header]
headers :: [Header], Message -> String
body :: String} deriving (ReadPrec [Message]
ReadPrec Message
Int -> ReadS Message
ReadS [Message]
(Int -> ReadS Message)
-> ReadS [Message]
-> ReadPrec Message
-> ReadPrec [Message]
-> Read Message
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Message]
$creadListPrec :: ReadPrec [Message]
readPrec :: ReadPrec Message
$creadPrec :: ReadPrec Message
readList :: ReadS [Message]
$creadList :: ReadS [Message]
readsPrec :: Int -> ReadS Message
$creadsPrec :: Int -> ReadS Message
Read, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show)
type Header = (String, String)

-- | Reads a date header as a UTCTime
parseDateHeader :: String -> Maybe UTCTime
parseDateHeader :: String -> Maybe UTCTime
parseDateHeader header :: String
header = [UTCTime] -> Maybe UTCTime
forall a. [a] -> Maybe a
listToMaybe ([UTCTime] -> Maybe UTCTime)
-> ([Maybe UTCTime] -> [UTCTime])
-> [Maybe UTCTime]
-> Maybe UTCTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe UTCTime] -> [UTCTime]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe UTCTime] -> Maybe UTCTime)
-> [Maybe UTCTime] -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ (String -> Maybe UTCTime) -> [String] -> [Maybe UTCTime]
forall a b. (a -> b) -> [a] -> [b]
map String -> Maybe UTCTime
forall t. ParseTime t => String -> Maybe t
tryParse [String]
formats where
  tryParse :: String -> Maybe t
tryParse f :: String
f = TimeLocale -> String -> String -> Maybe t
forall t. ParseTime t => TimeLocale -> String -> String -> Maybe t
parseTime TimeLocale
LC.defaultTimeLocale String
f String
header
  formats :: [String]
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"
    ]


-- | Attempts to retrieve the contents of a forwarded message from an enclosing message.
parseForward :: Message -> Message
parseForward :: Message -> Message
parseForward origMsg :: Message
origMsg@(Message f :: String
f _ b :: String
b) =
    case Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
drop 1 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= "-----Original Message-----") (String -> [String]
lines String
b) of
      [] -> Message
origMsg
      xs :: [String]
xs -> Message -> [Message] -> Message
forall a. a -> [a] -> a
headDef Message
origMsg ([Message] -> Message)
-> ([String] -> [Message]) -> [String] -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [Message]
parseMBox (String -> [Message])
-> ([String] -> String) -> [String] -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> Message) -> [String] -> Message
forall a b. (a -> b) -> a -> b
$ String
fString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
xs

-- | Reads a string as an mbox file.
parseMBox :: String -> MBox
parseMBox :: String -> [Message]
parseMBox = [String] -> [Message]
go ([String] -> [Message])
-> (String -> [String]) -> String -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines
    where
      go :: [String] -> [Message]
go [] = []
      go (x :: String
x:xs :: [String]
xs) = (Message -> [Message] -> [Message])
-> (Message, [Message]) -> [Message]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) ((Message, [Message]) -> [Message])
-> ([String] -> (Message, [Message])) -> [String] -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> [String] -> Message
readMsg String
x ([String] -> Message)
-> ([String] -> [Message])
-> ([String], [String])
-> (Message, [Message])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [String] -> [Message]
go) (([String], [String]) -> (Message, [Message]))
-> ([String] -> ([String], [String]))
-> [String]
-> (Message, [Message])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ("From " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`) ([String] -> [Message]) -> [String] -> [Message]
forall a b. (a -> b) -> a -> b
$ [String]
xs
      readMsg :: String -> [String] -> Message
      readMsg :: String -> [String] -> Message
readMsg x :: String
x xs :: [String]
xs = ([Header] -> String -> Message) -> ([Header], String) -> Message
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (String -> [Header] -> String -> Message
Message String
x) (([Header], String) -> Message)
-> ([String] -> ([Header], String)) -> [String] -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([String] -> String) -> ([Header], [String]) -> ([Header], String)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
unquoteFrom)(([Header], [String]) -> ([Header], String))
-> ([String] -> ([Header], [String]))
-> [String]
-> ([Header], String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> ([Header], [String])
readHeaders ([String] -> Message) -> [String] -> Message
forall a b. (a -> b) -> a -> b
$ [String]
xs
      readHeaders :: [String] -> ([Header], [String])
      readHeaders :: [String] -> ([Header], [String])
readHeaders [] = ([],[])
      readHeaders (x :: String
x:xs :: [String]
xs)
          | String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
x Bool -> Bool -> Bool
|| (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
x Bool -> Bool -> Bool
|| Bool -> Bool
not ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') String
x) = ([],[String]
xs)
          | Bool
otherwise = ([Header] -> [Header])
-> ([Header], [String]) -> ([Header], [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((ShowS -> Header -> Header
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (ShowS
killSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS
sanHeader ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
headerCont) ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ShowS
forall a. Int -> [a] -> [a]
drop 1) (Header -> Header) -> (String -> Header) -> String -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> Header
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') (String -> Header) -> String -> Header
forall a b. (a -> b) -> a -> b
$ String
x)Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
:) (([Header], [String]) -> ([Header], [String]))
-> ([Header], [String]) -> ([Header], [String])
forall a b. (a -> b) -> a -> b
$ [String] -> ([Header], [String])
readHeaders [String]
xs'
            where (headerCont :: String
headerCont, xs' :: [String]
xs') = ([String] -> String) -> ([String], [String]) -> (String, [String])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((" " String -> ShowS
forall a. [a] -> [a] -> [a]
++) ShowS -> ([String] -> String) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> String)
-> ([String] -> [String]) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
killSpace) (([String], [String]) -> (String, [String]))
-> ([String] -> ([String], [String]))
-> [String]
-> (String, [String])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break String -> Bool
notCont ([String] -> (String, [String])) -> [String] -> (String, [String])
forall a b. (a -> b) -> a -> b
$ [String]
xs
                  notCont :: String -> Bool
notCont [] = Bool
True
                  notCont (c :: Char
c:cs :: String
cs) = Bool -> Bool
not (Char -> Bool
isSpace Char
c) Bool -> Bool -> Bool
|| ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isSpace String
cs)
      unquoteFrom :: String -> String
      unquoteFrom :: ShowS
unquoteFrom xs' :: String
xs'@('>':xs :: String
xs) = if "From " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='>') String
xs
                                   then String
xs
                                   else String
xs'
      unquoteFrom xs :: String
xs = String
xs

sanHeader :: String -> String
sanHeader :: ShowS
sanHeader = (Char -> Char) -> ShowS
forall a b. (a -> b) -> [a] -> [b]
map (\x :: Char
x -> if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '\n' then ' ' else Char
x)

-- | Renders an MBox into a String
showMBox :: MBox -> String
showMBox :: [Message] -> String
showMBox = (Message -> String) -> [Message] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Message -> String
showMessage

-- | Renders an individual message into a String.
showMessage :: Message -> String
showMessage :: Message -> String
showMessage (Message f :: String
f hs :: [Header]
hs b :: String
b) = [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
f String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: String
x,y :: String
y) -> (String
x String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
y)) [Header]
hs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ["\n"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ShowS -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ShowS
unFrom (String -> [String]
lines String
b)
    where unFrom :: ShowS
unFrom x :: String
x
             | String -> Bool
isFrom String
x  = '>'Char -> ShowS
forall a. a -> [a] -> [a]
:String
x
             | Bool
otherwise = String
x
          isFrom :: String -> Bool
isFrom x :: String
x = "From " String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='>') String
x

killSpace :: String -> String
killSpace :: ShowS
killSpace = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropWhile Char -> Bool
isSpace ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
dropEndWhile Char -> Bool
isSpace

dropEndWhile :: (a -> Bool) -> [a] -> [a]
dropEndWhile :: (a -> Bool) -> [a] -> [a]
dropEndWhile p :: a -> Bool
p = (a -> [a] -> [a]) -> [a] -> [a] -> [a]
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\x :: a
x xs :: [a]
xs -> if a -> Bool
p a
x Bool -> Bool -> Bool
&& [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs then [] else a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs) []


-- | Header accessors

isID :: Header -> Bool
isID :: Header -> Bool
isID (x :: String
x, _y :: String
_y) = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Message-ID"

isDate :: Header -> Bool
isDate :: Header -> Bool
isDate (x :: String
x, _y :: String
_y) = String
x String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== "Date"

getHeader :: (Header -> Bool) -> Message -> [String]
getHeader :: (Header -> Bool) -> Message -> [String]
getHeader p :: Header -> Bool
p = (Header -> String) -> [Header] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Header -> String
forall a b. (a, b) -> b
snd ([Header] -> [String])
-> (Message -> [Header]) -> Message -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
p ([Header] -> [Header])
-> (Message -> [Header]) -> Message -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> [Header]
headers