Test/Time/HTTP.hs

   1 {-# LANGUAGE
   2     FlexibleInstances
   3   , OverloadedStrings
   4   , UnicodeSyntax
   5   #-}
   6 module Main (main) where
   7 import Control.Applicative
   8 import Control.Applicative.Unicode
   9 import Data.Ascii (Ascii)
  10 import Data.Attempt hiding (Failure, Success)
  11 import Data.Convertible.Base
  12 import Data.Proxy
  13 import Data.Tagged
  14 import Data.Time
  15 import Data.Time.Asctime
  16 import Data.Time.HTTP
  17 import Data.Time.RFC733
  18 import Data.Time.RFC822
  19 import Data.Time.RFC1123
  20 import System.Exit
  21 import Prelude.Unicode
  22 import Test.QuickCheck
  23
  24 main ∷ IO ()
  25 main = mapM_ runTest tests
  26
  27 runTest ∷ Property → IO ()
  28 runTest prop
  29     = do r ← quickCheckResult prop
  30          case r of
  31            Success {}           → return ()
  32            GaveUp  {}           → exitFailure
  33            Failure {}           → exitFailure
  34            NoExpectedFailure {} → exitFailure
  35
  36 data Cent20
  37
  38 cent20 ∷ Proxy Cent20
  39 cent20 = Proxy
  40
  41 instance Arbitrary Day where
  42     arbitrary = ModifiedJulianDay <$> arbitrary
  43
  44 instance Arbitrary (Tagged Cent20 Day) where
  45     arbitrary = ((Tagged ∘) ∘) ∘ fromGregorian
  46                 <$> choose (1900, 1999)
  47                 ⊛ arbitrary
  48                 ⊛ arbitrary
  49
  50 instance Arbitrary TimeOfDay where
  51     arbitrary
  52         = do h ← choose (0, 23)
  53              m ← choose (0, 59)
  54              s ← choose (0, 60)
  55              return $ TimeOfDay h m (fromIntegral (s ∷ Int))
  56
  57 instance Arbitrary LocalTime where
  58     arbitrary = LocalTime <$> arbitrary ⊛ arbitrary
  59
  60 instance Arbitrary (Tagged Cent20 LocalTime) where
  61     arbitrary = (Tagged ∘) ∘ LocalTime <$>
  62                 (flip proxy cent20 <$> arbitrary)
  63                 ⊛ arbitrary
  64
  65 instance Eq ZonedTime where
  66     a == b = zonedTimeToUTC a ≡ zonedTimeToUTC b
  67
  68 instance Arbitrary TimeZone where
  69     arbitrary
  70         = do m ← choose (-1439, 1439)
  71              s ← arbitrary
  72              n ← arbitrary
  73              return $ TimeZone m s n
  74
  75 instance Arbitrary ZonedTime where
  76     arbitrary = ZonedTime <$> arbitrary ⊛ arbitrary
  77
  78 instance Arbitrary (Tagged Cent20 ZonedTime) where
  79     arbitrary = (Tagged ∘) ∘ ZonedTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
  80
  81 instance Arbitrary DiffTime where
  82     arbitrary = secondsToDiffTime <$> choose (0, 86400)
  83
  84 instance Arbitrary UTCTime where
  85     arbitrary = UTCTime <$> arbitrary ⊛ arbitrary
  86
  87 instance Arbitrary (Tagged Cent20 UTCTime) where
  88     arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary
  89
  90 tests ∷ [Property]
  91 tests = [ -- Asctime
  92           property ( fromAttempt (ca (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged Asctime Ascii))
  93                      ≡ Just referenceLocalTime
  94                    )
  95
  96         , property ( (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged Asctime Ascii)
  97                      ≡ cs referenceLocalTime
  98                    )
  99
 100         , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime)
 101                                                         ∷ Tagged Asctime Ascii))
 102
 103           -- RFC733
 104         , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
 105                      ≡ Just referenceZonedTime
 106                    )
 107
 108         , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
 109                      ≡ cs referenceZonedTime
 110                    )
 111
 112         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
 113                                                         ∷ Tagged RFC733 Ascii))
 114
 115           -- RFC822
 116         , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
 117                      ≡ Just referenceZonedTime
 118                    )
 119
 120         , property ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
 121                      ≡ cs referenceZonedTime
 122                    )
 123         , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime))
 124                                                                 ∷ Tagged RFC822 Ascii))
 125
 126           -- RFC1123
 127         , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
 128                      ≡ Just referenceZonedTime
 129                    )
 130
 131         , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
 132                      ≡ cs referenceZonedTime
 133                    )
 134
 135         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime)
 136                                                         ∷ Tagged RFC1123 Ascii))
 137
 138           -- HTTP
 139         , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
 140                      ≡ cs referenceUTCTime
 141                    )
 142         , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
 143         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged Asctime Ascii)))
 144         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733  Ascii)))
 145         , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime)))
 146                                                                            ∷ Tagged RFC822 Ascii)))
 147         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
 148         ]
 149     where
 150       referenceLocalTime ∷ LocalTime
 151       referenceLocalTime
 152           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
 153
 154       referenceZonedTime ∷ ZonedTime
 155       referenceZonedTime
 156           = ZonedTime referenceLocalTime utc
 157
 158       referenceUTCTime ∷ UTCTime
 159       referenceUTCTime
 160           = zonedTimeToUTC referenceZonedTime
 161
 162       ut2lt ∷ UTCTime → LocalTime
 163       ut2lt = utcToLocalTime utc
 164
 165       ut2zt ∷ UTCTime → ZonedTime
 166       ut2zt = utcToZonedTime utc
 167
 168       retagHTTP ∷ Tagged s b → Tagged HTTP b
 169       retagHTTP = retag