Data/Time/Format/RFC1123.hs

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