+++ /dev/null
-{-# 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 |])
- ]
projects / time-http.git / blobdiff