From 1636662996d663cc800f4a2fa702739cfd24d3f4 Mon Sep 17 00:00:00 2001 From: PHO Date: Mon, 12 Dec 2011 07:46:41 +0900 Subject: [PATCH] HTTP Ditz-issue: 0a3272772c73cf31486eb2b6691fa38232d3c4c5 --- Data/Time/HTTP.hs | 86 +++++++++++++++++++++++++++----------- Data/Time/HTTP/Internal.hs | 44 ------------------- Test/Time/HTTP.hs | 17 +++++--- time-http.cabal | 1 - 4 files changed, 73 insertions(+), 75 deletions(-) delete mode 100644 Data/Time/HTTP/Internal.hs diff --git a/Data/Time/HTTP.hs b/Data/Time/HTTP.hs index f106fc4..31d70e7 100644 --- a/Data/Time/HTTP.hs +++ b/Data/Time/HTTP.hs @@ -1,5 +1,9 @@ {-# LANGUAGE - UnicodeSyntax + FlexibleInstances + , MultiParamTypeClasses + , OverloadedStrings + , TemplateHaskell + , UnicodeSyntax #-} -- |This module provides functions to parse and format HTTP\/1.1 date -- and time formats. @@ -40,38 +44,70 @@ -- > | "May" | "Jun" | "Jul" | "Aug" -- > | "Sep" | "Oct" | "Nov" | "Dec" module Data.Time.HTTP - ( -- * Formatting - toAscii - , toAsciiBuilder - - -- * Parsing - , fromAscii + ( HTTP , httpDateAndTime ) where -import Data.Ascii (Ascii) +import Control.Applicative +import Data.Ascii (Ascii, AsciiBuilder) import qualified Data.Ascii as A -import qualified Data.Attoparsec.Char8 as P +import Data.Attoparsec.Char8 +import Data.Convertible.Base +import Data.Tagged import Data.Time -import Data.Time.HTTP.Internal +import Data.Time.Asctime +import Data.Time.RFC1123 +import Data.Time.RFC733 +import Data.Time.RFC822 +import Data.Time.HTTP.Common import Prelude.Unicode --- |Convert a 'UTCTime' to RFC 1123 date and time string. -toAscii ∷ UTCTime → Ascii -toAscii = A.fromAsciiBuilder ∘ toAsciiBuilder +-- |FIXME: doc +data HTTP + +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. When the string can't be parsed, it --- returns @'Left' err@. +-- and ANSI C's asctime() formats. -- --- 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 +-- 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 <$> asctime + ] + +toAsciiBuilder ∷ UTCTime → AsciiBuilder +toAsciiBuilder = untag' ∘ cs ∘ ut2zt where - p = do zt ← httpDateAndTime - P.endOfInput - return zt + untag' ∷ Tagged RFC1123 AsciiBuilder → AsciiBuilder + {-# INLINE CONLIKE untag' #-} + untag' = untag + + 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/HTTP/Internal.hs b/Data/Time/HTTP/Internal.hs deleted file mode 100644 index b008d9d..0000000 --- a/Data/Time/HTTP/Internal.hs +++ /dev/null @@ -1,44 +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.Convertible.Base -import Data.Tagged -import Data.Time -import Data.Time.RFC1123 -import Data.Time.RFC733 -import Data.Time.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 rfc1123DateAndTime - , zonedTimeToUTC <$> try rfc733DateAndTime - , localTimeToUTC utc <$> asctime - ] - --- |Convert a 'UTCTime' to RFC 1123 date and time string. -toAsciiBuilder ∷ UTCTime → AsciiBuilder -toAsciiBuilder = untag' ∘ cs ∘ ut2zt - where - untag' ∷ Tagged RFC1123 AsciiBuilder → AsciiBuilder - {-# INLINE CONLIKE untag' #-} - untag' = untag - - ut2zt ∷ UTCTime → ZonedTime - {-# INLINE ut2zt #-} - ut2zt = utcToZonedTime gmt - - gmt ∷ TimeZone - {-# INLINE CONLIKE gmt #-} - gmt = TimeZone 0 False "GMT" diff --git a/Test/Time/HTTP.hs b/Test/Time/HTTP.hs index 3022d0d..afa17bf 100644 --- a/Test/Time/HTTP.hs +++ b/Test/Time/HTTP.hs @@ -11,7 +11,7 @@ import Data.Convertible.Base import Data.Tagged import Data.Time import Data.Time.Asctime -import qualified Data.Time.HTTP as HTTP +import Data.Time.HTTP import Data.Time.RFC733 import Data.Time.RFC1123 import System.Exit @@ -100,18 +100,25 @@ tests = [ -- Asctime ∷ Tagged RFC1123 Ascii)) -- HTTP - , property $ \ut → Right ut ≡ HTTP.fromAscii (HTTP.toAscii ut ) - , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2lt ut) ∷ Tagged Asctime Ascii)) - , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)) - , property $ \ut → Right ut ≡ HTTP.fromAscii (untag (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime) + , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged Asctime Ascii))) + , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii))) + , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii))) ] where + referenceLocalTime ∷ LocalTime referenceLocalTime = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37) + referenceZonedTime ∷ ZonedTime referenceZonedTime = ZonedTime referenceLocalTime utc + ut2lt ∷ UTCTime → LocalTime ut2lt = utcToLocalTime utc + ut2zt ∷ UTCTime → ZonedTime ut2zt = utcToZonedTime utc + + retagHTTP ∷ Tagged s b → Tagged HTTP b + retagHTTP = retag diff --git a/time-http.cabal b/time-http.cabal index 110262d..32dfebd 100644 --- a/time-http.cabal +++ b/time-http.cabal @@ -34,7 +34,6 @@ Library Other-modules: Data.Time.HTTP.Common - Data.Time.HTTP.Internal Data.Time.RFC822.Internal Build-depends: -- 2.40.0