Merge branch 'convertible'

[time-http.git] / Test / Time / Format / HTTP.hs

diff --git a/Test/Time/Format/HTTP.hs b/Test/Time/Format/HTTP.hs
new file mode 100644 (file)
index 0000000..b443e86
--- /dev/null
+++ b/Test/Time/Format/HTTP.hs
@@ -0,0 +1,166 @@
+{-# LANGUAGE
+    FlexibleInstances
+  , OverloadedStrings
+  , UnicodeSyntax
+  #-}
+module Main (main) where
+import Control.Applicative
+import Control.Applicative.Unicode
+import Data.Ascii (Ascii)
+import Data.Attempt hiding (Failure, Success)
+import Data.Convertible.Base
+import Data.Proxy
+import Data.Tagged
+import Data.Time
+import Data.Time.Format.C
+import Data.Time.Format.HTTP
+import Data.Time.Format.RFC733
+import Data.Time.Format.RFC822
+import Data.Time.Format.RFC1123
+import System.Exit
+import Prelude.Unicode
+import Test.QuickCheck
+
+main ∷ IO ()
+main = mapM_ runTest tests
+
+runTest ∷ Property → IO ()
+runTest prop
+    = do r ← quickCheckResult prop
+         case r of
+           Success {}           → return ()
+           GaveUp  {}           → exitFailure
+           Failure {}           → exitFailure
+           NoExpectedFailure {} → exitFailure
+
+data Cent20
+
+cent20 ∷ Proxy Cent20
+cent20 = Proxy
+
+instance Arbitrary Day where
+    arbitrary = ModifiedJulianDay <$> arbitrary
+
+instance Arbitrary (Tagged Cent20 Day) where
+    arbitrary = ((Tagged ∘) ∘) ∘ fromGregorian
+                <$> choose (1900, 1999)
+                ⊛ arbitrary
+                ⊛ arbitrary
+
+instance Arbitrary TimeOfDay where
+    arbitrary
+        = do h ← choose (0, 23)
+             m ← choose (0, 59)
+             s ← choose (0, 60)
+             return $ TimeOfDay h m (fromIntegral (s ∷ Int))
+
+instance Arbitrary LocalTime where
+    arbitrary = LocalTime <$> arbitrary ⊛ arbitrary
+
+instance Arbitrary (Tagged Cent20 LocalTime) where
+    arbitrary = (Tagged ∘) ∘ LocalTime <$>
+                (flip proxy cent20 <$> arbitrary)
+                ⊛ arbitrary
+
+instance Eq ZonedTime where
+    a == b = zonedTimeToUTC a ≡ zonedTimeToUTC b
+
+instance Arbitrary TimeZone where
+    arbitrary
+        = do m ← choose (-1439, 1439)
+             s ← arbitrary
+             n ← arbitrary
+             return $ TimeZone m s n
+
+instance Arbitrary ZonedTime where
+    arbitrary = ZonedTime <$> arbitrary ⊛ arbitrary
+
+instance Arbitrary (Tagged Cent20 ZonedTime) where
+    arbitrary = (Tagged ∘) ∘ ZonedTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
+
+instance Arbitrary DiffTime where
+    arbitrary = secondsToDiffTime <$> choose (0, 86400)
+
+instance Arbitrary UTCTime where
+    arbitrary = UTCTime <$> arbitrary ⊛ arbitrary
+
+instance Arbitrary (Tagged Cent20 UTCTime) where
+    arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
+
+tests ∷ [Property]
+tests = [ -- Asctime
+          property ( fromAttempt (ca (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged C Ascii))
+                     ≡ Just referenceLocalTime
+                   )
+
+        , property ( (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged C Ascii)
+                     ≡ cs referenceLocalTime
+                   )
+
+        , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) ∷ Tagged C Ascii))
+
+          -- RFC733
+        , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
+                     ≡ Just referenceZonedTime
+                   )
+
+        , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
+                     ≡ cs referenceZonedTime
+                   )
+
+        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC733 Ascii))
+
+          -- RFC822
+        , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
+                     ≡ Just referenceZonedTime
+                   )
+
+        , property ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
+                     ≡ cs referenceZonedTime
+                   )
+        , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime))
+                                                                ∷ Tagged RFC822 Ascii))
+
+          -- RFC1123
+        , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
+                     ≡ Just referenceZonedTime
+                   )
+
+        , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
+                     ≡ cs referenceZonedTime
+                   )
+
+        , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC1123 Ascii))
+
+          -- HTTP
+        , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
+                     ≡ cs referenceUTCTime
+                   )
+        , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
+        , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged C Ascii)))
+        , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
+        , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime)))
+                                                                           ∷ Tagged RFC822 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
+
+      referenceUTCTime ∷ UTCTime
+      referenceUTCTime
+          = zonedTimeToUTC referenceZonedTime
+
+      ut2lt ∷ UTCTime → LocalTime
+      ut2lt = utcToLocalTime utc
+
+      ut2zt ∷ UTCTime → ZonedTime
+      ut2zt = utcToZonedTime utc
+
+      retagHTTP ∷ Tagged s b → Tagged HTTP b
+      retagHTTP = retag