4 , MultiParamTypeClasses
9 module Data.Time.Format.RFC822.Internal
15 import Control.Applicative
16 import Control.Failure
17 import Data.Ascii (Ascii, AsciiBuilder)
18 import qualified Data.Ascii as A
19 import Data.Attoparsec.Char8
20 import Data.Convertible.Base
21 import Data.Convertible.Utils
22 import Data.Monoid.Unicode
25 import Data.Time.Calendar.WeekDate
26 import Data.Time.Format.HTTP.Common
27 import Prelude.Unicode
29 -- |The phantom type for conversions between RFC 822 date and time
30 -- strings and 'ZonedTime'.
32 -- >>> convertAttempt (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
33 -- Success (Tagged "Sun, 06 Nov 94 08:49:37 GMT")
35 -- Note that RFC 822 has a Y2K problem so converting 'ZonedTime' whose
36 -- gregorian year is earlier than 1900 or from 2000 onward results in
37 -- @'ConvertBoundsException' 'Day' 'ZonedTime'@.
40 instance ConvertAttempt ZonedTime (Tagged RFC822 Ascii) where
41 {-# INLINE convertAttempt #-}
42 convertAttempt = ((A.fromAsciiBuilder <$>) <$>) ∘ ca
44 instance ConvertAttempt ZonedTime (Tagged RFC822 AsciiBuilder) where
45 {-# INLINE convertAttempt #-}
46 convertAttempt = (Tagged <$>) ∘ toAsciiBuilder
48 instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where
49 {-# INLINE convertSuccess #-}
50 convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
52 instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where
53 {-# INLINE convertSuccess #-}
55 | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT"
56 | otherwise = Tagged $ show4digitsTZ tz
58 instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where
59 {-# INLINE convertAttempt #-}
60 convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag
62 -- |Parse an RFC 822 date and time string.
63 rfc822DateAndTime ∷ Parser ZonedTime
64 rfc822DateAndTime = dateTime
66 dateTime ∷ Parser ZonedTime
67 dateTime = do weekDay ← optionMaybe $
68 do w ← shortWeekDayNameP
76 -> assertWeekDayIsGood givenWD gregDay
77 (tod, timeZone) ← rfc822Time
78 let lt = LocalTime gregDay tod
79 zt = ZonedTime lt timeZone
85 month ← shortMonthNameP
87 year ← (+ 1900) <$> read2
89 assertGregorianDateIsGood year month day
91 rfc822Time ∷ Parser (TimeOfDay, TimeZone)
92 rfc822Time = do tod ← hms
97 hms ∷ Parser TimeOfDay
99 minute ← char ':' *> read2
100 second ← option 0 (char ':' *> read2)
101 assertTimeOfDayIsGood hour minute second
103 zone ∷ Parser TimeZone
104 zone = choice [ string "UT" *> return (TimeZone 0 False "UT" )
105 , string "GMT" *> return (TimeZone 0 False "GMT")
107 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
108 , string "DT" *> return (TimeZone ((-4) * 60) True "EDT")
111 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
112 , string "DT" *> return (TimeZone ((-5) * 60) True "CDT")
115 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
116 , string "DT" *> return (TimeZone ((-6) * 60) True "MDT")
117 , return (TimeZone ((-12) * 60) False "M")
120 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
121 , string "DT" *> return (TimeZone ((-7) * 60) True "PDT")
123 , char 'Z' *> return (TimeZone 0 False "Z")
124 , char 'A' *> return (TimeZone ((-1) * 60) False "A")
125 , char 'N' *> return (TimeZone ( 1 * 60) False "N")
126 , char 'Y' *> return (TimeZone ( 12 * 60) False "Y")
130 toAsciiBuilder ∷ Failure (ConvertBoundsException Day ZonedTime) f
133 toAsciiBuilder zonedTime
134 = let localTime = zonedTimeToLocalTime zonedTime
135 timeZone = zonedTimeZone zonedTime
136 (year, month, day) = toGregorian (localDay localTime)
137 (_, _, week) = toWeekDate (localDay localTime)
138 timeOfDay = localTimeOfDay localTime
140 if year < 1900 ∨ year ≥ 2000 then
141 let minDay = fromGregorian 1900 1 1
142 maxDay = fromGregorian 1999 12 31
144 failure $ ConvertBoundsException minDay maxDay zonedTime
147 shortWeekDayName week
148 ⊕ A.toAsciiBuilder ", "
150 ⊕ A.toAsciiBuilder " "
151 ⊕ shortMonthName month
152 ⊕ A.toAsciiBuilder " "
153 ⊕ show2 (year `mod` 100)
154 ⊕ A.toAsciiBuilder " "
155 ⊕ show2 (todHour timeOfDay)
156 ⊕ A.toAsciiBuilder ":"
157 ⊕ show2 (todMin timeOfDay)
158 ⊕ A.toAsciiBuilder ":"
159 ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
160 ⊕ A.toAsciiBuilder " "
161 ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
163 deriveAttempts [ ([t| TimeZone |], [t| Tagged RFC822 Ascii |])
164 , ([t| TimeZone |], [t| Tagged RFC822 AsciiBuilder |])