Data/Time/Format/RFC733.hs

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