Many improvements: still in early development

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

diff --git a/Network/HTTP/Lucu/RFC1123DateTime.hs b/Network/HTTP/Lucu/RFC1123DateTime.hs
new file mode 100644 (file)
index 0000000..9c58e51
--- /dev/null
+++ b/Network/HTTP/Lucu/RFC1123DateTime.hs
@@ -0,0 +1,75 @@
+module Network.HTTP.Lucu.RFC1123DateTime
+    ( formatRFC1123DateTime -- CalendarTime -> String
+    , formatHTTPDateTime    -- ClockTime -> String
+    , parseHTTPDateTime     -- String -> Maybe ClockTime
+    )
+    where
+
+import Control.Monad
+import System.Time
+import System.Locale
+import Text.ParserCombinators.Parsec
+import Text.Printf
+
+month = ["Jan", "Feb", "Mar", "Apr", "May", "Jun", "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
+week  = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
+
+formatRFC1123DateTime :: CalendarTime -> String
+formatRFC1123DateTime time
+    = printf "%s, %02d %s %04d %02d:%02d:%02d %s"
+      (week     !! fromEnum (ctWDay  time))
+      (ctDay    time)
+      (month    !! fromEnum (ctMonth time))
+      (ctYear   time)
+      (ctHour   time)
+      (ctMin    time)
+      (ctSec    time)
+      (ctTZName time)
+
+
+formatHTTPDateTime :: ClockTime -> String
+formatHTTPDateTime = formatRFC1123DateTime . (\cal -> cal { ctTZName = "GMT" }) . toUTCTime
+
+
+parseHTTPDateTime :: String -> Maybe ClockTime
+parseHTTPDateTime src
+    = case parse httpDateTime "" src of
+        Right ct  -> Just ct
+        Left  err -> Nothing
+
+httpDateTime :: Parser ClockTime
+httpDateTime = do foldl (<|>) (unexpected "") (map (try . string) week)
+                  char ','
+                  char ' '
+                  day  <- liftM read (count 2 digit)
+                  char ' '
+                  mon  <- foldl (<|>) (unexpected "") (map tryEqToFst (zip month [1..]))
+                  char ' '
+                  year <- liftM read (count 4 digit)
+                  char ' '
+                  hour <- liftM read (count 2 digit)
+                  char ':'
+                  min  <- liftM read (count 2 digit)
+                  char ':'
+                  sec  <- liftM read (count 2 digit)
+                  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
+                             }
+    where
+      tryEqToFst :: (String, a) -> Parser a
+      tryEqToFst (str, a) = try $ string str >> return a
+      
\ No newline at end of file