Data/Time/Format/RFC822/Internal.hs

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