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, :: [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 = (String, String)
parseDateHeader :: String -> Maybe UTCTime
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"
]
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
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
= (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)
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
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) []
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]
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