X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=time-http.git;a=blobdiff_plain;f=Test%2FTime%2FFormat%2FHTTP.hs;h=c5abaf1c9db87a2490c7be9414fb291e8ea75034;hp=6555cdbbd01d18c49626c1cdfcf2d9ddb2297370;hb=e8f778a;hpb=91c2402d530afff7f1fd4eee333f84cbe18d1014 diff --git a/Test/Time/Format/HTTP.hs b/Test/Time/Format/HTTP.hs index 6555cdb..c5abaf1 100644 --- a/Test/Time/Format/HTTP.hs +++ b/Test/Time/Format/HTTP.hs @@ -12,7 +12,7 @@ import Data.Convertible.Base import Data.Proxy import Data.Tagged import Data.Time -import Data.Time.Format.Asctime +import Data.Time.Format.C import Data.Time.Format.HTTP import Data.Time.Format.RFC733 import Data.Time.Format.RFC822 @@ -87,61 +87,85 @@ instance Arbitrary UTCTime where instance Arbitrary (Tagged Cent20 UTCTime) where arbitrary = (Tagged ∘) ∘ UTCTime <$> (flip proxy cent20 <$> arbitrary) ⊛ arbitrary +instance Arbitrary (Tagged C LocalTime) where + arbitrary = Tagged <$> arbitrary + +instance Arbitrary (Tagged RFC733 ZonedTime) where + arbitrary = Tagged <$> arbitrary + +instance Arbitrary (Tagged RFC1123 ZonedTime) where + arbitrary = Tagged <$> arbitrary + +instance Arbitrary (Tagged HTTP UTCTime) where + arbitrary = Tagged <$> arbitrary + tests ∷ [Property] tests = [ -- Asctime - property ( fromAttempt (ca (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii)) - ≡ Just referenceLocalTime + property ( fromAttempt (ca ("Sun Nov 6 08:49:37 1994" ∷ Ascii)) + ≡ Just (Tagged referenceLocalTime ∷ Tagged C LocalTime) ) - , property ( (Tagged "Sun Nov 6 08:49:37 1994" ∷ Tagged Asctime Ascii) - ≡ cs referenceLocalTime + , property ( ("Sun Nov 6 08:49:37 1994" ∷ Ascii) + ≡ cs (Tagged referenceLocalTime ∷ Tagged C LocalTime) ) - , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ LocalTime) ∷ Tagged Asctime Ascii)) + , property $ \lt → Just lt ≡ fromAttempt (ca (cs (lt ∷ Tagged C LocalTime) ∷ Ascii)) -- RFC733 - , property ( fromAttempt (ca (Tagged "Sunday, 06-Nov-94 08:49:37 GMT" ∷ Tagged RFC733 Ascii)) - ≡ Just referenceZonedTime + , property ( fromAttempt (ca ("Sunday, 06-Nov-94 08:49:37 GMT" ∷ Ascii)) + ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime) ) - , property ( (Tagged "Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Tagged RFC733 Ascii) - ≡ cs referenceZonedTime + , property ( ("Sunday, 06-Nov-1994 08:49:37 GMT" ∷ Ascii) + ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC733 ZonedTime) ) - , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC733 Ascii)) + , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC733 ZonedTime) ∷ Ascii)) -- RFC822 - , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii)) - ≡ Just referenceZonedTime + , property ( fromAttempt (ca ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii)) + ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime) ) - , property ( (Tagged "Sun, 06 Nov 94 08:49:37 GMT" ∷ Tagged RFC822 Ascii) - ≡ cs referenceZonedTime + , property ( Just ("Sun, 06 Nov 94 08:49:37 GMT" ∷ Ascii) + ≡ fromAttempt (ca (Tagged referenceZonedTime ∷ Tagged RFC822 ZonedTime)) ) - , property $ \zt → Just (untag zt) ≡ fromAttempt (ca (cs (untag (zt ∷ Tagged Cent20 ZonedTime)) - ∷ Tagged RFC822 Ascii)) + + , property $ \zt → let zt' = do a ← ca (retag (zt ∷ Tagged Cent20 ZonedTime) ∷ Tagged RFC822 ZonedTime) + ca (a ∷ Ascii) ∷ Attempt (Tagged RFC822 ZonedTime) + in + fromAttempt zt' ≡ Just (retag zt) -- RFC1123 - , property ( fromAttempt (ca (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii)) - ≡ Just referenceZonedTime + , property ( fromAttempt (ca ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii)) + ≡ Just (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime) ) - , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged RFC1123 Ascii) - ≡ cs referenceZonedTime + , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii) + ≡ cs (Tagged referenceZonedTime ∷ Tagged RFC1123 ZonedTime) ) - , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ ZonedTime) ∷ Tagged RFC1123 Ascii)) + , property $ \zt → Just zt ≡ fromAttempt (ca (cs (zt ∷ Tagged RFC1123 ZonedTime) ∷ Ascii)) -- HTTP - , property ( (Tagged "Sun, 06 Nov 1994 08:49:37 GMT" ∷ Tagged HTTP Ascii) - ≡ cs referenceUTCTime + , property ( ("Sun, 06 Nov 1994 08:49:37 GMT" ∷ Ascii) + ≡ cs (Tagged referenceUTCTime ∷ Tagged HTTP UTCTime) ) - , property $ \ut → Just ut ≡ fromAttempt (ca (cs ut ∷ Tagged HTTP Ascii) ∷ Attempt UTCTime) - , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2lt ut) ∷ Tagged Asctime Ascii))) - , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC733 Ascii))) - , property $ \ut → Just (untag ut) ≡ fromAttempt (ca (retagHTTP (cs (ut2zt (untag (ut ∷ Tagged Cent20 UTCTime))) - ∷ Tagged RFC822 Ascii))) - , property $ \ut → Just ut ≡ fromAttempt (ca (retagHTTP (cs (ut2zt ut) ∷ Tagged RFC1123 Ascii))) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (ut ∷ Tagged HTTP UTCTime) ∷ Ascii)) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2lt <$> (ut ∷ Tagged HTTP UTCTime)) + ∷ Tagged C LocalTime) + ∷ Ascii)) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime)) + ∷ Tagged RFC733 ZonedTime) + ∷ Ascii)) + , property $ \ut → let zt = ut2zt $ untag (ut ∷ Tagged Cent20 UTCTime) + ut' = do a ← ca (Tagged zt ∷ Tagged RFC822 ZonedTime) + ca (a ∷ Ascii) ∷ Attempt (Tagged HTTP UTCTime) + in + fromAttempt ut' ≡ Just (retag ut) + , property $ \ut → Just ut ≡ fromAttempt (ca (cs (retag (ut2zt <$> (ut ∷ Tagged HTTP UTCTime)) + ∷ Tagged RFC1123 ZonedTime) + ∷ Ascii)) ] where referenceLocalTime ∷ LocalTime @@ -161,6 +185,3 @@ tests = [ -- Asctime ut2zt ∷ UTCTime → ZonedTime ut2zt = utcToZonedTime utc - - retagHTTP ∷ Tagged s b → Tagged HTTP b - retagHTTP = retag