Data/Time/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 formats.
  10 --
  11 -- The format is basically same as RFC 822, but the syntax for @date@
  12 -- is changed from:
  13 --
  14 -- > year ::= 2DIGIT
  15 --
  16 -- to:
  17 --
  18 -- > year ::= 4DIGIT
  19 module Data.Time.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.HTTP.Common
  34 import Data.Time.RFC822.Internal
  35 import Prelude.Unicode
  36
  37 -- FIXME: doc
  38 data RFC1123
  39
  40 instance ConvertSuccess ZonedTime (Tagged RFC1123 Ascii) where
  41     {-# INLINE convertSuccess #-}
  42     convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
  43
  44 instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where
  45     {-# INLINE convertSuccess #-}
  46     convertSuccess = Tagged ∘ toAsciiBuilder
  47
  48 instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where
  49     {-# INLINE convertAttempt #-}
  50     convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag
  51
  52 -- |Parse an RFC 1123 date and time string.
  53 rfc1123DateAndTime ∷ Parser ZonedTime
  54 rfc1123DateAndTime = dateTime
  55
  56 dateTime ∷ Parser ZonedTime
  57 dateTime = do weekDay ← optionMaybe $
  58                          do w ← shortWeekDayNameP
  59                             _ ← string ", "
  60                             return w
  61               gregDay ← date
  62               case weekDay of
  63                 Nothing
  64                     → return ()
  65                 Just givenWD
  66                     → assertWeekDayIsGood givenWD gregDay
  67               (tod, timeZone) ← rfc822Time
  68               let lt = LocalTime gregDay tod
  69                   zt = ZonedTime lt timeZone
  70               return zt
  71
  72 date ∷ Parser Day
  73 date = do day   ← read2
  74           _     ← char ' '
  75           month ← shortMonthNameP
  76           _     ← char ' '
  77           year  ← read4
  78           _     ← char ' '
  79           assertGregorianDateIsGood year month day
  80
  81 toAsciiBuilder ∷ ZonedTime → AsciiBuilder
  82 toAsciiBuilder zonedTime
  83     = let localTime          = zonedTimeToLocalTime zonedTime
  84           timeZone           = zonedTimeZone zonedTime
  85           (year, month, day) = toGregorian (localDay localTime)
  86           (_, _, week)       = toWeekDate  (localDay localTime)
  87           timeOfDay          = localTimeOfDay localTime
  88       in
  89         shortWeekDayName week
  90         ⊕ A.toAsciiBuilder ", "
  91         ⊕ show2 day
  92         ⊕ A.toAsciiBuilder " "
  93         ⊕ shortMonthName month
  94         ⊕ A.toAsciiBuilder " "
  95         ⊕ show4 year
  96         ⊕ A.toAsciiBuilder " "
  97         ⊕ show2 (todHour timeOfDay)
  98         ⊕ A.toAsciiBuilder ":"
  99         ⊕ show2 (todMin timeOfDay)
 100         ⊕ A.toAsciiBuilder ":"
 101         ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
 102         ⊕ A.toAsciiBuilder " "
 103         ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 104
 105 deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii        |])
 106                , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |])
 107                ]