]> gitweb @ CieloNegro.org - time-http.git/blob - Data/Time/Format/RFC822/Internal.hs
Rename Asctime -> C
[time-http.git] / Data / Time / Format / RFC822 / Internal.hs
1 {-# LANGUAGE
2     FlexibleInstances
3   , MultiParamTypeClasses
4   , OverloadedStrings
5   , TemplateHaskell
6   , UnicodeSyntax
7   #-}
8 module Data.Time.Format.RFC822.Internal
9     ( RFC822
10     , rfc822DateAndTime
11     , rfc822Time
12     )
13     where
14 import Control.Applicative
15 import Data.Ascii (Ascii, AsciiBuilder)
16 import qualified Data.Ascii as A
17 import Data.Attoparsec.Char8
18 import Data.Convertible.Base
19 import Data.Monoid.Unicode
20 import Data.Tagged
21 import Data.Time
22 import Data.Time.Calendar.WeekDate
23 import Data.Time.Format.HTTP.Common
24 import Prelude.Unicode
25
26 -- |The phantom type for conversions between RFC 822 date and time
27 -- strings and 'ZonedTime'.
28 --
29 -- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
30 -- Tagged "Sun, 06 Nov 94 08:49:37 GMT"
31 data RFC822
32
33 instance ConvertSuccess ZonedTime (Tagged RFC822 Ascii) where
34     {-# INLINE convertSuccess #-}
35     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
36
37 instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where
38     {-# INLINE convertSuccess #-}
39     convertSuccess = Tagged ∘ toAsciiBuilder
40
41 instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where
42     {-# INLINE convertSuccess #-}
43     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
44
45 instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where
46     {-# INLINE convertSuccess #-}
47     convertSuccess tz
48         | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT"
49         | otherwise              = Tagged $ show4digitsTZ tz
50
51 instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where
52     {-# INLINE convertAttempt #-}
53     convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag
54
55 -- |Parse an RFC 822 date and time string.
56 rfc822DateAndTime ∷ Parser ZonedTime
57 rfc822DateAndTime = dateTime
58
59 dateTime ∷ Parser ZonedTime
60 dateTime = do weekDay ← optionMaybe $
61                         do w ← shortWeekDayNameP
62                            _ ← string ", "
63                            return w
64               gregDay ← date
65               case weekDay of
66                 Nothing
67                     -> return ()
68                 Just givenWD
69                     -> assertWeekDayIsGood givenWD gregDay
70               (tod, timeZone) ← rfc822Time
71               let lt = LocalTime gregDay tod
72                   zt = ZonedTime lt timeZone
73               return zt
74
75 date ∷ Parser Day
76 date = do day   ← read2
77           _     ← char ' '
78           month ← shortMonthNameP
79           _     ← char ' '
80           year  ← (+ 1900) <$> read2
81           _     ← char ' '
82           assertGregorianDateIsGood year month day
83
84 rfc822Time ∷ Parser (TimeOfDay, TimeZone)
85 rfc822Time = do tod ← hms
86                 _   ← char ' '
87                 tz  ← zone
88                 return (tod, tz)
89
90 hms ∷ Parser TimeOfDay
91 hms = do hour   ← read2
92          minute ← char ':' *> read2
93          second ← option 0 (char ':' *> read2)
94          assertTimeOfDayIsGood hour minute second
95
96 zone ∷ Parser TimeZone
97 zone = choice [ string "UT"  *> return (TimeZone 0 False "UT" )
98               , string "GMT" *> return (TimeZone 0 False "GMT")
99               , char 'E'
100                 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
101                           , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
102                           ]
103               , char 'C'
104                 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
105                           , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
106                           ]
107               , char 'M'
108                 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
109                           , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
110                           , return (TimeZone ((-12) * 60) False "M")
111                           ]
112               , char 'P'
113                 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
114                           , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
115                           ]
116               , char 'Z' *> return (TimeZone 0           False "Z")
117               , char 'A' *> return (TimeZone ((-1) * 60) False "A")
118               , char 'N' *> return (TimeZone (  1  * 60) False "N")
119               , char 'Y' *> return (TimeZone ( 12  * 60) False "Y")
120               , read4digitsTZ
121               ]
122
123 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
124 toAsciiBuilder zonedTime
125     = let localTime          = zonedTimeToLocalTime zonedTime
126           timeZone           = zonedTimeZone zonedTime
127           (year, month, day) = toGregorian (localDay localTime)
128           (_, _, week)       = toWeekDate  (localDay localTime)
129           timeOfDay          = localTimeOfDay localTime
130       in
131         shortWeekDayName week
132         ⊕ A.toAsciiBuilder ", "
133         ⊕ show2 day
134         ⊕ A.toAsciiBuilder " "
135         ⊕ shortMonthName month
136         ⊕ A.toAsciiBuilder " "
137         ⊕ show2 (year `mod` 100)
138         ⊕ A.toAsciiBuilder " "
139         ⊕ show2 (todHour timeOfDay)
140         ⊕ A.toAsciiBuilder ":"
141         ⊕ show2 (todMin timeOfDay)
142         ⊕ A.toAsciiBuilder ":"
143         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
144         ⊕ A.toAsciiBuilder " "
145         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
146
147 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC822 Ascii        |])
148                , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |])
149                , ([t| TimeZone  |], [t| Tagged RFC822 Ascii        |])
150                , ([t| TimeZone  |], [t| Tagged RFC822 AsciiBuilder |])
151                ]