Data/Time/Format/RFC1123.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , MultiParamTypeClasses
   4   , OverloadedStrings
   5   , TemplateHaskell
   6   , UnicodeSyntax
   7   #-}
   8 -- |This module provides functions to parse and format RFC 1123 date
   9 -- and time strings (<http://tools.ietf.org/html/rfc1123#page-55>).
  10 --
  11 -- The format is basically the same as RFC 822, but the syntax for
  12 -- @date@ is changed from:
  13 --
  14 -- > year ::= 2DIGIT
  15 --
  16 -- to:
  17 --
  18 -- > year ::= 4DIGIT
  19 module Data.Time.Format.RFC1123
  20     ( RFC1123
  21     , rfc1123DateAndTime
  22     )
  23     where
  24 import Control.Applicative
  25 import Data.Ascii (Ascii, AsciiBuilder)
  26 import qualified Data.Ascii as A
  27 import Data.Attoparsec.Char8
  28 import Data.Convertible.Base
  29 import Data.Monoid.Unicode
  30 import Data.Tagged
  31 import Data.Time
  32 import Data.Time.Calendar.WeekDate
  33 import Data.Time.Format.HTTP.Common
  34 import Data.Time.Format.RFC822.Internal
  35 import Prelude.Unicode
  36
  37 -- |The phantom type for conversions between RFC 1123 date and time
  38 -- strings and 'ZonedTime'.
  39 --
  40 -- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
  41 -- Tagged "Sun, 06 Nov 1994 08:49:37 GMT"
  42 data RFC1123
  43
  44 instance ConvertSuccess ZonedTime (Tagged RFC1123 Ascii) where
  45     {-# INLINE convertSuccess #-}
  46     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  47
  48 instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where
  49     {-# INLINE convertSuccess #-}
  50     convertSuccess = Tagged ∘ toAsciiBuilder
  51
  52 instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where
  53     {-# INLINE convertAttempt #-}
  54     convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag
  55
  56 -- |Parse an RFC 1123 date and time string.
  57 rfc1123DateAndTime ∷ Parser ZonedTime
  58 rfc1123DateAndTime = dateTime
  59
  60 dateTime ∷ Parser ZonedTime
  61 dateTime = do weekDay ← optionMaybe $
  62                          do w ← shortWeekDayNameP
  63                             _ ← string ", "
  64                             return w
  65               gregDay ← date
  66               case weekDay of
  67                 Nothing
  68                     → return ()
  69                 Just givenWD
  70                     → assertWeekDayIsGood givenWD gregDay
  71               (tod, timeZone) ← rfc822Time
  72               let lt = LocalTime gregDay tod
  73                   zt = ZonedTime lt timeZone
  74               return zt
  75
  76 date ∷ Parser Day
  77 date = do day   ← read2
  78           _     ← char ' '
  79           month ← shortMonthNameP
  80           _     ← char ' '
  81           year  ← read4
  82           _     ← char ' '
  83           assertGregorianDateIsGood year month day
  84
  85 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
  86 toAsciiBuilder zonedTime
  87     = let localTime          = zonedTimeToLocalTime zonedTime
  88           timeZone           = zonedTimeZone zonedTime
  89           (year, month, day) = toGregorian (localDay localTime)
  90           (_, _, week)       = toWeekDate  (localDay localTime)
  91           timeOfDay          = localTimeOfDay localTime
  92       in
  93         shortWeekDayName week
  94         ⊕ A.toAsciiBuilder ", "
  95         ⊕ show2 day
  96         ⊕ A.toAsciiBuilder " "
  97         ⊕ shortMonthName month
  98         ⊕ A.toAsciiBuilder " "
  99         ⊕ show4 year
 100         ⊕ A.toAsciiBuilder " "
 101         ⊕ show2 (todHour timeOfDay)
 102         ⊕ A.toAsciiBuilder ":"
 103         ⊕ show2 (todMin timeOfDay)
 104         ⊕ A.toAsciiBuilder ":"
 105         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 106         ⊕ A.toAsciiBuilder " "
 107         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 108
 109 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii        |])
 110                , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |])
 111                ]