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.Time
  13 import           Data.Time.Calendar.WeekDate
  14 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  15 import           Network.HTTP.Lucu.Format
  16 import           Network.HTTP.Lucu.Parser
  17 import           Prelude hiding (min)
  18
  19
  20 monthStr :: [String]
  21 monthStr =  ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
  22
  23 weekStr :: [String]
  24 weekStr =  ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
  25
  26 -- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time
  27 -- string.
  28 formatRFC1123DateTime :: ZonedTime -> String
  29 formatRFC1123DateTime zonedTime
  30     = let localTime          = zonedTimeToLocalTime zonedTime
  31           timeZone           = zonedTimeZone zonedTime
  32           (year, month, day) = toGregorian (localDay localTime)
  33           (_, _, week)       = toWeekDate (localDay localTime)
  34           timeOfDay          = localTimeOfDay localTime
  35       in
  36         id       (weekStr !! (week - 1))
  37         ++ ", " ++
  38         fmtDec 2 day
  39         ++ " "  ++
  40         id       (monthStr !! (month - 1))
  41         ++ " " ++
  42         fmtDec 4 (fromInteger year)
  43         ++ " " ++
  44         fmtDec 2 (todHour timeOfDay)
  45         ++ ":" ++
  46         fmtDec 2 (todMin timeOfDay)
  47         ++ ":" ++
  48         fmtDec 2 (floor (todSec timeOfDay))
  49         ++ " " ++
  50         id       (timeZoneName timeZone)
  51
  52
  53 -- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone
  54 -- will be always UTC but prints as GMT.
  55 formatHTTPDateTime :: UTCTime -> String
  56 formatHTTPDateTime utcTime
  57     = let timeZone  = TimeZone 0 False "GMT"
  58           zonedTime = utcToZonedTime timeZone utcTime
  59       in
  60         formatRFC1123DateTime zonedTime
  61
  62
  63 -- |Parse an HTTP Date and Time.
  64 --
  65 -- Limitation: RFC 2616 (HTTP\/1.1) says we must accept these three
  66 -- formats:
  67 --
  68 -- * @Sun, 06 Nov 1994 08:49:37 GMT  ; RFC 822, updated by RFC 1123@
  69 --
  70 -- * @Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036@
  71 --
  72 -- * @Sun Nov  6 08:49:37 1994       ; ANSI C's asctime() format@
  73 --
  74 -- ...but currently this function only supports the RFC 1123
  75 -- format. This is a violation of RFC 2616 so this should be fixed
  76 -- later. What a bother!
  77 parseHTTPDateTime :: Lazy.ByteString -> Maybe UTCTime
  78 parseHTTPDateTime src
  79     = case parse httpDateTime src of
  80         (# Success ct, _ #) -> Just ct
  81         (# _         , _ #) -> Nothing
  82
  83
  84 httpDateTime :: Parser UTCTime
  85 httpDateTime = do _    <- foldl (<|>) failP (map string weekStr)
  86                   _    <- char ','
  87                   _    <- char ' '
  88                   day  <- liftM read (count 2 digit)
  89                   _    <- char ' '
  90                   mon  <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..]))
  91                   _    <- char ' '
  92                   year <- liftM read (count 4 digit)
  93                   _    <- char ' '
  94                   hour <- liftM read (count 2 digit)
  95                   _    <- char ':'
  96                   min  <- liftM read (count 2 digit)
  97                   _    <- char ':'
  98                   sec  <- liftM read (count 2 digit) :: Parser Int
  99                   _    <- char ' '
 100                   _    <- string "GMT"
 101                   eof
 102                   let julianDay = fromGregorian year mon day
 103                       timeOfDay = TimeOfDay hour min (fromIntegral sec)
 104                       utcTime   = UTCTime julianDay (timeOfDayToTime timeOfDay)
 105                   return utcTime
 106     where
 107       tryEqToFst :: (String, a) -> Parser a
 108       tryEqToFst (str, a) = string str >> return a
 109