Test/Time/HTTP.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , UnicodeSyntax
   4   , ViewPatterns
   5   #-}
   6 module Main (main) where
   7 import Control.Applicative
   8 import Control.Applicative.Unicode
   9 import Data.Time
  10 import qualified Data.Time.Asctime as Asctime
  11 import qualified Data.Time.HTTP    as HTTP
  12 import qualified Data.Time.RFC733  as RFC733
  13 import qualified Data.Time.RFC1123 as RFC1123
  14 import System.Exit
  15 import Prelude.Unicode
  16 import Test.QuickCheck
  17
  18 main ∷ IO ()
  19 main = mapM_ runTest tests
  20
  21 runTest ∷ Property → IO ()
  22 runTest prop
  23     = do r ← quickCheckResult prop
  24          case r of
  25            Success {}           → return ()
  26            GaveUp  {}           → exitFailure
  27            Failure {}           → exitFailure
  28            NoExpectedFailure {} → exitFailure
  29
  30 instance Arbitrary Day where
  31     arbitrary = ModifiedJulianDay <$> arbitrary
  32
  33 instance Arbitrary TimeOfDay where
  34     arbitrary
  35         = do h ← choose (0, 23)
  36              m ← choose (0, 59)
  37              s ← choose (0, 60)
  38              return $ TimeOfDay h m (fromIntegral (s ∷ Int))
  39
  40 instance Arbitrary LocalTime where
  41     arbitrary = LocalTime <$> arbitrary ⊛ arbitrary
  42
  43 instance Eq ZonedTime where
  44     a == b = zonedTimeToUTC a ≡ zonedTimeToUTC b
  45
  46 instance Arbitrary TimeZone where
  47     arbitrary
  48         = do m ← choose (-1439, 1439)
  49              s ← arbitrary
  50              n ← arbitrary
  51              return $ TimeZone m s n
  52
  53 instance Arbitrary ZonedTime where
  54     arbitrary = ZonedTime <$> arbitrary ⊛ arbitrary
  55
  56 instance Arbitrary DiffTime where
  57     arbitrary = secondsToDiffTime <$> choose (0, 86400)
  58
  59 instance Arbitrary UTCTime where
  60     arbitrary = UTCTime <$> arbitrary ⊛ arbitrary
  61
  62 tests ∷ [Property]
  63 tests = [ -- Asctime
  64           property ( Asctime.fromAscii "Sun Nov  6 08:49:37 1994"
  65                      ≡ Right referenceLocalTime )
  66
  67         , property ( "Sun Nov  6 08:49:37 1994"
  68                      ≡ Asctime.toAscii referenceLocalTime )
  69
  70         , property $ \lt → Right lt ≡ Asctime.fromAscii (Asctime.toAscii lt)
  71
  72           -- RFC733
  73         , property ( RFC733.fromAscii "Sunday, 06-Nov-94 08:49:37 GMT"
  74                      ≡ Right referenceZonedTime )
  75
  76         , property ( "Sunday, 06-Nov-1994 08:49:37 GMT"
  77                      ≡ RFC733.toAscii referenceZonedTime )
  78
  79         , property $ \zt → Right zt ≡ RFC733.fromAscii (RFC733.toAscii zt)
  80
  81           -- RFC1123
  82         , property ( RFC1123.fromAscii "Sun, 06 Nov 1994 08:49:37 GMT"
  83                      ≡ Right referenceZonedTime )
  84
  85         , property ( "Sun, 06 Nov 1994 08:49:37 GMT"
  86                      ≡ RFC1123.toAscii referenceZonedTime )
  87
  88         , property $ \zt → Right zt ≡ RFC1123.fromAscii (RFC1123.toAscii zt)
  89
  90           -- HTTP
  91         , property $ \ut → Right ut ≡ HTTP.fromAscii (HTTP.toAscii           ut )
  92         , property $ \ut → Right ut ≡ HTTP.fromAscii (Asctime.toAscii (ut2lt ut))
  93         , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC733.toAscii  (ut2zt ut))
  94         , property $ \ut → Right ut ≡ HTTP.fromAscii (RFC1123.toAscii (ut2zt ut))
  95         ]
  96     where
  97       referenceLocalTime
  98           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
  99
 100       referenceZonedTime
 101           = ZonedTime referenceLocalTime utc
 102
 103       ut2lt = utcToLocalTime utc
 104
 105       ut2zt = utcToZonedTime utc