diff --git a/COPYING b/COPYING new file mode 100644 --- /dev/null +++ b/COPYING @@ -0,0 +1,29 @@ + + + + + time-http + + + PHO + + + + + + + + + + + + diff --git a/Data/Time/Asctime.hs b/Data/Time/Asctime.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Asctime.hs @@ -0,0 +1,65 @@ +-- |This module provides functions for ANSI C's asctime() format. +-- +-- ANSI C's asctime() format looks like: +-- +-- @Wdy Mon DD HH:MM:SS YYYY@ +-- +-- The exact syntax is as follows: +-- +-- > date-time ::= wday SP month SP day SP time SP year +-- > wday ::= "Mon" | "Tue" | "Wed" | "Thu" +-- > | "Fri" | "Sat" | "Sun" +-- > month ::= "Jan" | "Feb" | "Mar" | "Apr" +-- > | "May" | "Jun" | "Jul" | "Aug" +-- > | "Sep" | "Oct" | "Nov" | "Dec" +-- > day ::= 2DIGIT +-- > time ::= 2DIGIT ':' 2DIGIT [':' 2DIGIT] +-- > year ::= 4DIGIT +-- +-- As you can see, it has no time zone info. "Data.Time.HTTP" will +-- treat it as UTC. +module Data.Time.Asctime + ( 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.Asctime.Parsec + +-- |Format a 'LocalTime' in the ANSI C's asctime() way. +format :: LocalTime -> String +format localTime + = let (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + concat [ shortWeekDayName week + , ", " + , shortMonthName month + , " " + , show2 day + , " " + , show2 (todHour timeOfDay) + , ":" + , show2 (todMin timeOfDay) + , ":" + , show2 (floor (todSec timeOfDay)) + , " " + , show4 year + ] + +-- |Parse an ANSI C's asctime() format to 'LocalTime'. When the string +-- can't be parsed, it returns 'Nothing'. +parse :: String -> Maybe LocalTime +parse src = case P.parse p "" src of + Right zt -> Just zt + Left _ -> Nothing + where + p = do zt <- asctime + _ <- P.eof + return zt diff --git a/Data/Time/Asctime/Parsec.hs b/Data/Time/Asctime/Parsec.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Asctime/Parsec.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.Asctime.Parsec + ( asctime + ) + where + +import Control.Monad +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Text.Parsec + +-- |This is a parsec parser for ANSI C's asctime() format. +asctime :: Stream s m Char => ParsecT s u m LocalTime +asctime = do weekDay <- shortWeekDayNameP + _ <- string ", " + month <- shortMonthNameP + _ <- char ' ' + day <- read2 + _ <- char ' ' + hour <- read2 + _ <- char ':' + minute <- read2 + _ <- char ':' + second <- read2 + _ <- char ' ' + year <- read4 + + gregDay <- assertGregorianDateIsGood year month day + _ <- assertWeekDayIsGood weekDay gregDay + tod <- assertTimeOfDayIsGood hour minute second + + return (LocalTime gregDay tod) diff --git a/Data/Time/HTTP.hs b/Data/Time/HTTP.hs new file mode 100644 --- /dev/null +++ b/Data/Time/HTTP.hs @@ -0,0 +1,75 @@ +-- |This module provides functions to parse and format HTTP\/1.1 date +-- and time formats. +-- +-- The HTTP\/1.1 specification (RFC 2616) says that HTTP\/1.1 clients +-- and servers which parse the date value MUST accept all the +-- following formats, though they MUST only generate the RFC 1123 +-- format for representing HTTP-date values in header fields: +-- +-- > Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +-- > Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +-- > Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format +-- +-- It also says that all HTTP date\/time stamps MUST be represented in +-- Greenwich Mean Time (GMT), without exception. For the purposes of +-- HTTP, GMT is exactly equal to UTC (Coordinated Universal +-- Time). This is indicated in the first two formats by the inclusion +-- of @\"GMT\"@ as the three-letter abbreviation for time zone, and +-- MUST be assumed when reading the asctime format. +-- +-- > HTTP-date = rfc1123-date | rfc850-date | asctime-date +-- > rfc1123-date = wkday "," SP date1 SP time SP "GMT" +-- > rfc850-date = weekday "," SP date2 SP time SP "GMT" +-- > asctime-date = wkday SP date3 SP time SP 4DIGIT +-- > date1 = 2DIGIT SP month SP 4DIGIT +-- > ; day month year (e.g., 02 Jun 1982) +-- > date2 = 2DIGIT "-" month "-" 2DIGIT +-- > ; day-month-year (e.g., 02-Jun-82) +-- > date3 = month SP ( 2DIGIT | ( SP 1DIGIT )) +-- > ; month day (e.g., Jun 2) +-- > time = 2DIGIT ":" 2DIGIT ":" 2DIGIT +-- > ; 00:00:00 - 23:59:59 +-- > wkday = "Mon" | "Tue" | "Wed" +-- > | "Thu" | "Fri" | "Sat" | "Sun" +-- > weekday = "Monday" | "Tuesday" | "Wednesday" +-- > | "Thursday" | "Friday" | "Saturday" | "Sunday" +-- > month = "Jan" | "Feb" | "Mar" | "Apr" +-- > | "May" | "Jun" | "Jul" | "Aug" +-- > | "Sep" | "Oct" | "Nov" | "Dec" +module Data.Time.HTTP + ( format + , parse + ) + where + +import qualified Data.Time.RFC1123 as RFC1123 +import qualified Text.Parsec as P + +import Data.Time +import Data.Time.HTTP.Parsec + +-- |Format an 'UTCTime' in RFC 1123 date and time. +format :: UTCTime -> String +format utcTime + = let timeZone = TimeZone 0 False "GMT" + zonedTime = utcToZonedTime timeZone utcTime + in + RFC1123.format zonedTime + +-- |Parse a date and time string in any of RFC 822, RFC 1123, RFC 850 +-- and ANSI C's asctime() formats. When the string can't be parsed, it +-- returns 'Nothing'. +-- +-- This function is even more permissive than what HTTP\/1.1 +-- specifies. That is, it accepts 2-digit years in RFC 822, omitted +-- separator symbols in RFC 850, omitted sec fields, and non-GMT time +-- zones. I believe this behavior will not cause a problem but you +-- should know this. +parse :: String -> Maybe UTCTime +parse src = case P.parse p "" src of + Right ut -> Just ut + Left _ -> Nothing + where + p = do zt <- rfc2616DateAndTime + _ <- P.eof + return zt diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Time/HTTP/Common.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.HTTP.Common + ( shortWeekDayName + , shortWeekDayNameP + + , longWeekDayName + , longWeekDayNameP + + , shortMonthName + , shortMonthNameP + + , longMonthName + , longMonthNameP + + , show2 + , show4 + + , read2 + , read4 + + , show4digitsTZ + , 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 +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 + ] + +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 + | 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 + +show4digitsTZ :: TimeZone -> String +show4digitsTZ 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/HTTP/Parsec.hs b/Data/Time/HTTP/Parsec.hs new file mode 100644 --- /dev/null +++ b/Data/Time/HTTP/Parsec.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.HTTP.Parsec + ( rfc2616DateAndTime + ) + where + +import Control.Monad +import Data.Time +import Data.Time.RFC1123.Parsec +import Data.Time.RFC733.Parsec +import Data.Time.Asctime.Parsec +import Text.Parsec + +-- |This is a parsec parser for date and time formats allowed in +-- HTTP\/1.1 (RFC 2616). +rfc2616DateAndTime :: Stream s m Char => ParsecT s u m UTCTime +rfc2616DateAndTime + = choice [ liftM zonedTimeToUTC $ try rfc1123DateAndTime + , liftM zonedTimeToUTC $ try rfc733DateAndTime + , liftM (localTimeToUTC utc) $ asctime + ] diff --git a/Data/Time/RFC1123.hs b/Data/Time/RFC1123.hs new file mode 100644 --- /dev/null +++ b/Data/Time/RFC1123.hs @@ -0,0 +1,61 @@ +-- |This module provides functions to parse and format RFC 1123 date +-- and time formats. +-- +-- The format is basically same as RFC 822, but the syntax for @date@ +-- is changed from: +-- +-- > year ::= 2DIGIT +-- +-- to: +-- +-- > year ::= 4DIGIT +module Data.Time.RFC1123 + ( 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 (showRFC822TimeZone) +import Data.Time.RFC1123.Parsec + +-- |Format a 'ZonedTime' in RFC 1123. +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 + , " " + , show4 year + , " " + , show2 (todHour timeOfDay) + , ":" + , show2 (todMin timeOfDay) + , ":" + , show2 (floor (todSec timeOfDay)) + , " " + , showRFC822TimeZone timeZone + ] + +-- |Parse an RFC 1123 date and time string. When the string can't be +-- parsed, it returns 'Nothing'. +parse :: String -> Maybe ZonedTime +parse src = case P.parse p "" src of + Right zt -> Just zt + Left _ -> Nothing + where + p = do zt <- rfc1123DateAndTime + _ <- P.eof + return zt diff --git a/Data/Time/RFC1123/Parsec.hs b/Data/Time/RFC1123/Parsec.hs new file mode 100644 --- /dev/null +++ b/Data/Time/RFC1123/Parsec.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.RFC1123.Parsec + ( rfc1123DateAndTime + ) + where + +import Control.Monad +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Data.Time.RFC822.Parsec +import Text.Parsec + +-- |This is a parsec parser for RFC 1123 date and time strings. +rfc1123DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime +rfc1123DateAndTime = 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 + -> assertWeekDayIsGood givenWD gregDay + (tod, timeZone) <- rfc822time + 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 ' ' + month <- shortMonthNameP + _ <- char ' ' + year <- read4 + _ <- char ' ' + assertGregorianDateIsGood year month day diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs new file mode 100644 --- /dev/null +++ b/Data/Time/RFC733.hs @@ -0,0 +1,88 @@ +-- |This module provides functions to parse and format RFC 733 date +-- and time formats. +-- +-- The syntax is as follows: +-- +-- > date-time ::= [ day-of-week ", " ] date SP time ("-" | SP) zone +-- > day-of-week ::= "Monday" | "Mon" | "Tuesday" | "Tue" +-- > | "Wednesday" | "Wed" | "Thursday" | "Thu" +-- > | "Friday" | "Fri" | "Saturday" | "Sat" +-- > | "Sunday" | "Sun" +-- > date ::= day ("-" | SP) month ("-" | SP) year +-- > day ::= 2DIGIT +-- > year ::= 2DIGIT | 4DIGIT +-- > 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 [ ":" ] minute [ [ ":" ] second ] +-- > hour ::= 2DIGIT +-- > minute ::= 2DIGIT +-- > second ::= 2DIGIT +-- > zone ::= "GMT" ; Universal Time +-- > | "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 +-- > | "Z" ; GMT +-- > | "A" ; -1 +-- > | "M" ; -12 +-- > | "N" ; +1 +-- > | "Y" ; +12 +-- > | ("+" | "-") 4DIGIT ; Local diff: HHMM +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 + +-- |Format a 'ZonedTime' in RFC 733. +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)) + , "-" + , show4digitsTZ timeZone + ] + +-- |Parse an RFC 733 date and time string. When the string can't be +-- parsed, it returns 'Nothing'. +parse :: String -> Maybe ZonedTime +parse src = case P.parse p "" src of + Right zt -> Just zt + Left _ -> Nothing + where + p = do zt <- rfc733DateAndTime + _ <- P.eof + return zt diff --git a/Data/Time/RFC733/Parsec.hs b/Data/Time/RFC733/Parsec.hs new file mode 100644 --- /dev/null +++ b/Data/Time/RFC733/Parsec.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE FlexibleContexts #-} +module Data.Time.RFC733.Parsec + ( rfc733DateAndTime + ) + where + +import Control.Monad +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Text.Parsec + +-- |This is a parsec parser for RFC 733 date and time strings. +rfc733DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime +rfc733DateAndTime = 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 year month day + +time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) +time = do tod <- hour + _ <- char '-' <|> 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 new file mode 100644 --- /dev/null +++ b/Data/Time/RFC822.hs @@ -0,0 +1,88 @@ +{-# OPTIONS_HADDOCK prune #-} + +-- |This module provides functions to parse and format RFC 822 date +-- and time formats. +-- +-- The syntax is as follows: +-- +-- > date-time ::= [ day-of-week ", " ] date SP time SP zone +-- > day-of-week ::= "Mon" | "Tue" | "Wed" | "Thu" +-- > | "Fri" | "Sat" | "Sun" +-- > date ::= day SP month SP year +-- > day ::= 2DIGIT +-- > year ::= 2DIGIT ; Yes, only 2 digits. +-- > month ::= "Jan" | "Feb" | "Mar" | "Apr" +-- > | "May" | "Jun" | "Jul" | "Aug" +-- > | "Sep" | "Oct" | "Nov" | "Dec" +-- > time ::= hour ":" minute [ ":" second ] +-- > hour ::= 2DIGIT +-- > minute ::= 2DIGIT +-- > second ::= 2DIGIT +-- > zone ::= "UT" | "GMT" ; Universal Time +-- > | "EST" | "EDT" ; Eastern : -5 / -4 +-- > | "CST" | "CDT" ; Central : -6 / -5 +-- > | "MST" | "MDT" ; Mountain: -7 / -6 +-- > | "PST" | "PDT" ; Pacific : -8 / -7 +-- > | "Z" ; UT +-- > | "A" ; -1 +-- > | "M" ; -12 +-- > | "N" ; +1 +-- > | "Y" ; +12 +-- > | ("+" | "-") 4DIGIT ; Local diff: HHMM +module Data.Time.RFC822 + ( format + , parse + + -- private + , showRFC822TimeZone + ) + 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 + +-- |Format a 'ZonedTime' in RFC 822. +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)) + , " " + , showRFC822TimeZone timeZone + ] + +showRFC822TimeZone :: TimeZone -> String +showRFC822TimeZone tz + | timeZoneMinutes tz == 0 = "GMT" + | otherwise = show4digitsTZ tz + +-- |Parse an RFC 822 date and time string. When the string can't be +-- parsed, it returns 'Nothing'. +parse :: String -> Maybe ZonedTime +parse src = case P.parse p "" src of + Right zt -> Just zt + Left _ -> Nothing + where + p = do zt <- rfc822DateAndTime + _ <- P.eof + return zt diff --git a/Data/Time/RFC822/Parsec.hs b/Data/Time/RFC822/Parsec.hs new file mode 100644 --- /dev/null +++ b/Data/Time/RFC822/Parsec.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# OPTIONS_HADDOCK prune #-} + +module Data.Time.RFC822.Parsec + ( rfc822DateAndTime + + -- private + , rfc822time + ) + where + +import Control.Monad +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Text.Parsec + +-- |This is a parsec parser for RFC 822 date and time strings. +rfc822DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime +rfc822DateAndTime = 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 + -> assertWeekDayIsGood givenWD gregDay + (tod, timeZone) <- rfc822time + 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 ' ' + month <- shortMonthNameP + _ <- char ' ' + year <- liftM (+ 1900) read2 + _ <- char ' ' + assertGregorianDateIsGood year month day + +rfc822time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) +rfc822time = 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) + assertTimeOfDayIsGood hour minute second + +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") + , read4digitsTZ + ] diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMain diff --git a/time-http.cabal b/time-http.cabal new file mode 100644 --- /dev/null +++ b/time-http.cabal @@ -0,0 +1,44 @@ +Name: time-http +Version: 0.1 +Synopsis: Parse and format HTTP/1.1 Date and Time string +Description: + This package provides functionalities to parse and format + various Date and Time formats allowed in HTTP\/1.1 (RFC 2616). + +Homepage: http://cielonegro.org/HTTPDateTime.html +License: PublicDomain +License-file: COPYING +Author: PHO +Maintainer: PHO +Stability: Experimental +Category: Web +Build-type: Simple +Cabal-version: >= 1.6 + +Source-Repository head + Type: git + Location: git://git.cielonegro.org/time-http.git + +Library + Exposed-modules: + Data.Time.RFC733 + Data.Time.RFC733.Parsec + Data.Time.RFC822 + Data.Time.RFC822.Parsec + Data.Time.RFC1123 + Data.Time.RFC1123.Parsec + Data.Time.Asctime + Data.Time.Asctime.Parsec + Data.Time.HTTP + Data.Time.HTTP.Parsec + + Other-modules: + Data.Time.HTTP.Common + + Build-depends: + base == 4.2.*, + parsec == 3.0.*, + time == 1.1.* + + Extensions: + FlexibleContexts