time-http 0.4 → 0.5
raw patch · 8 files changed
+296/−338 lines, 8 filesdep +data-default
Dependencies added: data-default
Files
- ChangeLog +3/−1
- Data/Time/Format/C.hs +31/−39
- Data/Time/Format/HTTP.hs +32/−34
- Data/Time/Format/RFC1123.hs +39/−42
- Data/Time/Format/RFC733.hs +36/−44
- Data/Time/Format/RFC822.hs +151/−10
- Data/Time/Format/RFC822/Internal.hs +0/−165
- time-http.cabal +4/−3
ChangeLog view
@@ -1,4 +1,6 @@-== time-http-0.4 / unreleased+== time-http-0.5 / 2012-01-03+* Use data-default to provide default parsers.+== time-http-0.4 / 2011-12-16 * 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
Data/Time/Format/C.hs view
@@ -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 @@ -- |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 @@ ⊕ 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 |]) ]
Data/Time/Format/HTTP.hs view
@@ -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 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 @@ -- |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 @@ {-# 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 |]) ]
Data/Time/Format/RFC1123.hs view
@@ -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 @@ _ ← 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 @@ ⊕ 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 |]) ]
Data/Time/Format/RFC733.hs view
@@ -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 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 @@ , 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 @@ ⊕ 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 |]) ]
Data/Time/Format/RFC822.hs view
@@ -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 (<http://tools.ietf.org/html/rfc822#section-5>).@@ -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+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 proxy for conversions between RFC 822 date and time strings--- and 'ZonedTime'.-rfc822 ∷ Proxy RFC822-{-# INLINE CONLIKE rfc822 #-}-rfc822 = Proxy+-- |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 |])+ ]
− Data/Time/Format/RFC822/Internal.hs
@@ -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 |])- ]
time-http.cabal view
@@ -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@@ -13,7 +13,7 @@ Author: PHO <pho AT cielonegro DOT org> Maintainer: PHO <pho AT cielonegro DOT org> Stability: Experimental-Category: Web+Category: Time, Web Build-type: Simple Tested-With: GHC == 7.0.3 Cabal-version: >= 1.10@@ -35,7 +35,6 @@ Other-modules: Data.Time.Format.HTTP.Common- Data.Time.Format.RFC822.Internal Build-depends: ascii == 0.0.*,@@ -47,6 +46,7 @@ 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 @@ blaze-textual == 0.2.*, bytestring == 0.9.*, convertible-text == 0.4.*,+ data-default == 0.3.*, failure == 0.1.*, tagged == 0.2.*, time == 1.2.*