Test/Time/Format/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.Format.C
  16 import Data.Time.Format.HTTP
  17 import Data.Time.Format.RFC733
  18 import Data.Time.Format.RFC822
  19 import Data.Time.Format.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 C Ascii))
  93                      ≡ Just referenceLocalTime
  94                    )
  95
  96         , property ( (Tagged "Sun Nov  6 08:49:37 1994" ∷ Tagged C Ascii)
  97                      ≡ cs referenceLocalTime
  98                    )
  99
 100         , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) ∷ Tagged C Ascii))
 101
 102           -- RFC733
 103         , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii))
 104                      ≡ Just referenceZonedTime
 105                    )
 106
 107         , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii)
 108                      ≡ cs referenceZonedTime
 109                    )
 110
 111         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC733 Ascii))
 112
 113           -- RFC822
 114         , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii))
 115                      ≡ Just referenceZonedTime
 116                    )
 117
 118         , property ( Just (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
 119                      ≡ fromAttempt (ca referenceZonedTime)
 120                    )
 121         , property $ \zt → let zt' = do a ← ca $ untag (zt ∷ Tagged Cent20 ZonedTime)
 122                                         ca (a ∷ Tagged RFC822 Ascii)
 123                            in
 124                              fromAttempt zt' ≡ Just (untag zt)
 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) ∷ Tagged RFC1123 Ascii))
 136
 137           -- HTTP
 138         , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
 139                      ≡ cs referenceUTCTime
 140                    )
 141         , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
 142         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged C Ascii)))
 143         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
 144         , property $ \ut → let zt  = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime)
 145                                ut' = do a ← ca zt
 146                                         ca $ retagHTTP (a ∷ Tagged RFC822 Ascii)
 147                            in
 148                              fromAttempt ut' ≡ Just (untag ut)
 149         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
 150         ]
 151     where
 152       referenceLocalTime ∷ LocalTime
 153       referenceLocalTime
 154           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
 155
 156       referenceZonedTime ∷ ZonedTime
 157       referenceZonedTime
 158           = ZonedTime referenceLocalTime utc
 159
 160       referenceUTCTime ∷ UTCTime
 161       referenceUTCTime
 162           = zonedTimeToUTC referenceZonedTime
 163
 164       ut2lt ∷ UTCTime → LocalTime
 165       ut2lt = utcToLocalTime utc
 166
 167       ut2zt ∷ UTCTime → ZonedTime
 168       ut2zt = utcToZonedTime utc
 169
 170       retagHTTP ∷ Tagged s b → Tagged HTTP b
 171       retagHTTP = retag