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