{-# LANGUAGE ViewPatterns #-}
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 {Message -> Text
fromLine :: T.Text, :: [Header], Message -> Text
body :: T.Text} 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 = (T.Text, T.Text)
parseDateHeader :: T.Text -> Maybe UTCTime
txt :: Text
txt = [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
header :: String
header = Text -> String
T.unpack Text
txt
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"
]
parseForward :: Message -> Message
parseForward :: Message -> Message
parseForward origMsg :: Message
origMsg@(Message f :: Text
f _ b :: Text
b) =
case Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop 1 ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ (Text -> Bool) -> [Text] -> [Text]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= String -> Text
T.pack "-----Original Message-----") (Text -> [Text]
T.lines Text
b) of
[] -> Message
origMsg
xs :: [Text]
xs -> Message -> [Message] -> Message
forall a. a -> [a] -> a
headDef Message
origMsg ([Message] -> Message)
-> ([Text] -> [Message]) -> [Text] -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Message]
parseMBox (Text -> [Message]) -> ([Text] -> Text) -> [Text] -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Message) -> [Text] -> Message
forall a b. (a -> b) -> a -> b
$ Text
fText -> [Text] -> [Text]
forall a. a -> [a] -> [a]
:[Text]
xs
parseMBox :: T.Text -> MBox
parseMBox :: Text -> [Message]
parseMBox = [Text] -> [Message]
go ([Text] -> [Message]) -> (Text -> [Text]) -> Text -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
where
go :: [Text] -> [Message]
go [] = []
go (x :: Text
x:xs :: [Text]
xs) = (Message -> [Message] -> [Message])
-> (Message, [Message]) -> [Message]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) ((Message, [Message]) -> [Message])
-> ([Text] -> (Message, [Message])) -> [Text] -> [Message]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> [Text] -> Message
readMsg Text
x ([Text] -> Message)
-> ([Text] -> [Message])
-> ([Text], [Text])
-> (Message, [Message])
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** [Text] -> [Message]
go) (([Text], [Text]) -> (Message, [Message]))
-> ([Text] -> ([Text], [Text])) -> [Text] -> (Message, [Message])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break ((String -> Text
T.pack "From ") Text -> Text -> Bool
`T.isPrefixOf`) ([Text] -> [Message]) -> [Text] -> [Message]
forall a b. (a -> b) -> a -> b
$ [Text]
xs
readMsg :: T.Text -> [T.Text] -> Message
readMsg :: Text -> [Text] -> Message
readMsg x :: Text
x xs :: [Text]
xs = ([Header] -> Text -> Message) -> ([Header], Text) -> Message
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Text -> [Header] -> Text -> Message
Message Text
x) (([Header], Text) -> Message)
-> ([Text] -> ([Header], Text)) -> [Text] -> Message
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Text] -> Text) -> ([Header], [Text]) -> ([Header], Text)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second ([Text] -> Text
T.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
unquoteFrom)(([Header], [Text]) -> ([Header], Text))
-> ([Text] -> ([Header], [Text])) -> [Text] -> ([Header], Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> ([Header], [Text])
readHeaders ([Text] -> Message) -> [Text] -> Message
forall a b. (a -> b) -> a -> b
$ [Text]
xs
readHeaders :: [T.Text] -> ([Header], [T.Text])
readHeaders :: [Text] -> ([Header], [Text])
readHeaders [] = ([],[])
readHeaders (x :: Text
x:xs :: [Text]
xs)
| Text -> Bool
T.null Text
x Bool -> Bool -> Bool
|| (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace Text
x Bool -> Bool -> Bool
|| Bool -> Bool
not ((Char -> Bool) -> Text -> Bool
T.any (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') Text
x) = ([],[Text]
xs)
| Bool
otherwise = ([Header] -> [Header]) -> ([Header], [Text]) -> ([Header], [Text])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (((Text -> Text) -> Header -> Header
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Text -> Text
T.strip (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
sanHeader (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text -> Text
`T.append` Text
headerCont) (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Text -> Text
T.drop 1) (Header -> Header) -> (Text -> Header) -> Text -> Header
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Header
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==':') (Text -> Header) -> Text -> Header
forall a b. (a -> b) -> a -> b
$ Text
x)Header -> [Header] -> [Header]
forall a. a -> [a] -> [a]
:) (([Header], [Text]) -> ([Header], [Text]))
-> ([Header], [Text]) -> ([Header], [Text])
forall a b. (a -> b) -> a -> b
$ [Text] -> ([Header], [Text])
readHeaders [Text]
xs'
where (headerCont :: Text
headerCont, xs' :: [Text]
xs') = ([Text] -> Text) -> ([Text], [Text]) -> (Text, [Text])
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((String -> Text
T.pack " " Text -> Text -> Text
`T.append`) (Text -> Text) -> ([Text] -> Text) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Text) -> ([Text] -> [Text]) -> [Text] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
T.strip) (([Text], [Text]) -> (Text, [Text]))
-> ([Text] -> ([Text], [Text])) -> [Text] -> (Text, [Text])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Bool) -> [Text] -> ([Text], [Text])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break Text -> Bool
notCont ([Text] -> (Text, [Text])) -> [Text] -> (Text, [Text])
forall a b. (a -> b) -> a -> b
$ [Text]
xs
notCont :: T.Text -> Bool
notCont :: Text -> Bool
notCont s :: Text
s = Text -> Bool
doesNotStartSpace Text
s Bool -> Bool -> Bool
|| Text -> Bool
allSpace Text
s
allSpace :: Text -> Bool
allSpace = (Char -> Bool) -> Text -> Bool
T.all Char -> Bool
isSpace
doesNotStartSpace :: Text -> Bool
doesNotStartSpace s :: Text
s = case Text -> Int64
T.length Text
s of
0 -> Bool
True
_ -> Bool -> Bool
not (Char -> Bool
isSpace (Char -> Bool) -> Char -> Bool
forall a b. (a -> b) -> a -> b
$ Text -> Char
T.head Text
s)
unquoteFrom :: T.Text -> T.Text
unquoteFrom :: Text -> Text
unquoteFrom xs' :: Text
xs'@(Text -> Text -> Maybe Text
T.stripPrefix (String -> Text
T.pack ">") -> Just suf :: Text
suf) = if (String -> Text
T.pack "From ") Text -> Text -> Bool
`T.isPrefixOf` (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='>') Text
suf
then Text
suf
else Text
xs'
unquoteFrom xs :: Text
xs = Text
xs
sanHeader :: T.Text -> T.Text
= Text -> Text -> Text -> Text
T.replace (String -> Text
T.pack "\n") (String -> Text
T.pack " ")
showMBox :: MBox -> T.Text
showMBox :: [Message] -> Text
showMBox = [Text] -> Text
T.concat ([Text] -> Text) -> ([Message] -> [Text]) -> [Message] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Message -> Text) -> [Message] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Message -> Text
showMessage
showMessage :: Message -> T.Text
showMessage :: Message -> Text
showMessage (Message f :: Text
f hs :: [Header]
hs b :: Text
b) = [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Text
f Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Header] -> [Text]
formatHeaders [Header]
hs [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [(String -> Text
T.pack "\n")] [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ Text -> [Text]
formatBody Text
b
where
formatHeaders :: [Header] -> [Text]
formatHeaders = (Header -> Text) -> [Header] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (\(x :: Text
x,y :: Text
y) -> Text
x Text -> Text -> Text
`T.append` (String -> Text
T.pack ": ") Text -> Text -> Text
`T.append` Text
y)
formatBody :: Text -> [Text]
formatBody = (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
unFrom ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
T.lines
unFrom :: Text -> Text
unFrom x :: Text
x
| Text -> Bool
isFrom Text
x = '>' Char -> Text -> Text
`T.cons` Text
x
| Bool
otherwise = Text
x
isFrom :: Text -> Bool
isFrom x :: Text
x = (String -> Text
T.pack "From ") Text -> Text -> Bool
`T.isPrefixOf` (Char -> Bool) -> Text -> Text
T.dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
=='>') Text
x
isID :: Header -> Bool
isID :: Header -> Bool
isID (x :: Text
x, _) = Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack "Message-ID"
isDate :: Header -> Bool
isDate :: Header -> Bool
isDate (x :: Text
x, _) = Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
T.pack "Date"
getHeader :: (Header -> Bool) -> Message -> [T.Text]
predFunc :: Header -> Bool
predFunc = (Header -> Text) -> [Header] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Header -> Text
forall a b. (a, b) -> b
snd ([Header] -> [Text]) -> (Message -> [Header]) -> Message -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Header -> Bool) -> [Header] -> [Header]
forall a. (a -> Bool) -> [a] -> [a]
filter Header -> Bool
predFunc ([Header] -> [Header])
-> (Message -> [Header]) -> Message -> [Header]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Message -> [Header]
headers