Data/Time/Format/RFC733.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |This module provides functions to parse and format RFC 733 date
   9 -- and time strings (<http://tools.ietf.org/html/rfc733#appendix-E>).
  10 --
  11 -- The syntax is as follows:
  12 --
  13 -- > date-time   ::= [ day-of-week ", " ] date SP time ("-" | SP) zone
  14 -- > day-of-week ::= "Monday"    | "Mon" | "Tuesday"  | "Tue"
  15 -- >               | "Wednesday" | "Wed" | "Thursday" | "Thu"
  16 -- >               | "Friday"    | "Fri" | "Saturday" | "Sat"
  17 -- >               | "Sunday"    | "Sun"
  18 -- > date        ::= day ("-" | SP) month ("-" | SP) year
  19 -- > day         ::= 2DIGIT
  20 -- > year        ::= 2DIGIT | 4DIGIT
  21 -- > month       ::= "January"   | "Jan" | "February" | "Feb"
  22 -- >               | "March"     | "Mar" | "April"    | "Apr"
  23 -- >               | "May"               | "June"     | "Jun"
  24 -- >               | "July"      | "Jul" | "August"   | "Aug"
  25 -- >               | "September" | "Sep" | "October"  | "Oct"
  26 -- >               | "November"  | "Nov" | "December" | "Dec"
  27 -- > time        ::= hour [ ":" ] minute [ [ ":" ] second ]
  28 -- > hour        ::= 2DIGIT
  29 -- > minute      ::= 2DIGIT
  30 -- > second      ::= 2DIGIT
  31 -- > zone        ::= "GMT"              ; Universal Time
  32 -- >               | "NST"              ; Newfoundland: -3:30
  33 -- >               | "AST" | "ADT"      ; Atlantic    :  -4 /  -3
  34 -- >               | "EST" | "EDT"      ; Eastern     :  -5 /  -4
  35 -- >               | "CST" | "CDT"      ; Central     :  -6 /  -5
  36 -- >               | "MST" | "MDT"      ; Mountain    :  -7 /  -6
  37 -- >               | "PST" | "PDT"      ; Pacific     :  -8 /  -7
  38 -- >               | "YST" | "YDT"      ; Yukon       :  -9 /  -8
  39 -- >               | "HST" | "HDT"      ; Haw/Ala     : -10 /  -9
  40 -- >               | "BST" | "BDT"      ; Bering      : -11 / -10
  41 -- >               | "Z"                ; GMT
  42 -- >               | "A"                ;  -1
  43 -- >               | "M"                ; -12
  44 -- >               | "N"                ;  +1
  45 -- >               | "Y"                ; +12
  46 -- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
  47 module Data.Time.Format.RFC733
  48     ( RFC733
  49     , rfc733
  50     , rfc733DateAndTime
  51     )
  52     where
  53 import Control.Applicative
  54 import Data.Ascii (Ascii, AsciiBuilder)
  55 import qualified Data.Ascii as A
  56 import Data.Attoparsec.Char8
  57 import Data.Convertible.Base
  58 import Data.Monoid.Unicode
  59 import Data.Proxy
  60 import Data.Tagged
  61 import Data.Time
  62 import Data.Time.Calendar.WeekDate
  63 import Data.Time.Format.HTTP.Common
  64 import Data.Time.Format.RFC822.Internal
  65 import Prelude.Unicode
  66
  67 -- |The phantom type for conversions between RFC 733 date and time
  68 -- strings and 'ZonedTime'.
  69 --
  70 -- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
  71 -- Tagged "Sunday, 06-Nov-1994 08:49:37 GMT"
  72 data RFC733
  73
  74 -- |The proxy for conversions between RFC 733 date and time strings
  75 -- and 'ZonedTime'.
  76 rfc733 ∷ Proxy RFC733
  77 {-# INLINE CONLIKE rfc733 #-}
  78 rfc733 = Proxy
  79
  80 instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where
  81     {-# INLINE convertSuccess #-}
  82     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  83
  84 instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where
  85     {-# INLINE convertSuccess #-}
  86     convertSuccess = Tagged ∘ toAsciiBuilder
  87
  88 instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where
  89     {-# INLINE convertAttempt #-}
  90     convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag
  91
  92 -- |Parse an RFC 733 date and time string.
  93 rfc733DateAndTime ∷ Parser ZonedTime
  94 rfc733DateAndTime = dateTime
  95
  96 dateTime ∷ Parser ZonedTime
  97 dateTime = do weekDay ← optionMaybe $
  98                         do w ← longWeekDayNameP
  99                                <|>
 100                                shortWeekDayNameP
 101                            _ ← string ", "
 102                            return w
 103               gregDay ← date
 104               case weekDay of
 105                 Nothing
 106                     → return ()
 107                 Just givenWD
 108                     → assertWeekDayIsGood givenWD gregDay
 109               (tod, timeZone) ← time
 110               let lt = LocalTime gregDay tod
 111                   zt = ZonedTime lt timeZone
 112               return zt
 113
 114 date ∷ Parser Day
 115 date = do day   ← read2
 116           _     ← char '-' <|> char ' '
 117           month ← try longMonthNameP
 118                   <|>
 119                   shortMonthNameP
 120           _     ← char '-' <|> char ' '
 121           year  ← try read4
 122                   <|>
 123                   (+ 1900) <$> read2
 124           _     ← char ' '
 125           assertGregorianDateIsGood year month day
 126
 127 time ∷ Parser (TimeOfDay, TimeZone)
 128 time = do tod ← hms
 129           _   ← char '-' <|> char ' '
 130           tz  ← zone
 131           return (tod, tz)
 132
 133 hms ∷ Parser TimeOfDay
 134 hms = do hour   ← read2
 135          _      ← optional (char ':')
 136          minute ← read2
 137          second ← option 0 $
 138                   do _ ← optional (char ':')
 139                      read2
 140          assertTimeOfDayIsGood hour minute second
 141
 142 zone ∷ Parser TimeZone
 143 zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
 144               , char 'N'
 145                 *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
 146                           , return (TimeZone (1 * 60) False "N")
 147                           ]
 148               , char 'A'
 149                 *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
 150                           , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
 151                           , return (TimeZone ((-1) * 60) False "A")
 152                           ]
 153               , char 'E'
 154                 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
 155                           , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
 156                           ]
 157               , char 'C'
 158                 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
 159                           , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
 160                           ]
 161               , char 'M'
 162                 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
 163                           , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
 164                           , return (TimeZone ((-12) * 60) False "M")
 165                           ]
 166               , char 'P'
 167                 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
 168                           , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
 169                           ]
 170               , char 'Y'
 171                 *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
 172                           , string "DT" *> return (TimeZone ((-8) * 60) True  "YDT")
 173                           , return (TimeZone ( 12  * 60) False "Y")
 174                           ]
 175               , char 'H'
 176                 *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
 177                           , string "DT" *> return (TimeZone (( -9) * 60) True  "HDT")
 178                           ]
 179               , char 'B'
 180                 *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
 181                           , string "DT" *> return (TimeZone ((-10) * 60) True  "BDT")
 182                           ]
 183               , char 'Z' *> return (TimeZone 0 False "Z")
 184               , read4digitsTZ
 185               ]
 186
 187 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
 188 toAsciiBuilder zonedTime
 189     = let localTime          = zonedTimeToLocalTime zonedTime
 190           timeZone           = zonedTimeZone zonedTime
 191           (year, month, day) = toGregorian (localDay localTime)
 192           (_, _, week)       = toWeekDate  (localDay localTime)
 193           timeOfDay          = localTimeOfDay localTime
 194       in
 195         longWeekDayName week
 196         ⊕ A.toAsciiBuilder ", "
 197         ⊕ show2 day
 198         ⊕ A.toAsciiBuilder "-"
 199         ⊕ shortMonthName month
 200         ⊕ A.toAsciiBuilder "-"
 201         ⊕ show4 year
 202         ⊕ A.toAsciiBuilder " "
 203         ⊕ show2 (todHour timeOfDay)
 204         ⊕ A.toAsciiBuilder ":"
 205         ⊕ show2 (todMin timeOfDay)
 206         ⊕ A.toAsciiBuilder ":"
 207         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 208         ⊕ A.toAsciiBuilder " "
 209         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 210
 211 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii        |])
 212                , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |])
 213                ]