Data/Time/Format/RFC822/Internal.hs

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