X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FRFC733.hs;h=a6eb286117366eb9bd0b387f2b3fda165a79fc60;hp=6234c1b50b8fb9848123ccd602a6a1814de22ffc;hb=2371481;hpb=4e2898d9c40d6e962a33d5d05a3aa80c10c312fc diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs index 6234c1b..a6eb286 100644 --- a/Data/Time/RFC733.hs +++ b/Data/Time/RFC733.hs @@ -1,5 +1,9 @@ {-# LANGUAGE - UnicodeSyntax + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 733 date -- and time formats. @@ -41,31 +45,156 @@ -- > | "Y" ; +12 -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM module Data.Time.RFC733 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii + ( RFC733 , rfc733DateAndTime ) where -import Data.Ascii (Ascii) +import Control.Applicative +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P +import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Monoid.Unicode +import Data.Tagged import Data.Time -import Data.Time.RFC733.Internal +import Data.Time.Calendar.WeekDate +import Data.Time.RFC822 +import Data.Time.HTTP.Common import Prelude.Unicode --- |Convert a 'ZonedTime' to RFC 733 date and time string. -toAscii ∷ ZonedTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder +-- FIXME: docs +data RFC733 --- |Parse an RFC 733 date and time string. When the string can't be --- parsed, it returns @'Left' err@. -fromAscii ∷ Ascii → Either String ZonedTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← rfc733DateAndTime - P.endOfInput - return zt +instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag + +rfc733DateAndTime ∷ Parser ZonedTime +rfc733DateAndTime = dateTime + +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 + +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 + +time ∷ Parser (TimeOfDay, TimeZone) +time = do tod ← hms + _ ← char '-' <|> char ' ' + tz ← zone + return (tod, tz) + +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + _ ← optional (char ':') + minute ← read2 + second ← option 0 $ + do _ ← optional (char ':') + read2 + assertTimeOfDayIsGood hour minute second + +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 + 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) + +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |]) + ]