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 Data.Time.HTTP
  15 import Data.Time.RFC733
  16 import Data.Time.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 ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
  92                      ≡ Just referenceZonedTime
  93                    )
  94
  95         , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
  96                      ≡ cs referenceZonedTime
  97                    )
  98
  99         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
 100                                                         ∷ Tagged RFC1123 Ascii))
 101
 102           -- HTTP
 103         , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
 104         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged Asctime Ascii)))
 105         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733  Ascii)))
 106         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
 107         ]
 108     where
 109       referenceLocalTime ∷ LocalTime
 110       referenceLocalTime
 111           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
 112
 113       referenceZonedTime ∷ ZonedTime
 114       referenceZonedTime
 115           = ZonedTime referenceLocalTime utc
 116
 117       ut2lt ∷ UTCTime → LocalTime
 118       ut2lt = utcToLocalTime utc
 119
 120       ut2zt ∷ UTCTime → ZonedTime
 121       ut2zt = utcToZonedTime utc
 122
 123       retagHTTP ∷ Tagged s b → Tagged HTTP b
 124       retagHTTP = retag