From 01d923fe509a76afa27efdc7370438c5d4900492 Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 17 Mar 2010 15:24:36 +0900 Subject: [PATCH] Data.Time.RFC733 now fully works --- Data/Time/HTTP/Common.hs | 125 +++++++++++++++++++++++++++++++++++++ Data/Time/RFC733.hs | 88 ++++++++++++++++++++++++++ Data/Time/RFC733/Parsec.hs | 107 +++++++++++++++++++++++++++++++ Data/Time/RFC822.hs | 12 ---- Data/Time/RFC822/Parsec.hs | 67 +++----------------- time-http.cabal | 2 + 6 files changed, 329 insertions(+), 72 deletions(-) create mode 100644 Data/Time/RFC733.hs create mode 100644 Data/Time/RFC733/Parsec.hs diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs index 1ea61de..6cb59b3 100644 --- a/Data/Time/HTTP/Common.hs +++ b/Data/Time/HTTP/Common.hs @@ -9,15 +9,28 @@ module Data.Time.HTTP.Common , shortMonthName , shortMonthNameP + , longMonthName + , longMonthNameP + , show2 , show4 , read2 , read4 + + , showTZ + , read4digitsTZ + + , assertWeekDayIsGood + , assertGregorianDateIsGood + , assertTimeOfDayIsGood ) where import Control.Monad +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate import Text.Parsec shortWeekDayName :: Int -> String @@ -108,6 +121,45 @@ shortMonthNameP , string "Dec" >> return 12 ] +longMonthName :: Int -> String +longMonthName 1 = "January" +longMonthName 2 = "February" +longMonthName 3 = "March" +longMonthName 4 = "April" +longMonthName 5 = "May" +longMonthName 6 = "June" +longMonthName 7 = "July" +longMonthName 8 = "August" +longMonthName 9 = "September" +longMonthName 10 = "October" +longMonthName 11 = "November" +longMonthName 12 = "December" +longMonthName n = error ("longMonthName: unknown month number: " ++ show n) + +longMonthNameP :: Stream s m Char => ParsecT s u m Int +longMonthNameP + = choice [ char 'J' + >> choice [ string "anuary" >> return 1 + , char 'u' + >> choice [ string "ne" >> return 6 + , string "ly" >> return 7 + ] + ] + , string "February" >> return 2 + , string "Ma" + >> choice [ string "rch" >> return 3 + , char 'y' >> return 5 + ] + , char 'A' + >> choice [ string "pril" >> return 4 + , string "ugust" >> return 8 + ] + , string "September" >> return 9 + , string "October" >> return 10 + , string "November" >> return 11 + , string "December" >> return 12 + ] + show4 :: Integral i => i -> String show4 i | i >= 0 && i < 10 = "000" ++ show i @@ -149,3 +201,76 @@ fromC '7' = 7 fromC '8' = 8 fromC '9' = 9 fromC _ = undefined + +showTZ :: TimeZone -> String +showTZ tz + = case timeZoneMinutes tz of + offset | offset < 0 -> '-' : showTZ' (negate offset) + | otherwise -> '+' : showTZ' offset + where + showTZ' offset + = let h = offset `div` 60 + m = offset - h * 60 + in + concat [show2 h, show2 m] + +read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone +read4digitsTZ + = do sign <- (char '+' >> return 1) + <|> + (char '-' >> return (-1)) + hour <- read2 + minute <- read2 + let tz = TimeZone { + timeZoneMinutes = (sign * (hour * 60 + minute)) + , timeZoneSummerOnly = False + , timeZoneName = timeZoneOffsetString tz + } + return tz + +assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m () +assertWeekDayIsGood givenWD gregDay + = let (_, _, correctWD ) = toWeekDate gregDay + (year, month, day) = toGregorian gregDay + in + unless (givenWD == correctWD) + $ fail + $ concat [ "Gregorian day " + , show year + , "-" + , show month + , "-" + , show day + , " is " + , longWeekDayName correctWD + , ", not " + , longWeekDayName givenWD + ] + +assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day +assertGregorianDateIsGood year month day + = case fromGregorianValid year month day of + Nothing + -> fail $ concat [ "Invalid gregorian day: " + , show year + , "-" + , show month + , "-" + , show day + ] + Just gregDay + -> return gregDay + +assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay +assertTimeOfDayIsGood hour minute second + = case makeTimeOfDayValid hour minute second of + Nothing + -> fail $ concat [ "Invalid time of day: " + , show hour + , ":" + , show minute + , ":" + , showFixed True second + ] + Just tod + -> return tod diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs new file mode 100644 index 0000000..a5e28d3 --- /dev/null +++ b/Data/Time/RFC733.hs @@ -0,0 +1,88 @@ +module Data.Time.RFC733 + ( format + , parse + ) + where + +import qualified Text.Parsec as P + +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Data.Time.RFC733.Parsec + +{- +date-time = [ day-of-week "," ] date time + +day-of-week = "Monday" / "Mon" / "Tuesday" / "Tue" + / "Wednesday" / "Wed" / "Thursday" / "Thu" + / "Friday" / "Fri" / "Saturday" / "Sat" + / "Sunday" / "Sun" + +date = 1*2DIGIT ["-"] month ; day month year + ["-"] (2DIGIT /4DIGIT) ; e.g. 20 Aug [19]77 + +month = "January" / "Jan" / "February" / "Feb" + / "March" / "Mar" / "April" / "Apr" + / "May" / "June" / "Jun" + / "July" / "Jul" / "August" / "Aug" + / "September" / "Sep" / "October" / "Oct" + / "November" / "Nov" / "December" / "Dec" + +time = hour zone ; ANSI and Military + ; (seconds optional) + +hour = 2DIGIT [":"] 2DIGIT [ [":"] 2DIGIT ] + ; 0000[00] - 2359[59] + +zone = ( ["-"] ( "GMT" ; Relative to GMT: + ; North American + / "NST" / ; Newfoundland:-3:30 + / "AST" / "ADT" ; Atlantic: - 4/ - 3 + / "EST" / "EDT" ; Eastern: - 5/ - 4 + / "CST" / "CDT" ; Central: - 6/ - 5 + / "MST" / "MDT" ; Mountain: - 7/ - 6 + / "PST" / "PDT" ; Pacific: - 8/ - 7 + / "YST" / "YDT" ; Yukon: - 9/ - 8 + / "HST" / "HDT" ; Haw/Ala -10/ - 9 + / "BST" / "BDT" ; Bering: -11/ -10 + 1ALPHA )) ; Military: Z = GMT; + ; A:-1; (J not used) + ; M:-12; N:+1; Y:+12 + / ( ("+" / "-") 4DIGIT ) ; Local differential + ; hours/min. (HHMM) +-} + +format :: ZonedTime -> String +format zonedTime + = let localTime = zonedTimeToLocalTime zonedTime + timeZone = zonedTimeZone zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + concat [ longWeekDayName week + , ", " + , show2 day + , "-" + , shortMonthName month + , "-" + , show4 year + , " " + , show2 (todHour timeOfDay) + , ":" + , show2 (todMin timeOfDay) + , ":" + , show2 (floor (todSec timeOfDay)) + , " " + , showTZ timeZone + ] + +parse :: String -> Maybe ZonedTime +parse src = case P.parse p "" src of + Right zt -> Just zt + Left _ -> Nothing + where + p = do zt <- parser + _ <- P.eof + return zt diff --git a/Data/Time/RFC733/Parsec.hs b/Data/Time/RFC733/Parsec.hs new file mode 100644 index 0000000..baf2469 --- /dev/null +++ b/Data/Time/RFC733/Parsec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.RFC733.Parsec + ( parser + ) + where + +import Control.Monad +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Text.Parsec + + +parser :: Stream s m Char => ParsecT s u m ZonedTime +parser = dateTime + +dateTime :: Stream s m Char => ParsecT s u m ZonedTime +dateTime = do weekDay <- optionMaybe $ + do w <- try longWeekDayNameP + <|> + shortWeekDayNameP + _ <- string ", " + return w + gregDay <- date + case weekDay of + Nothing + -> return () + Just givenWD + -> assertWeekDayIsGood givenWD gregDay + (tod, timeZone) <- time + let lt = LocalTime gregDay tod + zt = ZonedTime lt timeZone + return zt + +date :: Stream s m Char => ParsecT s u m Day +date = do day <- read2 + _ <- char '-' <|> char ' ' + month <- try longMonthNameP + <|> + shortMonthNameP + _ <- char '-' <|> char ' ' + year <- try read4 + <|> + liftM (+ 1900) read2 + _ <- char ' ' + assertGregorianDateIsGood (toInteger year) month day + +time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) +time = do tod <- hour + _ <- char ' ' + tz <- zone + return (tod, tz) + +hour :: Stream s m Char => ParsecT s u m TimeOfDay +hour = do hour <- read2 + _ <- optional (char ':') + minute <- read2 + second <- option 0 $ + do _ <- optional (char ':') + read2 + assertTimeOfDayIsGood hour minute second + +zone :: Stream s m Char => ParsecT s u m TimeZone +zone = choice [ string "GMT" >> return (TimeZone 0 False "GMT") + , char 'N' + >> choice [ string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST") + , return (TimeZone (1 * 60) False "N") + ] + , char 'A' + >> choice [ string "ST" >> return (TimeZone ((-4) * 60) False "AST") + , string "DT" >> return (TimeZone ((-3) * 60) False "AST") + , return (TimeZone ((-1) * 60) False "A") + ] + , char 'E' + >> choice [ string "ST" >> return (TimeZone ((-5) * 60) False "EST") + , string "DT" >> return (TimeZone ((-4) * 60) True "EDT") + ] + , char 'C' + >> choice [ string "ST" >> return (TimeZone ((-6) * 60) False "CST") + , string "DT" >> return (TimeZone ((-5) * 60) True "CDT") + ] + , char 'M' + >> choice [ string "ST" >> return (TimeZone ((-7) * 60) False "MST") + , string "DT" >> return (TimeZone ((-6) * 60) True "MDT") + , return (TimeZone ((-12) * 60) False "M") + ] + , char 'P' + >> choice [ string "ST" >> return (TimeZone ((-8) * 60) False "PST") + , string "DT" >> return (TimeZone ((-7) * 60) True "PDT") + ] + , char 'Y' + >> choice [ string "ST" >> return (TimeZone ((-9) * 60) False "YST") + , string "DT" >> return (TimeZone ((-8) * 60) True "YDT") + , return (TimeZone ( 12 * 60) False "Y") + ] + , char 'H' + >> choice [ string "ST" >> return (TimeZone ((-10) * 60) False "HST") + , string "DT" >> return (TimeZone (( -9) * 60) True "HDT") + ] + , char 'B' + >> choice [ string "ST" >> return (TimeZone ((-11) * 60) False "BST") + , string "DT" >> return (TimeZone ((-10) * 60) True "BDT") + ] + , char 'Z' >> return (TimeZone 0 False "Z") + , read4digitsTZ + ] diff --git a/Data/Time/RFC822.hs b/Data/Time/RFC822.hs index 4b3d91c..fa4f8ef 100644 --- a/Data/Time/RFC822.hs +++ b/Data/Time/RFC822.hs @@ -69,18 +69,6 @@ format zonedTime , showTZ timeZone ] -showTZ :: TimeZone -> String -showTZ tz - = case timeZoneMinutes tz of - offset | offset < 0 -> '-' : showTZ' (negate offset) - | otherwise -> '+' : showTZ' offset - where - showTZ' offset - = let h = offset `div` 60 - m = offset - h * 60 - in - concat [show2 h, show2 m] - parse :: String -> Maybe ZonedTime parse src = case P.parse p "" src of Right zt -> Just zt diff --git a/Data/Time/RFC822/Parsec.hs b/Data/Time/RFC822/Parsec.hs index f80633e..138b9a4 100644 --- a/Data/Time/RFC822/Parsec.hs +++ b/Data/Time/RFC822/Parsec.hs @@ -15,7 +15,6 @@ import Text.Parsec parser :: Stream s m Char => ParsecT s u m ZonedTime parser = dateTime - dateTime :: Stream s m Char => ParsecT s u m ZonedTime dateTime = do weekDay <- optionMaybe $ do w <- shortWeekDayNameP @@ -26,32 +25,11 @@ dateTime = do weekDay <- optionMaybe $ Nothing -> return () -- No day in week exists. Just givenWD - -> let (_, _, correctWD) = toWeekDate gregDay - in - if correctWD == givenWD then - return () -- Correct day in the week. - else - let (year, month, day) = toGregorian gregDay - in - fail $ concat [ "Gregorian day " - , show year - , "-" - , show month - , "-" - , show day - , " is " - , longWeekDayName correctWD - , ", not " - , longWeekDayName givenWD - ] + -> assertWeekDayIsGood givenWD gregDay (tod, timeZone) <- time - return ZonedTime { - zonedTimeToLocalTime = LocalTime { - localDay = gregDay - , localTimeOfDay = tod - } - , zonedTimeZone = timeZone - } + let lt = LocalTime gregDay tod + zt = ZonedTime lt timeZone + return zt date :: Stream s m Char => ParsecT s u m Day date = do day <- read2 @@ -60,18 +38,7 @@ date = do day <- read2 _ <- char ' ' year <- liftM (+ 1900) read2 _ <- char ' ' - - case fromGregorianValid (toInteger year) month day of - Nothing - -> fail $ concat [ "Invalid gregorian day: " - , show year - , "-" - , show month - , "-" - , show day - ] - Just gregDay - -> return gregDay + assertGregorianDateIsGood (toInteger year) month day time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) time = do tod <- hour @@ -83,17 +50,7 @@ hour :: Stream s m Char => ParsecT s u m TimeOfDay hour = do hour <- read2 minute <- char ':' >> read2 second <- option 0 (char ':' >> read2) - case makeTimeOfDayValid hour minute second of - Nothing - -> fail $ concat [ "Invalid time of day: " - , show hour - , ":" - , show minute - , ":" - , showFixed True second - ] - Just tod - -> return tod + assertTimeOfDayIsGood hour minute second zone :: Stream s m Char => ParsecT s u m TimeZone zone = choice [ string "UT" >> return (TimeZone 0 False "UT" ) @@ -119,15 +76,5 @@ zone = choice [ string "UT" >> return (TimeZone 0 False "UT" ) , char 'A' >> return (TimeZone ((-1) * 60) False "A") , char 'N' >> return (TimeZone ( 1 * 60) False "N") , char 'Y' >> return (TimeZone ( 12 * 60) False "Y") - , do sign <- (char '+' >> return 1) - <|> - (char '-' >> return (-1)) - hour <- read2 - minute <- read2 - let tz = TimeZone { - timeZoneMinutes = (sign * (hour * 60 + minute)) - , timeZoneSummerOnly = False - , timeZoneName = timeZoneOffsetString tz - } - return tz + , read4digitsTZ ] diff --git a/time-http.cabal b/time-http.cabal index 6ec5f3d..cfdc663 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -23,6 +23,8 @@ Library Exposed-modules: Data.Time.RFC822 Data.Time.RFC822.Parsec + Data.Time.RFC733 + Data.Time.RFC733.Parsec Other-modules: Data.Time.HTTP.Common -- 2.40.0