HTTP

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

diff --git a/Data/Time/HTTP.hs b/Data/Time/HTTP.hs
index 9f628063938c744d232aa1751303e3e7b6b23817..31d70e7bf917e74a02c6ab3e4bdba2123c5a6069 100644 (file)
--- a/Data/Time/HTTP.hs
+++ b/Data/Time/HTTP.hs
@@ -1,3 +1,10 @@
+{-# LANGUAGE
+    FlexibleInstances
+  , MultiParamTypeClasses
+  , OverloadedStrings
+  , TemplateHaskell
+  , UnicodeSyntax
+  #-}
 -- |This module provides functions to parse and format HTTP\/1.1 date
 -- and time formats.
 --
@@ -37,39 +44,70 @@
 -- >              | "May" | "Jun" | "Jul" | "Aug"
 -- >              | "Sep" | "Oct" | "Nov" | "Dec"
 module Data.Time.HTTP
-    ( format
-    , parse
+    ( 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.Tagged
+import Data.Time
+import Data.Time.Asctime
+import Data.Time.RFC1123
+import Data.Time.RFC733
+import Data.Time.RFC822
+import Data.Time.HTTP.Common
+import Prelude.Unicode
 
-import qualified Data.Time.RFC1123 as RFC1123
-import qualified Text.Parsec as P
+-- |FIXME: doc
+data HTTP
 
-import Data.Time
-import Data.Time.HTTP.Parsec
+instance ConvertSuccess UTCTime (Tagged HTTP Ascii) where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = (A.fromAsciiBuilder <$>) ∘ cs
 
--- |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
+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 'Nothing'.
+-- 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.
-parse :: String -> Maybe UTCTime
-parse src = case P.parse p "" src of
-              Right ut -> Just ut
-              Left  _  -> Nothing
+-- 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 <- rfc2616DateAndTime
-             _  <- P.eof
-             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 |])
+               ]