, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |This module provides functions for ANSI C's date and time strings.
-- > 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
-- |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
⊕ 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 |])
]
, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |This module provides functions to parse and format HTTP\/1.1 date
-- > | "Sep" | "Oct" | "Nov" | "Dec"
module Data.Time.Format.HTTP
( HTTP
- , http
- , httpDateAndTime
)
where
import Control.Applicative
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
-- |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 #-}
{-# 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 |])
]
, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |This module provides functions to parse and format RFC 1123 date
-- > 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
_ ← 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
⊕ 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 |])
]
, MultiParamTypeClasses
, OverloadedStrings
, TemplateHaskell
+ , TypeSynonymInstances
, UnicodeSyntax
#-}
-- |This module provides functions to parse and format RFC 733 date
-- > | ("+" | "-") 4DIGIT ; Local diff: HHMM
module Data.Time.Format.RFC733
( RFC733
- , rfc733
- , rfc733DateAndTime
)
where
import Control.Applicative
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
, 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
⊕ 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 |])
]
{-# 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>).
-- > | ("+" | "-") 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 |])
+ ]
+++ /dev/null
-{-# 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 |])
- ]
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
ut2zt ∷ UTCTime → ZonedTime
ut2zt = utcToZonedTime utc
-
- retagHTTP ∷ Tagged s b → Tagged HTTP b
- retagHTTP = retag
HLINT_OPTS ?= \
--hint=Default --hint=Dollar --hint=Generalise \
--cross \
+ --ignore="Parse error" \
--report=dist/report.html
SETUP_FILE := $(wildcard Setup.*hs)
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
Other-modules:
Data.Time.Format.HTTP.Common
- Data.Time.Format.RFC822.Internal
Build-depends:
ascii == 0.0.*,
blaze-textual == 0.2.*,
bytestring == 0.9.*,
convertible-text == 0.4.*,
+ data-default == 0.3.*,
failure == 0.1.*,
tagged == 0.2.*,
time == 1.2.*
blaze-textual == 0.2.*,
bytestring == 0.9.*,
convertible-text == 0.4.*,
+ data-default == 0.3.*,
failure == 0.1.*,
tagged == 0.2.*,
time == 1.2.*
projects / time-http.git / commitdiff