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