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 -- |FIXME: move this to RFC822.Internal
  67 instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where
  68     {-# INLINE convertSuccess #-}
  69     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  70
  71 -- |FIXME: move this to RFC822.Internal
  72 instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where
  73     {-# INLINE convertSuccess #-}
  74     convertSuccess tz
  75         | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT"
  76         | otherwise              = Tagged $ show4digitsTZ tz
  77
  78 instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where
  79     {-# INLINE convertAttempt #-}
  80     convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag
  81
  82 -- |Parse an RFC 822 date and time string.
  83 rfc822DateAndTime ∷ Parser ZonedTime
  84 rfc822DateAndTime = dateTime
  85
  86 dateTime ∷ Parser ZonedTime
  87 dateTime = do weekDay ← optionMaybe $
  88                         do w ← shortWeekDayNameP
  89                            _ ← string ", "
  90                            return w
  91               gregDay ← date
  92               case weekDay of
  93                 Nothing
  94                     -> return ()
  95                 Just givenWD
  96                     -> assertWeekDayIsGood givenWD gregDay
  97               (tod, timeZone) ← rfc822Time
  98               let lt = LocalTime gregDay tod
  99                   zt = ZonedTime lt timeZone
 100               return zt
 101
 102 date ∷ Parser Day
 103 date = do day   ← read2
 104           _     ← char ' '
 105           month ← shortMonthNameP
 106           _     ← char ' '
 107           year  ← (+ 1900) <$> read2
 108           _     ← char ' '
 109           assertGregorianDateIsGood year month day
 110
 111 -- |FIXME: move this to RFC822.Internal
 112 rfc822Time ∷ Parser (TimeOfDay, TimeZone)
 113 rfc822Time = do tod ← hms
 114                 _   ← char ' '
 115                 tz  ← zone
 116                 return (tod, tz)
 117
 118 hms ∷ Parser TimeOfDay
 119 hms = do hour   ← read2
 120          minute ← char ':' *> read2
 121          second ← option 0 (char ':' *> read2)
 122          assertTimeOfDayIsGood hour minute second
 123
 124 zone ∷ Parser TimeZone
 125 zone = choice [ string "UT"  *> return (TimeZone 0 False "UT" )
 126               , string "GMT" *> return (TimeZone 0 False "GMT")
 127               , char 'E'
 128                 *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST")
 129                           , string "DT" *> return (TimeZone ((-4) * 60) True  "EDT")
 130                           ]
 131               , char 'C'
 132                 *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST")
 133                           , string "DT" *> return (TimeZone ((-5) * 60) True  "CDT")
 134                           ]
 135               , char 'M'
 136                 *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST")
 137                           , string "DT" *> return (TimeZone ((-6) * 60) True  "MDT")
 138                           , return (TimeZone ((-12) * 60) False "M")
 139                           ]
 140               , char 'P'
 141                 *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST")
 142                           , string "DT" *> return (TimeZone ((-7) * 60) True  "PDT")
 143                           ]
 144               , char 'Z' *> return (TimeZone 0           False "Z")
 145               , char 'A' *> return (TimeZone ((-1) * 60) False "A")
 146               , char 'N' *> return (TimeZone (  1  * 60) False "N")
 147               , char 'Y' *> return (TimeZone ( 12  * 60) False "Y")
 148               , read4digitsTZ
 149               ]
 150
 151 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
 152 toAsciiBuilder zonedTime
 153     = let localTime          = zonedTimeToLocalTime zonedTime
 154           timeZone           = zonedTimeZone zonedTime
 155           (year, month, day) = toGregorian (localDay localTime)
 156           (_, _, week)       = toWeekDate  (localDay localTime)
 157           timeOfDay          = localTimeOfDay localTime
 158       in
 159         shortWeekDayName week
 160         ⊕ A.toAsciiBuilder ", "
 161         ⊕ show2 day
 162         ⊕ A.toAsciiBuilder " "
 163         ⊕ shortMonthName month
 164         ⊕ A.toAsciiBuilder " "
 165         ⊕ show2 (year `mod` 100)
 166         ⊕ A.toAsciiBuilder " "
 167         ⊕ show2 (todHour timeOfDay)
 168         ⊕ A.toAsciiBuilder ":"
 169         ⊕ show2 (todMin timeOfDay)
 170         ⊕ A.toAsciiBuilder ":"
 171         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 172         ⊕ A.toAsciiBuilder " "
 173         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 174
 175 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC822 Ascii        |])
 176                , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |])
 177                , ([t| TimeZone  |], [t| Tagged RFC822 Ascii        |])
 178                , ([t| TimeZone  |], [t| Tagged RFC822 AsciiBuilder |])
 179                ]