-- |A simple feed generator: Date utilities -- -- Copyright (c) 2006 Manuel M T Chakravarty -- -- License: -- --- 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 -- 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 }