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     , rfc1123
  22     , rfc1123DateAndTime
  23     )
  24     where
  25 import Control.Applicative
  26 import Data.Ascii (Ascii, AsciiBuilder)
  27 import qualified Data.Ascii as A
  28 import Data.Attoparsec.Char8
  29 import Data.Convertible.Base
  30 import Data.Monoid.Unicode
  31 import Data.Proxy
  32 import Data.Tagged
  33 import Data.Time
  34 import Data.Time.Calendar.WeekDate
  35 import Data.Time.Format.HTTP.Common
  36 import Data.Time.Format.RFC822.Internal
  37 import Prelude.Unicode
  38
  39 -- |The phantom type for conversions between RFC 1123 date and time
  40 -- strings and 'ZonedTime'.
  41 --
  42 -- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
  43 -- Tagged "Sun, 06 Nov 1994 08:49:37 GMT"
  44 data RFC1123
  45
  46 -- |The proxy for conversions between RFC 1123 date and time strings
  47 -- and 'ZonedTime'.
  48 rfc1123 ∷ Proxy RFC1123
  49 {-# INLINE CONLIKE rfc1123 #-}
  50 rfc1123 = Proxy
  51
  52 instance ConvertSuccess ZonedTime (Tagged RFC1123 Ascii) where
  53     {-# INLINE convertSuccess #-}
  54     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  55
  56 instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where
  57     {-# INLINE convertSuccess #-}
  58     convertSuccess = Tagged ∘ toAsciiBuilder
  59
  60 instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where
  61     {-# INLINE convertAttempt #-}
  62     convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag
  63
  64 -- |Parse an RFC 1123 date and time string.
  65 rfc1123DateAndTime ∷ Parser ZonedTime
  66 rfc1123DateAndTime = dateTime
  67
  68 dateTime ∷ Parser ZonedTime
  69 dateTime = do weekDay ← optionMaybe $
  70                          do w ← shortWeekDayNameP
  71                             _ ← string ", "
  72                             return w
  73               gregDay ← date
  74               case weekDay of
  75                 Nothing
  76                     → return ()
  77                 Just givenWD
  78                     → assertWeekDayIsGood givenWD gregDay
  79               (tod, timeZone) ← rfc822Time
  80               let lt = LocalTime gregDay tod
  81                   zt = ZonedTime lt timeZone
  82               return zt
  83
  84 date ∷ Parser Day
  85 date = do day   ← read2
  86           _     ← char ' '
  87           month ← shortMonthNameP
  88           _     ← char ' '
  89           year  ← read4
  90           _     ← char ' '
  91           assertGregorianDateIsGood year month day
  92
  93 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
  94 toAsciiBuilder zonedTime
  95     = let localTime          = zonedTimeToLocalTime zonedTime
  96           timeZone           = zonedTimeZone zonedTime
  97           (year, month, day) = toGregorian (localDay localTime)
  98           (_, _, week)       = toWeekDate  (localDay localTime)
  99           timeOfDay          = localTimeOfDay localTime
 100       in
 101         shortWeekDayName week
 102         ⊕ A.toAsciiBuilder ", "
 103         ⊕ show2 day
 104         ⊕ A.toAsciiBuilder " "
 105         ⊕ shortMonthName month
 106         ⊕ A.toAsciiBuilder " "
 107         ⊕ show4 year
 108         ⊕ A.toAsciiBuilder " "
 109         ⊕ show2 (todHour timeOfDay)
 110         ⊕ A.toAsciiBuilder ":"
 111         ⊕ show2 (todMin timeOfDay)
 112         ⊕ A.toAsciiBuilder ":"
 113         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 114         ⊕ A.toAsciiBuilder " "
 115         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 116
 117 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii        |])
 118                , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |])
 119                ]