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