diff --git a/ChangeLog b/ChangeLog new file mode 100644 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,9 @@ +== 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 +== time-http-0.2 / 2011-10-03 +* Use attoparsec, ascii and blaze-builder +* Create a test suite using QuickCheck diff --git a/Data/Time/Asctime.hs b/Data/Time/Asctime.hs deleted file mode 100644 --- a/Data/Time/Asctime.hs +++ /dev/null @@ -1,65 +0,0 @@ --- |This module provides functions for ANSI C's asctime() format. --- --- ANSI C's asctime() format looks like: --- --- @Wdy Mon DD HH:MM:SS YYYY@ --- --- The exact syntax is as follows: --- --- > date-time ::= wday SP month SP day SP time SP year --- > wday ::= "Mon" | "Tue" | "Wed" | "Thu" --- > | "Fri" | "Sat" | "Sun" --- > month ::= "Jan" | "Feb" | "Mar" | "Apr" --- > | "May" | "Jun" | "Jul" | "Aug" --- > | "Sep" | "Oct" | "Nov" | "Dec" --- > day ::= 2DIGIT --- > time ::= 2DIGIT ':' 2DIGIT [':' 2DIGIT] --- > year ::= 4DIGIT --- --- As you can see, it has no time zone info. "Data.Time.HTTP" will --- treat it as UTC. -module Data.Time.Asctime - ( format - , parse - ) - where - -import qualified Text.Parsec as P - -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.Asctime.Parsec - --- |Format a 'LocalTime' in the ANSI C's asctime() way. -format :: LocalTime -> String -format localTime - = let (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - concat [ shortWeekDayName week - , ", " - , shortMonthName month - , " " - , show2 day - , " " - , show2 (todHour timeOfDay) - , ":" - , show2 (todMin timeOfDay) - , ":" - , show2 (floor (todSec timeOfDay)) - , " " - , show4 year - ] - --- |Parse an ANSI C's asctime() format to 'LocalTime'. When the string --- can't be parsed, it returns 'Nothing'. -parse :: String -> Maybe LocalTime -parse src = case P.parse p "" src of - Right zt -> Just zt - Left _ -> Nothing - where - p = do zt <- asctime - _ <- P.eof - return zt diff --git a/Data/Time/Asctime/Parsec.hs b/Data/Time/Asctime/Parsec.hs deleted file mode 100644 --- a/Data/Time/Asctime/Parsec.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Data.Time.Asctime.Parsec - ( asctime - ) - where - -import Control.Monad -import Data.Fixed -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Text.Parsec - --- |This is a parsec parser for ANSI C's asctime() format. -asctime :: Stream s m Char => ParsecT s u m LocalTime -asctime = do weekDay <- shortWeekDayNameP - _ <- string ", " - 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 - - return (LocalTime gregDay tod) diff --git a/Data/Time/Format/C.hs b/Data/Time/Format/C.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Format/C.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax + #-} +-- |This module provides functions for ANSI C's date and time strings. +-- +-- ANSI C's @ctime(3)@/@asctime(3)@ format looks like: +-- +-- @Wdy Mon [D]D HH:MM:SS YYYY@ +-- +-- The exact syntax is as follows: +-- +-- > date-time ::= wday SP month SP day SP time SP year +-- > wday ::= "Mon" | "Tue" | "Wed" | "Thu" +-- > | "Fri" | "Sat" | "Sun" +-- > month ::= "Jan" | "Feb" | "Mar" | "Apr" +-- > | "May" | "Jun" | "Jul" | "Aug" +-- > | "Sep" | "Oct" | "Nov" | "Dec" +-- > day ::= 2DIGIT | SP 1DIGIT +-- > time ::= 2DIGIT ':' 2DIGIT [':' 2DIGIT] +-- > year ::= 4DIGIT +module Data.Time.Format.C + ( C + ) + where +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.Tagged +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.Format.HTTP.Common +import Prelude.Unicode + +-- |The phantom type for conversions between ANSI C's date and time +-- strings and 'LocalTime'. +-- +-- >>> convertSuccess (Tagged (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) :: Tagged C LocalTime) +-- "Sun Nov 6 08:49:37 1994" +data C + +instance ConvertSuccess (Tagged C LocalTime) Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = A.fromAsciiBuilder ∘ cs + +instance ConvertSuccess (Tagged C LocalTime) AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess = toAsciiBuilder ∘ untag + +instance ConvertAttempt Ascii (Tagged C LocalTime) where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' def + +-- |Parse an ANSI C's date and time string. +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 + + return ∘ Tagged $ LocalTime gregDay tod + +toAsciiBuilder ∷ LocalTime → AsciiBuilder +toAsciiBuilder localTime + = let (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + shortWeekDayName week + ⊕ A.toAsciiBuilder " " + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder " " + ⊕ show2' day + ⊕ A.toAsciiBuilder " " + ⊕ show2 (todHour timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (todMin timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (floor (todSec timeOfDay) ∷ Int) + ⊕ A.toAsciiBuilder " " + ⊕ show4 year + +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 new file mode 100644 --- /dev/null +++ b/Data/Time/Format/HTTP.hs @@ -0,0 +1,121 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax + #-} +-- |This module provides functions to parse and format HTTP\/1.1 date +-- and time strings +-- (). +-- +-- The HTTP\/1.1 specification (RFC 2616) says that HTTP\/1.1 clients +-- and servers which parse the date value MUST accept all the +-- following formats, though they MUST only generate the RFC 1123 +-- format for representing HTTP-date values in header fields: +-- +-- > Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 +-- > Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 +-- > Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format +-- +-- It also says that all HTTP date\/time stamps MUST be represented in +-- Greenwich Mean Time (GMT), without exception. For the purposes of +-- HTTP, GMT is exactly equal to UTC (Coordinated Universal +-- Time). This is indicated in the first two formats by the inclusion +-- of @\"GMT\"@ as the three-letter abbreviation for time zone, and +-- MUST be assumed when reading the asctime format. +-- +-- > HTTP-date = rfc1123-date | rfc850-date | asctime-date +-- > rfc1123-date = wkday "," SP date1 SP time SP "GMT" +-- > rfc850-date = weekday "," SP date2 SP time SP "GMT" +-- > asctime-date = wkday SP date3 SP time SP 4DIGIT +-- > date1 = 2DIGIT SP month SP 4DIGIT +-- > ; day month year (e.g., 02 Jun 1982) +-- > date2 = 2DIGIT "-" month "-" 2DIGIT +-- > ; day-month-year (e.g., 02-Jun-82) +-- > date3 = month SP ( 2DIGIT | ( SP 1DIGIT )) +-- > ; month day (e.g., Jun 2) +-- > time = 2DIGIT ":" 2DIGIT ":" 2DIGIT +-- > ; 00:00:00 - 23:59:59 +-- > wkday = "Mon" | "Tue" | "Wed" +-- > | "Thu" | "Fri" | "Sat" | "Sun" +-- > weekday = "Monday" | "Tuesday" | "Wednesday" +-- > | "Thursday" | "Friday" | "Saturday" | "Sunday" +-- > month = "Jan" | "Feb" | "Mar" | "Apr" +-- > | "May" | "Jun" | "Jul" | "Aug" +-- > | "Sep" | "Oct" | "Nov" | "Dec" +module Data.Time.Format.HTTP + ( HTTP + ) + 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.Tagged +import Data.Time +import Data.Time.Format.C +import Data.Time.Format.HTTP.Common +import Data.Time.Format.RFC733 +import Data.Time.Format.RFC822 +import Data.Time.Format.RFC1123 +import Prelude.Unicode + +-- |The phantom type for conversions between HTTP/1.1 date and time +-- strings and 'UTCTime'. +-- +-- >>> convertSuccess (Tagged (UTCTime (ModifiedJulianDay 49662) 31777) :: Tagged HTTP UTCTime) +-- "Sun, 06 Nov 1994 08:49:37 GMT" +data HTTP + +instance ConvertSuccess (Tagged HTTP UTCTime) Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = A.fromAsciiBuilder ∘ cs + +instance ConvertSuccess (Tagged HTTP UTCTime) AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess = toAsciiBuilder + +instance ConvertAttempt Ascii (Tagged HTTP UTCTime) where + {-# INLINE convertAttempt #-} + 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 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 ∷ Tagged HTTP UTCTime → AsciiBuilder +{-# INLINEABLE toAsciiBuilder #-} +toAsciiBuilder = cs ∘ (ut2zt <$>) ∘ retag' + where + ut2zt ∷ UTCTime → ZonedTime + {-# INLINE ut2zt #-} + ut2zt = utcToZonedTime gmt + + gmt ∷ TimeZone + {-# INLINE CONLIKE gmt #-} + gmt = TimeZone 0 False "GMT" + + 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/HTTP/Common.hs b/Data/Time/Format/HTTP/Common.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Format/HTTP/Common.hs @@ -0,0 +1,363 @@ +{-# LANGUAGE + OverloadedStrings + , UnicodeSyntax + #-} +module Data.Time.Format.HTTP.Common + ( shortWeekDayName + , shortWeekDayNameP + + , longWeekDayName + , longWeekDayNameP + + , shortMonthName + , shortMonthNameP + + , longMonthName + , longMonthNameP + + , show4 + , show2 + , show2' + + , read4 + , read2 + , read2' + + , show4digitsTZ + , read4digitsTZ + + , assertWeekDayIsGood + , assertGregorianDateIsGood + , assertTimeOfDayIsGood + + , optionMaybe + , finishOff + + , parseAttempt + , parseAttempt' + ) + where +import Blaze.ByteString.Builder.ByteString as B +import Blaze.Text.Int as BT +import Control.Applicative +import Control.Exception.Base +import Control.Monad +import Control.Monad.Unicode +import Data.Ascii (Ascii, AsciiBuilder) +import qualified Data.Ascii as A +import Data.Attempt +import Data.Attoparsec.Char8 as P +import Data.ByteString (ByteString) +import Data.Char +import Data.Monoid.Unicode +import Data.Fixed +import Data.Time +import Data.Time.Calendar.WeekDate +import Prelude.Unicode + +shortWeekDayName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE shortWeekDayName #-} +shortWeekDayName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "Mon" + go 2 = "Tue" + go 3 = "Wed" + go 4 = "Thu" + go 5 = "Fri" + go 6 = "Sat" + go 7 = "Sun" + go n = error ("shortWeekDayName: invalid week day: " ⧺ show n) + +shortWeekDayNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE shortWeekDayNameP #-} +shortWeekDayNameP + = choice [ string "Mon" *> return 1 + , char 'T' + *> choice [ string "ue" *> return 2 + , string "hu" *> return 4 + ] + , string "Wed" *> return 3 + , string "Fri" *> return 5 + , char 'S' + *> choice [ string "at" *> return 6 + , string "un" *> return 7 + ] + ] + +longWeekDayName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE longWeekDayName #-} +longWeekDayName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "Monday" + go 2 = "Tuesday" + go 3 = "Wednesday" + go 4 = "Thursday" + go 5 = "Friday" + go 6 = "Saturday" + go 7 = "Sunday" + go n = error ("longWeekDayName: invalid week day: " ⧺ show n) + +longWeekDayNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE longWeekDayNameP #-} +longWeekDayNameP + = choice [ string "Monday" *> return 1 + , char 'T' + *> choice [ string "uesday" *> return 2 + , string "hursday" *> return 4 + ] + , string "Wednesday" *> return 3 + , string "Friday" *> return 5 + , char 'S' + *> choice [ string "aturday" *> return 6 + , string "unday" *> return 7 + ] + ] + +shortMonthName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE shortMonthName #-} +shortMonthName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "Jan" + go 2 = "Feb" + go 3 = "Mar" + go 4 = "Apr" + go 5 = "May" + go 6 = "Jun" + go 7 = "Jul" + go 8 = "Aug" + go 9 = "Sep" + go 10 = "Oct" + go 11 = "Nov" + go 12 = "Dec" + go n = error ("shortMonthName: invalid month: " ⧺ show n) + +shortMonthNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE shortMonthNameP #-} +shortMonthNameP + = choice [ char 'J' + *> choice [ string "an" *> return 1 + , char 'u' + *> choice [ char 'n' *> return 6 + , char 'l' *> return 7 + ] + ] + , string "Feb" *> return 2 + , string "Ma" + *> choice [ char 'r' *> return 3 + , char 'y' *> return 5 + ] + , char 'A' + *> choice [ string "pr" *> return 4 + , string "ug" *> return 8 + ] + , string "Sep" *> return 9 + , string "Oct" *> return 10 + , string "Nov" *> return 11 + , string "Dec" *> return 12 + ] + +longMonthName ∷ Num n ⇒ n → AsciiBuilder +{-# INLINE longMonthName #-} +longMonthName = A.toAsciiBuilder ∘ go + where + {-# INLINEABLE go #-} + go 1 = "January" + go 2 = "February" + go 3 = "March" + go 4 = "April" + go 5 = "May" + go 6 = "June" + go 7 = "July" + go 8 = "August" + go 9 = "September" + go 10 = "October" + go 11 = "November" + go 12 = "December" + go n = error ("longMonthName: invalid month: " ⧺ show n) + +longMonthNameP ∷ Num n ⇒ Parser n +{-# INLINEABLE longMonthNameP #-} +longMonthNameP + = choice [ char 'J' + *> choice [ string "anuary" *> return 1 + , char 'u' + *> choice [ string "ne" *> return 6 + , string "ly" *> return 7 + ] + ] + , string "February" *> return 2 + , string "Ma" + *> choice [ string "rch" *> return 3 + , char 'y' *> return 5 + ] + , char 'A' + *> choice [ string "pril" *> return 4 + , string "ugust" *> return 8 + ] + , string "September" *> return 9 + , string "October" *> return 10 + , string "November" *> return 11 + , string "December" *> return 12 + ] + +show4 ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show4 #-} +show4 = A.unsafeFromBuilder ∘ go + where + {-# INLINEABLE go #-} + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "000" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = B.fromByteString "00" ⊕ BT.integral i + | i ≥ 0 ∧ i < 1000 = B.fromByteString "0" ⊕ BT.integral i + | i ≥ 0 ∧ i < 10000 = BT.integral i + | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ⧺ show i) + +show2 ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show2 #-} +show2 = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString "0" ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = BT.integral i + | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ⧺ show i) + +show2' ∷ Integral i ⇒ i → AsciiBuilder +{-# INLINE show2' #-} +show2' = A.unsafeFromBuilder ∘ go + where + go i | i ≥ 0 ∧ i < 10 = B.fromByteString " " ⊕ BT.digit i + | i ≥ 0 ∧ i < 100 = BT.integral i + | otherwise = error ("show2': the integer i must satisfy 0 <= i < 100: " ⧺ show i) + +read4 ∷ Num n ⇒ Parser n +{-# INLINEABLE read4 #-} +read4 = do n1 ← digit' + n2 ← digit' + n3 ← digit' + n4 ← digit' + return (n1 * 1000 + n2 * 100 + n3 * 10 + n4) + +read2 ∷ Num n ⇒ Parser n +{-# INLINEABLE read2 #-} +read2 = do n1 ← digit' + n2 ← digit' + return (n1 * 10 + n2) + +read2' ∷ Num n ⇒ Parser n +{-# INLINEABLE read2' #-} +read2' = do n1 ← (char ' ' *> pure 0) <|> digit' + n2 ← digit' + return (n1 * 10 + n2) + +digit' ∷ Num n ⇒ Parser n +{-# INLINE digit' #-} +digit' = fromIntegral <$> fromC <$> P.digit + where + {-# INLINE fromC #-} + fromC c = ord c - ord '0' + +show4digitsTZ ∷ TimeZone → AsciiBuilder +{-# INLINEABLE show4digitsTZ #-} +show4digitsTZ tz + = case timeZoneMinutes tz of + offset | offset < 0 → A.toAsciiBuilder "-" ⊕ showTZ' (negate offset) + | otherwise → A.toAsciiBuilder "+" ⊕ showTZ' offset + where + showTZ' offset + = let h = offset `div` 60 + m = offset - h * 60 + in + show2 h ⊕ show2 m + +read4digitsTZ ∷ Parser TimeZone +{-# INLINEABLE read4digitsTZ #-} +read4digitsTZ + = do sign ← (char '+' *> return 1) + <|> + (char '-' *> return (-1)) + hour ← read2 + minute ← read2 + let tz = TimeZone { + timeZoneMinutes = sign * (hour * 60 + minute) + , timeZoneSummerOnly = False + , timeZoneName = timeZoneOffsetString tz + } + return tz + +assertWeekDayIsGood ∷ Monad m ⇒ Int → Day → m () +{-# INLINEABLE assertWeekDayIsGood #-} +assertWeekDayIsGood givenWD gregDay + = let (_, _, correctWD ) = toWeekDate gregDay + (year, month, day) = toGregorian gregDay + in + unless (givenWD ≡ correctWD) + ∘ fail + $ concat [ "Gregorian day " + , show year + , "-" + , show month + , "-" + , show day + , " is " + , toStr $ longWeekDayName correctWD + , ", not " + , toStr $ longWeekDayName givenWD + ] + where + toStr ∷ AsciiBuilder → String + toStr = A.toString ∘ A.fromAsciiBuilder + +assertGregorianDateIsGood ∷ Monad m ⇒ Integer → Int → Int → m Day +{-# INLINEABLE assertGregorianDateIsGood #-} +assertGregorianDateIsGood year month day + = case fromGregorianValid year month day of + Nothing + → fail $ concat [ "Invalid gregorian day: " + , show year + , "-" + , show month + , "-" + , show day + ] + Just gregDay + → return gregDay + +assertTimeOfDayIsGood ∷ Monad m ⇒ Int → Int → Pico → m TimeOfDay +{-# INLINEABLE assertTimeOfDayIsGood #-} +assertTimeOfDayIsGood hour minute second + = case makeTimeOfDayValid hour minute second of + Nothing + → fail $ concat [ "Invalid time of day: " + , show hour + , ":" + , show minute + , ":" + , showFixed True second + ] + Just tod + → return tod + +optionMaybe ∷ Alternative f ⇒ f a → f (Maybe a) +{-# INLINE optionMaybe #-} +optionMaybe p + = option Nothing (Just <$> p) + +finishOff ∷ Parser α → Parser α +{-# INLINE finishOff #-} +finishOff = ((endOfInput *>) ∘ return =≪) + +parseAttempt ∷ Exception e + ⇒ (String → e) + → Parser α + → ByteString + → Attempt α +{-# INLINEABLE parseAttempt #-} +parseAttempt f p bs + = case parseOnly (finishOff p) bs of + Right α → Success α + Left e → Failure $ f e + +parseAttempt' ∷ Parser α → Ascii → Attempt α +{-# INLINE parseAttempt' #-} +parseAttempt' = (∘ A.toByteString) ∘ parseAttempt StringException diff --git a/Data/Time/Format/RFC1123.hs b/Data/Time/Format/RFC1123.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Format/RFC1123.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax + #-} +-- |This module provides functions to parse and format RFC 1123 date +-- and time strings (). +-- +-- The format is basically the same as RFC 822, but the syntax for +-- @date@ is changed from: +-- +-- > year ::= 2DIGIT +-- +-- to: +-- +-- > year ::= 4DIGIT +module Data.Time.Format.RFC1123 + ( RFC1123 + ) + 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.Tagged +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.Format.HTTP.Common +import Data.Time.Format.RFC822 +import Prelude.Unicode + +-- |The phantom type for conversions between RFC 1123 date and time +-- strings and 'ZonedTime'. +-- +-- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC1123 ZonedTime) +-- "Sun, 06 Nov 1994 08:49:37 GMT" +data RFC1123 + +instance ConvertSuccess (Tagged RFC1123 ZonedTime) Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = A.fromAsciiBuilder ∘ cs + +instance ConvertSuccess (Tagged RFC1123 ZonedTime) AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess = toAsciiBuilder + +instance ConvertAttempt Ascii (Tagged RFC1123 ZonedTime) where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' def + +-- |Parse an RFC 1123 date and time string. +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 ' ' + month ← shortMonthNameP + _ ← char ' ' + year ← read4 + _ ← char ' ' + assertGregorianDateIsGood year month day + +toAsciiBuilder ∷ Tagged RFC1123 ZonedTime → AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime $ untag zonedTime + timeZone = zonedTimeZone <$> retag' 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 " " + ⊕ cs timeZone + where + retag' ∷ Tagged τ α → Tagged RFC822 α + retag' = retag + +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 new file mode 100644 --- /dev/null +++ b/Data/Time/Format/RFC733.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax + #-} +-- |This module provides functions to parse and format RFC 733 date +-- and time strings (). +-- +-- The syntax is as follows: +-- +-- > date-time ::= [ day-of-week ", " ] date SP time ("-" | SP) zone +-- > day-of-week ::= "Monday" | "Mon" | "Tuesday" | "Tue" +-- > | "Wednesday" | "Wed" | "Thursday" | "Thu" +-- > | "Friday" | "Fri" | "Saturday" | "Sat" +-- > | "Sunday" | "Sun" +-- > date ::= day ("-" | SP) month ("-" | SP) year +-- > day ::= 2DIGIT +-- > year ::= 2DIGIT | 4DIGIT +-- > month ::= "January" | "Jan" | "February" | "Feb" +-- > | "March" | "Mar" | "April" | "Apr" +-- > | "May" | "June" | "Jun" +-- > | "July" | "Jul" | "August" | "Aug" +-- > | "September" | "Sep" | "October" | "Oct" +-- > | "November" | "Nov" | "December" | "Dec" +-- > time ::= hour [ ":" ] minute [ [ ":" ] second ] +-- > hour ::= 2DIGIT +-- > minute ::= 2DIGIT +-- > second ::= 2DIGIT +-- > zone ::= "GMT" ; Universal Time +-- > | "NST" ; Newfoundland: -3:30 +-- > | "AST" | "ADT" ; Atlantic : -4 / -3 +-- > | "EST" | "EDT" ; Eastern : -5 / -4 +-- > | "CST" | "CDT" ; Central : -6 / -5 +-- > | "MST" | "MDT" ; Mountain : -7 / -6 +-- > | "PST" | "PDT" ; Pacific : -8 / -7 +-- > | "YST" | "YDT" ; Yukon : -9 / -8 +-- > | "HST" | "HDT" ; Haw/Ala : -10 / -9 +-- > | "BST" | "BDT" ; Bering : -11 / -10 +-- > | "Z" ; GMT +-- > | "A" ; -1 +-- > | "M" ; -12 +-- > | "N" ; +1 +-- > | "Y" ; +12 +-- > | ("+" | "-") 4DIGIT ; Local diff: HHMM +module Data.Time.Format.RFC733 + ( RFC733 + ) + 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.Tagged +import Data.Time +import Data.Time.Calendar.WeekDate +import Data.Time.Format.HTTP.Common +import Data.Time.Format.RFC822 +import Prelude.Unicode + +-- |The phantom type for conversions between RFC 733 date and time +-- strings and 'ZonedTime'. +-- +-- >>> convertSuccess (Tagged (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) :: Tagged RFC733 ZonedTime) +-- "Sunday, 06-Nov-1994 08:49:37 GMT" +data RFC733 + +instance ConvertSuccess (Tagged RFC733 ZonedTime) Ascii where + {-# INLINE convertSuccess #-} + convertSuccess = A.fromAsciiBuilder ∘ cs + +instance ConvertSuccess (Tagged RFC733 ZonedTime) AsciiBuilder where + {-# INLINE convertSuccess #-} + convertSuccess = toAsciiBuilder + +instance ConvertAttempt Ascii (Tagged RFC733 ZonedTime) where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' def + +-- |Parse an RFC 733 date and time string. +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 + _ ← char '-' <|> char ' ' + month ← try longMonthNameP + <|> + shortMonthNameP + _ ← char '-' <|> char ' ' + year ← try read4 + <|> + (+ 1900) <$> read2 + _ ← char ' ' + assertGregorianDateIsGood year month day + +time ∷ Parser (TimeOfDay, TimeZone) +time = do tod ← hms + _ ← char '-' <|> char ' ' + tz ← zone + return (tod, tz) + +hms ∷ Parser TimeOfDay +hms = do hour ← read2 + _ ← optional (char ':') + minute ← read2 + second ← option 0 $ + do _ ← optional (char ':') + read2 + assertTimeOfDayIsGood hour minute second + +zone ∷ Parser TimeZone +zone = choice [ string "GMT" *> return (TimeZone 0 False "GMT") + , char 'N' + *> choice [ string "ST" *> return (TimeZone ((-3) * 60 - 30) False "NST") + , return (TimeZone (1 * 60) False "N") + ] + , char 'A' + *> choice [ string "ST" *> return (TimeZone ((-4) * 60) False "AST") + , string "DT" *> return (TimeZone ((-3) * 60) False "AST") + , return (TimeZone ((-1) * 60) False "A") + ] + , char 'E' + *> choice [ string "ST" *> return (TimeZone ((-5) * 60) False "EST") + , string "DT" *> return (TimeZone ((-4) * 60) True "EDT") + ] + , char 'C' + *> choice [ string "ST" *> return (TimeZone ((-6) * 60) False "CST") + , string "DT" *> return (TimeZone ((-5) * 60) True "CDT") + ] + , char 'M' + *> choice [ string "ST" *> return (TimeZone ((-7) * 60) False "MST") + , string "DT" *> return (TimeZone ((-6) * 60) True "MDT") + , return (TimeZone ((-12) * 60) False "M") + ] + , char 'P' + *> choice [ string "ST" *> return (TimeZone ((-8) * 60) False "PST") + , string "DT" *> return (TimeZone ((-7) * 60) True "PDT") + ] + , char 'Y' + *> choice [ string "ST" *> return (TimeZone ((-9) * 60) False "YST") + , string "DT" *> return (TimeZone ((-8) * 60) True "YDT") + , return (TimeZone ( 12 * 60) False "Y") + ] + , char 'H' + *> choice [ string "ST" *> return (TimeZone ((-10) * 60) False "HST") + , string "DT" *> return (TimeZone (( -9) * 60) True "HDT") + ] + , char 'B' + *> choice [ string "ST" *> return (TimeZone ((-11) * 60) False "BST") + , string "DT" *> return (TimeZone ((-10) * 60) True "BDT") + ] + , char 'Z' *> return (TimeZone 0 False "Z") + , read4digitsTZ + ] + +toAsciiBuilder ∷ Tagged RFC733 ZonedTime → AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime $ untag zonedTime + timeZone = zonedTimeZone <$> retag' zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + longWeekDayName week + ⊕ A.toAsciiBuilder ", " + ⊕ show2 day + ⊕ A.toAsciiBuilder "-" + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder "-" + ⊕ show4 year + ⊕ A.toAsciiBuilder " " + ⊕ show2 (todHour timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (todMin timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (floor (todSec timeOfDay) ∷ Int) + ⊕ A.toAsciiBuilder " " + ⊕ cs timeZone + where + retag' ∷ Tagged τ α → Tagged RFC822 α + retag' = retag + +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 new file mode 100644 --- /dev/null +++ b/Data/Time/Format/RFC822.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE + DeriveDataTypeable + , FlexibleContexts + , FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , TypeSynonymInstances + , UnicodeSyntax + #-} +-- |This module provides functions to parse and format RFC 822 date +-- and time strings (). +-- +-- The syntax is as follows: +-- +-- > date-time ::= [ day-of-week ", " ] date SP time SP zone +-- > day-of-week ::= "Mon" | "Tue" | "Wed" | "Thu" +-- > | "Fri" | "Sat" | "Sun" +-- > date ::= day SP month SP year +-- > day ::= 2DIGIT +-- > year ::= 2DIGIT ; Yes, only 2 digits. +-- > month ::= "Jan" | "Feb" | "Mar" | "Apr" +-- > | "May" | "Jun" | "Jul" | "Aug" +-- > | "Sep" | "Oct" | "Nov" | "Dec" +-- > time ::= hour ":" minute [ ":" second ] +-- > hour ::= 2DIGIT +-- > minute ::= 2DIGIT +-- > second ::= 2DIGIT +-- > zone ::= "UT" | "GMT" ; Universal Time +-- > | "EST" | "EDT" ; Eastern : -5 / -4 +-- > | "CST" | "CDT" ; Central : -6 / -5 +-- > | "MST" | "MDT" ; Mountain: -7 / -6 +-- > | "PST" | "PDT" ; Pacific : -8 / -7 +-- > | "Z" ; UT +-- > | "A" ; -1 +-- > | "M" ; -12 +-- > | "N" ; +1 +-- > | "Y" ; +12 +-- > | ("+" | "-") 4DIGIT ; Local diff: HHMM +module Data.Time.Format.RFC822 + ( RFC822 + ) + where +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/HTTP.hs b/Data/Time/HTTP.hs deleted file mode 100644 --- a/Data/Time/HTTP.hs +++ /dev/null @@ -1,75 +0,0 @@ --- |This module provides functions to parse and format HTTP\/1.1 date --- and time formats. --- --- The HTTP\/1.1 specification (RFC 2616) says that HTTP\/1.1 clients --- and servers which parse the date value MUST accept all the --- following formats, though they MUST only generate the RFC 1123 --- format for representing HTTP-date values in header fields: --- --- > Sun, 06 Nov 1994 08:49:37 GMT ; RFC 822, updated by RFC 1123 --- > Sunday, 06-Nov-94 08:49:37 GMT ; RFC 850, obsoleted by RFC 1036 --- > Sun Nov 6 08:49:37 1994 ; ANSI C's asctime() format --- --- It also says that all HTTP date\/time stamps MUST be represented in --- Greenwich Mean Time (GMT), without exception. For the purposes of --- HTTP, GMT is exactly equal to UTC (Coordinated Universal --- Time). This is indicated in the first two formats by the inclusion --- of @\"GMT\"@ as the three-letter abbreviation for time zone, and --- MUST be assumed when reading the asctime format. --- --- > HTTP-date = rfc1123-date | rfc850-date | asctime-date --- > rfc1123-date = wkday "," SP date1 SP time SP "GMT" --- > rfc850-date = weekday "," SP date2 SP time SP "GMT" --- > asctime-date = wkday SP date3 SP time SP 4DIGIT --- > date1 = 2DIGIT SP month SP 4DIGIT --- > ; day month year (e.g., 02 Jun 1982) --- > date2 = 2DIGIT "-" month "-" 2DIGIT --- > ; day-month-year (e.g., 02-Jun-82) --- > date3 = month SP ( 2DIGIT | ( SP 1DIGIT )) --- > ; month day (e.g., Jun 2) --- > time = 2DIGIT ":" 2DIGIT ":" 2DIGIT --- > ; 00:00:00 - 23:59:59 --- > wkday = "Mon" | "Tue" | "Wed" --- > | "Thu" | "Fri" | "Sat" | "Sun" --- > weekday = "Monday" | "Tuesday" | "Wednesday" --- > | "Thursday" | "Friday" | "Saturday" | "Sunday" --- > month = "Jan" | "Feb" | "Mar" | "Apr" --- > | "May" | "Jun" | "Jul" | "Aug" --- > | "Sep" | "Oct" | "Nov" | "Dec" -module Data.Time.HTTP - ( format - , parse - ) - where - -import qualified Data.Time.RFC1123 as RFC1123 -import qualified Text.Parsec as P - -import Data.Time -import Data.Time.HTTP.Parsec - --- |Format an 'UTCTime' in RFC 1123 date and time. -format :: UTCTime -> String -format utcTime - = let timeZone = TimeZone 0 False "GMT" - zonedTime = utcToZonedTime timeZone utcTime - in - RFC1123.format zonedTime - --- |Parse a date and time string in any of RFC 822, RFC 1123, RFC 850 --- and ANSI C's asctime() formats. When the string can't be parsed, it --- returns 'Nothing'. --- --- This function is even more permissive than what HTTP\/1.1 --- 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 but you --- should know this. -parse :: String -> Maybe UTCTime -parse src = case P.parse p "" src of - Right ut -> Just ut - Left _ -> Nothing - where - p = do zt <- rfc2616DateAndTime - _ <- P.eof - return zt diff --git a/Data/Time/HTTP/Common.hs b/Data/Time/HTTP/Common.hs deleted file mode 100644 --- a/Data/Time/HTTP/Common.hs +++ /dev/null @@ -1,276 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Data.Time.HTTP.Common - ( shortWeekDayName - , shortWeekDayNameP - - , longWeekDayName - , longWeekDayNameP - - , shortMonthName - , shortMonthNameP - - , longMonthName - , longMonthNameP - - , show2 - , show4 - - , read2 - , read4 - - , show4digitsTZ - , read4digitsTZ - - , assertWeekDayIsGood - , assertGregorianDateIsGood - , assertTimeOfDayIsGood - ) - where - -import Control.Monad -import Data.Fixed -import Data.Time -import Data.Time.Calendar.WeekDate -import Text.Parsec - -shortWeekDayName :: Int -> String -shortWeekDayName 1 = "Mon" -shortWeekDayName 2 = "Tue" -shortWeekDayName 3 = "Wed" -shortWeekDayName 4 = "Thu" -shortWeekDayName 5 = "Fri" -shortWeekDayName 6 = "Sat" -shortWeekDayName 7 = "Sun" -shortWeekDayName n = error ("shortWeekDayName: unknown day number: " ++ show n) - -shortWeekDayNameP :: Stream s m Char => ParsecT s u m Int -shortWeekDayNameP - = choice [ string "Mon" >> return 1 - , char 'T' - >> choice [ string "ue" >> return 2 - , string "hu" >> return 4 - ] - , string "Wed" >> return 3 - , string "Fri" >> return 5 - , char 'S' - >> choice [ string "at" >> return 6 - , string "un" >> return 7 - ] - ] - -longWeekDayName :: Int -> String -longWeekDayName 1 = "Monday" -longWeekDayName 2 = "Tuesday" -longWeekDayName 3 = "Wednesday" -longWeekDayName 4 = "Thursday" -longWeekDayName 5 = "Friday" -longWeekDayName 6 = "Saturday" -longWeekDayName 7 = "Sunday" - -longWeekDayNameP :: Stream s m Char => ParsecT s u m Int -longWeekDayNameP - = choice [ string "Monday" >> return 1 - , char 'T' - >> choice [ string "uesday" >> return 2 - , string "hursday" >> return 4 - ] - , string "Wednesday" >> return 3 - , string "Friday" >> return 5 - , char 'S' - >> choice [ string "aturday" >> return 6 - , string "unday" >> return 7 - ] - ] - -shortMonthName :: Int -> String -shortMonthName 1 = "Jan" -shortMonthName 2 = "Feb" -shortMonthName 3 = "Mar" -shortMonthName 4 = "Apr" -shortMonthName 5 = "May" -shortMonthName 6 = "Jun" -shortMonthName 7 = "Jul" -shortMonthName 8 = "Aug" -shortMonthName 9 = "Sep" -shortMonthName 10 = "Oct" -shortMonthName 11 = "Nov" -shortMonthName 12 = "Dec" -shortMonthName n = error ("shortMonthName: unknown month number: " ++ show n) - -shortMonthNameP :: Stream s m Char => ParsecT s u m Int -shortMonthNameP - = choice [ char 'J' - >> choice [ string "an" >> return 1 - , char 'u' - >> choice [ char 'n' >> return 6 - , char 'l' >> return 7 - ] - ] - , string "Feb" >> return 2 - , string "Ma" - >> choice [ char 'r' >> return 3 - , char 'y' >> return 5 - ] - , char 'A' - >> choice [ string "pr" >> return 4 - , string "ug" >> return 8 - ] - , string "Sep" >> return 9 - , string "Oct" >> return 10 - , string "Nov" >> return 11 - , string "Dec" >> return 12 - ] - -longMonthName :: Int -> String -longMonthName 1 = "January" -longMonthName 2 = "February" -longMonthName 3 = "March" -longMonthName 4 = "April" -longMonthName 5 = "May" -longMonthName 6 = "June" -longMonthName 7 = "July" -longMonthName 8 = "August" -longMonthName 9 = "September" -longMonthName 10 = "October" -longMonthName 11 = "November" -longMonthName 12 = "December" -longMonthName n = error ("longMonthName: unknown month number: " ++ show n) - -longMonthNameP :: Stream s m Char => ParsecT s u m Int -longMonthNameP - = choice [ char 'J' - >> choice [ string "anuary" >> return 1 - , char 'u' - >> choice [ string "ne" >> return 6 - , string "ly" >> return 7 - ] - ] - , string "February" >> return 2 - , string "Ma" - >> choice [ string "rch" >> return 3 - , char 'y' >> return 5 - ] - , char 'A' - >> choice [ string "pril" >> return 4 - , string "ugust" >> return 8 - ] - , string "September" >> return 9 - , string "October" >> return 10 - , string "November" >> return 11 - , string "December" >> return 12 - ] - -show4 :: Integral i => i -> String -show4 i - | i >= 0 && i < 10 = "000" ++ show i - | i >= 0 && i < 100 = "00" ++ show i - | i >= 0 && i < 1000 = '0' : show i - | i >= 0 && i < 10000 = show i - | otherwise = error ("show4: the integer i must satisfy 0 <= i < 10000: " ++ show i) - -show2 :: Integral i => i -> String -show2 i - | i >= 0 && i < 10 = '0' : show i - | i >= 0 && i < 100 = show i - | otherwise = error ("show2: the integer i must satisfy 0 <= i < 100: " ++ show i) - -read4 :: (Stream s m Char, Num n) => ParsecT s u m n -read4 = do n1 <- digit' - n2 <- digit' - n3 <- digit' - n4 <- digit' - return (n1 * 1000 + n2 * 100 + n3 * 10 + n4) - -read2 :: (Stream s m Char, Num n) => ParsecT s u m n -read2 = do n1 <- digit' - n2 <- digit' - return (n1 * 10 + n2) - -digit' :: (Stream s m Char, Num n) => ParsecT s u m n -digit' = liftM fromC digit - -fromC :: Num n => Char -> n -fromC '0' = 0 -fromC '1' = 1 -fromC '2' = 2 -fromC '3' = 3 -fromC '4' = 4 -fromC '5' = 5 -fromC '6' = 6 -fromC '7' = 7 -fromC '8' = 8 -fromC '9' = 9 -fromC _ = undefined - -show4digitsTZ :: TimeZone -> String -show4digitsTZ tz - = case timeZoneMinutes tz of - offset | offset < 0 -> '-' : showTZ' (negate offset) - | otherwise -> '+' : showTZ' offset - where - showTZ' offset - = let h = offset `div` 60 - m = offset - h * 60 - in - show2 h ++ show2 m - -read4digitsTZ :: Stream s m Char => ParsecT s u m TimeZone -read4digitsTZ - = do sign <- (char '+' >> return 1) - <|> - (char '-' >> return (-1)) - hour <- read2 - minute <- read2 - let tz = TimeZone { - timeZoneMinutes = sign * (hour * 60 + minute) - , timeZoneSummerOnly = False - , timeZoneName = timeZoneOffsetString tz - } - return tz - -assertWeekDayIsGood :: Stream s m t => Int -> Day -> ParsecT s u m () -assertWeekDayIsGood givenWD gregDay - = let (_, _, correctWD ) = toWeekDate gregDay - (year, month, day) = toGregorian gregDay - in - unless (givenWD == correctWD) - $ fail - $ concat [ "Gregorian day " - , show year - , "-" - , show month - , "-" - , show day - , " is " - , longWeekDayName correctWD - , ", not " - , longWeekDayName givenWD - ] - -assertGregorianDateIsGood :: Stream s m t => Integer -> Int -> Int -> ParsecT s u m Day -assertGregorianDateIsGood year month day - = case fromGregorianValid year month day of - Nothing - -> fail $ concat [ "Invalid gregorian day: " - , show year - , "-" - , show month - , "-" - , show day - ] - Just gregDay - -> return gregDay - -assertTimeOfDayIsGood :: Stream s m t => Int -> Int -> Pico -> ParsecT s u m TimeOfDay -assertTimeOfDayIsGood hour minute second - = case makeTimeOfDayValid hour minute second of - Nothing - -> fail $ concat [ "Invalid time of day: " - , show hour - , ":" - , show minute - , ":" - , showFixed True second - ] - Just tod - -> return tod diff --git a/Data/Time/HTTP/Parsec.hs b/Data/Time/HTTP/Parsec.hs deleted file mode 100644 --- a/Data/Time/HTTP/Parsec.hs +++ /dev/null @@ -1,21 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Data.Time.HTTP.Parsec - ( rfc2616DateAndTime - ) - where - -import Control.Monad -import Data.Time -import Data.Time.RFC1123.Parsec -import Data.Time.RFC733.Parsec -import Data.Time.Asctime.Parsec -import Text.Parsec - --- |This is a parsec parser for date and time formats allowed in --- HTTP\/1.1 (RFC 2616). -rfc2616DateAndTime :: Stream s m Char => ParsecT s u m UTCTime -rfc2616DateAndTime - = choice [ liftM zonedTimeToUTC $ try rfc1123DateAndTime - , liftM zonedTimeToUTC $ try rfc733DateAndTime - , liftM (localTimeToUTC utc) asctime - ] diff --git a/Data/Time/RFC1123.hs b/Data/Time/RFC1123.hs deleted file mode 100644 --- a/Data/Time/RFC1123.hs +++ /dev/null @@ -1,61 +0,0 @@ --- |This module provides functions to parse and format RFC 1123 date --- and time formats. --- --- The format is basically same as RFC 822, but the syntax for @date@ --- is changed from: --- --- > year ::= 2DIGIT --- --- to: --- --- > year ::= 4DIGIT -module Data.Time.RFC1123 - ( format - , parse - ) - where - -import qualified Text.Parsec as P - -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822 (showRFC822TimeZone) -import Data.Time.RFC1123.Parsec - --- |Format a 'ZonedTime' in RFC 1123. -format :: ZonedTime -> String -format zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - concat [ shortWeekDayName week - , ", " - , show2 day - , " " - , shortMonthName month - , " " - , show4 year - , " " - , show2 (todHour timeOfDay) - , ":" - , show2 (todMin timeOfDay) - , ":" - , show2 (floor (todSec timeOfDay)) - , " " - , showRFC822TimeZone timeZone - ] - --- |Parse an RFC 1123 date and time string. When the string can't be --- parsed, it returns 'Nothing'. -parse :: String -> Maybe ZonedTime -parse src = case P.parse p "" src of - Right zt -> Just zt - Left _ -> Nothing - where - p = do zt <- rfc1123DateAndTime - _ <- P.eof - return zt diff --git a/Data/Time/RFC1123/Parsec.hs b/Data/Time/RFC1123/Parsec.hs deleted file mode 100644 --- a/Data/Time/RFC1123/Parsec.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Data.Time.RFC1123.Parsec - ( rfc1123DateAndTime - ) - where - -import Control.Monad -import Data.Fixed -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822.Parsec -import Text.Parsec - --- |This is a parsec parser for RFC 1123 date and time strings. -rfc1123DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime -rfc1123DateAndTime = dateTime - -dateTime :: Stream s m Char => ParsecT s u m ZonedTime -dateTime = do weekDay <- optionMaybe $ - do w <- shortWeekDayNameP - _ <- string ", " - return w - gregDay <- date - case weekDay of - Nothing - -> return () -- No day in week exists. - Just givenWD - -> assertWeekDayIsGood givenWD gregDay - (tod, timeZone) <- rfc822time - let lt = LocalTime gregDay tod - zt = ZonedTime lt timeZone - return zt - -date :: Stream s m Char => ParsecT s u m Day -date = do day <- read2 - _ <- char ' ' - month <- shortMonthNameP - _ <- char ' ' - year <- read4 - _ <- char ' ' - assertGregorianDateIsGood year month day diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs deleted file mode 100644 --- a/Data/Time/RFC733.hs +++ /dev/null @@ -1,88 +0,0 @@ --- |This module provides functions to parse and format RFC 733 date --- and time formats. --- --- The syntax is as follows: --- --- > date-time ::= [ day-of-week ", " ] date SP time ("-" | SP) zone --- > day-of-week ::= "Monday" | "Mon" | "Tuesday" | "Tue" --- > | "Wednesday" | "Wed" | "Thursday" | "Thu" --- > | "Friday" | "Fri" | "Saturday" | "Sat" --- > | "Sunday" | "Sun" --- > date ::= day ("-" | SP) month ("-" | SP) year --- > day ::= 2DIGIT --- > year ::= 2DIGIT | 4DIGIT --- > month ::= "January" | "Jan" | "February" | "Feb" --- > | "March" | "Mar" | "April" | "Apr" --- > | "May" | "June" | "Jun" --- > | "July" | "Jul" | "August" | "Aug" --- > | "September" | "Sep" | "October" | "Oct" --- > | "November" | "Nov" | "December" | "Dec" --- > time ::= hour [ ":" ] minute [ [ ":" ] second ] --- > hour ::= 2DIGIT --- > minute ::= 2DIGIT --- > second ::= 2DIGIT --- > zone ::= "GMT" ; Universal Time --- > | "NST" ; Newfoundland: -3:30 --- > | "AST" | "ADT" ; Atlantic : -4 / -3 --- > | "EST" | "EDT" ; Eastern : -5 / -4 --- > | "CST" | "CDT" ; Central : -6 / -5 --- > | "MST" | "MDT" ; Mountain : -7 / -6 --- > | "PST" | "PDT" ; Pacific : -8 / -7 --- > | "YST" | "YDT" ; Yukon : -9 / -8 --- > | "HST" | "HDT" ; Haw/Ala : -10 / -9 --- > | "BST" | "BDT" ; Bering : -11 / -10 --- > | "Z" ; GMT --- > | "A" ; -1 --- > | "M" ; -12 --- > | "N" ; +1 --- > | "Y" ; +12 --- > | ("+" | "-") 4DIGIT ; Local diff: HHMM -module Data.Time.RFC733 - ( format - , parse - ) - where - -import qualified Text.Parsec as P - -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC733.Parsec - --- |Format a 'ZonedTime' in RFC 733. -format :: ZonedTime -> String -format zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - concat [ longWeekDayName week - , ", " - , show2 day - , "-" - , shortMonthName month - , "-" - , show4 year - , " " - , show2 (todHour timeOfDay) - , ":" - , show2 (todMin timeOfDay) - , ":" - , show2 (floor (todSec timeOfDay)) - , "-" - , show4digitsTZ timeZone - ] - --- |Parse an RFC 733 date and time string. When the string can't be --- parsed, it returns 'Nothing'. -parse :: String -> Maybe ZonedTime -parse src = case P.parse p "" src of - Right zt -> Just zt - Left _ -> Nothing - where - p = do zt <- rfc733DateAndTime - _ <- P.eof - return zt diff --git a/Data/Time/RFC733/Parsec.hs b/Data/Time/RFC733/Parsec.hs deleted file mode 100644 --- a/Data/Time/RFC733/Parsec.hs +++ /dev/null @@ -1,107 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -module Data.Time.RFC733.Parsec - ( rfc733DateAndTime - ) - where - -import Control.Monad -import Data.Fixed -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Text.Parsec - --- |This is a parsec parser for RFC 733 date and time strings. -rfc733DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime -rfc733DateAndTime = dateTime - -dateTime :: Stream s m Char => ParsecT s u m ZonedTime -dateTime = do weekDay <- optionMaybe $ - do w <- try longWeekDayNameP - <|> - shortWeekDayNameP - _ <- string ", " - return w - gregDay <- date - case weekDay of - Nothing - -> return () - Just givenWD - -> assertWeekDayIsGood givenWD gregDay - (tod, timeZone) <- time - let lt = LocalTime gregDay tod - zt = ZonedTime lt timeZone - return zt - -date :: Stream s m Char => ParsecT s u m Day -date = do day <- read2 - _ <- char '-' <|> char ' ' - month <- try longMonthNameP - <|> - shortMonthNameP - _ <- char '-' <|> char ' ' - year <- try read4 - <|> - liftM (+ 1900) read2 - _ <- char ' ' - assertGregorianDateIsGood year month day - -time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) -time = do tod <- hour - _ <- char '-' <|> char ' ' - tz <- zone - return (tod, tz) - -hour :: Stream s m Char => ParsecT s u m TimeOfDay -hour = do hour <- read2 - _ <- optional (char ':') - minute <- read2 - second <- option 0 $ - do _ <- optional (char ':') - read2 - assertTimeOfDayIsGood hour minute second - -zone :: Stream s m Char => ParsecT s u m TimeZone -zone = choice [ string "GMT" >> return (TimeZone 0 False "GMT") - , char 'N' - >> choice [ string "ST" >> return (TimeZone ((-3) * 60 - 30) False "NST") - , return (TimeZone (1 * 60) False "N") - ] - , char 'A' - >> choice [ string "ST" >> return (TimeZone ((-4) * 60) False "AST") - , string "DT" >> return (TimeZone ((-3) * 60) False "AST") - , return (TimeZone ((-1) * 60) False "A") - ] - , char 'E' - >> choice [ string "ST" >> return (TimeZone ((-5) * 60) False "EST") - , string "DT" >> return (TimeZone ((-4) * 60) True "EDT") - ] - , char 'C' - >> choice [ string "ST" >> return (TimeZone ((-6) * 60) False "CST") - , string "DT" >> return (TimeZone ((-5) * 60) True "CDT") - ] - , char 'M' - >> choice [ string "ST" >> return (TimeZone ((-7) * 60) False "MST") - , string "DT" >> return (TimeZone ((-6) * 60) True "MDT") - , return (TimeZone ((-12) * 60) False "M") - ] - , char 'P' - >> choice [ string "ST" >> return (TimeZone ((-8) * 60) False "PST") - , string "DT" >> return (TimeZone ((-7) * 60) True "PDT") - ] - , char 'Y' - >> choice [ string "ST" >> return (TimeZone ((-9) * 60) False "YST") - , string "DT" >> return (TimeZone ((-8) * 60) True "YDT") - , return (TimeZone ( 12 * 60) False "Y") - ] - , char 'H' - >> choice [ string "ST" >> return (TimeZone ((-10) * 60) False "HST") - , string "DT" >> return (TimeZone (( -9) * 60) True "HDT") - ] - , char 'B' - >> choice [ string "ST" >> return (TimeZone ((-11) * 60) False "BST") - , string "DT" >> return (TimeZone ((-10) * 60) True "BDT") - ] - , char 'Z' >> return (TimeZone 0 False "Z") - , read4digitsTZ - ] diff --git a/Data/Time/RFC822.hs b/Data/Time/RFC822.hs deleted file mode 100644 --- a/Data/Time/RFC822.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# OPTIONS_HADDOCK prune #-} - --- |This module provides functions to parse and format RFC 822 date --- and time formats. --- --- The syntax is as follows: --- --- > date-time ::= [ day-of-week ", " ] date SP time SP zone --- > day-of-week ::= "Mon" | "Tue" | "Wed" | "Thu" --- > | "Fri" | "Sat" | "Sun" --- > date ::= day SP month SP year --- > day ::= 2DIGIT --- > year ::= 2DIGIT ; Yes, only 2 digits. --- > month ::= "Jan" | "Feb" | "Mar" | "Apr" --- > | "May" | "Jun" | "Jul" | "Aug" --- > | "Sep" | "Oct" | "Nov" | "Dec" --- > time ::= hour ":" minute [ ":" second ] --- > hour ::= 2DIGIT --- > minute ::= 2DIGIT --- > second ::= 2DIGIT --- > zone ::= "UT" | "GMT" ; Universal Time --- > | "EST" | "EDT" ; Eastern : -5 / -4 --- > | "CST" | "CDT" ; Central : -6 / -5 --- > | "MST" | "MDT" ; Mountain: -7 / -6 --- > | "PST" | "PDT" ; Pacific : -8 / -7 --- > | "Z" ; UT --- > | "A" ; -1 --- > | "M" ; -12 --- > | "N" ; +1 --- > | "Y" ; +12 --- > | ("+" | "-") 4DIGIT ; Local diff: HHMM -module Data.Time.RFC822 - ( format - , parse - - -- private - , showRFC822TimeZone - ) - where - -import qualified Text.Parsec as P - -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822.Parsec - --- |Format a 'ZonedTime' in RFC 822. -format :: ZonedTime -> String -format zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - concat [ shortWeekDayName week - , ", " - , show2 day - , " " - , shortMonthName month - , " " - , show2 (year `mod` 100) - , " " - , show2 (todHour timeOfDay) - , ":" - , show2 (todMin timeOfDay) - , ":" - , show2 (floor (todSec timeOfDay)) - , " " - , showRFC822TimeZone timeZone - ] - -showRFC822TimeZone :: TimeZone -> String -showRFC822TimeZone tz - | timeZoneMinutes tz == 0 = "GMT" - | otherwise = show4digitsTZ tz - --- |Parse an RFC 822 date and time string. When the string can't be --- parsed, it returns 'Nothing'. -parse :: String -> Maybe ZonedTime -parse src = case P.parse p "" src of - Right zt -> Just zt - Left _ -> Nothing - where - p = do zt <- rfc822DateAndTime - _ <- P.eof - return zt diff --git a/Data/Time/RFC822/Parsec.hs b/Data/Time/RFC822/Parsec.hs deleted file mode 100644 --- a/Data/Time/RFC822/Parsec.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# OPTIONS_HADDOCK prune #-} - -module Data.Time.RFC822.Parsec - ( rfc822DateAndTime - - -- private - , rfc822time - ) - where - -import Control.Monad -import Data.Fixed -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Text.Parsec - --- |This is a parsec parser for RFC 822 date and time strings. -rfc822DateAndTime :: Stream s m Char => ParsecT s u m ZonedTime -rfc822DateAndTime = dateTime - -dateTime :: Stream s m Char => ParsecT s u m ZonedTime -dateTime = do weekDay <- optionMaybe $ - do w <- shortWeekDayNameP - _ <- string ", " - return w - gregDay <- date - case weekDay of - Nothing - -> return () -- No day in week exists. - Just givenWD - -> assertWeekDayIsGood givenWD gregDay - (tod, timeZone) <- rfc822time - let lt = LocalTime gregDay tod - zt = ZonedTime lt timeZone - return zt - -date :: Stream s m Char => ParsecT s u m Day -date = do day <- read2 - _ <- char ' ' - month <- shortMonthNameP - _ <- char ' ' - year <- liftM (+ 1900) read2 - _ <- char ' ' - assertGregorianDateIsGood year month day - -rfc822time :: Stream s m Char => ParsecT s u m (TimeOfDay, TimeZone) -rfc822time = do tod <- hour - _ <- char ' ' - tz <- zone - return (tod, tz) - -hour :: Stream s m Char => ParsecT s u m TimeOfDay -hour = do hour <- read2 - minute <- char ':' >> read2 - second <- option 0 (char ':' >> read2) - assertTimeOfDayIsGood hour minute second - -zone :: Stream s m Char => ParsecT s u m 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 - ] diff --git a/time-http.cabal b/time-http.cabal --- a/time-http.cabal +++ b/time-http.cabal @@ -1,19 +1,25 @@ Name: time-http -Version: 0.1.0.1 +Version: 0.5 Synopsis: Parse and format HTTP/1.1 Date and Time strings Description: This package provides functionalities to parse and format - various Date and Time formats allowed in HTTP\/1.1 (RFC 2616). + various Date and Time formats allowed in HTTP\/1.1 + (). Homepage: http://cielonegro.org/HTTPDateTime.html +Bug-Reports: http://static.cielonegro.org/ditz/time-http/ License: PublicDomain License-file: COPYING Author: PHO Maintainer: PHO Stability: Experimental -Category: Web +Category: Time, Web Build-type: Simple -Cabal-version: >= 1.6 +Tested-With: GHC == 7.0.3 +Cabal-version: >= 1.10 +Extra-Source-Files: + COPYING + ChangeLog Source-Repository head Type: git @@ -21,24 +27,54 @@ Library Exposed-modules: - Data.Time.RFC733 - Data.Time.RFC733.Parsec - Data.Time.RFC822 - Data.Time.RFC822.Parsec - Data.Time.RFC1123 - Data.Time.RFC1123.Parsec - Data.Time.Asctime - Data.Time.Asctime.Parsec - Data.Time.HTTP - Data.Time.HTTP.Parsec + Data.Time.Format.C + Data.Time.Format.RFC733 + Data.Time.Format.RFC822 + Data.Time.Format.RFC1123 + Data.Time.Format.HTTP Other-modules: - Data.Time.HTTP.Common + Data.Time.Format.HTTP.Common Build-depends: - base == 4.3.*, - parsec == 3.1.*, - time == 1.2.* + ascii == 0.0.*, + attempt == 0.3.*, + attoparsec == 0.10.*, + base == 4.*, + base-unicode-symbols == 0.2.*, + blaze-builder == 0.3.*, + blaze-textual == 0.2.*, + bytestring == 0.9.*, + convertible-text == 0.4.*, + data-default == 0.3.*, + failure == 0.1.*, + tagged == 0.2.*, + time == 1.2.* - Extensions: - FlexibleContexts + Default-Language: + Haskell2010 + + GHC-Options: + -Wall + +Test-Suite test-time-http + Type: exitcode-stdio-1.0 + Main-Is: Test/Time/Format/HTTP.hs + Default-Language: Haskell2010 + Build-depends: + QuickCheck == 2.4.*, + ascii == 0.0.*, + attempt == 0.3.*, + attoparsec == 0.10.*, + base == 4.*, + base-unicode-symbols == 0.2.*, + blaze-builder == 0.3.*, + blaze-textual == 0.2.*, + bytestring == 0.9.*, + convertible-text == 0.4.*, + data-default == 0.3.*, + failure == 0.1.*, + tagged == 0.2.*, + time == 1.2.* + GHC-Options: + -Wall -fno-warn-orphans