New issue ditz/lucu-4

[Lucu.git] / Network / HTTP / Lucu / RFC1123DateTime.hs

diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs
index 2cd06cc9cac7f79f2870e3da1847c57f8e089350..bc2c5901233bd8679955e7aff0e4c3a38cc7b009 100644 (file)
--- a/Network/HTTP/Lucu/RFC1123DateTime.hs
+++ b/Network/HTTP/Lucu/RFC1123DateTime.hs
@@ -9,44 +9,56 @@ module Network.HTTP.Lucu.RFC1123DateTime
     where
 
 import           Control.Monad
+import           Data.Time
+import           Data.Time.Calendar.WeekDate
+import qualified Data.ByteString.Lazy as Lazy (ByteString)
 import           Network.HTTP.Lucu.Format
 import           Network.HTTP.Lucu.Parser
-import           System.Time
+import           Prelude hiding (min)
 
-month :: [String]
-month =  ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
 
-week :: [String]
-week =  ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+monthStr :: [String]
+monthStr =  ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
 
--- |Format a @CalendarTime@ to RFC 1123 Date and Time string.
-formatRFC1123DateTime :: CalendarTime -> String
-formatRFC1123DateTime time
-    = time `seq`
+weekStr :: [String]
+weekStr =  ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
 
-      id       (week     !! fromEnum (ctWDay  time))
-      ++ ", " ++
-      fmtDec 2 (ctDay    time)
-      ++ " "  ++
-      id       (month    !! fromEnum (ctMonth time))
-      ++ " "  ++
-      fmtDec 4 (ctYear   time)
-      ++ " "  ++
-      fmtDec 2 (ctHour   time)
-      ++ ":"  ++
-      fmtDec 2 (ctMin    time)
-      ++ ":"  ++
-      fmtDec 2 (ctSec    time)
-      ++ " "  ++
-      id       (ctTZName time)
+-- |Format a 'System.Time.CalendarTime' to RFC 1123 Date and Time
+-- string.
+formatRFC1123DateTime :: ZonedTime -> String
+formatRFC1123DateTime zonedTime
+    = let localTime          = zonedTimeToLocalTime zonedTime
+          timeZone           = zonedTimeZone zonedTime
+          (year, month, day) = toGregorian (localDay localTime)
+          (_, _, week)       = toWeekDate (localDay localTime)
+          timeOfDay          = localTimeOfDay localTime
+      in
+        id       (weekStr !! (week - 1))
+        ++ ", " ++
+        fmtDec 2 day
+        ++ " "  ++
+        id       (monthStr !! (month - 1))
+        ++ " " ++
+        fmtDec 4 (fromInteger year)
+        ++ " " ++
+        fmtDec 2 (todHour timeOfDay)
+        ++ ":" ++
+        fmtDec 2 (todMin timeOfDay)
+        ++ ":" ++
+        fmtDec 2 (floor (todSec timeOfDay))
+        ++ " " ++
+        id       (timeZoneName timeZone)
       
 
--- |Format a @ClockTime@ to HTTP Date and Time. Time zone will be
--- always UTC but prints as GMT.
-formatHTTPDateTime :: ClockTime -> String
-formatHTTPDateTime time
-    = time `seq`
-      formatRFC1123DateTime $! (\cal -> cal { ctTZName = "GMT" }) $! toUTCTime time
+-- |Format a 'System.Time.ClockTime' to HTTP Date and Time. Time zone
+-- will be always UTC but prints as GMT.
+formatHTTPDateTime :: UTCTime -> String
+formatHTTPDateTime utcTime
+    = let timeZone  = TimeZone 0 False "GMT"
+          zonedTime = utcToZonedTime timeZone utcTime
+      in
+        formatRFC1123DateTime zonedTime
+
 
 -- |Parse an HTTP Date and Time.
 --
@@ -62,45 +74,35 @@ formatHTTPDateTime time
 -- ...but currently this function only supports the RFC 1123
 -- format. This is a violation of RFC 2616 so this should be fixed
 -- later. What a bother!
-parseHTTPDateTime :: String -> Maybe ClockTime
+parseHTTPDateTime :: Lazy.ByteString -> Maybe UTCTime
 parseHTTPDateTime src
-    = case parseStr httpDateTime src of
+    = case parse httpDateTime src of
         (# Success ct, _ #) -> Just ct
         (# _         , _ #) -> Nothing
 
 
-httpDateTime :: Parser ClockTime
-httpDateTime = do foldl (<|>) failP (map string week)
-                  char ','
-                  char ' '
+httpDateTime :: Parser UTCTime
+httpDateTime = do _    <- foldl (<|>) failP (map string weekStr)
+                  _    <- char ','
+                  _    <- char ' '
                   day  <- liftM read (count 2 digit)
-                  char ' '
-                  mon  <- foldl (<|>) failP (map tryEqToFst (zip month [1..]))
-                  char ' '
+                  _    <- char ' '
+                  mon  <- foldl (<|>) failP (map tryEqToFst (zip monthStr [1..]))
+                  _    <- char ' '
                   year <- liftM read (count 4 digit)
-                  char ' '
+                  _    <- char ' '
                   hour <- liftM read (count 2 digit)
-                  char ':'
+                  _    <- char ':'
                   min  <- liftM read (count 2 digit)
-                  char ':'
-                  sec  <- liftM read (count 2 digit)
-                  char ' '
-                  string "GMT"
+                  _    <- char ':'
+                  sec  <- liftM read (count 2 digit) :: Parser Int
+                  _    <- char ' '
+                  _    <- string "GMT"
                   eof
-                  return $ toClockTime $ CalendarTime {
-                               ctYear    = year
-                             , ctMonth   = toEnum (mon - 1)
-                             , ctDay     = day
-                             , ctHour    = hour
-                             , ctMin     = min
-                             , ctSec     = sec
-                             , ctPicosec = 0
-                             , ctTZ      = 0
-                             , ctWDay    = undefined
-                             , ctYDay    = undefined
-                             , ctTZName  = undefined
-                             , ctIsDST   = undefined
-                             }
+                  let julianDay = fromGregorian year mon day
+                      timeOfDay = TimeOfDay hour min (fromIntegral sec)
+                      utcTime   = UTCTime julianDay (timeOfDayToTime timeOfDay)
+                  return utcTime
     where
       tryEqToFst :: (String, a) -> Parser a
       tryEqToFst (str, a) = string str >> return a