Data/Time/Format/HTTP.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 HTTP\/1.1 date
  10 -- and time strings
  11 -- (<http://tools.ietf.org/html/rfc2616#section-3.3>).
  12 --
  13 -- The HTTP\/1.1 specification (RFC 2616) says that HTTP\/1.1 clients
  14 -- and servers which parse the date value MUST accept all the
  15 -- following formats, though they MUST only generate the RFC 1123
  16 -- format for representing HTTP-date values in header fields:
  17 --
  18 -- > Sun, 06 Nov 1994 08:49:37 GMT  ; RFC 822, updated by RFC 1123
  19 -- > Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036
  20 -- > Sun Nov  6 08:49:37 1994       ; ANSI C's asctime() format
  21 --
  22 -- It also says that all HTTP date\/time stamps MUST be represented in
  23 -- Greenwich Mean Time (GMT), without exception. For the purposes of
  24 -- HTTP, GMT is exactly equal to UTC (Coordinated Universal
  25 -- Time). This is indicated in the first two formats by the inclusion
  26 -- of @\"GMT\"@ as the three-letter abbreviation for time zone, and
  27 -- MUST be assumed when reading the asctime format.
  28 --
  29 -- > HTTP-date    = rfc1123-date | rfc850-date | asctime-date
  30 -- > rfc1123-date = wkday "," SP date1 SP time SP "GMT"
  31 -- > rfc850-date  = weekday "," SP date2 SP time SP "GMT"
  32 -- > asctime-date = wkday SP date3 SP time SP 4DIGIT
  33 -- > date1        = 2DIGIT SP month SP 4DIGIT
  34 -- >                ; day month year (e.g., 02 Jun 1982)
  35 -- > date2        = 2DIGIT "-" month "-" 2DIGIT
  36 -- >                ; day-month-year (e.g., 02-Jun-82)
  37 -- > date3        = month SP ( 2DIGIT | ( SP 1DIGIT ))
  38 -- >                ; month day (e.g., Jun  2)
  39 -- > time         = 2DIGIT ":" 2DIGIT ":" 2DIGIT
  40 -- >                ; 00:00:00 - 23:59:59
  41 -- > wkday        = "Mon" | "Tue" | "Wed"
  42 -- >              | "Thu" | "Fri" | "Sat" | "Sun"
  43 -- > weekday      = "Monday" | "Tuesday" | "Wednesday"
  44 -- >              | "Thursday" | "Friday" | "Saturday" | "Sunday"
  45 -- > month        = "Jan" | "Feb" | "Mar" | "Apr"
  46 -- >              | "May" | "Jun" | "Jul" | "Aug"
  47 -- >              | "Sep" | "Oct" | "Nov" | "Dec"
  48 module Data.Time.Format.HTTP
  49     ( HTTP
  50     )
  51     where
  52 import Control.Applicative
  53 import Data.Ascii (Ascii, AsciiBuilder)
  54 import qualified Data.Ascii as A
  55 import Data.Attoparsec.Char8
  56 import Data.Convertible.Base
  57 import Data.Default
  58 import Data.Tagged
  59 import Data.Time
  60 import Data.Time.Format.C
  61 import Data.Time.Format.HTTP.Common
  62 import Data.Time.Format.RFC733
  63 import Data.Time.Format.RFC822
  64 import Data.Time.Format.RFC1123
  65 import Prelude.Unicode
  66
  67 -- |The phantom type for conversions between HTTP/1.1 date and time
  68 -- strings and 'UTCTime'.
  69 --
  70 -- >>> convertSuccess (Tagged (UTCTime (ModifiedJulianDay 49662) 31777) :: Tagged HTTP UTCTime)
  71 -- "Sun, 06 Nov 1994 08:49:37 GMT"
  72 data HTTP
  73
  74 instance ConvertSuccess (Tagged HTTP UTCTime) Ascii where
  75     {-# INLINE convertSuccess #-}
  76     convertSuccess = A.fromAsciiBuilder ∘ cs
  77
  78 instance ConvertSuccess (Tagged HTTP UTCTime) AsciiBuilder where
  79     {-# INLINE convertSuccess #-}
  80     convertSuccess = toAsciiBuilder
  81
  82 instance ConvertAttempt Ascii (Tagged HTTP UTCTime) where
  83     {-# INLINE convertAttempt #-}
  84     convertAttempt = parseAttempt' def
  85
  86 -- |Parse a date and time string in any of RFC 822, RFC 1123, RFC 850
  87 -- and ANSI C's asctime() formats.
  88 --
  89 -- This parser is even more permissive than what HTTP\/1.1 (RFC 2616)
  90 -- specifies. That is, it accepts 2-digit years in RFC 822, omitted
  91 -- separator symbols in RFC 850, omitted sec fields, and non-GMT time
  92 -- zones. I believe this behavior will not cause a problem though.
  93 instance Default (Parser (Tagged HTTP UTCTime)) where
  94     {-# INLINEABLE def #-}
  95     def = Tagged
  96           <$>
  97           choice [ (zonedTimeToUTC     ∘ untag) <$> try (def ∷ Parser (Tagged RFC1123 ZonedTime))
  98                  , (zonedTimeToUTC     ∘ untag) <$> try (def ∷ Parser (Tagged RFC733  ZonedTime))
  99                  , (zonedTimeToUTC     ∘ untag) <$> try (def ∷ Parser (Tagged RFC822  ZonedTime))
 100                  , (localTimeToUTC utc ∘ untag) <$>     (def ∷ Parser (Tagged C       LocalTime))
 101                  ]
 102
 103 toAsciiBuilder ∷ Tagged HTTP UTCTime → AsciiBuilder
 104 {-# INLINEABLE toAsciiBuilder #-}
 105 toAsciiBuilder = cs ∘ (ut2zt <$>) ∘ retag'
 106     where
 107       ut2zt ∷ UTCTime → ZonedTime
 108       {-# INLINE ut2zt #-}
 109       ut2zt = utcToZonedTime gmt
 110
 111       gmt ∷ TimeZone
 112       {-# INLINE CONLIKE gmt #-}
 113       gmt = TimeZone 0 False "GMT"
 114
 115       retag' ∷ Tagged τ α → Tagged RFC1123 α
 116       {-# INLINE retag' #-}
 117       retag' = retag
 118
 119 deriveAttempts [ ([t| Tagged HTTP UTCTime |], [t| Ascii        |])
 120                , ([t| Tagged HTTP UTCTime |], [t| AsciiBuilder |])
 121                ]