Data/Time/Format/RFC822.hs

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