X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Data%2FTime%2FRFC733.hs;h=a6eb286117366eb9bd0b387f2b3fda165a79fc60;hp=9073cd7d11848e6eab7091800320f7936b5f6bfb;hb=2371481;hpb=82afb594c5b4254385435491700befcbea185a5d diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs index 9073cd7..a6eb286 100644 --- a/Data/Time/RFC733.hs +++ b/Data/Time/RFC733.hs @@ -1,3 +1,10 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax + #-} -- |This module provides functions to parse and format RFC 733 date -- and time formats. -- @@ -38,48 +45,156 @@ -- > | "Y" ; +12 -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM module Data.Time.RFC733 - ( format - , parse + ( RFC733 + , rfc733DateAndTime ) where +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.Internal +import Prelude.Unicode --- |Format a 'ZonedTime' in RFC 733. -format :: ZonedTime -> String -format zonedTime +-- FIXME: docs +data RFC733 + +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 - concat [ longWeekDayName week - , ", " - , show2 day - , "-" - , shortMonthName month - , "-" - , show4 year - , " " - , show2 (todHour timeOfDay) - , ":" - , show2 (todMin timeOfDay) - , ":" - , show2 (floor (todSec timeOfDay)) - , "-" - , show4digitsTZ 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 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 +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |]) + ]