From 782e6a9bfebeb1036921a293549395c17f0f035c Mon Sep 17 00:00:00 2001 From: PHO Date: Fri, 9 Dec 2011 13:46:40 +0900 Subject: [PATCH] Rewrote RFC733 Ditz-issue: 0a3272772c73cf31486eb2b6691fa38232d3c4c5 --- Data/Time/Asctime.hs | 13 +-- Data/Time/RFC733.hs | 171 ++++++++++++++++++++++++++++++----- Data/Time/RFC733/Internal.hs | 139 ---------------------------- Test/Time/HTTP.hs | 33 ++++--- time-http.cabal | 5 +- 5 files changed, 173 insertions(+), 188 deletions(-) delete mode 100644 Data/Time/RFC733/Internal.hs diff --git a/Data/Time/Asctime.hs b/Data/Time/Asctime.hs index de9de39..f8d28cc 100644 --- a/Data/Time/Asctime.hs +++ b/Data/Time/Asctime.hs @@ -2,6 +2,7 @@ FlexibleInstances , MultiParamTypeClasses , OverloadedStrings + , TemplateHaskell , UnicodeSyntax #-} -- |This module provides functions for ANSI C's asctime() format. @@ -52,18 +53,10 @@ instance ConvertSuccess LocalTime (Tagged Asctime Ascii) where {-# INLINE convertSuccess #-} convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs -instance ConvertAttempt LocalTime (Tagged Asctime Ascii) where - {-# INLINE convertAttempt #-} - convertAttempt = return ∘ cs - instance ConvertSuccess LocalTime (Tagged Asctime AsciiBuilder) where {-# INLINE convertSuccess #-} convertSuccess = Tagged ∘ toAsciiBuilder -instance ConvertAttempt LocalTime (Tagged Asctime AsciiBuilder) where - {-# INLINE convertAttempt #-} - convertAttempt = return ∘ cs - instance ConvertAttempt (Tagged Asctime Ascii) LocalTime where {-# INLINE convertAttempt #-} convertAttempt = parseAttempt' asctime ∘ untag @@ -109,3 +102,7 @@ toAsciiBuilder localTime ⊕ show2 (floor (todSec timeOfDay) ∷ Int) ⊕ A.toAsciiBuilder " " ⊕ show4 year + +deriveAttempts [ ([t| LocalTime |], [t| Tagged Asctime Ascii |]) + , ([t| LocalTime |], [t| Tagged Asctime AsciiBuilder |]) + ] diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs index 6234c1b..e6981af 100644 --- a/Data/Time/RFC733.hs +++ b/Data/Time/RFC733.hs @@ -1,5 +1,9 @@ {-# LANGUAGE - UnicodeSyntax + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 733 date -- and time formats. @@ -41,31 +45,156 @@ -- > | "Y" ; +12 -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM module Data.Time.RFC733 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii + ( RFC733 , rfc733DateAndTime ) where -import Data.Ascii (Ascii) +import Control.Applicative +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P +import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Monoid.Unicode +import Data.Tagged import Data.Time -import Data.Time.RFC733.Internal +import Data.Time.Calendar.WeekDate +import Data.Time.RFC822.Internal hiding (toAsciiBuilder) +import Data.Time.HTTP.Common import Prelude.Unicode --- |Convert a 'ZonedTime' to RFC 733 date and time string. -toAscii ∷ ZonedTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder +-- FIXME: docs +data RFC733 --- |Parse an RFC 733 date and time string. When the string can't be --- parsed, it returns @'Left' err@. -fromAscii ∷ Ascii → Either String ZonedTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← rfc733DateAndTime - P.endOfInput - return zt +instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag + +rfc733DateAndTime ∷ Parser ZonedTime +rfc733DateAndTime = dateTime + +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← longWeekDayNameP + <|> + shortWeekDayNameP + _ ← string ", " + return w + gregDay ← date + case weekDay of + Nothing + → return () + Just givenWD + → assertWeekDayIsGood givenWD gregDay + (tod, timeZone) ← time + let lt = LocalTime gregDay tod + zt = ZonedTime lt timeZone + return zt + +date ∷ Parser Day +date = do day ← read2 + _ ← char '-' <|> char ' ' + month ← try longMonthNameP + <|> + shortMonthNameP + _ ← char '-' <|> char ' ' + year ← try read4 + <|> + (+ 1900) <$> read2 + _ ← char ' ' + assertGregorianDateIsGood year month day + +time ∷ Parser (TimeOfDay, TimeZone) +time = do tod ← hms + _ ← char '-' <|> char ' ' + tz ← zone + return (tod, tz) + +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + _ ← optional (char ':') + minute ← read2 + second ← option 0 $ + do _ ← optional (char ':') + read2 + assertTimeOfDayIsGood hour minute second + +zone ∷ Parser TimeZone +zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT") + , char 'N' + *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST") + , return (TimeZone (1 * 60) False "N") + ] + , char 'A' + *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST") + , string "DT" *> return (TimeZone ((-3) * 60) False "AST") + , return (TimeZone ((-1) * 60) False "A") + ] + , char 'E' + *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST") + , string "DT" *> return (TimeZone ((-4) * 60) True "EDT") + ] + , char 'C' + *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST") + , string "DT" *> return (TimeZone ((-5) * 60) True "CDT") + ] + , char 'M' + *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST") + , string "DT" *> return (TimeZone ((-6) * 60) True "MDT") + , return (TimeZone ((-12) * 60) False "M") + ] + , char 'P' + *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST") + , string "DT" *> return (TimeZone ((-7) * 60) True "PDT") + ] + , char 'Y' + *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST") + , string "DT" *> return (TimeZone ((-8) * 60) True "YDT") + , return (TimeZone ( 12 * 60) False "Y") + ] + , char 'H' + *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST") + , string "DT" *> return (TimeZone (( -9) * 60) True "HDT") + ] + , char 'B' + *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST") + , string "DT" *> return (TimeZone ((-10) * 60) True "BDT") + ] + , char 'Z' *> return (TimeZone 0 False "Z") + , read4digitsTZ + ] + +toAsciiBuilder ∷ ZonedTime → AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime zonedTime + timeZone = zonedTimeZone zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + longWeekDayName week + ⊕ A.toAsciiBuilder ", " + ⊕ show2 day + ⊕ A.toAsciiBuilder "-" + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder "-" + ⊕ show4 year + ⊕ A.toAsciiBuilder " " + ⊕ show2 (todHour timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (todMin timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (floor (todSec timeOfDay) ∷ Int) + ⊕ A.toAsciiBuilder " " + ⊕ showRFC822TimeZone timeZone + +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |]) + ] diff --git a/Data/Time/RFC733/Internal.hs b/Data/Time/RFC733/Internal.hs deleted file mode 100644 index 4037918..0000000 --- a/Data/Time/RFC733/Internal.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} --- |Internal functions for "Data.Time.RFC733". -module Data.Time.RFC733.Internal - ( rfc733DateAndTime - , toAsciiBuilder - ) - where -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Control.Applicative -import Data.Attoparsec.Char8 -import Data.Monoid.Unicode -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822.Internal hiding (toAsciiBuilder) - --- |Parse RFC 733 date and time strings. -rfc733DateAndTime ∷ Parser ZonedTime -rfc733DateAndTime = dateTime - -dateTime ∷ Parser ZonedTime -dateTime = do weekDay ← optionMaybe $ - do w ← longWeekDayNameP - <|> - shortWeekDayNameP - _ ← string ", " - return w - gregDay ← date - case weekDay of - Nothing - → return () - Just givenWD - → assertWeekDayIsGood givenWD gregDay - (tod, timeZone) ← time - let lt = LocalTime gregDay tod - zt = ZonedTime lt timeZone - return zt - -date ∷ Parser Day -date = do day ← read2 - _ ← char '-' <|> char ' ' - month ← try longMonthNameP - <|> - shortMonthNameP - _ ← char '-' <|> char ' ' - year ← try read4 - <|> - (+ 1900) <$> read2 - _ ← char ' ' - assertGregorianDateIsGood year month day - -time ∷ Parser (TimeOfDay, TimeZone) -time = do tod ← hms - _ ← char '-' <|> char ' ' - tz ← zone - return (tod, tz) - -hms ∷ Parser TimeOfDay -hms = do hour ← read2 - _ ← optional (char ':') - minute ← read2 - second ← option 0 $ - do _ ← optional (char ':') - read2 - assertTimeOfDayIsGood hour minute second - -zone ∷ Parser TimeZone -zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT") - , char 'N' - *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST") - , return (TimeZone (1 * 60) False "N") - ] - , char 'A' - *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST") - , string "DT" *> return (TimeZone ((-3) * 60) False "AST") - , return (TimeZone ((-1) * 60) False "A") - ] - , char 'E' - *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST") - , string "DT" *> return (TimeZone ((-4) * 60) True "EDT") - ] - , char 'C' - *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST") - , string "DT" *> return (TimeZone ((-5) * 60) True "CDT") - ] - , char 'M' - *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST") - , string "DT" *> return (TimeZone ((-6) * 60) True "MDT") - , return (TimeZone ((-12) * 60) False "M") - ] - , char 'P' - *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST") - , string "DT" *> return (TimeZone ((-7) * 60) True "PDT") - ] - , char 'Y' - *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST") - , string "DT" *> return (TimeZone ((-8) * 60) True "YDT") - , return (TimeZone ( 12 * 60) False "Y") - ] - , char 'H' - *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST") - , string "DT" *> return (TimeZone (( -9) * 60) True "HDT") - ] - , char 'B' - *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST") - , string "DT" *> return (TimeZone ((-10) * 60) True "BDT") - ] - , char 'Z' *> return (TimeZone 0 False "Z") - , read4digitsTZ - ] - --- |Convert a 'ZonedTime' to RFC 733 date and time string. -toAsciiBuilder ∷ ZonedTime → AsciiBuilder -toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - longWeekDayName week - ⊕ A.toAsciiBuilder ", " - ⊕ show2 day - ⊕ A.toAsciiBuilder "-" - ⊕ shortMonthName month - ⊕ A.toAsciiBuilder "-" - ⊕ show4 year - ⊕ A.toAsciiBuilder " " - ⊕ show2 (todHour timeOfDay) - ⊕ A.toAsciiBuilder ":" - ⊕ show2 (todMin timeOfDay) - ⊕ A.toAsciiBuilder ":" - ⊕ show2 (floor (todSec timeOfDay) ∷ Int) - ⊕ A.toAsciiBuilder " " - ⊕ showRFC822TimeZone timeZone diff --git a/Test/Time/HTTP.hs b/Test/Time/HTTP.hs index 2f7225e..7ef3210 100644 --- a/Test/Time/HTTP.hs +++ b/Test/Time/HTTP.hs @@ -6,12 +6,13 @@ module Main (main) where import Control.Applicative import Control.Applicative.Unicode import Data.Ascii (Ascii) +import Data.Attempt hiding (Failure, Success) import Data.Convertible.Base import Data.Tagged import Data.Time import Data.Time.Asctime import qualified Data.Time.HTTP as HTTP -import qualified Data.Time.RFC733 as RFC733 +import Data.Time.RFC733 import qualified Data.Time.RFC1123 as RFC1123 import System.Exit import Prelude.Unicode @@ -63,30 +64,28 @@ instance Arbitrary UTCTime where tests ∷ [Property] tests = [ -- Asctime - property ( convertUnsafe ( Tagged "Sun Nov 6 08:49:37 1994" - ∷ Tagged Asctime Ascii - ) - ≡ referenceLocalTime + property ( fromAttempt (ca (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii)) + ≡ Just referenceLocalTime ) - , property ( ( Tagged "Sun Nov 6 08:49:37 1994" - ∷ Tagged Asctime Ascii - ) + , property ( (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii) ≡ cs referenceLocalTime ) - , property $ \lt → lt ≡ convertUnsafe ( cs (lt ∷ LocalTime) - ∷ Tagged Asctime Ascii - ) + , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) + ∷ Tagged Asctime Ascii)) -- RFC733 - , property ( RFC733.fromAscii "Sunday, 06-Nov-94 08:49:37 GMT" - ≡ Right referenceZonedTime ) + , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii)) + ≡ Just referenceZonedTime + ) - , property ( "Sunday, 06-Nov-1994 08:49:37 GMT" - ≡ RFC733.toAscii referenceZonedTime ) + , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii) + ≡ cs referenceZonedTime + ) - , property $ \zt → Right zt ≡ RFC733.fromAscii (RFC733.toAscii zt) + , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) + ∷ Tagged RFC733 Ascii)) -- RFC1123 , property ( RFC1123.fromAscii "Sun, 06 Nov 1994 08:49:37 GMT" @@ -100,7 +99,7 @@ tests = [ -- Asctime -- HTTP , property $ \ut → Right ut ≡ HTTP.fromAscii (HTTP.toAscii ut ) , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2lt ut) ∷ Tagged Asctime Ascii)) - , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC733.toAscii (ut2zt ut)) + , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)) , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC1123.toAscii (ut2zt ut)) ] where diff --git a/time-http.cabal b/time-http.cabal index b6bc9aa..bd7072c 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -36,7 +36,6 @@ Library Data.Time.HTTP.Common Data.Time.HTTP.Internal Data.Time.RFC1123.Internal - Data.Time.RFC733.Internal Data.Time.RFC822.Internal Build-depends: @@ -48,7 +47,7 @@ Library blaze-builder == 0.3.*, blaze-textual == 0.2.*, bytestring == 0.9.*, - convertible-text == 0.3.*, + convertible-text == 0.4.*, tagged == 0.2.*, time == 1.2.* @@ -72,7 +71,7 @@ Test-Suite test-time-http blaze-builder == 0.3.*, blaze-textual == 0.2.*, bytestring == 0.9.*, - convertible-text == 0.3.*, + convertible-text == 0.4.*, tagged == 0.2.*, time == 1.2.* GHC-Options: -- 2.40.0