X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FRFC733.hs;h=a6eb286117366eb9bd0b387f2b3fda165a79fc60;hp=a5e28d3b9bdd5c34d8a659580269dd060476320d;hb=2371481;hpb=01d923fe509a76afa27efdc7370438c5d4900492 diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs index a5e28d3..a6eb286 100644 --- a/Data/Time/RFC733.hs +++ b/Data/Time/RFC733.hs @@ -1,88 +1,200 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax + #-} +-- |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 + ( RFC733 + , rfc733DateAndTime ) where - -import qualified Text.Parsec as P - +import Control.Applicative +import Data.Ascii (Ascii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Monoid.Unicode +import Data.Tagged import Data.Time import Data.Time.Calendar.WeekDate +import Data.Time.RFC822 import Data.Time.HTTP.Common -import Data.Time.RFC733.Parsec +import Prelude.Unicode + +-- FIXME: docs +data RFC733 + +instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs -{- -date-time = [ day-of-week "," ] date time +instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder -day-of-week = "Monday" / "Mon" / "Tuesday" / "Tue" - / "Wednesday" / "Wed" / "Thursday" / "Thu" - / "Friday" / "Fri" / "Saturday" / "Sat" - / "Sunday" / "Sun" +instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag -date = 1*2DIGIT ["-"] month ; day month year - ["-"] (2DIGIT /4DIGIT) ; e.g. 20 Aug [19]77 +rfc733DateAndTime ∷ Parser ZonedTime +rfc733DateAndTime = dateTime -month = "January" / "Jan" / "February" / "Feb" - / "March" / "Mar" / "April" / "Apr" - / "May" / "June" / "Jun" - / "July" / "Jul" / "August" / "Aug" - / "September" / "Sep" / "October" / "Oct" - / "November" / "Nov" / "December" / "Dec" +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← 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 -time = hour zone ; ANSI and Military - ; (seconds optional) +date ∷ Parser Day +date = do day ← read2 + _ ← char '-' <|> char ' ' + month ← try longMonthNameP + <|> + shortMonthNameP + _ ← char '-' <|> char ' ' + year ← try read4 + <|> + (+ 1900) <$> read2 + _ ← char ' ' + assertGregorianDateIsGood year month day -hour = 2DIGIT [":"] 2DIGIT [ [":"] 2DIGIT ] - ; 0000[00] - 2359[59] +time ∷ Parser (TimeOfDay, TimeZone) +time = do tod ← hms + _ ← char '-' <|> char ' ' + tz ← zone + return (tod, tz) -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) --} +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + _ ← optional (char ':') + minute ← read2 + second ← option 0 $ + do _ ← optional (char ':') + read2 + assertTimeOfDayIsGood hour minute second -format :: ZonedTime -> String -format zonedTime +zone ∷ Parser 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 + ] + +toAsciiBuilder ∷ ZonedTime → AsciiBuilder +toAsciiBuilder 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 - ] + longWeekDayName week + ⊕ A.toAsciiBuilder ", " + ⊕ show2 day + ⊕ A.toAsciiBuilder "-" + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder "-" + ⊕ show4 year + ⊕ A.toAsciiBuilder " " + ⊕ show2 (todHour timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (todMin timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (floor (todSec timeOfDay) ∷ Int) + ⊕ A.toAsciiBuilder " " + ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) -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 +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |]) + ]