Data/Time/RFC822.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |This module provides functions to parse and format RFC 822 date
   9 -- and time formats.
  10 --
  11 -- The syntax is as follows:
  12 --
  13 -- > date-time   ::= [ day-of-week ", " ] date SP time SP zone
  14 -- > day-of-week ::= "Mon" | "Tue" | "Wed" | "Thu"
  15 -- >               | "Fri" | "Sat" | "Sun"
  16 -- > date        ::= day SP month SP year
  17 -- > day         ::= 2DIGIT
  18 -- > year        ::= 2DIGIT             ; Yes, only 2 digits.
  19 -- > month       ::= "Jan" | "Feb" | "Mar" | "Apr"
  20 -- >               | "May" | "Jun" | "Jul" | "Aug"
  21 -- >               | "Sep" | "Oct" | "Nov" | "Dec"
  22 -- > time        ::= hour ":" minute [ ":" second ]
  23 -- > hour        ::= 2DIGIT
  24 -- > minute      ::= 2DIGIT
  25 -- > second      ::= 2DIGIT
  26 -- > zone        ::= "UT"  | "GMT"      ; Universal Time
  27 -- >               | "EST" | "EDT"      ; Eastern : -5 / -4
  28 -- >               | "CST" | "CDT"      ; Central : -6 / -5
  29 -- >               | "MST" | "MDT"      ; Mountain: -7 / -6
  30 -- >               | "PST" | "PDT"      ; Pacific : -8 / -7
  31 -- >               | "Z"                ; UT
  32 -- >               | "A"                ;  -1
  33 -- >               | "M"                ; -12
  34 -- >               | "N"                ;  +1
  35 -- >               | "Y"                ; +12
  36 -- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
  37 module Data.Time.RFC822
  38     ( RFC822
  39     , rfc822DateAndTime
  40     , rfc822Time
  41     )
  42     where
  43 import Control.Applicative
  44 import Data.Ascii (Ascii, AsciiBuilder)
  45 import qualified Data.Ascii as A
  46 import Data.Attoparsec.Char8
  47 import Data.Convertible.Base
  48 import Data.Monoid.Unicode
  49 import Data.Tagged
  50 import Data.Time
  51 import Data.Time.Calendar.WeekDate
  52 import Data.Time.HTTP.Common
  53 import Prelude.Unicode
  54
  55 -- |FIXME: docs
  56 data RFC822
  57
  58 instance ConvertSuccess ZonedTime (Tagged RFC822 Ascii) where
  59     {-# INLINE convertSuccess #-}
  60     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  61
  62 instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where
  63     {-# INLINE convertSuccess #-}
  64     convertSuccess = Tagged ∘ toAsciiBuilder
  65
  66 instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where
  67     {-# INLINE convertSuccess #-}
  68     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  69
  70 instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where
  71     {-# INLINE convertSuccess #-}
  72     convertSuccess tz
  73         | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT"
  74         | otherwise              = Tagged $ show4digitsTZ tz
  75
  76 instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where
  77     {-# INLINE convertAttempt #-}
  78     convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag
  79
  80 -- |Parse an RFC 822 date and time string.
  81 rfc822DateAndTime ∷ Parser ZonedTime
  82 rfc822DateAndTime = dateTime
  83
  84 dateTime ∷ Parser ZonedTime
  85 dateTime = do weekDay ← optionMaybe $
  86                         do w ← shortWeekDayNameP
  87                            _ ← string ", "
  88                            return w
  89               gregDay ← date
  90               case weekDay of
  91                 Nothing
  92                     -> return ()
  93                 Just givenWD
  94                     -> assertWeekDayIsGood givenWD gregDay
  95               (tod, timeZone) ← rfc822Time
  96               let lt = LocalTime gregDay tod
  97                   zt = ZonedTime lt timeZone
  98               return zt
  99
 100 date ∷ Parser Day
 101 date = do day   ← read2
 102           _     ← char ' '
 103           month ← shortMonthNameP
 104           _     ← char ' '
 105           year  ← (+ 1900) <$> read2
 106           _     ← char ' '
 107           assertGregorianDateIsGood year month day
 108
 109 -- |Parse the time and time zone of an RFC 822 date and time string.
 110 rfc822Time ∷ Parser (TimeOfDay, TimeZone)
 111 rfc822Time = do tod ← hms
 112                 _   ← char ' '
 113                 tz  ← zone
 114                 return (tod, tz)
 115
 116 hms ∷ Parser TimeOfDay
 117 hms = do hour   ← read2
 118          minute ← char ':' *> read2
 119          second ← option 0 (char ':' *> read2)
 120          assertTimeOfDayIsGood hour minute second
 121
 122 zone ∷ Parser TimeZone
 123 zone = choice [ string "UT"  *> return (TimeZone 0 False "UT" )
 124               , string "GMT" *> return (TimeZone 0 False "GMT")
 125               , char 'E'
 126                 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
 127                           , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
 128                           ]
 129               , char 'C'
 130                 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
 131                           , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
 132                           ]
 133               , char 'M'
 134                 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
 135                           , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
 136                           , return (TimeZone ((-12) * 60) False "M")
 137                           ]
 138               , char 'P'
 139                 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
 140                           , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
 141                           ]
 142               , char 'Z' *> return (TimeZone 0           False "Z")
 143               , char 'A' *> return (TimeZone ((-1) * 60) False "A")
 144               , char 'N' *> return (TimeZone (  1  * 60) False "N")
 145               , char 'Y' *> return (TimeZone ( 12  * 60) False "Y")
 146               , read4digitsTZ
 147               ]
 148
 149 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
 150 toAsciiBuilder zonedTime
 151     = let localTime          = zonedTimeToLocalTime zonedTime
 152           timeZone           = zonedTimeZone zonedTime
 153           (year, month, day) = toGregorian (localDay localTime)
 154           (_, _, week)       = toWeekDate  (localDay localTime)
 155           timeOfDay          = localTimeOfDay localTime
 156       in
 157         shortWeekDayName week
 158         ⊕ A.toAsciiBuilder ", "
 159         ⊕ show2 day
 160         ⊕ A.toAsciiBuilder " "
 161         ⊕ shortMonthName month
 162         ⊕ A.toAsciiBuilder " "
 163         ⊕ show2 (year `mod` 100)
 164         ⊕ A.toAsciiBuilder " "
 165         ⊕ show2 (todHour timeOfDay)
 166         ⊕ A.toAsciiBuilder ":"
 167         ⊕ show2 (todMin timeOfDay)
 168         ⊕ A.toAsciiBuilder ":"
 169         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 170         ⊕ A.toAsciiBuilder " "
 171         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 172
 173 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC822 Ascii        |])
 174                , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |])
 175                , ([t| TimeZone  |], [t| Tagged RFC822 Ascii        |])
 176                , ([t| TimeZone  |], [t| Tagged RFC822 AsciiBuilder |])
 177                ]