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