Data.Time.RFC733 now fully works

[time-http.git] / Data / Time / HTTP / Common.hs

diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs
index 1ea61de90bc2a21cc0e85a5d41fe63225d188a34..6cb59b3bc63aaf06b1701c0ba978dc80870d3c4c 100644 (file)
--- a/Data/Time/HTTP/Common.hs
+++ b/Data/Time/HTTP/Common.hs
@@ -9,15 +9,28 @@ module Data.Time.HTTP.Common
     , shortMonthName
     , shortMonthNameP
 
+    , longMonthName
+    , longMonthNameP
+
     , show2
     , show4
 
     , read2
     , read4
+
+    , showTZ
+    , read4digitsTZ
+
+    , assertWeekDayIsGood
+    , assertGregorianDateIsGood
+    , assertTimeOfDayIsGood
     )
     where
 
 import Control.Monad
+import Data.Fixed
+import Data.Time
+import Data.Time.Calendar.WeekDate
 import Text.Parsec
 
 shortWeekDayName :: Int -> String
@@ -108,6 +121,45 @@ shortMonthNameP
              , string "Dec" >> return 12
              ]
 
+longMonthName :: Int -> String
+longMonthName  1 = "January"
+longMonthName  2 = "February"
+longMonthName  3 = "March"
+longMonthName  4 = "April"
+longMonthName  5 = "May"
+longMonthName  6 = "June"
+longMonthName  7 = "July"
+longMonthName  8 = "August"
+longMonthName  9 = "September"
+longMonthName 10 = "October"
+longMonthName 11 = "November"
+longMonthName 12 = "December"
+longMonthName  n = error ("longMonthName: unknown month number: " ++ show n)
+
+longMonthNameP :: Stream s m Char => ParsecT s u m Int
+longMonthNameP
+    = choice [ char 'J'
+               >> choice [ string "anuary" >> return 1
+                         , char 'u'
+                           >> choice [ string "ne" >> return 6
+                                     , string "ly" >> return 7
+                                     ]
+                         ]
+             , string "February" >> return 2
+             , string "Ma"
+               >> choice [ string "rch" >> return 3
+                         , char 'y' >> return 5
+                         ]
+             , char 'A'
+               >> choice [ string "pril" >> return 4
+                         , string "ugust" >> return 8
+                         ]
+             , string "September" >> return 9
+             , string "October"   >> return 10
+             , string "November"  >> return 11
+             , string "December"  >> return 12
+             ]
+
 show4 :: Integral i => i -> String
 show4 i
     | i >= 0 && i < 10    = "000" ++ show i
@@ -149,3 +201,76 @@ fromC '7' = 7
 fromC '8' = 8
 fromC '9' = 9
 fromC _   = undefined
+
+showTZ :: TimeZone -> String
+showTZ tz
+    = case timeZoneMinutes tz of
+        offset | offset <  0 -> '-' : showTZ' (negate offset)
+               | otherwise   -> '+' : showTZ' offset
+    where
+      showTZ' offset
+          = let h = offset `div` 60
+                m = offset - h * 60
+            in
+              concat [show2 h, show2 m]
+
+read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone
+read4digitsTZ
+    = do sign   <- (char '+' >> return 1)
+                   <|>
+                   (char '-' >> return (-1))
+         hour   <- read2
+         minute <- read2
+         let tz = TimeZone {
+                    timeZoneMinutes    = (sign * (hour * 60 + minute))
+                  , timeZoneSummerOnly = False
+                  , timeZoneName       = timeZoneOffsetString tz
+                  }
+         return tz
+
+assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m ()
+assertWeekDayIsGood givenWD gregDay
+    = let (_, _, correctWD ) = toWeekDate  gregDay
+          (year, month, day) = toGregorian gregDay
+      in
+        unless (givenWD == correctWD)
+                   $ fail
+                   $ concat [ "Gregorian day "
+                            , show year
+                            , "-"
+                            , show month
+                            , "-"
+                            , show day
+                            , " is "
+                            , longWeekDayName correctWD
+                            , ", not "
+                            , longWeekDayName givenWD
+                            ]
+
+assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day
+assertGregorianDateIsGood year month day
+    = case fromGregorianValid year month day of
+        Nothing
+            -> fail $ concat [ "Invalid gregorian day: "
+                             , show year
+                             , "-"
+                             , show month
+                             , "-"
+                             , show day
+                             ]
+        Just gregDay
+            -> return gregDay
+
+assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay
+assertTimeOfDayIsGood hour minute second
+    = case makeTimeOfDayValid hour minute second of
+        Nothing
+            -> fail $ concat [ "Invalid time of day: "
+                             , show hour
+                             , ":"
+                             , show minute
+                             , ":"
+                             , showFixed True second
+                             ]
+        Just tod
+            -> return tod