From 9f9ed0471883b50fec1b091621f332d62477a34c Mon Sep 17 00:00:00 2001 From: PHO Date: Wed, 17 Mar 2010 13:35:25 +0900 Subject: [PATCH] Data.Time.RFC822 now fully works --- Data/Time/HTTP/Common.hs | 151 +++++++++++++++++++++++++++++++++++++ Data/Time/RFC822.hs | 89 +++++++++++++++++++++- Data/Time/RFC822/Parsec.hs | 133 ++++++++++++++++++++++++++++++++ time-http.cabal | 7 ++ 4 files changed, 379 insertions(+), 1 deletion(-) create mode 100644 Data/Time/HTTP/Common.hs create mode 100644 Data/Time/RFC822/Parsec.hs diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs new file mode 100644 index 0000000..1ea61de --- /dev/null +++ b/Data/Time/HTTP/Common.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.HTTP.Common + ( shortWeekDayName + , shortWeekDayNameP + + , longWeekDayName + , longWeekDayNameP + + , shortMonthName + , shortMonthNameP + + , show2 + , show4 + + , read2 + , read4 + ) + where + +import Control.Monad +import Text.Parsec + +shortWeekDayName :: Int -> String +shortWeekDayName 1 = "Mon" +shortWeekDayName 2 = "Tue" +shortWeekDayName 3 = "Wed" +shortWeekDayName 4 = "Thu" +shortWeekDayName 5 = "Fri" +shortWeekDayName 6 = "Sat" +shortWeekDayName 7 = "Sun" +shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n) + +shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int +shortWeekDayNameP + = choice [ string "Mon" >> return 1 + , char 'T' + >> choice [ string "ue" >> return 2 + , string "hu" >> return 4 + ] + , string "Wed" >> return 3 + , string "Fri" >> return 5 + , char 'S' + >> choice [ string "at" >> return 6 + , string "un" >> return 7 + ] + ] + +longWeekDayName :: Int -> String +longWeekDayName 1 = "Monday" +longWeekDayName 2 = "Tuesday" +longWeekDayName 3 = "Wednesday" +longWeekDayName 4 = "Thursday" +longWeekDayName 5 = "Friday" +longWeekDayName 6 = "Saturday" +longWeekDayName 7 = "Sunday" + +longWeekDayNameP :: Stream s m Char => ParsecT s u m Int +longWeekDayNameP + = choice [ string "Monday" >> return 1 + , char 'T' + >> choice [ string "uesday" >> return 2 + , string "hursday" >> return 4 + ] + , string "Wednesday" >> return 3 + , string "Friday" >> return 5 + , char 'S' + >> choice [ string "aturday" >> return 6 + , string "unday" >> return 7 + ] + ] + +shortMonthName :: Int -> String +shortMonthName 1 = "Jan" +shortMonthName 2 = "Feb" +shortMonthName 3 = "Mar" +shortMonthName 4 = "Apr" +shortMonthName 5 = "May" +shortMonthName 6 = "Jun" +shortMonthName 7 = "Jul" +shortMonthName 8 = "Aug" +shortMonthName 9 = "Sep" +shortMonthName 10 = "Oct" +shortMonthName 11 = "Nov" +shortMonthName 12 = "Dec" +shortMonthName n = error ("shortMonthName: unknown month number: " ++ show n) + +shortMonthNameP :: Stream s m Char => ParsecT s u m Int +shortMonthNameP + = choice [ char 'J' + >> choice [ string "an" >> return 1 + , char 'u' + >> choice [ char 'n' >> return 6 + , char 'l' >> return 7 + ] + ] + , string "Feb" >> return 2 + , string "Ma" + >> choice [ char 'r' >> return 3 + , char 'y' >> return 5 + ] + , char 'A' + >> choice [ string "pr" >> return 4 + , string "ug" >> return 8 + ] + , string "Sep" >> return 9 + , string "Oct" >> return 10 + , string "Nov" >> return 11 + , string "Dec" >> return 12 + ] + +show4 :: Integral i => i -> String +show4 i + | i >= 0 && i < 10 = "000" ++ show i + | i >= 0 && i < 100 = "00" ++ show i + | i >= 0 && i < 1000 = "0" ++ show i + | i >= 0 && i < 10000 = show i + | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i) + +show2 :: Integral i => i -> String +show2 i + | i >= 0 && i < 10 = "0" ++ show i + | i >= 0 && i < 100 = show i + | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i) + +read4 :: (Stream s m Char, Num n) => ParsecT s u m n +read4 = do n1 <- digit' + n2 <- digit' + n3 <- digit' + n4 <- digit' + return (n1 * 1000 + n2 * 100 + n3 * 10 + n4) + +read2 :: (Stream s m Char, Num n) => ParsecT s u m n +read2 = do n1 <- digit' + n2 <- digit' + return (n1 * 10 + n2) + +digit' :: (Stream s m Char, Num n) => ParsecT s u m n +digit' = liftM fromC digit + +fromC :: Num n => Char -> n +fromC '0' = 0 +fromC '1' = 1 +fromC '2' = 2 +fromC '3' = 3 +fromC '4' = 4 +fromC '5' = 5 +fromC '6' = 6 +fromC '7' = 7 +fromC '8' = 8 +fromC '9' = 9 +fromC _ = undefined diff --git a/Data/Time/RFC822.hs b/Data/Time/RFC822.hs index 72e3b28..4b3d91c 100644 --- a/Data/Time/RFC822.hs +++ b/Data/Time/RFC822.hs @@ -1,4 +1,91 @@ module Data.Time.RFC822 - ( + ( 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.RFC822.Parsec + + +{- + date-time = [ day "," ] date time ; dd mm yy + ; hh:mm:ss zzz + + day = "Mon" / "Tue" / "Wed" / "Thu" + / "Fri" / "Sat" / "Sun" + + date = 1*2DIGIT month 2DIGIT ; day month year + ; e.g. 20 Jun 82 + + month = "Jan" / "Feb" / "Mar" / "Apr" + / "May" / "Jun" / "Jul" / "Aug" + / "Sep" / "Oct" / "Nov" / "Dec" + + time = hour zone ; ANSI and Military + + hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT] + ; 00:00:00 - 23:59:59 + + zone = "UT" / "GMT" ; Universal Time + ; North American : UT + / "EST" / "EDT" ; Eastern: - 5/ - 4 + / "CST" / "CDT" ; Central: - 6/ - 5 + / "MST" / "MDT" ; Mountain: - 7/ - 6 + / "PST" / "PDT" ; Pacific: - 8/ - 7 + / 1ALPHA ; Military: Z = UT; + ; 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 [ shortWeekDayName week + , ", " + , show2 day + , " " + , shortMonthName month + , " " + , show2 (year `mod` 100) + , " " + , show2 (todHour timeOfDay) + , ":" + , show2 (todMin timeOfDay) + , ":" + , show2 (floor (todSec timeOfDay)) + , " " + , 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 + Left _ -> Nothing + where + p = do zt <- parser + _ <- P.eof + return zt diff --git a/Data/Time/RFC822/Parsec.hs b/Data/Time/RFC822/Parsec.hs new file mode 100644 index 0000000..f80633e --- /dev/null +++ b/Data/Time/RFC822/Parsec.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.RFC822.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 <- shortWeekDayNameP + _ <- string ", " + return w + gregDay <- date + case weekDay of + 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 + ] + (tod, timeZone) <- time + return ZonedTime { + zonedTimeToLocalTime = LocalTime { + localDay = gregDay + , localTimeOfDay = tod + } + , zonedTimeZone = timeZone + } + +date :: Stream s m Char => ParsecT s u m Day +date = do day <- read2 + _ <- char ' ' + month <- shortMonthNameP + _ <- 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 + +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 + 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 + +zone :: Stream s m Char => ParsecT s u m TimeZone +zone = choice [ string "UT" >> return (TimeZone 0 False "UT" ) + , string "GMT" >> return (TimeZone 0 False "GMT") + , 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 'Z' >> return (TimeZone 0 False "Z") + , 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 + ] diff --git a/time-http.cabal b/time-http.cabal index 68bcc1f..6ec5f3d 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -22,8 +22,15 @@ Source-Repository head Library Exposed-modules: Data.Time.RFC822 + Data.Time.RFC822.Parsec + + Other-modules: + Data.Time.HTTP.Common Build-depends: base >= 4.2 && < 4.3, parsec >= 3.0 && < 3.1, time >= 1.1 && < 1.2 + + Extensions: + FlexibleContexts \ No newline at end of file -- 2.40.0