Bump version to 0.4: Don't forget that conversion from ZonedTime to RFC-822 date...

[time-http.git] / Data / Time / Format / RFC822 / Internal.hs

diff --git a/Data/Time/Format/RFC822/Internal.hs b/Data/Time/Format/RFC822/Internal.hs
index d1f62d2c3b5d330a0bcc6b4430b7e9de8d7eef65..a4c3c22ba49d86506a83fe8d74eb16248f0b2258 100644 (file)
--- a/Data/Time/Format/RFC822/Internal.hs
+++ b/Data/Time/Format/RFC822/Internal.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE
-    FlexibleInstances
+    FlexibleContexts
+  , FlexibleInstances
   , MultiParamTypeClasses
   , OverloadedStrings
   , TemplateHaskell
@@ -12,10 +13,12 @@ module Data.Time.Format.RFC822.Internal
     )
     where
 import Control.Applicative
+import Control.Failure
 import Data.Ascii (Ascii, AsciiBuilder)
 import qualified Data.Ascii as A
 import Data.Attoparsec.Char8
 import Data.Convertible.Base
+import Data.Convertible.Utils
 import Data.Monoid.Unicode
 import Data.Tagged
 import Data.Time
@@ -26,17 +29,21 @@ import Prelude.Unicode
 -- |The phantom type for conversions between RFC 822 date and time
 -- strings and 'ZonedTime'.
 --
--- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
--- Tagged "Sun, 06 Nov 94 08:49:37 GMT"
+-- >>> convertAttempt (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc)
+-- Success (Tagged "Sun, 06 Nov 94 08:49:37 GMT")
+--
+-- Note that RFC 822 has a Y2K problem so converting 'ZonedTime' whose
+-- gregorian year is earlier than 1900 or from 2000 onward results in
+-- @'ConvertBoundsException' 'Day' 'ZonedTime'@.
 data RFC822
 
-instance ConvertSuccess ZonedTime (Tagged RFC822 Ascii) where
-    {-# INLINE convertSuccess #-}
-    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
+instance ConvertAttempt ZonedTime (Tagged RFC822 Ascii) where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = ((A.fromAsciiBuilder <$>) <$>) ∘ ca
 
-instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where
-    {-# INLINE convertSuccess #-}
-    convertSuccess = Tagged ∘ toAsciiBuilder
+instance ConvertAttempt ZonedTime (Tagged RFC822 AsciiBuilder) where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = (Tagged <$>) ∘ toAsciiBuilder
 
 instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where
     {-# INLINE convertSuccess #-}
@@ -120,7 +127,9 @@ zone = choice [ string "UT"  *> return (TimeZone 0 False "UT" )
               , read4digitsTZ
               ]
 
-toAsciiBuilder ∷ ZonedTime → AsciiBuilder
+toAsciiBuilder ∷ Failure (ConvertBoundsException Day ZonedTime) f
+               ⇒ ZonedTime
+               → f AsciiBuilder
 toAsciiBuilder zonedTime
     = let localTime          = zonedTimeToLocalTime zonedTime
           timeZone           = zonedTimeZone zonedTime
@@ -128,24 +137,29 @@ toAsciiBuilder zonedTime
           (_, _, week)       = toWeekDate  (localDay localTime)
           timeOfDay          = localTimeOfDay localTime
       in
-        shortWeekDayName week
-        ⊕ A.toAsciiBuilder ", "
-        ⊕ show2 day
-        ⊕ A.toAsciiBuilder " "
-        ⊕ shortMonthName month
-        ⊕ A.toAsciiBuilder " "
-        ⊕ show2 (year `mod` 100)
-        ⊕ A.toAsciiBuilder " "
-        ⊕ show2 (todHour timeOfDay)
-        ⊕ A.toAsciiBuilder ":"
-        ⊕ show2 (todMin timeOfDay)
-        ⊕ A.toAsciiBuilder ":"
-        ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
-        ⊕ A.toAsciiBuilder " "
-        ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
+        if year < 1900 ∨ year ≥ 2000 then
+            let minDay = fromGregorian 1900  1  1
+                maxDay = fromGregorian 1999 12 31
+            in
+              failure $ ConvertBoundsException minDay maxDay zonedTime
+        else
+            return $
+            shortWeekDayName week
+            ⊕ A.toAsciiBuilder ", "
+            ⊕ show2 day
+            ⊕ A.toAsciiBuilder " "
+            ⊕ shortMonthName month
+            ⊕ A.toAsciiBuilder " "
+            ⊕ show2 (year `mod` 100)
+            ⊕ A.toAsciiBuilder " "
+            ⊕ show2 (todHour timeOfDay)
+            ⊕ A.toAsciiBuilder ":"
+            ⊕ show2 (todMin timeOfDay)
+            ⊕ A.toAsciiBuilder ":"
+            ⊕ show2 (floor (todSec timeOfDay) ∷ Int)
+            ⊕ A.toAsciiBuilder " "
+            ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder)
 
-deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC822 Ascii        |])
-               , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |])
-               , ([t| TimeZone  |], [t| Tagged RFC822 Ascii        |])
+deriveAttempts [ ([t| TimeZone  |], [t| Tagged RFC822 Ascii        |])
                , ([t| TimeZone  |], [t| Tagged RFC822 AsciiBuilder |])
                ]