X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FFormat%2FRFC822.hs;h=95fc926ac7856dad95652e368ee440f098f6320a;hp=0d8fcacdacae3b7db0546fcc2498677fbb68803a;hb=e8f778a;hpb=9e1f758b33355286df79648ffcf1f73cb414b5d9 diff --git a/Data/Time/Format/RFC822.hs b/Data/Time/Format/RFC822.hs index 0d8fcac..95fc926 100644 --- a/Data/Time/Format/RFC822.hs +++ b/Data/Time/Format/RFC822.hs @@ -1,5 +1,12 @@ {-# LANGUAGE - UnicodeSyntax + DeriveDataTypeable + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 822 date -- and time strings (). @@ -32,15 +39,149 @@ -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM module Data.Time.Format.RFC822 ( RFC822 - , rfc822 - , rfc822DateAndTime ) where -import Data.Proxy -import Data.Time.Format.RFC822.Internal - --- |The proxy for conversions between RFC 822 date and time strings --- and 'ZonedTime'. -rfc822 ∷ Proxy RFC822 -{-# INLINE CONLIKE rfc822 #-} -rfc822 = Proxy +import Control.Applicative +import Control.Applicative.Unicode +import Control.Failure +import Data.Ascii (Ascii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Convertible.Utils +import Data.Default +import Data.Monoid.Unicode +import Data.Tagged +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.Format.HTTP.Common +import Data.Typeable +import Prelude.Unicode + +-- |The phantom type for conversions between RFC 822 date and time +-- strings and 'ZonedTime'. +-- +-- >>> convertAttempt (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC822 ZonedTime) +-- Success "Sun, 06 Nov 94 08:49:37 GMT" +-- +-- Note that RFC 822 has a Y2K problem so converting 'ZonedTime' whose +-- gregorian year is earlier than 1900 or from 2000 onward results in +-- @'ConvertBoundsException' 'Day' ('Tagged' RFC822 'ZonedTime')@. +data RFC822 + deriving Typeable + +instance ConvertAttempt (Tagged RFC822 ZonedTime) Ascii where + {-# INLINE convertAttempt #-} + convertAttempt = (A.fromAsciiBuilder <$>) ∘ ca + +instance ConvertAttempt (Tagged RFC822 ZonedTime) AsciiBuilder where + {-# INLINE convertAttempt #-} + convertAttempt = toAsciiBuilder + +instance ConvertSuccess (Tagged RFC822 TimeZone) Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = A.fromAsciiBuilder ∘ cs + +instance ConvertSuccess (Tagged RFC822 TimeZone) AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (Tagged tz) + | timeZoneMinutes tz ≡ 0 = A.toAsciiBuilder "GMT" + | otherwise = show4digitsTZ tz + +instance ConvertAttempt Ascii (Tagged RFC822 ZonedTime) where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' def + +-- |Parse an RFC 822 date and time string. +instance Default (Parser (Tagged RFC822 ZonedTime)) where + def = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + string ", " *> pure w + gregDay ← date + case weekDay of + Nothing + → return () + Just givenWD + → assertWeekDayIsGood givenWD gregDay + tod ← def + timeZone ← char ' ' *> def + let lt = LocalTime gregDay <$> tod + zt = ZonedTime <$> lt ⊛ timeZone + return zt + +date ∷ Parser Day +date = do day ← read2 + month ← char ' ' *> shortMonthNameP + year ← char ' ' *> ((+ 1900) <$> read2) + char ' ' *> assertGregorianDateIsGood year month day + +instance Default (Parser (Tagged RFC822 TimeOfDay)) where + {-# INLINEABLE def #-} + def = do hour ← read2 + minute ← char ':' *> read2 + second ← option 0 (char ':' *> read2) + Tagged <$> assertTimeOfDayIsGood hour minute second + +instance Default (Parser (Tagged RFC822 TimeZone)) where + def = choice [ string "UT" *> pure (Tagged (TimeZone 0 False "UT" )) + , string "GMT" *> pure (Tagged (TimeZone 0 False "GMT")) + , char 'E' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-5) * 60) False "EST")) + , string "DT" *> pure (Tagged (TimeZone ((-4) * 60) True "EDT")) + ] + , char 'C' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-6) * 60) False "CST")) + , string "DT" *> pure (Tagged (TimeZone ((-5) * 60) True "CDT")) + ] + , char 'M' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-7) * 60) False "MST")) + , string "DT" *> pure (Tagged (TimeZone ((-6) * 60) True "MDT")) + , pure (Tagged (TimeZone ((-12) * 60) False "M")) + ] + , char 'P' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-8) * 60) False "PST")) + , string "DT" *> pure (Tagged (TimeZone ((-7) * 60) True "PDT")) + ] + , char 'Z' *> pure (Tagged (TimeZone 0 False "Z")) + , char 'A' *> pure (Tagged (TimeZone ((-1) * 60) False "A")) + , char 'N' *> pure (Tagged (TimeZone ( 1 * 60) False "N")) + , char 'Y' *> pure (Tagged (TimeZone ( 12 * 60) False "Y")) + , Tagged <$> read4digitsTZ + ] + +toAsciiBuilder ∷ Failure (ConvertBoundsException Day (Tagged RFC822 ZonedTime)) f + ⇒ Tagged RFC822 ZonedTime + → f AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime $ untag zonedTime + timeZone = zonedTimeZone <$> zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + if year < 1900 ∨ year ≥ 2000 then + let minDay = fromGregorian 1900 1 1 + maxDay = fromGregorian 1999 12 31 + in + failure $ ConvertBoundsException minDay maxDay zonedTime + else + return $ + 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 " " + ⊕ cs timeZone + +deriveAttempts [ ([t| Tagged RFC822 TimeZone |], [t| Ascii |]) + , ([t| Tagged RFC822 TimeZone |], [t| AsciiBuilder |]) + ]