From dac3f355097e647637a52dfa8dad43bbc5d589fa Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 12 Dec 2011 07:14:05 +0900 Subject: [PATCH] RFC1123 Ditz-issue: 0a3272772c73cf31486eb2b6691fa38232d3c4c5 --- Data/Time/HTTP/Internal.hs | 14 ++++- Data/Time/RFC1123.hs | 106 +++++++++++++++++++++++++++------- Data/Time/RFC1123/Internal.hs | 74 ------------------------ Data/Time/RFC822.hs | 4 +- Test/Time/HTTP.hs | 17 +++--- time-http.cabal | 1 - 6 files changed, 109 insertions(+), 107 deletions(-) delete mode 100644 Data/Time/RFC1123/Internal.hs diff --git a/Data/Time/HTTP/Internal.hs b/Data/Time/HTTP/Internal.hs index 6e0753d..b008d9d 100644 --- a/Data/Time/HTTP/Internal.hs +++ b/Data/Time/HTTP/Internal.hs @@ -10,8 +10,10 @@ module Data.Time.HTTP.Internal import Control.Applicative import Data.Ascii (AsciiBuilder) import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Tagged import Data.Time -import qualified Data.Time.RFC1123.Internal as RFC1123 +import Data.Time.RFC1123 import Data.Time.RFC733 import Data.Time.Asctime import Prelude.Unicode @@ -20,17 +22,23 @@ import Prelude.Unicode -- (RFC 2616). httpDateAndTime ∷ Parser UTCTime httpDateAndTime - = choice [ zonedTimeToUTC <$> try RFC1123.rfc1123DateAndTime + = choice [ zonedTimeToUTC <$> try rfc1123DateAndTime , zonedTimeToUTC <$> try rfc733DateAndTime , localTimeToUTC utc <$> asctime ] -- |Convert a 'UTCTime' to RFC 1123 date and time string. toAsciiBuilder ∷ UTCTime → AsciiBuilder -toAsciiBuilder = RFC1123.toAsciiBuilder ∘ ut2zt +toAsciiBuilder = untag' ∘ cs ∘ ut2zt where + untag' ∷ Tagged RFC1123 AsciiBuilder → AsciiBuilder + {-# INLINE CONLIKE untag' #-} + untag' = untag + ut2zt ∷ UTCTime → ZonedTime + {-# INLINE ut2zt #-} ut2zt = utcToZonedTime gmt gmt ∷ TimeZone + {-# INLINE CONLIKE gmt #-} gmt = TimeZone 0 False "GMT" diff --git a/Data/Time/RFC1123.hs b/Data/Time/RFC1123.hs index fb7839d..c00bf73 100644 --- a/Data/Time/RFC1123.hs +++ b/Data/Time/RFC1123.hs @@ -1,5 +1,9 @@ {-# LANGUAGE - UnicodeSyntax + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 1123 date -- and time formats. @@ -13,31 +17,91 @@ -- -- > year ::= 4DIGIT module Data.Time.RFC1123 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii + ( RFC1123 , rfc1123DateAndTime ) 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.RFC1123.Internal +import Data.Time.Calendar.WeekDate +import Data.Time.HTTP.Common +import Data.Time.RFC822 import Prelude.Unicode --- |Convert a 'ZonedTime' to RFC 1123 date and time string. -toAscii ∷ ZonedTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder +-- FIXME: doc +data RFC1123 --- |Parse an RFC 1123 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 ← rfc1123DateAndTime - P.endOfInput - return zt +instance ConvertSuccess ZonedTime (Tagged RFC1123 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag + +-- |Parse an RFC 1123 date and time string. +rfc1123DateAndTime ∷ Parser ZonedTime +rfc1123DateAndTime = dateTime + +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + _ ← string ", " + return w + gregDay ← date + case weekDay of + Nothing + → return () + Just givenWD + → assertWeekDayIsGood givenWD gregDay + (tod, timeZone) ← rfc822Time + let lt = LocalTime gregDay tod + zt = ZonedTime lt timeZone + return zt + +date ∷ Parser Day +date = do day ← read2 + _ ← char ' ' + month ← shortMonthNameP + _ ← char ' ' + year ← read4 + _ ← char ' ' + assertGregorianDateIsGood year month day + +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 + shortWeekDayName 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 " " + ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) + +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |]) + ] diff --git a/Data/Time/RFC1123/Internal.hs b/Data/Time/RFC1123/Internal.hs deleted file mode 100644 index 9fd1e83..0000000 --- a/Data/Time/RFC1123/Internal.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} --- |Internal functions for "Data.Time.RFC1123". -module Data.Time.RFC1123.Internal - ( rfc1123DateAndTime - , toAsciiBuilder - ) - where -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 -import Data.Convertible.Base -import Data.Monoid.Unicode -import Data.Tagged -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822 - --- |Parse an RFC 1123 date and time string. -rfc1123DateAndTime ∷ Parser ZonedTime -rfc1123DateAndTime = dateTime - -dateTime ∷ Parser ZonedTime -dateTime = do weekDay ← optionMaybe $ - do w ← shortWeekDayNameP - _ ← string ", " - return w - gregDay ← date - case weekDay of - Nothing - → return () - Just givenWD - → assertWeekDayIsGood givenWD gregDay - (tod, timeZone) ← rfc822Time - let lt = LocalTime gregDay tod - zt = ZonedTime lt timeZone - return zt - -date ∷ Parser Day -date = do day ← read2 - _ ← char ' ' - month ← shortMonthNameP - _ ← char ' ' - year ← read4 - _ ← char ' ' - assertGregorianDateIsGood year month day - --- |Convert a 'ZonedTime' to RFC 1123 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 - shortWeekDayName 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 " " - ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) diff --git a/Data/Time/RFC822.hs b/Data/Time/RFC822.hs index a5c1a0b..df6527c 100644 --- a/Data/Time/RFC822.hs +++ b/Data/Time/RFC822.hs @@ -63,10 +63,12 @@ instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where {-# INLINE convertSuccess #-} convertSuccess = Tagged ∘ toAsciiBuilder +-- |FIXME: move this to RFC822.Internal instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where {-# INLINE convertSuccess #-} convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs +-- |FIXME: move this to RFC822.Internal instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where {-# INLINE convertSuccess #-} convertSuccess tz @@ -106,7 +108,7 @@ date = do day ← read2 _ ← char ' ' assertGregorianDateIsGood year month day --- |Parse the time and time zone of an RFC 822 date and time string. +-- |FIXME: move this to RFC822.Internal rfc822Time ∷ Parser (TimeOfDay, TimeZone) rfc822Time = do tod ← hms _ ← char ' ' diff --git a/Test/Time/HTTP.hs b/Test/Time/HTTP.hs index 7ef3210..3022d0d 100644 --- a/Test/Time/HTTP.hs +++ b/Test/Time/HTTP.hs @@ -13,7 +13,7 @@ import Data.Time import Data.Time.Asctime import qualified Data.Time.HTTP as HTTP import Data.Time.RFC733 -import qualified Data.Time.RFC1123 as RFC1123 +import Data.Time.RFC1123 import System.Exit import Prelude.Unicode import Test.QuickCheck @@ -88,19 +88,22 @@ tests = [ -- Asctime ∷ Tagged RFC733 Ascii)) -- RFC1123 - , property ( RFC1123.fromAscii "Sun, 06 Nov 1994 08:49:37 GMT" - ≡ Right referenceZonedTime ) + , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)) + ≡ Just referenceZonedTime + ) - , property ( "Sun, 06 Nov 1994 08:49:37 GMT" - ≡ RFC1123.toAscii referenceZonedTime ) + , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii) + ≡ cs referenceZonedTime + ) - , property $ \zt → Right zt ≡ RFC1123.fromAscii (RFC1123.toAscii zt) + , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) + ∷ Tagged RFC1123 Ascii)) -- 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 (untag (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)) - , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC1123.toAscii (ut2zt ut)) + , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)) ] where referenceLocalTime diff --git a/time-http.cabal b/time-http.cabal index 46d18cc..f7668d7 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -35,7 +35,6 @@ Library Other-modules: Data.Time.HTTP.Common Data.Time.HTTP.Internal - Data.Time.RFC1123.Internal Build-depends: ascii == 0.0.*, -- 2.40.0