From 1636662996d663cc800f4a2fa702739cfd24d3f4 Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
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