X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;ds=sidebyside;f=Data%2FTime%2FRFC733.hs;fp=Data%2FTime%2FRFC733.hs;h=0000000000000000000000000000000000000000;hb=91c2402d530afff7f1fd4eee333f84cbe18d1014;hp=53a0b1e779d3d9a6123c825e1e1be28525cf4987;hpb=7fd4893fdd44f360647fa99c7f96ed96d2f7bac4;p=time-http.git diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs deleted file mode 100644 index 53a0b1e..0000000 --- a/Data/Time/RFC733.hs +++ /dev/null @@ -1,200 +0,0 @@ -{-# 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 - ( 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.Internal -import Data.Time.HTTP.Common -import Prelude.Unicode - --- 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 - 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 |]) - ]