module WASH.Mail.RFC2822 where
import Char
import Text.ParserCombinators.Parsec
crLf = try (string "\n\r" <|> string "\r\n") <|> string "\n" <|> string "\r"
fws =
do many1 ws1
option "" (do crLf
many1 ws1)
<|>
do crLf
many1 ws1
ws1 = oneOf " \t"
lineChar = noneOf "\n\r"
headerNameChar = noneOf "\n\r:"
data DateTime2822 =
DateTime2822 (Maybe DayOfWeek) Date2822 Time2822
instance Show DateTime2822 where
showsPrec i (DateTime2822 mDayOfWeek date2822 time2822) =
(case mDayOfWeek of
Just dayOfWeek ->
showsDayOfWeek dayOfWeek . showString ", "
Nothing ->
id) .
shows date2822 .
showChar ' ' .
shows time2822
parseDateTime =
do mdow <- option Nothing (try $ do fws
dow <- parseDayOfWeek
char ','
return (Just dow))
date <- parseDate
fws
time <- parseTime
return (DateTime2822 mdow date time)
type DayOfWeek = Int
showsDayOfWeek 1 = showString "Mon"
showsDayOfWeek 2 = showString "Tue"
showsDayOfWeek 3 = showString "Wed"
showsDayOfWeek 4 = showString "Thu"
showsDayOfWeek 5 = showString "Fri"
showsDayOfWeek 6 = showString "Sat"
showsDayOfWeek 7 = showString "Sun"
parseDayOfWeek =
(try (string "Mon") >> return (1 :: DayOfWeek))
<|> (try (string "Tue") >> return 2)
<|> (try (string "Wed") >> return 3)
<|> (try (string "Thu") >> return 4)
<|> (try (string "Fri") >> return 5)
<|> (try (string "Sat") >> return 6)
<|> (try (string "Sun") >> return 7)
data Date2822 =
Date2822 Int Int Int
instance Show Date2822 where
showsPrec i (Date2822 d m y) =
showsDay d .
showChar ' ' .
showsMonth m .
showChar ' ' .
showsYear y
parseDate =
do d <- parseDay
m <- parseMonth
y <- parseYear
return (Date2822 d m y)
showsDay i = shows i
parseDay =
do fws
d1 <- digit
md2 <- option Nothing (digit >>= (return . Just))
case md2 of
Nothing ->
return (digitToInt d1)
Just d2 ->
return (digitToInt d2 + 10 * digitToInt d1)
monthList =
["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
parseMonthName =
foldr1 (<|>) (zipWith g monthList [1::Int ..])
where
g mname mnr = try (string mname) >> return mnr
showsMonth m =
showString (monthList !! (m1))
parseMonth =
do fws
m <- parseMonthName
fws
return m
showsYear y =
showString (drop 1 (show (10000 + y)))
parseYear =
do y1 <- digit
y2 <- digit
my3 <- option Nothing (digit >>= (return . Just))
my4 <- option Nothing (digit >>= (return . Just))
case (my3, my4) of
(Just y3, Just y4) ->
return (1000 * digitToInt y1 + 100 * digitToInt y2
+ 10 * digitToInt y3 + digitToInt y4)
(Just y3, Nothing) ->
return (1900 + 100 * digitToInt y1 + 10 * digitToInt y2 + digitToInt y3)
(Nothing, Nothing) ->
let rawVal = 10 * digitToInt y1 + digitToInt y2 in
if rawVal < 50
then return (2000 + rawVal)
else return (1900 + rawVal)
_ ->
fail "parseYear"
data Time2822 =
Time2822 TimeOfDay2822 Zone2822
instance Show Time2822 where
showsPrec i (Time2822 timeOfDay2822 zone2822) =
shows timeOfDay2822 .
showChar ' ' .
shows zone2822
parseTime =
do tod <- parseTimeOfDay
fws
zone <- parseZone
return (Time2822 tod zone)
data TimeOfDay2822 =
TimeOfDay2822 Int Int Int
instance Show TimeOfDay2822 where
showsPrec i (TimeOfDay2822 hh mm ss) =
showString (drop 1 $ show (100+hh)) .
showChar ':' .
showString (drop 1 $ show (100+mm)) .
showChar ':' .
showString (drop 1 $ show (100+ss))
parseTimeOfDay =
do hh <- parseTwoDigits
char ':'
mm <- parseTwoDigits
ss <- option 0 (try $ do char ':'
parseTwoDigits)
return (TimeOfDay2822 hh mm ss)
zoneInfoList =
[( "UT", (Zone2822 '+' 0 0))
,( "GMT", (Zone2822 '+' 0 0))
,( "EDT", (Zone2822 '-' 4 0))
,( "EST", (Zone2822 '-' 5 0))
,( "CDT", (Zone2822 '-' 5 0))
,( "CST", (Zone2822 '-' 6 0))
,( "MDT", (Zone2822 '-' 6 0))
,( "MST", (Zone2822 '-' 7 0))
,( "PDT", (Zone2822 '-' 7 0))
,( "PST", (Zone2822 '-' 8 0))
]
parseZoneInfo =
foldr1 (<|>) (map g zoneInfoList)
where
g (zname, zinfo) = try (string zname) >> return zinfo
data Zone2822 =
Zone2822 Char Int Int
instance Show Zone2822 where
showsPrec i (Zone2822 sign hh mm) =
showChar sign .
showString (drop 1 $ show (100+hh)) .
showString (drop 1 $ show (100+mm))
parseZone =
do sign <- oneOf "+-"
hh <- parseTwoDigits
mm <- parseTwoDigits
return (Zone2822 sign hh mm)
<|> parseZoneInfo
parseTwoDigits =
do d1 <- digit
d2 <- digit
return (10 * digitToInt d1 + digitToInt d2)