Data/Time/RFC822/Internal.hs

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