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 ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)
 119                      ≡ cs referenceZonedTime
 120                    )
 121         , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime))
 122                                                                 ∷ Tagged RFC822 Ascii))
 123
 124           -- RFC1123
 125         , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii))
 126                      ≡ Just referenceZonedTime
 127                    )
 128
 129         , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)
 130                      ≡ cs referenceZonedTime
 131                    )
 132
 133         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC1123 Ascii))
 134
 135           -- HTTP
 136         , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii)
 137                      ≡ cs referenceUTCTime
 138                    )
 139         , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime)
 140         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged C Ascii)))
 141         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii)))
 142         , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime)))
 143                                                                            ∷ Tagged RFC822 Ascii)))
 144         , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii)))
 145         ]
 146     where
 147       referenceLocalTime ∷ LocalTime
 148       referenceLocalTime
 149           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
 150
 151       referenceZonedTime ∷ ZonedTime
 152       referenceZonedTime
 153           = ZonedTime referenceLocalTime utc
 154
 155       referenceUTCTime ∷ UTCTime
 156       referenceUTCTime
 157           = zonedTimeToUTC referenceZonedTime
 158
 159       ut2lt ∷ UTCTime → LocalTime
 160       ut2lt = utcToLocalTime utc
 161
 162       ut2zt ∷ UTCTime → ZonedTime
 163       ut2zt = utcToZonedTime utc
 164
 165       retagHTTP ∷ Tagged s b → Tagged HTTP b
 166       retagHTTP = retag