HTTP

Ditz-issue: 0a3272772c73cf31486eb2b6691fa38232d3c4c5

diff --git a/Data/Time/HTTP.hs b/Data/Time/HTTP.hs
index f106fc4c7f397f77466f75b3a986937ea68d16a3..31d70e7bf917e74a02c6ab3e4bdba2123c5a6069 100644 (file)
--- 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 (file)
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 3022d0d78c1ef3a95da6fae4d00dff11bf0ff355..afa17bf70ab2e65639db18fde00912364eaedc45 100644 (file)
--- 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 110262daf0d047215b635ff1684ed3263c18b8e9..32dfebd5dc8130307e1584ddc68e0012712ca086 100644 (file)
--- 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: