Network/HTTP/Lucu/RFC1123DateTime.hs

   1 -- |This module parses and prints RFC 1123 Date and Time string.
   2 --
   3 -- In general you don't have to use this module directly.
   4 module Network.HTTP.Lucu.RFC1123DateTime
   5     ( formatRFC1123DateTime
   6     , formatHTTPDateTime
   7     , parseHTTPDateTime
   8     )
   9     where
  10
  11 import           Control.Monad
  12 import           Data.ByteString.Base (LazyByteString)
  13 import           Network.HTTP.Lucu.Format
  14 import           Network.HTTP.Lucu.Parser
  15 import           System.Time
  16
  17 month :: [String]
  18 month =  ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
  19
  20 week :: [String]
  21 week =  ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
  22
  23 -- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time
  24 -- string.
  25 formatRFC1123DateTime :: CalendarTime -> String
  26 formatRFC1123DateTime time
  27     = time `seq`
  28
  29       id       (week     !! fromEnum (ctWDay  time))
  30       ++ ", " ++
  31       fmtDec 2 (ctDay    time)
  32       ++ " "  ++
  33       id       (month    !! fromEnum (ctMonth time))
  34       ++ " "  ++
  35       fmtDec 4 (ctYear   time)
  36       ++ " "  ++
  37       fmtDec 2 (ctHour   time)
  38       ++ ":"  ++
  39       fmtDec 2 (ctMin    time)
  40       ++ ":"  ++
  41       fmtDec 2 (ctSec    time)
  42       ++ " "  ++
  43       id       (ctTZName time)
  44
  45
  46 -- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone
  47 -- will be always UTC but prints as GMT.
  48 formatHTTPDateTime :: ClockTime -> String
  49 formatHTTPDateTime time
  50     = time `seq`
  51       formatRFC1123DateTime $! (\cal -> cal { ctTZName = "GMT" }) $! toUTCTime time
  52
  53 -- |Parse an HTTP Date and Time.
  54 --
  55 -- Limitation: RFC 2616 (HTTP\/1.1) says we must accept these three
  56 -- formats:
  57 --
  58 -- * @Sun, 06 Nov 1994 08:49:37 GMT  ; RFC 822, updated by RFC 1123@
  59 --
  60 -- * @Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036@
  61 --
  62 -- * @Sun Nov  6 08:49:37 1994       ; ANSI C's asctime() format@
  63 --
  64 -- ...but currently this function only supports the RFC 1123
  65 -- format. This is a violation of RFC 2616 so this should be fixed
  66 -- later. What a bother!
  67 parseHTTPDateTime :: LazyByteString -> Maybe ClockTime
  68 parseHTTPDateTime src
  69     = case parse httpDateTime src of
  70         (# Success ct, _ #) -> Just ct
  71         (# _         , _ #) -> Nothing
  72
  73
  74 httpDateTime :: Parser ClockTime
  75 httpDateTime = do foldl (<|>) failP (map string week)
  76                   char ','
  77                   char ' '
  78                   day  <- liftM read (count 2 digit)
  79                   char ' '
  80                   mon  <- foldl (<|>) failP (map tryEqToFst (zip month [1..]))
  81                   char ' '
  82                   year <- liftM read (count 4 digit)
  83                   char ' '
  84                   hour <- liftM read (count 2 digit)
  85                   char ':'
  86                   min  <- liftM read (count 2 digit)
  87                   char ':'
  88                   sec  <- liftM read (count 2 digit)
  89                   char ' '
  90                   string "GMT"
  91                   eof
  92                   return $ toClockTime $ CalendarTime {
  93                                ctYear    = year
  94                              , ctMonth   = toEnum (mon - 1)
  95                              , ctDay     = day
  96                              , ctHour    = hour
  97                              , ctMin     = min
  98                              , ctSec     = sec
  99                              , ctPicosec = 0
 100                              , ctTZ      = 0
 101                              , ctWDay    = undefined
 102                              , ctYDay    = undefined
 103                              , ctTZName  = undefined
 104                              , ctIsDST   = undefined
 105                              }
 106     where
 107       tryEqToFst :: (String, a) -> Parser a
 108       tryEqToFst (str, a) = string str >> return a
 109