RFC822.hs

{-# LANGUAGE
    DeriveDataTypeable
  , FlexibleContexts
  , FlexibleInstances
  , MultiParamTypeClasses
  , OverloadedStrings
  , TemplateHaskell
  , TypeSynonymInstances
  , UnicodeSyntax
  #-}
-- |This module provides functions to parse and format RFC 822 date
-- and time strings (<http://tools.ietf.org/html/rfc822#section-5>).
--
-- The syntax is as follows:
--
-- > date-time   ::= [ day-of-week ", " ] date SP time SP zone
-- > day-of-week ::= "Mon" | "Tue" | "Wed" | "Thu"
-- >               | "Fri" | "Sat" | "Sun"
-- > date        ::= day SP month SP year
-- > day         ::= 2DIGIT
-- > year        ::= 2DIGIT             ; Yes, only 2 digits.
-- > month       ::= "Jan" | "Feb" | "Mar" | "Apr"
-- >               | "May" | "Jun" | "Jul" | "Aug"
-- >               | "Sep" | "Oct" | "Nov" | "Dec"
-- > time        ::= hour ":" minute [ ":" second ]
-- > hour        ::= 2DIGIT
-- > minute      ::= 2DIGIT
-- > second      ::= 2DIGIT
-- > zone        ::= "UT"  | "GMT"      ; Universal Time
-- >               | "EST" | "EDT"      ; Eastern : -5 / -4
-- >               | "CST" | "CDT"      ; Central : -6 / -5
-- >               | "MST" | "MDT"      ; Mountain: -7 / -6
-- >               | "PST" | "PDT"      ; Pacific : -8 / -7
-- >               | "Z"                ; UT
-- >               | "A"                ;  -1
-- >               | "M"                ; -12
-- >               | "N"                ;  +1
-- >               | "Y"                ; +12
-- >               | ("+" | "-") 4DIGIT ; Local diff: HHMM
module Data.Time.Format.RFC822
    ( RFC822
    )
    where
import Control.Applicative
import Control.Applicative.Unicode
import Control.Failure
import Data.Ascii (Ascii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
import Data.Convertible.Base
import Data.Convertible.Utils
import Data.Default
import Data.Monoid.Unicode
import Data.Tagged
import Data.Time
import Data.Time.Calendar.WeekDate
import Data.Time.Format.HTTP.Common
import Data.Typeable
import Prelude.Unicode

-- |The phantom type for conversions between RFC 822 date and time
-- strings and 'ZonedTime'.
--
-- >>> convertAttempt (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC822 ZonedTime)
-- Success "Sun, 06 Nov 94 08:49:37 GMT"
--
-- Note that RFC 822 has a Y2K problem so converting 'ZonedTime' whose
-- gregorian year is earlier than 1900 or from 2000 onward results in
-- @'ConvertBoundsException' 'Day' ('Tagged' RFC822 'ZonedTime')@.
data RFC822
    deriving Typeable

instance ConvertAttempt (Tagged RFC822 ZonedTime) Ascii where
    {-# INLINE convertAttempt #-}
    convertAttempt = (A.fromAsciiBuilder <$>) ∘ ca

instance ConvertAttempt (Tagged RFC822 ZonedTime) AsciiBuilder where
    {-# INLINE convertAttempt #-}
    convertAttempt = toAsciiBuilder

instance ConvertSuccess (Tagged RFC822 TimeZone) Ascii where
    {-# INLINE convertSuccess #-}
    convertSuccess = A.fromAsciiBuilder ∘ cs

instance ConvertSuccess (Tagged RFC822 TimeZone) AsciiBuilder where
    {-# INLINE convertSuccess #-}
    convertSuccess (Tagged tz)
        | timeZoneMinutes tz ≡ 0 = A.toAsciiBuilder "GMT"
        | otherwise              = show4digitsTZ tz

instance ConvertAttempt Ascii (Tagged RFC822 ZonedTime) where
    {-# INLINE convertAttempt #-}
    convertAttempt = parseAttempt' def

-- |Parse an RFC 822 date and time string.
instance Default (Parser (Tagged RFC822 ZonedTime)) where
    def = do weekDay ← optionMaybe $
                       do w ← shortWeekDayNameP
                          string ", " *> pure w
             gregDay ← date
             case weekDay of
               Nothing
                   → return ()
               Just givenWD
                   → assertWeekDayIsGood givenWD gregDay
             tod      ← def
             timeZone ← char ' ' *> def
             let lt = LocalTime gregDay <$> tod
                 zt = ZonedTime <$> lt ⊛ timeZone
             return zt

date ∷ Parser Day
date = do day   ← read2
          month ← char ' ' *> shortMonthNameP
          year  ← char ' ' *> ((+ 1900) <$> read2)
          char ' ' *> assertGregorianDateIsGood year month day

instance Default (Parser (Tagged RFC822 TimeOfDay)) where
    {-# INLINEABLE def #-}
    def = do hour   ← read2
             minute ← char ':' *> read2
             second ← option 0 (char ':' *> read2)
             Tagged <$> assertTimeOfDayIsGood hour minute second

instance Default (Parser (Tagged RFC822 TimeZone)) where
    def = choice [ string "UT"  *> pure (Tagged (TimeZone 0 False "UT" ))
                 , string "GMT" *> pure (Tagged (TimeZone 0 False "GMT"))
                 , char 'E'
                   *> choice [ string "ST" *> pure (Tagged (TimeZone ((-5) * 60) False "EST"))
                             , string "DT" *> pure (Tagged (TimeZone ((-4) * 60) True  "EDT"))
                             ]
                 , char 'C'
                   *> choice [ string "ST" *> pure (Tagged (TimeZone ((-6) * 60) False "CST"))
                             , string "DT" *> pure (Tagged (TimeZone ((-5) * 60) True  "CDT"))
                             ]
                 , char 'M'
                   *> choice [ string "ST" *> pure (Tagged (TimeZone ((-7) * 60) False "MST"))
                             , string "DT" *> pure (Tagged (TimeZone ((-6) * 60) True  "MDT"))
                             , pure (Tagged (TimeZone ((-12) * 60) False "M"))
                             ]
                 , char 'P'
                   *> choice [ string "ST" *> pure (Tagged (TimeZone ((-8) * 60) False "PST"))
                             , string "DT" *> pure (Tagged (TimeZone ((-7) * 60) True  "PDT"))
                             ]
                 , char 'Z' *> pure (Tagged (TimeZone 0           False "Z"))
                 , char 'A' *> pure (Tagged (TimeZone ((-1) * 60) False "A"))
                 , char 'N' *> pure (Tagged (TimeZone (  1  * 60) False "N"))
                 , char 'Y' *> pure (Tagged (TimeZone ( 12  * 60) False "Y"))
                 , Tagged <$> read4digitsTZ
                 ]

toAsciiBuilder ∷ Failure (ConvertBoundsException Day (Tagged RFC822 ZonedTime)) f
               ⇒ Tagged RFC822 ZonedTime
               → f AsciiBuilder
toAsciiBuilder zonedTime
    = let localTime          = zonedTimeToLocalTime $ untag zonedTime
          timeZone           = zonedTimeZone <$> zonedTime
          (year, month, day) = toGregorian (localDay localTime)
          (_, _, week)       = toWeekDate  (localDay localTime)
          timeOfDay          = localTimeOfDay localTime
      in
        if year < 1900 ∨ year ≥ 2000 then
            let minDay = fromGregorian 1900  1  1
                maxDay = fromGregorian 1999 12 31
            in
              failure $ ConvertBoundsException minDay maxDay zonedTime
        else
            return $
            shortWeekDayName week
            ⊕ A.toAsciiBuilder ", "
            ⊕ show2 day
            ⊕ A.toAsciiBuilder " "
            ⊕ shortMonthName month
            ⊕ A.toAsciiBuilder " "
            ⊕ show2 (year `mod` 100)
            ⊕ A.toAsciiBuilder " "
            ⊕ show2 (todHour timeOfDay)
            ⊕ A.toAsciiBuilder ":"
            ⊕ show2 (todMin timeOfDay)
            ⊕ A.toAsciiBuilder ":"
            ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
            ⊕ A.toAsciiBuilder " "
            ⊕ cs timeZone

deriveAttempts [ ([t| Tagged RFC822 TimeZone |], [t| Ascii        |])
               , ([t| Tagged RFC822 TimeZone |], [t| AsciiBuilder |])
               ]