-- |A simple feed generator: Date utilities
--
-- Copyright (c) 2006 Manuel M T Chakravarty
--
-- License: <http://www.gnu.org/licenses/gpl.html>
--
--- Description ---------------------------------------------------------------
--
-- Language: Haskell 98
--
module Date (
Date(..), addMinutes, parseDate,
) where
-- hierachical libraries
--
import Control.Monad (
liftM)
import Data.Char (
isDigit, digitToInt)
import System.Locale (
TimeLocale(..), defaultTimeLocale, rfc822DateFormat)
import System.Time (
Month(..), ClockTime, TimeDiff(..), CalendarTime(..), noTimeDiff,
addToClockTime, toUTCTime, toClockTime, formatCalendarTime)
-- We convert all dates into an internal representation for storage and
-- comparison. All I/O uses the RFC822 format as required by the RSS 2.0
-- specification.
--
newtype Date = Date ClockTime
instance Eq Date where
Date d1 == Date d2 = d1 == d2
instance Ord Date where
compare (Date d1) (Date d2) = compare d1 d2
instance Show Date where
show (Date d) =
formatCalendarTime defaultTimeLocale rfc822DateFormat (toUTCTime d)
-- Advance a date specification by the specified number of minutes.
--
addMinutes :: Date -> Int -> Date
addMinutes (Date ct) min =
Date $ addToClockTime (noTimeDiff {tdMin = min}) ct
-- Parse an RFC822 date string (but allowing four digits for years and also
-- UTC, in addition to UT)
--
-- * Cf <http://asg.web.cmu.edu/rfc/rfc822.html#sec-5>
--
parseDate :: String -> Maybe Date
parseDate = liftM Date . parseDay
where
parseDay (_:_:_:',':' ':noWDay) = parseDay noWDay -- drop weekday
parseDay (d1 :' ':monthEtc) -- 1 digit day
| isDigit d1 = parseMonth (convDay '0' d1 ) monthEtc
parseDay (d1:d2:' ':monthEtc) -- 2 digit day
| isDigit d1 && isDigit d2 = parseMonth (convDay d1 d2) monthEtc
parseDay _ = Nothing
--
parseMonth day (m1:m2:m3:' ':yearEtc) =
parseYear day (parseMonth' (m1:m2:m3:[])) yearEtc
--
parseMonth' "Jan" = Just January
parseMonth' "Feb" = Just February
parseMonth' "Mar" = Just March
parseMonth' "Apr" = Just April
parseMonth' "May" = Just May
parseMonth' "Jun" = Just June
parseMonth' "Jul" = Just July
parseMonth' "Aug" = Just August
parseMonth' "Sep" = Just September
parseMonth' "Oct" = Just October
parseMonth' "Nov" = Just November
parseMonth' "Dec" = Just December
parseMonth' _ = Nothing
--
parseYear day mons (y1:y2 :' ':timeStr) -- 2 digit year
| isDigit y1 && isDigit y2 =
convert day mons (convYear Nothing y1 y2) (parseTime timeStr)
parseYear day mons (y1:y2:y3:y4:' ':timeStr) -- 4 digit year
| isDigit y1 && isDigit y2 && isDigit y3 && isDigit y4 =
convert day mons (convYear (Just (y1, y2)) y3 y4) (parseTime timeStr)
parseYear _ _ _ = Nothing
--
parseTime (h1:h2:':':m1:m2:':':s1:s2:' ':zoneStr) -- w/ seconds
| isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 &&
isDigit s1 && isDigit s2 =
do
hour <- convHour h1 h2
mins <- convMins m1 m2
secs <- convSecs s1 s2
zone <- parseZone zoneStr
return $ (hour, mins, secs, zone)
parseTime (h1:h2:':':m1:m2 :' ':zoneStr) -- w/o seconds
| isDigit h1 && isDigit h2 && isDigit m1 && isDigit m2 =
do
hour <- convHour h1 h2
mins <- convMins m1 m2
let secs = 0
zone <- parseZone zoneStr
return (hour, mins, secs, zone)
parseTime _ = Nothing
--
convYear Nothing y1 y2 | 70 <= year = Just $ 1900 + year
| otherwise = Just $ 2000 + year
where year = digitToInt y1 * 10 +
digitToInt y2
convYear (Just (y1, y2)) y3 y4 = Just $ digitToInt y1 * 1000 +
digitToInt y2 * 100 +
digitToInt y3 * 10 +
digitToInt y4
convDay d1 d2 | 1 <= day && day <= 31 = Just day
| otherwise = Nothing
where day = digitToInt d1 * 10 + digitToInt d2
convHour h1 h2 | 0 <= hour && hour <= 23 = Just hour
| otherwise = Nothing
where hour = digitToInt h1 * 10 + digitToInt h2
convMins m1 m2 | 0 <= mins && mins <= 59 = Just mins
| otherwise = Nothing
where mins = digitToInt m1 * 10 + digitToInt m2
convSecs s1 s2 | 0 <= secs && secs <= 59 = Just secs
| otherwise = Nothing
where secs = digitToInt s1 * 10 + digitToInt s2
--
parseZone :: String -> Maybe Int
parseZone "UT" = Just 0
parseZone "UTC" = Just 0
parseZone "GMT" = Just 0
parseZone "EST" = Just (hourToSecs (-5))
parseZone "EDT" = Just (hourToSecs (-4))
parseZone "CST" = Just (hourToSecs (-6))
parseZone "CDT" = Just (hourToSecs (-5))
parseZone "MST" = Just (hourToSecs (-7))
parseZone "MDT" = Just (hourToSecs (-6))
parseZone "PST" = Just (hourToSecs (-8))
parseZone "PDT" = Just (hourToSecs (-7))
parseZone "Z" = Just 0
parseZone "A" = Just (hourToSecs (-1))
parseZone "B" = Just (hourToSecs (-2))
parseZone "C" = Just (hourToSecs (-3))
parseZone "D" = Just (hourToSecs (-4))
parseZone "E" = Just (hourToSecs (-5))
parseZone "F" = Just (hourToSecs (-6))
parseZone "G" = Just (hourToSecs (-7))
parseZone "H" = Just (hourToSecs (-8))
parseZone "I" = Just (hourToSecs (-9))
parseZone "K" = Just (hourToSecs (-10))
parseZone "L" = Just (hourToSecs (-11))
parseZone "M" = Just (hourToSecs (-12))
parseZone "N" = Just (hourToSecs 1)
parseZone "O" = Just (hourToSecs 2)
parseZone "P" = Just (hourToSecs 3)
parseZone "Q" = Just (hourToSecs 4)
parseZone "R" = Just (hourToSecs 5)
parseZone "S" = Just (hourToSecs 6)
parseZone "T" = Just (hourToSecs 7)
parseZone "U" = Just (hourToSecs 8)
parseZone "V" = Just (hourToSecs 9)
parseZone "W" = Just (hourToSecs 10)
parseZone "X" = Just (hourToSecs 11)
parseZone "Y" = Just (hourToSecs 12)
parseZone ('+':hhmm) = parseDiff 1 hhmm
parseZone ('-':hhmm) = parseDiff (-1) hhmm
parseZone _ = Nothing
--
parseDiff :: Int -> String -> Maybe Int
parseDiff sign (h1:h2:m1:m2:[]) =
do
hour <- convHour h1 h2
mins <- convMins m1 m2
return $ sign * (hour * 60 + mins) * 60
--
hourToSecs hour = hour * 60 * 60
--
convert day mons year time =
do
day' <- day
mons' <- mons
year' <- year
(hour, mins, secs, zone) <- time
return $ toClockTime $ CalendarTime {
ctYear = year',
ctMonth = mons',
ctDay = day' ,
ctHour = hour ,
ctMin = mins ,
ctSec = secs ,
ctPicosec = 0 ,
ctTZ = zone ,
-- to avoid getting a warning
ctWDay = undefined,
ctYDay = undefined,
ctTZName = undefined,
ctIsDST = undefined
}