diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,2 +1,5 @@ -== time-http-0.2 / unreleased +== 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,52 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} --- |This module provides functions for ANSI C's asctime() format. --- --- ANSI C's asctime() 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 --- --- As you can see, it has no time zone info. "Data.Time.HTTP" will --- treat it as UTC. -module Data.Time.Asctime - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii - , asctime - ) - where -import Data.Ascii (Ascii) -import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P -import Data.Time -import Data.Time.Asctime.Internal -import Prelude.Unicode - --- |Convert a 'LocalTime' to ANSI C's @asctime()@ string. -toAscii ∷ LocalTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder - --- |Parse an ANSI C's @asctime()@ string. When the string can't be --- parsed, it returns @'Left' err@. -fromAscii ∷ Ascii → Either String LocalTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← asctime - P.endOfInput - return zt diff --git a/Data/Time/Asctime/Internal.hs b/Data/Time/Asctime/Internal.hs deleted file mode 100644 --- a/Data/Time/Asctime/Internal.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} --- |Internal functions for "Data.Time.Asctime". -module Data.Time.Asctime.Internal - ( asctime - , toAsciiBuilder - ) - where -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 -import Data.Monoid.Unicode -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common - --- |Parse an ANSI C's @asctime()@ string. -asctime ∷ Parser LocalTime -asctime = 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 (LocalTime gregDay tod) - --- |Convert a 'LocalTime' to ANSI C's @asctime()@ string. -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 - 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,114 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , 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 + , 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.Monoid.Unicode +import Data.Proxy +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 (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) +-- Tagged "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 + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess LocalTime (Tagged C AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged C Ascii) LocalTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' cDateAndTime ∘ untag + +-- |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 + + gregDay ← assertGregorianDateIsGood year month day + _ ← assertWeekDayIsGood weekDay gregDay + tod ← assertTimeOfDayIsGood hour minute second + + return (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| LocalTime |], [t| Tagged C Ascii |]) + , ([t| LocalTime |], [t| Tagged C 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,123 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , 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 + , http + , httpDateAndTime + ) + 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.Proxy +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 (UTCTime (ModifiedJulianDay 49662) 31777) +-- Tagged "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 + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess UTCTime (Tagged HTTP AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged HTTP Ascii) UTCTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' httpDateAndTime ∘ untag + +-- |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 + ] + +toAsciiBuilder ∷ UTCTime → AsciiBuilder +{-# INLINE toAsciiBuilder #-} +toAsciiBuilder = flip proxy rfc1123 ∘ cs ∘ ut2zt + where + ut2zt ∷ UTCTime → ZonedTime + {-# INLINE ut2zt #-} + ut2zt = utcToZonedTime gmt + + gmt ∷ TimeZone + {-# INLINE CONLIKE gmt #-} + gmt = TimeZone 0 False "GMT" + +deriveAttempts [ ([t| UTCTime |], [t| Tagged HTTP Ascii |]) + , ([t| UTCTime |], [t| Tagged HTTP 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,119 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , 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 + , rfc1123 + , rfc1123DateAndTime + ) + 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.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 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" +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 + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC1123 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged RFC1123 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc1123DateAndTime ∘ untag + +-- |Parse an RFC 1123 date and time string. +rfc1123DateAndTime ∷ Parser ZonedTime +rfc1123DateAndTime = dateTime + +dateTime ∷ Parser ZonedTime +dateTime = do weekDay ← optionMaybe $ + do w ← shortWeekDayNameP + _ ← string ", " + return w + gregDay ← date + case weekDay of + Nothing + → return () + Just givenWD + → assertWeekDayIsGood givenWD gregDay + (tod, timeZone) ← rfc822Time + let lt = LocalTime gregDay tod + zt = ZonedTime lt timeZone + return zt + +date ∷ Parser Day +date = do day ← read2 + _ ← char ' ' + month ← shortMonthNameP + _ ← char ' ' + year ← read4 + _ ← char ' ' + assertGregorianDateIsGood year month day + +toAsciiBuilder ∷ ZonedTime → AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime zonedTime + timeZone = zonedTimeZone zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + shortWeekDayName week + ⊕ A.toAsciiBuilder ", " + ⊕ show2 day + ⊕ A.toAsciiBuilder " " + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder " " + ⊕ show4 year + ⊕ A.toAsciiBuilder " " + ⊕ show2 (todHour timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (todMin timeOfDay) + ⊕ A.toAsciiBuilder ":" + ⊕ show2 (floor (todSec timeOfDay) ∷ Int) + ⊕ A.toAsciiBuilder " " + ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) + +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC1123 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC1123 AsciiBuilder |]) + ] diff --git a/Data/Time/Format/RFC733.hs b/Data/Time/Format/RFC733.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Format/RFC733.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , 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 + , rfc733 + , rfc733DateAndTime + ) + 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.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 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" +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 + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC733 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = Tagged ∘ toAsciiBuilder + +instance ConvertAttempt (Tagged RFC733 Ascii) ZonedTime where + {-# INLINE convertAttempt #-} + convertAttempt = parseAttempt' rfc733DateAndTime ∘ untag + +-- |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 + +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 ∷ ZonedTime → AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime zonedTime + timeZone = zonedTimeZone zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + 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 " " + ⊕ untag (cs timeZone ∷ Tagged RFC822 AsciiBuilder) + +deriveAttempts [ ([t| ZonedTime |], [t| Tagged RFC733 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC733 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,46 @@ +{-# LANGUAGE + 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 + , 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 diff --git a/Data/Time/Format/RFC822/Internal.hs b/Data/Time/Format/RFC822/Internal.hs new file mode 100644 --- /dev/null +++ b/Data/Time/Format/RFC822/Internal.hs @@ -0,0 +1,151 @@ +{-# LANGUAGE + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax + #-} +module Data.Time.Format.RFC822.Internal + ( RFC822 + , rfc822DateAndTime + , rfc822Time + ) + 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.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'. +-- +-- >>> convertSuccess (ZonedTime (LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)) utc) +-- Tagged "Sun, 06 Nov 94 08:49:37 GMT" +data RFC822 + +instance ConvertSuccess ZonedTime (Tagged RFC822 Ascii) where + {-# INLINE convertSuccess #-} + convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs + +instance ConvertSuccess ZonedTime (Tagged RFC822 AsciiBuilder) where + {-# INLINE convertSuccess #-} + convertSuccess = 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 ∷ ZonedTime → AsciiBuilder +toAsciiBuilder zonedTime + = let localTime = zonedTimeToLocalTime zonedTime + timeZone = zonedTimeZone zonedTime + (year, month, day) = toGregorian (localDay localTime) + (_, _, week) = toWeekDate (localDay localTime) + timeOfDay = localTimeOfDay localTime + in + shortWeekDayName week + ⊕ A.toAsciiBuilder ", " + ⊕ show2 day + ⊕ A.toAsciiBuilder " " + ⊕ shortMonthName month + ⊕ A.toAsciiBuilder " " + ⊕ 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| ZonedTime |], [t| Tagged RFC822 Ascii |]) + , ([t| ZonedTime |], [t| Tagged RFC822 AsciiBuilder |]) + , ([t| TimeZone |], [t| Tagged RFC822 Ascii |]) + , ([t| TimeZone |], [t| Tagged RFC822 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,77 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} --- |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 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii - , httpDateAndTime - ) - where -import Data.Ascii (Ascii) -import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P -import Data.Time -import Data.Time.HTTP.Internal -import Prelude.Unicode - --- |Convert a 'UTCTime' to RFC 1123 date and time string. -toAscii ∷ UTCTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder - --- |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 @'Left' err@. --- --- 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. -fromAscii ∷ Ascii → Either String UTCTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← httpDateAndTime - P.endOfInput - 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,334 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} -module Data.Time.HTTP.Common - ( shortWeekDayName - , shortWeekDayNameP - - , longWeekDayName - , longWeekDayNameP - - , shortMonthName - , shortMonthNameP - - , longMonthName - , longMonthNameP - - , show4 - , show2 - , show2' - - , read4 - , read2 - , read2' - - , show4digitsTZ - , read4digitsTZ - - , assertWeekDayIsGood - , assertGregorianDateIsGood - , assertTimeOfDayIsGood - - , optionMaybe - ) - where -import Blaze.ByteString.Builder.ByteString as B -import Blaze.Text.Int as BT -import Control.Applicative -import Control.Monad -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 as P -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 -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 -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) diff --git a/Data/Time/HTTP/Internal.hs b/Data/Time/HTTP/Internal.hs deleted file mode 100644 --- a/Data/Time/HTTP/Internal.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} --- |Internal functions for "Data.Time.HTTP". -module Data.Time.HTTP.Internal - ( httpDateAndTime - , toAsciiBuilder - ) - where -import Control.Applicative -import Data.Ascii (AsciiBuilder) -import Data.Attoparsec.Char8 -import Data.Time -import qualified Data.Time.RFC1123.Internal as RFC1123 -import qualified Data.Time.RFC733.Internal as RFC733 -import qualified Data.Time.Asctime.Internal as Asctime -import Prelude.Unicode - --- |Parse a date and time string in any formats allowed by HTTP\/1.1 --- (RFC 2616). -httpDateAndTime ∷ Parser UTCTime -httpDateAndTime - = choice [ zonedTimeToUTC <$> try RFC1123.rfc1123DateAndTime - , zonedTimeToUTC <$> try RFC733.rfc733DateAndTime - , localTimeToUTC utc <$> Asctime.asctime - ] - --- |Convert a 'UTCTime' to RFC 1123 date and time string. -toAsciiBuilder ∷ UTCTime → AsciiBuilder -toAsciiBuilder = RFC1123.toAsciiBuilder ∘ ut2zt - where - ut2zt ∷ UTCTime → ZonedTime - ut2zt = utcToZonedTime gmt - - gmt ∷ TimeZone - gmt = TimeZone 0 False "GMT" diff --git a/Data/Time/RFC1123.hs b/Data/Time/RFC1123.hs deleted file mode 100644 --- a/Data/Time/RFC1123.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} --- |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 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii - , rfc1123DateAndTime - ) - where -import Data.Ascii (Ascii) -import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P -import Data.Time -import Data.Time.RFC1123.Internal -import Prelude.Unicode - --- |Convert a 'ZonedTime' to RFC 1123 date and time string. -toAscii ∷ ZonedTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder - --- |Parse an RFC 1123 date and time string. When the string can't be --- parsed, it returns @'Left' err@. -fromAscii ∷ Ascii → Either String ZonedTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← rfc1123DateAndTime - P.endOfInput - return zt diff --git a/Data/Time/RFC1123/Internal.hs b/Data/Time/RFC1123/Internal.hs deleted file mode 100644 --- a/Data/Time/RFC1123/Internal.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} --- |Internal functions for "Data.Time.RFC1123". -module Data.Time.RFC1123.Internal - ( rfc1123DateAndTime - , toAsciiBuilder - ) - where -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 -import Data.Monoid.Unicode -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822.Internal hiding (toAsciiBuilder) - --- |Parse an RFC 1123 date and time string. -rfc1123DateAndTime ∷ Parser ZonedTime -rfc1123DateAndTime = dateTime - -dateTime ∷ Parser ZonedTime -dateTime = do weekDay ← optionMaybe $ - do w ← shortWeekDayNameP - _ ← string ", " - return w - gregDay ← date - case weekDay of - Nothing - → return () - Just givenWD - → assertWeekDayIsGood givenWD gregDay - (tod, timeZone) ← rfc822time - let lt = LocalTime gregDay tod - zt = ZonedTime lt timeZone - return zt - -date ∷ Parser Day -date = do day ← read2 - _ ← char ' ' - month ← shortMonthNameP - _ ← char ' ' - year ← read4 - _ ← char ' ' - assertGregorianDateIsGood year month day - --- |Convert a 'ZonedTime' to RFC 1123 date and time string. -toAsciiBuilder ∷ ZonedTime → AsciiBuilder -toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - shortWeekDayName week - ⊕ A.toAsciiBuilder ", " - ⊕ show2 day - ⊕ A.toAsciiBuilder " " - ⊕ shortMonthName month - ⊕ A.toAsciiBuilder " " - ⊕ show4 year - ⊕ A.toAsciiBuilder " " - ⊕ show2 (todHour timeOfDay) - ⊕ A.toAsciiBuilder ":" - ⊕ show2 (todMin timeOfDay) - ⊕ A.toAsciiBuilder ":" - ⊕ show2 (floor (todSec timeOfDay) ∷ Int) - ⊕ A.toAsciiBuilder " " - ⊕ showRFC822TimeZone timeZone diff --git a/Data/Time/RFC733.hs b/Data/Time/RFC733.hs deleted file mode 100644 --- a/Data/Time/RFC733.hs +++ /dev/null @@ -1,71 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} --- |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 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii - , rfc733DateAndTime - ) - where -import Data.Ascii (Ascii) -import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P -import Data.Time -import Data.Time.RFC733.Internal -import Prelude.Unicode - --- |Convert a 'ZonedTime' to RFC 733 date and time string. -toAscii ∷ ZonedTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder - --- |Parse an RFC 733 date and time string. When the string can't be --- parsed, it returns @'Left' err@. -fromAscii ∷ Ascii → Either String ZonedTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← rfc733DateAndTime - P.endOfInput - return zt diff --git a/Data/Time/RFC733/Internal.hs b/Data/Time/RFC733/Internal.hs deleted file mode 100644 --- a/Data/Time/RFC733/Internal.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} --- |Internal functions for "Data.Time.RFC733". -module Data.Time.RFC733.Internal - ( rfc733DateAndTime - , toAsciiBuilder - ) - where -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Control.Applicative -import Data.Attoparsec.Char8 -import Data.Monoid.Unicode -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Data.Time.RFC822.Internal hiding (toAsciiBuilder) - --- |Parse RFC 733 date and time strings. -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 - -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 - ] - --- |Convert a 'ZonedTime' to RFC 733 date and time string. -toAsciiBuilder ∷ ZonedTime → AsciiBuilder -toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - 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 " " - ⊕ showRFC822TimeZone timeZone diff --git a/Data/Time/RFC822.hs b/Data/Time/RFC822.hs deleted file mode 100644 --- a/Data/Time/RFC822.hs +++ /dev/null @@ -1,61 +0,0 @@ -{-# LANGUAGE - UnicodeSyntax - #-} --- |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 - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii - , rfc822DateAndTime - ) - where -import Data.Ascii (Ascii) -import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P -import Data.Time -import Data.Time.RFC822.Internal -import Prelude.Unicode - --- |Convert a 'ZonedTime' to RFC 822 date and time string. -toAscii ∷ ZonedTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder - --- |Parse an RFC 822 date and time string. When the string can't be --- parsed, it returns @'Left' err@. -fromAscii ∷ Ascii → Either String ZonedTime -fromAscii = P.parseOnly p ∘ A.toByteString - where - p = do zt ← rfc822DateAndTime - P.endOfInput - return zt diff --git a/Data/Time/RFC822/Internal.hs b/Data/Time/RFC822/Internal.hs deleted file mode 100644 --- a/Data/Time/RFC822/Internal.hs +++ /dev/null @@ -1,121 +0,0 @@ -{-# LANGUAGE - OverloadedStrings - , UnicodeSyntax - #-} --- |Internal functions for "Data.Time.RFC822". -module Data.Time.RFC822.Internal - ( rfc822DateAndTime - , rfc822time - , showRFC822TimeZone - , toAsciiBuilder - ) - where -import Control.Applicative -import Data.Ascii (AsciiBuilder) -import qualified Data.Ascii as A -import Data.Attoparsec.Char8 -import Data.Monoid.Unicode -import Data.Time -import Data.Time.Calendar.WeekDate -import Data.Time.HTTP.Common -import Prelude.Unicode - --- |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 - --- |Parse the time and time zone of an RFC 822 date and time string. -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 - ] - --- |No need to explain. -showRFC822TimeZone ∷ TimeZone → AsciiBuilder -showRFC822TimeZone tz - | timeZoneMinutes tz ≡ 0 = A.toAsciiBuilder "GMT" - | otherwise = show4digitsTZ tz - --- |Convert a 'ZonedTime' to RFC 822 date and time string. -toAsciiBuilder ∷ ZonedTime → AsciiBuilder -toAsciiBuilder zonedTime - = let localTime = zonedTimeToLocalTime zonedTime - timeZone = zonedTimeZone zonedTime - (year, month, day) = toGregorian (localDay localTime) - (_, _, week) = toWeekDate (localDay localTime) - timeOfDay = localTimeOfDay localTime - in - shortWeekDayName week - ⊕ A.toAsciiBuilder ", " - ⊕ show2 day - ⊕ A.toAsciiBuilder " " - ⊕ shortMonthName month - ⊕ A.toAsciiBuilder " " - ⊕ show2 (year `mod` 100) - ⊕ A.toAsciiBuilder " " - ⊕ show2 (todHour timeOfDay) - ⊕ A.toAsciiBuilder ":" - ⊕ show2 (todMin timeOfDay) - ⊕ A.toAsciiBuilder ":" - ⊕ show2 (floor (todSec timeOfDay) ∷ Int) - ⊕ A.toAsciiBuilder " " - ⊕ showRFC822TimeZone timeZone diff --git a/time-http.cabal b/time-http.cabal --- a/time-http.cabal +++ b/time-http.cabal @@ -1,9 +1,10 @@ Name: time-http -Version: 0.2 +Version: 0.3 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/ @@ -26,27 +27,27 @@ Library Exposed-modules: - Data.Time.Asctime - Data.Time.HTTP - Data.Time.RFC1123 - Data.Time.RFC733 - Data.Time.RFC822 + Data.Time.Format.C + Data.Time.Format.RFC733 + Data.Time.Format.RFC822 + Data.Time.Format.RFC1123 + Data.Time.Format.HTTP Other-modules: - Data.Time.Asctime.Internal - Data.Time.HTTP.Common - Data.Time.HTTP.Internal - Data.Time.RFC1123.Internal - Data.Time.RFC733.Internal - Data.Time.RFC822.Internal + Data.Time.Format.HTTP.Common + Data.Time.Format.RFC822.Internal Build-depends: ascii == 0.0.*, + attempt == 0.3.*, attoparsec == 0.9.*, - blaze-builder == 0.3.*, - blaze-textual == 0.2.*, base == 4.*, base-unicode-symbols == 0.2.*, + blaze-builder == 0.3.*, + blaze-textual == 0.2.*, + bytestring == 0.9.*, + convertible-text == 0.4.*, + tagged == 0.2.*, time == 1.2.* Default-Language: @@ -57,16 +58,20 @@ Test-Suite test-time-http Type: exitcode-stdio-1.0 - Main-Is: Test/Time/HTTP.hs + Main-Is: Test/Time/Format/HTTP.hs Default-Language: Haskell2010 Build-depends: QuickCheck == 2.4.*, ascii == 0.0.*, + attempt == 0.3.*, attoparsec == 0.9.*, - blaze-builder == 0.3.*, - blaze-textual == 0.2.*, base == 4.*, base-unicode-symbols == 0.2.*, + blaze-builder == 0.3.*, + blaze-textual == 0.2.*, + bytestring == 0.9.*, + convertible-text == 0.4.*, + tagged == 0.2.*, time == 1.2.* GHC-Options: -Wall -fno-warn-orphans