Test/Time/HTTP.hs

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