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 instance Arbitrary (Tagged C LocalTime) where
  91     arbitrary = Tagged <$> arbitrary
  92
  93 instance Arbitrary (Tagged RFC733 ZonedTime) where
  94     arbitrary = Tagged <$> arbitrary
  95
  96 instance Arbitrary (Tagged RFC1123 ZonedTime) where
  97     arbitrary = Tagged <$> arbitrary
  98
  99 instance Arbitrary (Tagged HTTP UTCTime) where
 100     arbitrary = Tagged <$> arbitrary
 101
 102 tests ∷ [Property]
 103 tests = [ -- Asctime
 104           property ( fromAttempt (ca ("Sun Nov  6 08:49:37 1994" ∷ Ascii))
 105                      ≡ Just (Tagged referenceLocalTime ∷ Tagged C LocalTime)
 106                    )
 107
 108         , property ( ("Sun Nov  6 08:49:37 1994" ∷ Ascii)
 109                      ≡ cs (Tagged referenceLocalTime ∷ Tagged C LocalTime)
 110                    )
 111
 112         , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ Tagged C LocalTime) ∷ Ascii))
 113
 114           -- RFC733
 115         , property ( fromAttempt (ca ("Sunday, 06-Nov-94 08:49:37 GMT" ∷ Ascii))
 116                      ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime)
 117                    )
 118
 119         , property ( ("Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Ascii)
 120                      ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime)
 121                    )
 122
 123         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC733 ZonedTime) ∷ Ascii))
 124
 125           -- RFC822
 126         , property ( fromAttempt (ca ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii))
 127                      ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime)
 128                    )
 129
 130         , property ( Just ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii)
 131                      ≡ fromAttempt (ca (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime))
 132                    )
 133
 134         , property $ \zt → let zt' = do a ← ca (retag (zt ∷ Tagged Cent20 ZonedTime) ∷ Tagged RFC822 ZonedTime)
 135                                         ca (a ∷ Ascii) ∷ Attempt (Tagged RFC822 ZonedTime)
 136                            in
 137                              fromAttempt zt' ≡ Just (retag zt)
 138
 139           -- RFC1123
 140         , property ( fromAttempt (ca ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii))
 141                      ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime)
 142                    )
 143
 144         , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)
 145                      ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime)
 146                    )
 147
 148         , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC1123 ZonedTime) ∷ Ascii))
 149
 150           -- HTTP
 151         , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)
 152                      ≡ cs (Tagged referenceUTCTime ∷ Tagged HTTP UTCTime)
 153                    )
 154         , property $ \ut → Just ut ≡ fromAttempt (ca (cs (ut ∷ Tagged HTTP UTCTime) ∷ Ascii))
 155         , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2lt <$> (ut ∷ Tagged HTTP UTCTime))
 156                                                             ∷ Tagged C LocalTime)
 157                                                         ∷ Ascii))
 158         , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime))
 159                                                             ∷ Tagged RFC733 ZonedTime)
 160                                                         ∷ Ascii))
 161         , property $ \ut → let zt  = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime)
 162                                ut' = do a ← ca (Tagged zt ∷ Tagged RFC822 ZonedTime)
 163                                         ca (a ∷ Ascii) ∷ Attempt (Tagged HTTP UTCTime)
 164                            in
 165                              fromAttempt ut' ≡ Just (retag ut)
 166         , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime))
 167                                                             ∷ Tagged RFC1123 ZonedTime)
 168                                                         ∷ Ascii))
 169         ]
 170     where
 171       referenceLocalTime ∷ LocalTime
 172       referenceLocalTime
 173           = LocalTime (ModifiedJulianDay 49662) (TimeOfDay 8 49 37)
 174
 175       referenceZonedTime ∷ ZonedTime
 176       referenceZonedTime
 177           = ZonedTime referenceLocalTime utc
 178
 179       referenceUTCTime ∷ UTCTime
 180       referenceUTCTime
 181           = zonedTimeToUTC referenceZonedTime
 182
 183       ut2lt ∷ UTCTime → LocalTime
 184       ut2lt = utcToLocalTime utc
 185
 186       ut2zt ∷ UTCTime → ZonedTime
 187       ut2zt = utcToZonedTime utc