Data/Time/RFC822/Parsec.hs

   1 {-# LANGUAGE FlexibleContexts #-}
   2 module Data.Time.RFC822.Parsec
   3     ( parser
   4     )
   5     where
   6
   7 import Control.Monad
   8 import Data.Fixed
   9 import Data.Time
  10 import Data.Time.Calendar.WeekDate
  11 import Data.Time.HTTP.Common
  12 import Text.Parsec
  13
  14
  15 parser :: Stream s m Char => ParsecT s u m ZonedTime
  16 parser = dateTime
  17
  18
  19 dateTime :: Stream s m Char => ParsecT s u m ZonedTime
  20 dateTime = do weekDay <- optionMaybe $
  21                          do w <- shortWeekDayNameP
  22                             _ <- string ", "
  23                             return w
  24               gregDay <- date
  25               case weekDay of
  26                 Nothing
  27                     -> return () -- No day in week exists.
  28                 Just givenWD
  29                     -> let (_, _, correctWD) = toWeekDate gregDay
  30                        in
  31                          if correctWD == givenWD then
  32                              return () -- Correct day in the week.
  33                          else
  34                              let (year, month, day) = toGregorian gregDay
  35                              in
  36                                fail $ concat [ "Gregorian day "
  37                                              , show year
  38                                              , "-"
  39                                              , show month
  40                                              , "-"
  41                                              , show day
  42                                              , " is "
  43                                              , longWeekDayName correctWD
  44                                              , ", not "
  45                                              , longWeekDayName givenWD
  46                                              ]
  47               (tod, timeZone) <- time
  48               return ZonedTime {
  49                            zonedTimeToLocalTime = LocalTime {
  50                                                     localDay       = gregDay
  51                                                   , localTimeOfDay = tod
  52                                                   }
  53                          , zonedTimeZone        = timeZone
  54                          }
  55
  56 date :: Stream s m Char => ParsecT s u m Day
  57 date = do day   <- read2
  58           _     <- char ' '
  59           month <- shortMonthNameP
  60           _     <- char ' '
  61           year  <- liftM (+ 1900) read2
  62           _     <- char ' '
  63
  64           case fromGregorianValid (toInteger year) month day of
  65             Nothing
  66                 -> fail $ concat [ "Invalid gregorian day: "
  67                                  , show year
  68                                  , "-"
  69                                  , show month
  70                                  , "-"
  71                                  , show day
  72                                  ]
  73             Just gregDay
  74                 -> return gregDay
  75
  76 time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone)
  77 time = do tod <- hour
  78           _   <- char ' '
  79           tz  <- zone
  80           return (tod, tz)
  81
  82 hour :: Stream s m Char => ParsecT s u m TimeOfDay
  83 hour = do hour   <- read2
  84           minute <- char ':' >> read2
  85           second <- option 0 (char ':' >> read2)
  86           case makeTimeOfDayValid hour minute second of
  87             Nothing
  88                 -> fail $ concat [ "Invalid time of day: "
  89                                  , show hour
  90                                  , ":"
  91                                  , show minute
  92                                  , ":"
  93                                  , showFixed True second
  94                                  ]
  95             Just tod
  96                 -> return tod
  97
  98 zone :: Stream s m Char => ParsecT s u m TimeZone
  99 zone = choice [ string "UT"  >> return (TimeZone 0 False "UT" )
 100               , string "GMT" >> return (TimeZone 0 False "GMT")
 101               , char 'E'
 102                 >> choice [ string "ST" >> return (TimeZone ((-5) * 60) False "EST")
 103                           , string "DT" >> return (TimeZone ((-4) * 60) True  "EDT")
 104                           ]
 105               , char 'C'
 106                 >> choice [ string "ST" >> return (TimeZone ((-6) * 60) False "CST")
 107                           , string "DT" >> return (TimeZone ((-5) * 60) True  "CDT")
 108                           ]
 109               , char 'M'
 110                 >> choice [ string "ST" >> return (TimeZone ((-7) * 60) False "MST")
 111                           , string "DT" >> return (TimeZone ((-6) * 60) True  "MDT")
 112                           , return (TimeZone ((-12) * 60) False "M")
 113                           ]
 114               , char 'P'
 115                 >> choice [ string "ST" >> return (TimeZone ((-8) * 60) False "PST")
 116                           , string "DT" >> return (TimeZone ((-7) * 60) True  "PDT")
 117                           ]
 118               , char 'Z' >> return (TimeZone 0           False "Z")
 119               , char 'A' >> return (TimeZone ((-1) * 60) False "A")
 120               , char 'N' >> return (TimeZone (  1  * 60) False "N")
 121               , char 'Y' >> return (TimeZone ( 12  * 60) False "Y")
 122               , do sign   <- (char '+' >> return 1)
 123                              <|>
 124                              (char '-' >> return (-1))
 125                    hour   <- read2
 126                    minute <- read2
 127                    let tz = TimeZone {
 128                               timeZoneMinutes    = (sign * (hour * 60 + minute))
 129                             , timeZoneSummerOnly = False
 130                             , timeZoneName       = timeZoneOffsetString tz
 131                             }
 132                    return tz
 133               ]