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.RFC1123 as RFC1123
  12 import System.Exit
  13 import Prelude.Unicode
  14 import Test.QuickCheck
  15
  16 main ∷ IO ()
  17 main = mapM_ runTest tests
  18
  19 runTest ∷ Property → IO ()
  20 runTest prop
  21     = do r ← quickCheckResult prop
  22          case r of
  23            Success {}           → return ()
  24            GaveUp  {}           → exitFailure
  25            Failure {}           → exitFailure
  26            NoExpectedFailure {} → exitFailure
  27
  28 instance Arbitrary Day where
  29     arbitrary = ModifiedJulianDay <$> arbitrary
  30
  31 instance Arbitrary TimeOfDay where
  32     arbitrary
  33         = do h ← choose (0, 23)
  34              m ← choose (0, 59)
  35              s ← choose (0, 60)
  36              return $ TimeOfDay h m (fromIntegral (s ∷ Int))
  37
  38 instance Arbitrary LocalTime where
  39     arbitrary = LocalTime <$> arbitrary ⊛ arbitrary
  40
  41 instance Eq ZonedTime where
  42     a == b = zonedTimeToUTC a ≡ zonedTimeToUTC b
  43
  44 instance Arbitrary TimeZone where
  45     arbitrary
  46         = do m ← choose (-1439, 1439)
  47              s ← arbitrary
  48              n ← arbitrary
  49              return $ TimeZone m s n
  50
  51 instance Arbitrary ZonedTime where
  52     arbitrary = ZonedTime <$> arbitrary ⊛ arbitrary
  53
  54 tests ∷ [Property]
  55 tests = [ -- Asctime
  56           property ( Asctime.fromAscii "Sun Nov  6 08:49:37 1994"
  57                      ≡ Right referenceLocalTime )
  58
  59         , property ( "Sun Nov  6 08:49:37 1994"
  60                      ≡ Asctime.toAscii referenceLocalTime )
  61
  62         , property $ \lt → Right lt ≡ Asctime.fromAscii (Asctime.toAscii lt)
  63
  64           -- RFC1123
  65         , property ( RFC1123.fromAscii "Sun, 06 Nov 1994 08:49:37 GMT"
  66                      ≡ Right referenceZonedTime )
  67
  68         , property ( "Sun, 06 Nov 1994 08:49:37 GMT"
  69                      ≡ RFC1123.toAscii referenceZonedTime )
  70
  71         , property $ \zt → Right zt ≡ RFC1123.fromAscii (RFC1123.toAscii zt)
  72         ]
  73     where
  74       referenceLocalTime
  75           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
  76
  77       referenceZonedTime
  78           = ZonedTime referenceLocalTime utc