Data/Time/RFC733/Internal.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   #-}
   5 -- |Internal functions for "Data.Time.RFC733".
   6 module Data.Time.RFC733.Internal
   7     ( rfc733DateAndTime
   8     , toAsciiBuilder
   9     )
  10     where
  11 import Data.Ascii (AsciiBuilder)
  12 import qualified Data.Ascii as A
  13 import Control.Applicative
  14 import Data.Attoparsec.Char8
  15 import Data.Monoid.Unicode
  16 import Data.Time
  17 import Data.Time.Calendar.WeekDate
  18 import Data.Time.HTTP.Common
  19 import Data.Time.RFC822.Internal hiding (toAsciiBuilder)
  20
  21 -- |Parse RFC 733 date and time strings.
  22 rfc733DateAndTime ∷ Parser ZonedTime
  23 rfc733DateAndTime = dateTime
  24
  25 dateTime ∷ Parser ZonedTime
  26 dateTime = do weekDay ← optionMaybe $
  27                         do w ← longWeekDayNameP
  28                                <|>
  29                                shortWeekDayNameP
  30                            _ ← string ", "
  31                            return w
  32               gregDay ← date
  33               case weekDay of
  34                 Nothing
  35                     → return ()
  36                 Just givenWD
  37                     → assertWeekDayIsGood givenWD gregDay
  38               (tod, timeZone) ← time
  39               let lt = LocalTime gregDay tod
  40                   zt = ZonedTime lt timeZone
  41               return zt
  42
  43 date ∷ Parser Day
  44 date = do day   ← read2
  45           _     ← char '-' <|> char ' '
  46           month ← try longMonthNameP
  47                   <|>
  48                   shortMonthNameP
  49           _     ← char '-' <|> char ' '
  50           year  ← try read4
  51                   <|>
  52                   (+ 1900) <$> read2
  53           _     ← char ' '
  54           assertGregorianDateIsGood year month day
  55
  56 time ∷ Parser (TimeOfDay, TimeZone)
  57 time = do tod ← hms
  58           _   ← char '-' <|> char ' '
  59           tz  ← zone
  60           return (tod, tz)
  61
  62 hms ∷ Parser TimeOfDay
  63 hms = do hour   ← read2
  64          _      ← optional (char ':')
  65          minute ← read2
  66          second ← option 0 $
  67                   do _ ← optional (char ':')
  68                      read2
  69          assertTimeOfDayIsGood hour minute second
  70
  71 zone ∷ Parser TimeZone
  72 zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT")
  73               , char 'N'
  74                 *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST")
  75                           , return (TimeZone (1 * 60) False "N")
  76                           ]
  77               , char 'A'
  78                 *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST")
  79                           , string "DT" *> return (TimeZone ((-3) * 60) False "AST")
  80                           , return (TimeZone ((-1) * 60) False "A")
  81                           ]
  82               , char 'E'
  83                 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
  84                           , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
  85                           ]
  86               , char 'C'
  87                 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
  88                           , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
  89                           ]
  90               , char 'M'
  91                 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
  92                           , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
  93                           , return (TimeZone ((-12) * 60) False "M")
  94                           ]
  95               , char 'P'
  96                 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
  97                           , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
  98                           ]
  99               , char 'Y'
 100                 *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST")
 101                           , string "DT" *> return (TimeZone ((-8) * 60) True  "YDT")
 102                           , return (TimeZone ( 12  * 60) False "Y")
 103                           ]
 104               , char 'H'
 105                 *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST")
 106                           , string "DT" *> return (TimeZone (( -9) * 60) True  "HDT")
 107                           ]
 108               , char 'B'
 109                 *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST")
 110                           , string "DT" *> return (TimeZone ((-10) * 60) True  "BDT")
 111                           ]
 112               , char 'Z' *> return (TimeZone 0 False "Z")
 113               , read4digitsTZ
 114               ]
 115
 116 -- |Convert a 'ZonedTime' to RFC 733 date and time string.
 117 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
 118 toAsciiBuilder zonedTime
 119     = let localTime          = zonedTimeToLocalTime zonedTime
 120           timeZone           = zonedTimeZone zonedTime
 121           (year, month, day) = toGregorian (localDay localTime)
 122           (_, _, week)       = toWeekDate  (localDay localTime)
 123           timeOfDay          = localTimeOfDay localTime
 124       in
 125         longWeekDayName week
 126         ⊕ A.toAsciiBuilder ", "
 127         ⊕ show2 day
 128         ⊕ A.toAsciiBuilder "-"
 129         ⊕ shortMonthName month
 130         ⊕ A.toAsciiBuilder "-"
 131         ⊕ show4 year
 132         ⊕ A.toAsciiBuilder " "
 133         ⊕ show2 (todHour timeOfDay)
 134         ⊕ A.toAsciiBuilder ":"
 135         ⊕ show2 (todMin timeOfDay)
 136         ⊕ A.toAsciiBuilder ":"
 137         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 138         ⊕ A.toAsciiBuilder " "
 139         ⊕ showRFC822TimeZone timeZone