X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FRFC822.hs;h=a5c1a0bd97713e68f3420756b14dea3c2d18ba89;hp=4b3d91cf8799714e45eb15c1dfe16e5b77c72d22;hb=2371481;hpb=9f9ed0471883b50fec1b091621f332d62477a34c diff --git a/Data/Time/RFC822.hs b/Data/Time/RFC822.hs index 4b3d91c..a5c1a0b 100644 --- a/Data/Time/RFC822.hs +++ b/Data/Time/RFC822.hs @@ -1,91 +1,177 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax + #-} +-- |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 + ( RFC822 + , rfc822DateAndTime + , rfc822Time ) 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.HTTP.Common -import Data.Time.RFC822.Parsec +import Prelude.Unicode + +-- |FIXME: docs +data RFC822 + +instance ConvertSuccess ZonedTime (Tagged RFC822 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs +instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess tz + | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT" + | otherwise = Tagged $ show4digitsTZ tz -{- - date-time = [ day "," ] date time ; dd mm yy - ; hh:mm:ss zzz +instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag - day = "Mon" / "Tue" / "Wed" / "Thu" - / "Fri" / "Sat" / "Sun" +-- |Parse an RFC 822 date and time string. +rfc822DateAndTime ∷ Parser ZonedTime +rfc822DateAndTime = dateTime - date = 1*2DIGIT month 2DIGIT ; day month year - ; e.g. 20 Jun 82 +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + _ ← string ", " + return w + gregDay ← date + case weekDay of + Nothing + -> return () + Just givenWD + -> assertWeekDayIsGood givenWD gregDay + (tod, timeZone) ← rfc822Time + let lt = LocalTime gregDay tod + zt = ZonedTime lt timeZone + return zt - month = "Jan" / "Feb" / "Mar" / "Apr" - / "May" / "Jun" / "Jul" / "Aug" - / "Sep" / "Oct" / "Nov" / "Dec" +date ∷ Parser Day +date = do day ← read2 + _ ← char ' ' + month ← shortMonthNameP + _ ← char ' ' + year ← (+ 1900) <$> read2 + _ ← char ' ' + assertGregorianDateIsGood year month day - time = hour zone ; ANSI and Military +-- |Parse the time and time zone of an RFC 822 date and time string. +rfc822Time ∷ Parser (TimeOfDay, TimeZone) +rfc822Time = do tod ← hms + _ ← char ' ' + tz ← zone + return (tod, tz) - hour = 2DIGIT ":" 2DIGIT [":" 2DIGIT] - ; 00:00:00 - 23:59:59 +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + minute ← char ':' *> read2 + second ← option 0 (char ':' *> read2) + assertTimeOfDayIsGood hour minute second - 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) --} +zone ∷ Parser 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 + ] -format :: ZonedTime -> String -format zonedTime +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 [ 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] + shortWeekDayName week + ⊕ A.toAsciiBuilder ", " + ⊕ show2 day + ⊕ A.toAsciiBuilder " " + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder " " + ⊕ show2 (year `mod` 100) + ⊕ 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 RFC822 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |]) + , ([t| TimeZone |], [t| Tagged RFC822 Ascii |]) + , ([t| TimeZone |], [t| Tagged RFC822 AsciiBuilder |]) + ]