From: PHO Date: Tue, 3 Jan 2012 00:24:17 +0000 (+0900) Subject: Use data-default to provide fafault parsers; remove proxies. X-Git-Tag: RELEASE-0.5~1^2~1 X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=e8f778a;p=time-http.git Use data-default to provide fafault parsers; remove proxies. Ditz-issue: 42a90d1c79f29dc9cf8ecccb9d070f151633904a --- diff --git a/Data/Time/Format/C.hs b/Data/Time/Format/C.hs index 0c204d5..ba9fee8 100644 --- a/Data/Time/Format/C.hs +++ b/Data/Time/Format/C.hs @@ -3,6 +3,7 @@ , MultiParamTypeClasses , OverloadedStrings , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |This module provides functions for ANSI C's date and time strings. @@ -24,17 +25,14 @@ -- > year ::= 4DIGIT module Data.Time.Format.C ( C - , c - , cDateAndTime ) where -import Control.Applicative import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 import Data.Convertible.Base +import Data.Default import Data.Monoid.Unicode -import Data.Proxy import Data.Tagged import Data.Time import Data.Time.Calendar.WeekDate @@ -44,50 +42,44 @@ import Prelude.Unicode -- |The phantom type for conversions between ANSI C's date and time -- strings and 'LocalTime'. -- --- >>> convertSuccess (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) --- Tagged "Sun Nov 6 08:49:37 1994" +-- >>> convertSuccess (Tagged (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) :: Tagged C LocalTime) +-- "Sun Nov 6 08:49:37 1994" data C --- |The proxy for conversions between ANSI C's date and time strings --- and 'LocalTime'. -c ∷ Proxy C -{-# INLINE CONLIKE c #-} -c = Proxy - -instance ConvertSuccess LocalTime (Tagged C Ascii) where +instance ConvertSuccess (Tagged C LocalTime) Ascii where {-# INLINE convertSuccess #-} - convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + convertSuccess = A.fromAsciiBuilder ∘ cs -instance ConvertSuccess LocalTime (Tagged C AsciiBuilder) where +instance ConvertSuccess (Tagged C LocalTime) AsciiBuilder where {-# INLINE convertSuccess #-} - convertSuccess = Tagged ∘ toAsciiBuilder + convertSuccess = toAsciiBuilder ∘ untag -instance ConvertAttempt (Tagged C Ascii) LocalTime where +instance ConvertAttempt Ascii (Tagged C LocalTime) where {-# INLINE convertAttempt #-} - convertAttempt = parseAttempt' cDateAndTime ∘ untag + convertAttempt = parseAttempt' def -- |Parse an ANSI C's date and time string. -cDateAndTime ∷ Parser LocalTime -cDateAndTime - = do weekDay ← shortWeekDayNameP - _ ← char ' ' - month ← shortMonthNameP - _ ← char ' ' - day ← read2' - _ ← char ' ' - hour ← read2 - _ ← char ':' - minute ← read2 - _ ← char ':' - second ← read2 - _ ← char ' ' - year ← read4 +instance Default (Parser (Tagged C LocalTime)) where + {-# INLINEABLE def #-} + def = do weekDay ← shortWeekDayNameP + _ ← char ' ' + month ← shortMonthNameP + _ ← char ' ' + day ← read2' + _ ← char ' ' + hour ← read2 + _ ← char ':' + minute ← read2 + _ ← char ':' + second ← read2 + _ ← char ' ' + year ← read4 - gregDay ← assertGregorianDateIsGood year month day - _ ← assertWeekDayIsGood weekDay gregDay - tod ← assertTimeOfDayIsGood hour minute second + gregDay ← assertGregorianDateIsGood year month day + _ ← assertWeekDayIsGood weekDay gregDay + tod ← assertTimeOfDayIsGood hour minute second - return (LocalTime gregDay tod) + return ∘ Tagged $ LocalTime gregDay tod toAsciiBuilder ∷ LocalTime → AsciiBuilder toAsciiBuilder localTime @@ -109,6 +101,6 @@ toAsciiBuilder localTime ⊕ A.toAsciiBuilder " " ⊕ show4 year -deriveAttempts [ ([t| LocalTime |], [t| Tagged C Ascii |]) - , ([t| LocalTime |], [t| Tagged C AsciiBuilder |]) +deriveAttempts [ ([t| Tagged C LocalTime |], [t| Ascii |]) + , ([t| Tagged C LocalTime |], [t| AsciiBuilder |]) ] diff --git a/Data/Time/Format/HTTP.hs b/Data/Time/Format/HTTP.hs index 2c44147..1d2ceac 100644 --- a/Data/Time/Format/HTTP.hs +++ b/Data/Time/Format/HTTP.hs @@ -3,6 +3,7 @@ , MultiParamTypeClasses , OverloadedStrings , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |This module provides functions to parse and format HTTP\/1.1 date @@ -46,8 +47,6 @@ -- > | "Sep" | "Oct" | "Nov" | "Dec" module Data.Time.Format.HTTP ( HTTP - , http - , httpDateAndTime ) where import Control.Applicative @@ -55,7 +54,7 @@ import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 import Data.Convertible.Base -import Data.Proxy +import Data.Default import Data.Tagged import Data.Time import Data.Time.Format.C @@ -68,47 +67,42 @@ import Prelude.Unicode -- |The phantom type for conversions between HTTP/1.1 date and time -- strings and 'UTCTime'. -- --- >>> convertSuccess (UTCTime (ModifiedJulianDay 49662) 31777) --- Tagged "Sun, 06 Nov 1994 08:49:37 GMT" +-- >>> convertSuccess (Tagged (UTCTime (ModifiedJulianDay 49662) 31777) :: Tagged HTTP UTCTime) +-- "Sun, 06 Nov 1994 08:49:37 GMT" data HTTP --- |The proxy for conversions between ANSI HTTP/1.1 date and time --- strings and 'UTCTime'. -http ∷ Proxy HTTP -{-# INLINE CONLIKE http #-} -http = Proxy - -instance ConvertSuccess UTCTime (Tagged HTTP Ascii) where +instance ConvertSuccess (Tagged HTTP UTCTime) Ascii where {-# INLINE convertSuccess #-} - convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + convertSuccess = A.fromAsciiBuilder ∘ cs -instance ConvertSuccess UTCTime (Tagged HTTP AsciiBuilder) where +instance ConvertSuccess (Tagged HTTP UTCTime) AsciiBuilder where {-# INLINE convertSuccess #-} - convertSuccess = Tagged ∘ toAsciiBuilder + convertSuccess = toAsciiBuilder -instance ConvertAttempt (Tagged HTTP Ascii) UTCTime where +instance ConvertAttempt Ascii (Tagged HTTP UTCTime) where {-# INLINE convertAttempt #-} - convertAttempt = parseAttempt' httpDateAndTime ∘ untag + convertAttempt = parseAttempt' def -- |Parse a date and time string in any of RFC 822, RFC 1123, RFC 850 -- and ANSI C's asctime() formats. -- --- This function is even more permissive than what HTTP\/1.1 (RFC --- 2616) specifies. That is, it accepts 2-digit years in RFC 822, --- omitted separator symbols in RFC 850, omitted sec fields, and --- non-GMT time zones. I believe this behavior will not cause a --- problem though. -httpDateAndTime ∷ Parser UTCTime -httpDateAndTime - = choice [ zonedTimeToUTC <$> try rfc1123DateAndTime - , zonedTimeToUTC <$> try rfc733DateAndTime - , zonedTimeToUTC <$> try rfc822DateAndTime - , localTimeToUTC utc <$> cDateAndTime - ] +-- This parser is even more permissive than what HTTP\/1.1 (RFC 2616) +-- specifies. That is, it accepts 2-digit years in RFC 822, omitted +-- separator symbols in RFC 850, omitted sec fields, and non-GMT time +-- zones. I believe this behavior will not cause a problem though. +instance Default (Parser (Tagged HTTP UTCTime)) where + {-# INLINEABLE def #-} + def = Tagged + <$> + choice [ (zonedTimeToUTC ∘ untag) <$> try (def ∷ Parser (Tagged RFC1123 ZonedTime)) + , (zonedTimeToUTC ∘ untag) <$> try (def ∷ Parser (Tagged RFC733 ZonedTime)) + , (zonedTimeToUTC ∘ untag) <$> try (def ∷ Parser (Tagged RFC822 ZonedTime)) + , (localTimeToUTC utc ∘ untag) <$> (def ∷ Parser (Tagged C LocalTime)) + ] -toAsciiBuilder ∷ UTCTime → AsciiBuilder -{-# INLINE toAsciiBuilder #-} -toAsciiBuilder = flip proxy rfc1123 ∘ cs ∘ ut2zt +toAsciiBuilder ∷ Tagged HTTP UTCTime → AsciiBuilder +{-# INLINEABLE toAsciiBuilder #-} +toAsciiBuilder = cs ∘ (ut2zt <$>) ∘ retag' where ut2zt ∷ UTCTime → ZonedTime {-# INLINE ut2zt #-} @@ -118,6 +112,10 @@ toAsciiBuilder = flip proxy rfc1123 ∘ cs ∘ ut2zt {-# INLINE CONLIKE gmt #-} gmt = TimeZone 0 False "GMT" -deriveAttempts [ ([t| UTCTime |], [t| Tagged HTTP Ascii |]) - , ([t| UTCTime |], [t| Tagged HTTP AsciiBuilder |]) + retag' ∷ Tagged τ α → Tagged RFC1123 α + {-# INLINE retag' #-} + retag' = retag + +deriveAttempts [ ([t| Tagged HTTP UTCTime |], [t| Ascii |]) + , ([t| Tagged HTTP UTCTime |], [t| AsciiBuilder |]) ] diff --git a/Data/Time/Format/RFC1123.hs b/Data/Time/Format/RFC1123.hs index 1d4f28e..9f3fbd6 100644 --- a/Data/Time/Format/RFC1123.hs +++ b/Data/Time/Format/RFC1123.hs @@ -3,6 +3,7 @@ , MultiParamTypeClasses , OverloadedStrings , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 1123 date @@ -18,68 +19,61 @@ -- > year ::= 4DIGIT module Data.Time.Format.RFC1123 ( RFC1123 - , rfc1123 - , rfc1123DateAndTime ) where import Control.Applicative +import Control.Applicative.Unicode import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 import Data.Convertible.Base +import Data.Default import Data.Monoid.Unicode -import Data.Proxy import Data.Tagged import Data.Time import Data.Time.Calendar.WeekDate import Data.Time.Format.HTTP.Common -import Data.Time.Format.RFC822.Internal +import Data.Time.Format.RFC822 import Prelude.Unicode -- |The phantom type for conversions between RFC 1123 date and time -- strings and 'ZonedTime'. -- --- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) --- Tagged "Sun, 06 Nov 1994 08:49:37 GMT" +-- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC1123 ZonedTime) +-- "Sun, 06 Nov 1994 08:49:37 GMT" data RFC1123 --- |The proxy for conversions between RFC 1123 date and time strings --- and 'ZonedTime'. -rfc1123 ∷ Proxy RFC1123 -{-# INLINE CONLIKE rfc1123 #-} -rfc1123 = Proxy - -instance ConvertSuccess ZonedTime (Tagged RFC1123 Ascii) where +instance ConvertSuccess (Tagged RFC1123 ZonedTime) Ascii where {-# INLINE convertSuccess #-} - convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + convertSuccess = A.fromAsciiBuilder ∘ cs -instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where +instance ConvertSuccess (Tagged RFC1123 ZonedTime) AsciiBuilder where {-# INLINE convertSuccess #-} - convertSuccess = Tagged ∘ toAsciiBuilder + convertSuccess = toAsciiBuilder -instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where +instance ConvertAttempt Ascii (Tagged RFC1123 ZonedTime) where {-# INLINE convertAttempt #-} - convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag + convertAttempt = parseAttempt' def -- |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 +instance Default (Parser (Tagged RFC1123 ZonedTime)) where + def = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + string ", " *> pure w + gregDay ← date + case weekDay of + Nothing + → return () + Just givenWD + → assertWeekDayIsGood givenWD gregDay + tod ← def + tz ← char ' ' *> def + let lt = LocalTime gregDay <$> tod + zt = ZonedTime <$> lt ⊛ tz + pure $ retag' zt + where + retag' ∷ Tagged RFC822 α → Tagged τ α + retag' = retag date ∷ Parser Day date = do day ← read2 @@ -90,10 +84,10 @@ date = do day ← read2 _ ← char ' ' assertGregorianDateIsGood year month day -toAsciiBuilder ∷ ZonedTime → AsciiBuilder +toAsciiBuilder ∷ Tagged RFC1123 ZonedTime → AsciiBuilder toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime + = let localTime = zonedTimeToLocalTime $ untag zonedTime + timeZone = zonedTimeZone <$> retag' zonedTime (year, month, day) = toGregorian (localDay localTime) (_, _, week) = toWeekDate (localDay localTime) timeOfDay = localTimeOfDay localTime @@ -112,8 +106,11 @@ toAsciiBuilder zonedTime ⊕ A.toAsciiBuilder ":" ⊕ show2 (floor (todSec timeOfDay) ∷ Int) ⊕ A.toAsciiBuilder " " - ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) + ⊕ cs timeZone + where + retag' ∷ Tagged τ α → Tagged RFC822 α + retag' = retag -deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii |]) - , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |]) +deriveAttempts [ ([t| Tagged RFC1123 ZonedTime |], [t| Ascii |]) + , ([t| Tagged RFC1123 ZonedTime |], [t| AsciiBuilder |]) ] diff --git a/Data/Time/Format/RFC733.hs b/Data/Time/Format/RFC733.hs index 58dec8d..3b66c88 100644 --- a/Data/Time/Format/RFC733.hs +++ b/Data/Time/Format/RFC733.hs @@ -3,6 +3,7 @@ , MultiParamTypeClasses , OverloadedStrings , TemplateHaskell + , TypeSynonymInstances , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 733 date @@ -46,8 +47,6 @@ -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM module Data.Time.Format.RFC733 ( RFC733 - , rfc733 - , rfc733DateAndTime ) where import Control.Applicative @@ -55,61 +54,51 @@ import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A import Data.Attoparsec.Char8 import Data.Convertible.Base +import Data.Default import Data.Monoid.Unicode -import Data.Proxy import Data.Tagged import Data.Time import Data.Time.Calendar.WeekDate import Data.Time.Format.HTTP.Common -import Data.Time.Format.RFC822.Internal +import Data.Time.Format.RFC822 import Prelude.Unicode -- |The phantom type for conversions between RFC 733 date and time -- strings and 'ZonedTime'. -- --- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) --- Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" +-- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC733 ZonedTime) +-- "Sunday, 06-Nov-1994 08:49:37 GMT" data RFC733 --- |The proxy for conversions between RFC 733 date and time strings --- and 'ZonedTime'. -rfc733 ∷ Proxy RFC733 -{-# INLINE CONLIKE rfc733 #-} -rfc733 = Proxy - -instance ConvertSuccess ZonedTime (Tagged RFC733 Ascii) where +instance ConvertSuccess (Tagged RFC733 ZonedTime) Ascii where {-# INLINE convertSuccess #-} - convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + convertSuccess = A.fromAsciiBuilder ∘ cs -instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where +instance ConvertSuccess (Tagged RFC733 ZonedTime) AsciiBuilder where {-# INLINE convertSuccess #-} - convertSuccess = Tagged ∘ toAsciiBuilder + convertSuccess = toAsciiBuilder -instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where +instance ConvertAttempt Ascii (Tagged RFC733 ZonedTime) where {-# INLINE convertAttempt #-} - convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag + convertAttempt = parseAttempt' def -- |Parse an RFC 733 date and time string. -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 +instance Default (Parser (Tagged RFC733 ZonedTime)) where + def = do weekDay ← optionMaybe $ + do w ← longWeekDayNameP + <|> + shortWeekDayNameP + string ", " *> pure 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 + pure $ Tagged zt date ∷ Parser Day date = do day ← read2 @@ -184,10 +173,10 @@ zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT") , read4digitsTZ ] -toAsciiBuilder ∷ ZonedTime → AsciiBuilder +toAsciiBuilder ∷ Tagged RFC733 ZonedTime → AsciiBuilder toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime + = let localTime = zonedTimeToLocalTime $ untag zonedTime + timeZone = zonedTimeZone <$> retag' zonedTime (year, month, day) = toGregorian (localDay localTime) (_, _, week) = toWeekDate (localDay localTime) timeOfDay = localTimeOfDay localTime @@ -206,8 +195,11 @@ toAsciiBuilder zonedTime ⊕ A.toAsciiBuilder ":" ⊕ show2 (floor (todSec timeOfDay) ∷ Int) ⊕ A.toAsciiBuilder " " - ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) + ⊕ cs timeZone + where + retag' ∷ Tagged τ α → Tagged RFC822 α + retag' = retag -deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |]) - , ([t| ZonedTime |], [t| Tagged RFC733 AsciiBuilder |]) +deriveAttempts [ ([t| Tagged RFC733 ZonedTime |], [t| Ascii |]) + , ([t| Tagged RFC733 ZonedTime |], [t| AsciiBuilder |]) ] diff --git a/Data/Time/Format/RFC822.hs b/Data/Time/Format/RFC822.hs index 0d8fcac..95fc926 100644 --- a/Data/Time/Format/RFC822.hs +++ b/Data/Time/Format/RFC822.hs @@ -1,5 +1,12 @@ {-# LANGUAGE - UnicodeSyntax + DeriveDataTypeable + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax #-} -- |This module provides functions to parse and format RFC 822 date -- and time strings (). @@ -32,15 +39,149 @@ -- > | ("+" | "-") 4DIGIT ; Local diff: HHMM module Data.Time.Format.RFC822 ( RFC822 - , rfc822 - , rfc822DateAndTime ) where -import Data.Proxy -import Data.Time.Format.RFC822.Internal - --- |The proxy for conversions between RFC 822 date and time strings --- and 'ZonedTime'. -rfc822 ∷ Proxy RFC822 -{-# INLINE CONLIKE rfc822 #-} -rfc822 = Proxy +import Control.Applicative +import Control.Applicative.Unicode +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.Default +import Data.Monoid.Unicode +import Data.Tagged +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.Format.HTTP.Common +import Data.Typeable +import Prelude.Unicode + +-- |The phantom type for conversions between RFC 822 date and time +-- strings and 'ZonedTime'. +-- +-- >>> convertAttempt (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC822 ZonedTime) +-- Success "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' ('Tagged' RFC822 'ZonedTime')@. +data RFC822 + deriving Typeable + +instance ConvertAttempt (Tagged RFC822 ZonedTime) Ascii where + {-# INLINE convertAttempt #-} + convertAttempt = (A.fromAsciiBuilder <$>) ∘ ca + +instance ConvertAttempt (Tagged RFC822 ZonedTime) AsciiBuilder where + {-# INLINE convertAttempt #-} + convertAttempt = toAsciiBuilder + +instance ConvertSuccess (Tagged RFC822 TimeZone) Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = A.fromAsciiBuilder ∘ cs + +instance ConvertSuccess (Tagged RFC822 TimeZone) AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess (Tagged tz) + | timeZoneMinutes tz ≡ 0 = A.toAsciiBuilder "GMT" + | otherwise = show4digitsTZ tz + +instance ConvertAttempt Ascii (Tagged RFC822 ZonedTime) where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' def + +-- |Parse an RFC 822 date and time string. +instance Default (Parser (Tagged RFC822 ZonedTime)) where + def = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + string ", " *> pure w + gregDay ← date + case weekDay of + Nothing + → return () + Just givenWD + → assertWeekDayIsGood givenWD gregDay + tod ← def + timeZone ← char ' ' *> def + let lt = LocalTime gregDay <$> tod + zt = ZonedTime <$> lt ⊛ timeZone + return zt + +date ∷ Parser Day +date = do day ← read2 + month ← char ' ' *> shortMonthNameP + year ← char ' ' *> ((+ 1900) <$> read2) + char ' ' *> assertGregorianDateIsGood year month day + +instance Default (Parser (Tagged RFC822 TimeOfDay)) where + {-# INLINEABLE def #-} + def = do hour ← read2 + minute ← char ':' *> read2 + second ← option 0 (char ':' *> read2) + Tagged <$> assertTimeOfDayIsGood hour minute second + +instance Default (Parser (Tagged RFC822 TimeZone)) where + def = choice [ string "UT" *> pure (Tagged (TimeZone 0 False "UT" )) + , string "GMT" *> pure (Tagged (TimeZone 0 False "GMT")) + , char 'E' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-5) * 60) False "EST")) + , string "DT" *> pure (Tagged (TimeZone ((-4) * 60) True "EDT")) + ] + , char 'C' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-6) * 60) False "CST")) + , string "DT" *> pure (Tagged (TimeZone ((-5) * 60) True "CDT")) + ] + , char 'M' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-7) * 60) False "MST")) + , string "DT" *> pure (Tagged (TimeZone ((-6) * 60) True "MDT")) + , pure (Tagged (TimeZone ((-12) * 60) False "M")) + ] + , char 'P' + *> choice [ string "ST" *> pure (Tagged (TimeZone ((-8) * 60) False "PST")) + , string "DT" *> pure (Tagged (TimeZone ((-7) * 60) True "PDT")) + ] + , char 'Z' *> pure (Tagged (TimeZone 0 False "Z")) + , char 'A' *> pure (Tagged (TimeZone ((-1) * 60) False "A")) + , char 'N' *> pure (Tagged (TimeZone ( 1 * 60) False "N")) + , char 'Y' *> pure (Tagged (TimeZone ( 12 * 60) False "Y")) + , Tagged <$> read4digitsTZ + ] + +toAsciiBuilder ∷ Failure (ConvertBoundsException Day (Tagged RFC822 ZonedTime)) f + ⇒ Tagged RFC822 ZonedTime + → f AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime $ untag zonedTime + timeZone = zonedTimeZone <$> zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + 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 " " + ⊕ cs timeZone + +deriveAttempts [ ([t| Tagged RFC822 TimeZone |], [t| Ascii |]) + , ([t| Tagged RFC822 TimeZone |], [t| AsciiBuilder |]) + ] diff --git a/Data/Time/Format/RFC822/Internal.hs b/Data/Time/Format/RFC822/Internal.hs deleted file mode 100644 index a4c3c22..0000000 --- a/Data/Time/Format/RFC822/Internal.hs +++ /dev/null @@ -1,165 +0,0 @@ -{-# LANGUAGE - FlexibleContexts - , FlexibleInstances - , MultiParamTypeClasses - , OverloadedStrings - , TemplateHaskell - , UnicodeSyntax - #-} -module Data.Time.Format.RFC822.Internal - ( RFC822 - , rfc822DateAndTime - , rfc822Time - ) - 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 -import Data.Time.Calendar.WeekDate -import Data.Time.Format.HTTP.Common -import Prelude.Unicode - --- |The phantom type for conversions between RFC 822 date and time --- strings and 'ZonedTime'. --- --- >>> 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 ConvertAttempt ZonedTime (Tagged RFC822 Ascii) where - {-# INLINE convertAttempt #-} - convertAttempt = ((A.fromAsciiBuilder <$>) <$>) ∘ ca - -instance ConvertAttempt ZonedTime (Tagged RFC822 AsciiBuilder) where - {-# INLINE convertAttempt #-} - convertAttempt = (Tagged <$>) ∘ toAsciiBuilder - -instance ConvertSuccess TimeZone (Tagged RFC822 Ascii) where - {-# INLINE convertSuccess #-} - convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs - -instance ConvertSuccess TimeZone (Tagged RFC822 AsciiBuilder) where - {-# INLINE convertSuccess #-} - convertSuccess tz - | timeZoneMinutes tz ≡ 0 = Tagged $ A.toAsciiBuilder "GMT" - | otherwise = Tagged $ show4digitsTZ tz - -instance ConvertAttempt (Tagged RFC822 Ascii) ZonedTime where - {-# INLINE convertAttempt #-} - convertAttempt = parseAttempt' rfc822DateAndTime ∘ untag - --- |Parse an RFC 822 date and time string. -rfc822DateAndTime ∷ Parser ZonedTime -rfc822DateAndTime = 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 ← (+ 1900) <$> read2 - _ ← char ' ' - assertGregorianDateIsGood year month day - -rfc822Time ∷ Parser (TimeOfDay, TimeZone) -rfc822Time = do tod ← hms - _ ← char ' ' - tz ← zone - return (tod, tz) - -hms ∷ Parser TimeOfDay -hms = do hour ← read2 - minute ← char ':' *> read2 - second ← option 0 (char ':' *> read2) - assertTimeOfDayIsGood hour minute second - -zone ∷ Parser TimeZone -zone = choice [ string "UT" *> return (TimeZone 0 False "UT" ) - , string "GMT" *> return (TimeZone 0 False "GMT") - , 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 'Z' *> return (TimeZone 0 False "Z") - , char 'A' *> return (TimeZone ((-1) * 60) False "A") - , char 'N' *> return (TimeZone ( 1 * 60) False "N") - , char 'Y' *> return (TimeZone ( 12 * 60) False "Y") - , read4digitsTZ - ] - -toAsciiBuilder ∷ Failure (ConvertBoundsException Day ZonedTime) f - ⇒ ZonedTime - → f AsciiBuilder -toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - 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| 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 67cdfc1..c5abaf1 100644 --- a/Test/Time/Format/HTTP.hs +++ b/Test/Time/Format/HTTP.hs @@ -87,66 +87,85 @@ instance Arbitrary UTCTime where instance Arbitrary (Tagged Cent20 UTCTime) where arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary +instance Arbitrary (Tagged C LocalTime) where + arbitrary = Tagged <$> arbitrary + +instance Arbitrary (Tagged RFC733 ZonedTime) where + arbitrary = Tagged <$> arbitrary + +instance Arbitrary (Tagged RFC1123 ZonedTime) where + arbitrary = Tagged <$> arbitrary + +instance Arbitrary (Tagged HTTP UTCTime) where + arbitrary = Tagged <$> arbitrary + tests ∷ [Property] tests = [ -- Asctime - property ( fromAttempt (ca (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged C Ascii)) - ≡ Just referenceLocalTime + property ( fromAttempt (ca ("Sun Nov 6 08:49:37 1994" ∷ Ascii)) + ≡ Just (Tagged referenceLocalTime ∷ Tagged C LocalTime) ) - , property ( (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged C Ascii) - ≡ cs referenceLocalTime + , property ( ("Sun Nov 6 08:49:37 1994" ∷ Ascii) + ≡ cs (Tagged referenceLocalTime ∷ Tagged C LocalTime) ) - , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) ∷ Tagged C Ascii)) + , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ Tagged C LocalTime) ∷ Ascii)) -- RFC733 - , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii)) - ≡ Just referenceZonedTime + , property ( fromAttempt (ca ("Sunday, 06-Nov-94 08:49:37 GMT" ∷ Ascii)) + ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime) ) - , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii) - ≡ cs referenceZonedTime + , property ( ("Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Ascii) + ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime) ) - , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC733 Ascii)) + , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC733 ZonedTime) ∷ Ascii)) -- RFC822 - , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)) - ≡ Just referenceZonedTime + , property ( fromAttempt (ca ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii)) + ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime) ) - , property ( Just (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii) - ≡ fromAttempt (ca referenceZonedTime) + , property ( Just ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii) + ≡ fromAttempt (ca (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime)) ) - , property $ \zt → let zt' = do a ← ca $ untag (zt ∷ Tagged Cent20 ZonedTime) - ca (a ∷ Tagged RFC822 Ascii) + + , property $ \zt → let zt' = do a ← ca (retag (zt ∷ Tagged Cent20 ZonedTime) ∷ Tagged RFC822 ZonedTime) + ca (a ∷ Ascii) ∷ Attempt (Tagged RFC822 ZonedTime) in - fromAttempt zt' ≡ Just (untag zt) + fromAttempt zt' ≡ Just (retag zt) -- RFC1123 - , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)) - ≡ Just referenceZonedTime + , property ( fromAttempt (ca ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)) + ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime) ) - , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii) - ≡ cs referenceZonedTime + , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii) + ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime) ) - , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC1123 Ascii)) + , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC1123 ZonedTime) ∷ Ascii)) -- HTTP - , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii) - ≡ cs referenceUTCTime + , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii) + ≡ cs (Tagged referenceUTCTime ∷ Tagged HTTP UTCTime) ) - , 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 ut ≡ fromAttempt (ca (cs (ut ∷ Tagged HTTP UTCTime) ∷ Ascii)) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2lt <$> (ut ∷ Tagged HTTP UTCTime)) + ∷ Tagged C LocalTime) + ∷ Ascii)) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime)) + ∷ Tagged RFC733 ZonedTime) + ∷ Ascii)) , property $ \ut → let zt = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime) - ut' = do a ← ca zt - ca $ retagHTTP (a ∷ Tagged RFC822 Ascii) + ut' = do a ← ca (Tagged zt ∷ Tagged RFC822 ZonedTime) + ca (a ∷ Ascii) ∷ Attempt (Tagged HTTP UTCTime) in - fromAttempt ut' ≡ Just (untag ut) - , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii))) + fromAttempt ut' ≡ Just (retag ut) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime)) + ∷ Tagged RFC1123 ZonedTime) + ∷ Ascii)) ] where referenceLocalTime ∷ LocalTime @@ -166,6 +185,3 @@ tests = [ -- Asctime ut2zt ∷ UTCTime → ZonedTime ut2zt = utcToZonedTime utc - - retagHTTP ∷ Tagged s b → Tagged HTTP b - retagHTTP = retag diff --git a/cabal-package.mk b/cabal-package.mk index bec1d14..831b0b2 100644 --- a/cabal-package.mk +++ b/cabal-package.mk @@ -22,6 +22,7 @@ HADDOCK_OPTS ?= --hyperlink-source HLINT_OPTS ?= \ --hint=Default --hint=Dollar --hint=Generalise \ --cross \ + --ignore="Parse error" \ --report=dist/report.html SETUP_FILE := $(wildcard Setup.*hs) diff --git a/time-http.cabal b/time-http.cabal index 40d4dc4..0314059 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -1,5 +1,5 @@ Name: time-http -Version: 0.4 +Version: 0.5 Synopsis: Parse and format HTTP/1.1 Date and Time strings Description: This package provides functionalities to parse and format @@ -35,7 +35,6 @@ Library Other-modules: Data.Time.Format.HTTP.Common - Data.Time.Format.RFC822.Internal Build-depends: ascii == 0.0.*, @@ -47,6 +46,7 @@ Library blaze-textual == 0.2.*, bytestring == 0.9.*, convertible-text == 0.4.*, + data-default == 0.3.*, failure == 0.1.*, tagged == 0.2.*, time == 1.2.* @@ -72,6 +72,7 @@ Test-Suite test-time-http blaze-textual == 0.2.*, bytestring == 0.9.*, convertible-text == 0.4.*, + data-default == 0.3.*, failure == 0.1.*, tagged == 0.2.*, time == 1.2.*