From daca86c87e52ed787d06306952f27a3d386e3a76 Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 16 Dec 2011 22:15:00 +0900 Subject: [PATCH] Bump version to 0.4: Don't forget that conversion from ZonedTime to RFC-822 date and time can fail, due to its Y2K problem. --- ChangeLog | 2 + Data/Time/Format/RFC822/Internal.hs | 70 +++++++++++-------- Test/Time/Format/HTTP.hs | 17 +++-- ...73d7c8927894257a438b5f02752d3ba702f66.yaml | 27 +++++++ bugs/project.yaml | 9 +++ time-http.cabal | 8 ++- 6 files changed, 96 insertions(+), 37 deletions(-) create mode 100644 bugs/issue-d8873d7c8927894257a438b5f02752d3ba702f66.yaml diff --git a/ChangeLog b/ChangeLog index 8f305ee..86a8379 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +== time-http-0.4 / unreleased +* bugfix: Don't forget that conversion from ZonedTime to RFC-822 date and time can fail, due to its Y2K problem. == time-http-0.3 / 2011-12-15 * Use tagged and convertible == time-http-0.2 / 2011-10-03 diff --git a/Data/Time/Format/RFC822/Internal.hs b/Data/Time/Format/RFC822/Internal.hs index d1f62d2..a4c3c22 100644 --- 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 |]) ] diff --git a/Test/Time/Format/HTTP.hs b/Test/Time/Format/HTTP.hs index b443e86..67cdfc1 100644 --- a/Test/Time/Format/HTTP.hs +++ b/Test/Time/Format/HTTP.hs @@ -115,11 +115,13 @@ tests = [ -- Asctime ≡ Just referenceZonedTime ) - , property ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii) - ≡ cs referenceZonedTime + , property ( Just (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii) + ≡ fromAttempt (ca referenceZonedTime) ) - , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime)) - ∷ Tagged RFC822 Ascii)) + , property $ \zt → let zt' = do a ← ca $ untag (zt ∷ Tagged Cent20 ZonedTime) + ca (a ∷ Tagged RFC822 Ascii) + in + fromAttempt zt' ≡ Just (untag zt) -- RFC1123 , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)) @@ -139,8 +141,11 @@ tests = [ -- Asctime , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime) , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged C Ascii))) , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii))) - , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime))) - ∷ Tagged RFC822 Ascii))) + , property $ \ut → let zt = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime) + ut' = do a ← ca zt + ca $ retagHTTP (a ∷ Tagged RFC822 Ascii) + in + fromAttempt ut' ≡ Just (untag ut) , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii))) ] where diff --git a/bugs/issue-d8873d7c8927894257a438b5f02752d3ba702f66.yaml b/bugs/issue-d8873d7c8927894257a438b5f02752d3ba702f66.yaml new file mode 100644 index 0000000..455210f --- /dev/null +++ b/bugs/issue-d8873d7c8927894257a438b5f02752d3ba702f66.yaml @@ -0,0 +1,27 @@ +--- !ditz.rubyforge.org,2008-03-06/issue +title: Don't forget that conversion from ZonedTime to RFC-822 date and time can fail, due to its Y2K problem. +desc: Make it ConvertAttempt, not ConvertSuccess. +type: :bugfix +component: time-http +release: time-http-0.4 +reporter: PHO +status: :closed +disposition: :fixed +creation_time: 2011-12-16 13:11:18.237158 Z +references: [] + +id: d8873d7c8927894257a438b5f02752d3ba702f66 +log_events: +- - 2011-12-16 13:11:24.381526 Z + - PHO + - created + - Done. +- - 2011-12-16 13:11:53.887803 Z + - PHO + - assigned to release time-http-0.4 from unassigned + - "" +- - 2011-12-16 13:12:10.385138 Z + - PHO + - closed with disposition fixed + - "" +git_branch: diff --git a/bugs/project.yaml b/bugs/project.yaml index 2b11e71..b6d3445 100644 --- a/bugs/project.yaml +++ b/bugs/project.yaml @@ -31,3 +31,12 @@ releases: - PHO - released - Done, but I'm not so confident with my own changes... +- !ditz.rubyforge.org,2008-03-06/release + name: time-http-0.4 + status: :unreleased + release_time: + log_events: + - - 2011-12-16 13:11:37.518764 Z + - PHO + - created + - "" diff --git a/time-http.cabal b/time-http.cabal index d30a68a..5f0cc63 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -1,5 +1,5 @@ Name: time-http -Version: 0.3 +Version: 0.4 Synopsis: Parse and format HTTP/1.1 Date and Time strings Description: This package provides functionalities to parse and format @@ -40,13 +40,14 @@ Library Build-depends: ascii == 0.0.*, attempt == 0.3.*, - attoparsec == 0.9.*, + attoparsec == 0.10.*, base == 4.*, base-unicode-symbols == 0.2.*, blaze-builder == 0.3.*, blaze-textual == 0.2.*, bytestring == 0.9.*, convertible-text == 0.4.*, + failure == 0.1.*, tagged == 0.2.*, time == 1.2.* @@ -64,13 +65,14 @@ Test-Suite test-time-http QuickCheck == 2.4.*, ascii == 0.0.*, attempt == 0.3.*, - attoparsec == 0.9.*, + attoparsec == 0.10.*, base == 4.*, base-unicode-symbols == 0.2.*, blaze-builder == 0.3.*, blaze-textual == 0.2.*, bytestring == 0.9.*, convertible-text == 0.4.*, + failure == 0.1.*, tagged == 0.2.*, time == 1.2.* GHC-Options: -- 2.40.0