HTTP

[time-http.git] / Data / Time / HTTP.hs

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 |])
+               ]