http-date 0.0.12 → 0.0.13
raw patch · 8 files changed
+425/−233 lines, 8 filesdep +criteriondep −arraydep −old-localedep ~attoparsecdep ~basedep ~bytestringPVP ok
version bump matches the API change (PVP)
Dependencies added: criterion
Dependencies removed: array, old-locale
Dependency ranges changed: attoparsec, base, bytestring, time
API changes (from Hackage documentation)
+ Network.HTTP.Date: httpDateToUTCValid :: HTTPDate -> Maybe UTCTime
Files
- ChangeLog.md +13/−0
- Network/HTTP/Date/Converter.hs +78/−100
- Network/HTTP/Date/Formatter.hs +31/−22
- Network/HTTP/Date/Parser.hs +101/−38
- bench/Bench.hs +30/−0
- http-date.cabal +62/−42
- test/DateSpec.hs +109/−24
- test/Model.hs +1/−7
ChangeLog.md view
@@ -1,5 +1,18 @@ # ChangeLog for http-date +## 0.0.13++* `epochTimeToHTTPDate` runs in constant time. A huge value took+ minutes.+* `formatHTTPDate` renders out-of-range numeric fields as underscores+ instead of non-digit characters.+* `parseHTTPDate` accepts the RFC 850 and asctime formats, and rejects+ trailing garbage and dates which do not exist. Trailing whitespace+ is ignored.+* `httpDateToUTC` clips out-of-range fields instead of wrapping them+ and keeps a leap second. New `httpDateToUTCValid` rejects them.+* GHC 9.2 or later is required.+ ## 0.0.12 * Security: `formatHTTPDate` read outside its tables if `hdMonth` or
Network/HTTP/Date/Converter.hs view
@@ -1,50 +1,66 @@-{-# LANGUAGE BangPatterns #-}- module Network.HTTP.Date.Converter ( epochTimeToHTTPDate, httpDateToUTC,+ httpDateToUTCValid, utcToHTTPDate, ) where import Data.Time import Data.Time.Calendar.WeekDate-import Data.Time.Clock.POSIX (posixSecondsToUTCTime)-import Data.Word-import Foreign.Marshal.Array-import Foreign.Ptr-import Foreign.Storable+import Foreign.C.Types (CTime (..)) import Network.HTTP.Date.Types-import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) import System.Posix.Types -- | -- Translating 'EpochTime' to 'HTTPDate'.+--+-- >>> epochTimeToHTTPDate 784887151+-- HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2} epochTimeToHTTPDate :: EpochTime -> HTTPDate-epochTimeToHTTPDate x- | x < 0 = utcToHTTPDate $ posixSecondsToUTCTime $ realToFrac x- | otherwise =- defaultHTTPDate- { hdYear = y- , hdMonth = m- , hdDay = d- , hdHour = h- , hdMinute = n- , hdSecond = s- , hdWkday = w- }+epochTimeToHTTPDate (CTime i) =+ defaultHTTPDate+ { hdYear = y+ , hdMonth = m+ , hdDay = d+ , hdHour = h+ , hdMinute = n+ , hdSecond = s+ , hdWkday = w+ } where- w64 :: Word64- w64 = fromIntegral $ fromEnum x- (days', secs') = w64 `quotRem` 86400- days = fromIntegral days'- secs = fromIntegral secs'+ (days, secs) = fromIntegral i `divMod` 86400 -- 1970/1/1 is Thu (4)- w = (days + 3) `rem` 7 + 1- (y, m, d) = toYYMMDD days- (h, n, s) = toHHMMSS secs+ w = (days + 3) `mod` 7 + 1+ (y, m, d) = civilFromDays days+ (hhmm, s) = secs `quotRem` 60+ (h, n) = hhmm `quotRem` 60 +-- Howard Hinnant's civil_from_days: days since 1970-01-01 to (y, m, d)+-- in constant time, for any sign. See:+-- http://howardhinnant.github.io/date_algorithms.html#civil_from_days+civilFromDays :: Int -> (Int, Int, Int)+civilFromDays z0 = (y + if m <= 2 then 1 else 0, m, d)+ where+ z = z0 + 719468+ era = z `div` 146097+ doe = z - era * 146097+ yoe = (doe - doe `quot` 1460 + doe `quot` 36524 - doe `quot` 146096) `quot` 365+ y = yoe + era * 400+ doy = doe - (365 * yoe + yoe `quot` 4 - yoe `quot` 100)+ mp = (5 * doy + 2) `quot` 153+ d = doy - (153 * mp + 2) `quot` 5 + 1+ m = if mp < 10 then mp + 3 else mp - 9+ -- | Translating 'HTTPDate' to 'UTCTime'. --+-- Out-of-range fields are clipped to the nearest valid value, as+-- 'fromGregorian' does. 'hdWkday' is ignored. A second of 60 is kept+-- as a leap second only at 23:59. Use 'httpDateToUTCValid' to reject+-- invalid values instead.+--+-- >>> httpDateToUTC defaultHTTPDate {hdMonth = 2, hdDay = 31, hdHour = 25}+-- 1970-02-28 23:00:00 UTC+-- -- Since 0.0.7. httpDateToUTC :: HTTPDate -> UTCTime httpDateToUTC x = UTCTime (fromGregorian y m d) (secondsToDiffTime s)@@ -52,12 +68,40 @@ y = fromIntegral $ hdYear x m = hdMonth x d = hdDay x- s =- fromIntegral $- (hdHour x `rem` 24) * 3600- + (hdMinute x `rem` 60) * 60- + (hdSecond x `rem` 60)+ h = clip 0 23 $ hdHour x+ n = clip 0 59 $ hdMinute x+ s0 = clip 0 60 $ hdSecond x+ s0'+ | s0 == 60 && (h /= 23 || n /= 59) = 59+ | otherwise = s0+ s = fromIntegral $ h * 3600 + n * 60 + s0'+ clip lo hi v = max lo $ min hi v +-- | Translating 'HTTPDate' to 'UTCTime' if all fields except+-- 'hdWkday' are valid. A second of 60 is accepted only at 23:59.+--+-- >>> httpDateToUTCValid defaultHTTPDate {hdMonth = 2, hdDay = 31}+-- Nothing+--+-- Since 0.0.13.+httpDateToUTCValid :: HTTPDate -> Maybe UTCTime+httpDateToUTCValid x+ | validTime (hdHour x) (hdMinute x) (hdSecond x) = do+ day <- fromGregorianValid (fromIntegral $ hdYear x) (hdMonth x) (hdDay x)+ return $ UTCTime day $ secondsToDiffTime s+ | otherwise = Nothing+ where+ s = fromIntegral $ hdHour x * 3600 + hdMinute x * 60 + hdSecond x++validTime :: Int -> Int -> Int -> Bool+validTime h n s =+ 0 <= h+ && h <= 23+ && 0 <= n+ && n <= 59+ && 0 <= s+ && (s <= 59 || s == 60 && h == 23 && n == 59)+ -- | Translating 'UTCTime' to 'HTTPDate'. -- -- Since 0.0.7.@@ -70,7 +114,7 @@ , hdHour = h , hdMinute = n , hdSecond = truncate s- , hdWkday = fromEnum (w :: Int)+ , hdWkday = w } where (y, m, d) = toGregorian day@@ -79,69 +123,3 @@ day = localDay time tod = localTimeOfDay time time = utcToLocalTime utc x--toYYMMDD :: Int -> (Int, Int, Int)-toYYMMDD x = (yy, mm, dd)- where- (y, d) = x `quotRem` 365- cy = 1970 + y- cy' = cy - 1- leap = cy' `quot` 4 - cy' `quot` 100 + cy' `quot` 400 - 477- (yy, days) = adjust cy d leap- (mm, dd) = findMonth days- adjust !ty td aj- | td >= aj = (ty, td - aj)- | isLeap (ty - 1) =- if td + 366 >= aj- then (ty - 1, td + 366 - aj)- else adjust (ty - 1) (td + 366) aj- | otherwise =- if td + 365 >= aj- then (ty - 1, td + 365 - aj)- else adjust (ty - 1) (td + 365) aj- isLeap year =- year `rem` 4 == 0- && ( year `rem` 400 == 0- || year `rem` 100 /= 0- )- (mnths, daysArr) =- if isLeap yy- then (leapMonth, leapDayInMonth)- else (normalMonth, normalDayInMonth)- findMonth n =- unsafeDupablePerformIO $- (,) <$> peekElemOff mnths n <*> peekElemOff daysArr n--------------------------------------------------------------------normalMonthDays :: [Int]-normalMonthDays = [31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]--leapMonthDays :: [Int]-leapMonthDays = [31, 29, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31]--mkPtrInt :: [Int] -> Ptr Int-mkPtrInt = unsafePerformIO . newArray . concat . zipWith (flip replicate) [1 ..]--mkPtrInt2 :: [Int] -> Ptr Int-mkPtrInt2 = unsafePerformIO . newArray . concatMap (enumFromTo 1)--normalMonth :: Ptr Int-normalMonth = mkPtrInt normalMonthDays--normalDayInMonth :: Ptr Int-normalDayInMonth = mkPtrInt2 normalMonthDays--leapMonth :: Ptr Int-leapMonth = mkPtrInt leapMonthDays--leapDayInMonth :: Ptr Int-leapDayInMonth = mkPtrInt2 leapMonthDays--------------------------------------------------------------------toHHMMSS :: Int -> (Int, Int, Int)-toHHMMSS x = (hh, mm, ss)- where- (hhmm, ss) = x `quotRem` 60- (hh, mm) = hhmm `quotRem` 60
Network/HTTP/Date/Formatter.hs view
@@ -6,6 +6,7 @@ import Data.ByteString.Internal import Data.Word import Foreign.ForeignPtr+import Foreign.Marshal.Utils (copyBytes) import Foreign.Ptr import Foreign.Storable import Network.HTTP.Date.Types@@ -16,25 +17,28 @@ -- -- >>> formatHTTPDate defaultHTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2} -- "Tue, 15 Nov 1994 08:12:31 GMT"--- >>> formatHTTPDate defaultHTTPDate {hdYear = 1994, hdMonth = 13, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 0}--- "___, 15 ___ 1994 08:12:31 GMT"+--+-- Out-of-range fields are rendered as underscores.+--+-- >>> formatHTTPDate defaultHTTPDate {hdYear = 10000, hdMonth = 13, hdDay = 32, hdHour = 24, hdMinute = -1, hdSecond = 61, hdWkday = 0}+-- "___, __ ___ ____ __:__:__ GMT" formatHTTPDate :: HTTPDate -> ByteString formatHTTPDate hd = unsafeCreate 29 $ \ptr -> do cpy3 ptr weekDays (3 * w) poke (ptr `plusPtr` 3) comma poke (ptr `plusPtr` 4) spc- int2 (ptr `plusPtr` 5) d+ int2 (ptr `plusPtr` 5) 1 31 d poke (ptr `plusPtr` 7) spc cpy3 (ptr `plusPtr` 8) months (3 * m) poke (ptr `plusPtr` 11) spc int4 (ptr `plusPtr` 12) y poke (ptr `plusPtr` 16) spc- int2 (ptr `plusPtr` 17) h+ int2 (ptr `plusPtr` 17) 0 23 h poke (ptr `plusPtr` 19) colon- int2 (ptr `plusPtr` 20) n+ int2 (ptr `plusPtr` 20) 0 59 n poke (ptr `plusPtr` 22) colon- int2 (ptr `plusPtr` 23) s+ int2 (ptr `plusPtr` 23) 0 60 s poke (ptr `plusPtr` 25) spc poke (ptr `plusPtr` 26) (71 :: Word8) poke (ptr `plusPtr` 27) (77 :: Word8)@@ -51,28 +55,30 @@ w = let w0 = hdWkday hd in if w0 < 1 || w0 > 7 then 0 else w0 cpy3 :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () cpy3 ptr p o = withForeignPtr p $ \fp ->- memcpy ptr (fp `plusPtr` o) 3+ copyBytes ptr (fp `plusPtr` o) 3 ---------------------------------------------------------------- -int2 :: Ptr Word8 -> Int -> IO ()-int2 ptr n- | n < 10 = do- poke ptr zero- poke (ptr `plusPtr` 1) (i2w8 n)+int2 :: Ptr Word8 -> Int -> Int -> Int -> IO ()+int2 ptr lo hi n+ | n < lo || n > hi = do+ poke ptr underscore+ poke (ptr `plusPtr` 1) underscore | otherwise = do poke ptr (i2w8 (n `quot` 10)) poke (ptr `plusPtr` 1) (i2w8 (n `rem` 10)) int4 :: Ptr Word8 -> Int -> IO ()-int4 ptr n0 = do- let (n1, x1) = n0 `quotRem` 10- (n2, x2) = n1 `quotRem` 10- (x4, x3) = n2 `quotRem` 10- poke ptr (i2w8 x4)- poke (ptr `plusPtr` 1) (i2w8 x3)- poke (ptr `plusPtr` 2) (i2w8 x2)- poke (ptr `plusPtr` 3) (i2w8 x1)+int4 ptr n0+ | n0 < 0 || n0 > 9999 = mapM_ (\i -> poke (ptr `plusPtr` i) underscore) [0 .. 3]+ | otherwise = do+ let (n1, x1) = n0 `quotRem` 10+ (n2, x2) = n1 `quotRem` 10+ (x4, x3) = n2 `quotRem` 10+ poke ptr (i2w8 x4)+ poke (ptr `plusPtr` 1) (i2w8 x3)+ poke (ptr `plusPtr` 2) (i2w8 x2)+ poke (ptr `plusPtr` 3) (i2w8 x1) i2w8 :: Int -> Word8 i2w8 n = fromIntegral n + zero@@ -80,10 +86,10 @@ ---------------------------------------------------------------- months :: ForeignPtr Word8-months = let (PS p _ _) = "___JanFebMarAprMayJunJulAugSepOctNovDec" in p+months = let (BS p _) = "___JanFebMarAprMayJunJulAugSepOctNovDec" in p weekDays :: ForeignPtr Word8-weekDays = let (PS p _ _) = "___MonTueWedThuFriSatSun" in p+weekDays = let (BS p _) = "___MonTueWedThuFriSatSun" in p ---------------------------------------------------------------- @@ -98,3 +104,6 @@ zero :: Word8 zero = 48++underscore :: Word8+underscore = 95
Network/HTTP/Date/Parser.hs view
@@ -4,47 +4,111 @@ import Control.Applicative import Control.Monad-import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString.Char8-import Data.ByteString+import Data.ByteString (ByteString) import Data.Char+import Data.Maybe (isJust)+import Network.HTTP.Date.Converter (httpDateToUTCValid) import Network.HTTP.Date.Types ---------------------------------------------------------------- -- |--- Parsing HTTP Date. Currently only RFC1123 style is supported.+-- Parsing HTTP Date. The three formats of RFC 9110 are supported:+-- IMF-fixdate (RFC 1123), the obsolete RFC 850 format and asctime.+-- Dates which do not exist are rejected while the day of the week is+-- not checked against the date. -- -- >>> :set -XOverloadedStrings -- >>> parseHTTPDate "Tue, 15 Nov 1994 08:12:31 GMT" -- Just (HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2})+-- >>> parseHTTPDate "Tuesday, 15-Nov-94 08:12:31 GMT"+-- Just (HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2})+-- >>> parseHTTPDate "Tue Nov 15 08:12:31 1994"+-- Just (HTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2})+-- >>> parseHTTPDate "Tue, 31 Feb 1994 08:12:31 GMT"+-- Nothing+--+-- A two-digit year of the RFC 850 format is taken as 1970-2069. parseHTTPDate :: ByteString -> Maybe HTTPDate-parseHTTPDate bs = case parseOnly rfc1123Date bs of- Right ut -> Just ut+parseHTTPDate bs = case parseOnly httpDate bs of+ Right hd -> Just hd _ -> Nothing +httpDate :: Parser HTTPDate+httpDate = do+ -- Trailing OWS is not part of a field value (RFC 9110 Section 5.5)+ -- but some HTTP parsers leave it there.+ hd <- rfc1123Date <|> rfc850Date <|> asctimeDate+ skipWhile (\c -> c == ' ' || c == '\t')+ endOfInput+ guard $ isJust $ httpDateToUTCValid hd+ return hd++mkHTTPDate :: Int -> (Int, Int, Int) -> (Int, Int, Int) -> HTTPDate+mkHTTPDate w (y, m, d) (h, n, s) =+ defaultHTTPDate+ { hdYear = y+ , hdMonth = m+ , hdDay = d+ , hdHour = h+ , hdMinute = n+ , hdSecond = s+ , hdWkday = w+ }++-- Sun, 06 Nov 1994 08:49:37 GMT rfc1123Date :: Parser HTTPDate rfc1123Date = do w <- wkday void $ string ", "- (y, m, d) <- date1+ d <- digit2 sp- (h, n, s) <- time+ m <- month sp- -- RFC 2616 defines GMT only but there are actually ill-formed ones such- -- as "+0000" and "UTC" in the wild.- void $ string "GMT" <|> string "+0000" <|> string "UTC"- return $- defaultHTTPDate- { hdYear = y- , hdMonth = m- , hdDay = d- , hdHour = h- , hdMinute = n- , hdSecond = s- , hdWkday = w- }+ y <- digit4+ sp+ t <- time+ sp+ gmt+ return $ mkHTTPDate w (y, m, d) t +-- Sunday, 06-Nov-94 08:49:37 GMT+rfc850Date :: Parser HTTPDate+rfc850Date = do+ w <- weekday+ void $ string ", "+ d <- digit2+ void $ char '-'+ m <- month+ void $ char '-'+ yy <- digit2+ sp+ t <- time+ sp+ gmt+ let y = if yy < 70 then 2000 + yy else 1900 + yy+ return $ mkHTTPDate w (y, m, d) t++-- Sun Nov 6 08:49:37 1994+asctimeDate :: Parser HTTPDate+asctimeDate = do+ w <- wkday+ sp+ m <- month+ sp+ d <- digit2 <|> (sp *> digit1)+ sp+ t <- time+ sp+ y <- digit4+ return $ mkHTTPDate w (y, m, d) t++-- RFC 9110 defines GMT only but there are actually ill-formed ones such+-- as "+0000" and "UTC" in the wild.+gmt :: Parser ()+gmt = void $ string "GMT" <|> string "+0000" <|> string "UTC"+ wkday :: Parser Int wkday = 1 <$ string "Mon"@@ -55,17 +119,15 @@ <|> 6 <$ string "Sat" <|> 7 <$ string "Sun" -date1 :: Parser (Int, Int, Int)-date1 = do- d <- day- sp- m <- month- sp- y <- year- return (y, m, d)- where- day = digit2- year = digit4+weekday :: Parser Int+weekday =+ 1 <$ string "Monday"+ <|> 2 <$ string "Tuesday"+ <|> 3 <$ string "Wednesday"+ <|> 4 <$ string "Thursday"+ <|> 5 <$ string "Friday"+ <|> 6 <$ string "Saturday"+ <|> 7 <$ string "Sunday" sp :: Parser () sp = () <$ char ' '@@ -94,19 +156,20 @@ <|> 11 <$ string "Nov" <|> 12 <$ string "Dec" +digit1 :: Parser Int+digit1 = toInt <$> digit+ digit2 :: Parser Int digit2 = do- x1 <- toInt <$> digit- x2 <- toInt <$> digit+ x1 <- digit1+ x2 <- digit1 return $ x1 * 10 + x2 digit4 :: Parser Int digit4 = do- x1 <- toInt <$> digit- x2 <- toInt <$> digit- x3 <- toInt <$> digit- x4 <- toInt <$> digit- return $ x1 * 1000 + x2 * 100 + x3 * 10 + x4+ x1 <- digit2+ x2 <- digit2+ return $ x1 * 100 + x2 toInt :: Char -> Int toInt c = ord c - ord '0'
+ bench/Bench.hs view
@@ -0,0 +1,30 @@+module Main where++import Criterion.Main+import Data.Time+import Model+import Network.HTTP.Date++main :: IO ()+main =+ defaultMain+ [ bgroup+ "format"+ [ bench "formatHTTPDate" (whnf formatHTTPDate hd)+ , bench "utcToDate" (whnf utcToDate utcd)+ , bench "epochTimeToHTTPDate" (whnf epochTimeToHTTPDate epochTime)+ ]+ ]+ where+ hd =+ defaultHTTPDate+ { hdYear = 2000+ , hdMonth = 2+ , hdDay = 9+ , hdHour = 10+ , hdMinute = 9+ , hdSecond = 20+ , hdWkday = 6+ }+ utcd = UTCTime (ModifiedJulianDay 51583) 36560+ epochTime = 10000000000
http-date.cabal view
@@ -1,45 +1,65 @@-Name: http-date-Version: 0.0.12-Author: Kazu Yamamoto <kazu@iij.ad.jp>-Maintainer: Kazu Yamamoto <kazu@iij.ad.jp>-License: BSD3-License-File: LICENSE-Synopsis: HTTP Date parser/formatter-Description: Fast parser and formatter for HTTP Date-Category: Network, Web-Cabal-Version: >= 1.10-Build-Type: Simple-Extra-Source-Files: ChangeLog.md+cabal-version: 2.0+name: http-date+version: 0.0.13+license: BSD3+license-file: LICENSE+maintainer: Kazu Yamamoto <kazu@iij.ad.jp>+author: Kazu Yamamoto <kazu@iij.ad.jp>+tested-with: GHC ==9.2 || ==9.4 || ==9.6 || ==9.8 || ==9.10 || ==9.12+synopsis: HTTP Date parser/formatter+description: Fast parser and formatter for HTTP Date+category: Network, Web+build-type: Simple+extra-doc-files: ChangeLog.md -Library- Default-Language: Haskell2010- GHC-Options: -Wall- Exposed-Modules: Network.HTTP.Date- Other-Modules: Network.HTTP.Date.Converter- Network.HTTP.Date.Formatter- Network.HTTP.Date.Types- Network.HTTP.Date.Parser- Build-Depends: base >= 4.9 && < 5- , array- , attoparsec- , bytestring- , time+source-repository head+ type: git+ location: https://github.com/kazu-yamamoto/http-date.git -Test-Suite spec- Default-Language: Haskell2010- Type: exitcode-stdio-1.0- HS-Source-Dirs: test- Main-Is: Spec.hs- Other-Modules: DateSpec- Model- Build-Tool-Depends: hspec-discover:hspec-discover- Build-Depends: base >= 4.9 && < 5- , bytestring- , hspec- , http-date- , old-locale- , time+library+ exposed-modules: Network.HTTP.Date+ other-modules:+ Network.HTTP.Date.Converter+ Network.HTTP.Date.Formatter+ Network.HTTP.Date.Types+ Network.HTTP.Date.Parser -Source-Repository head- Type: git- Location: https://github.com/kazu-yamamoto/http-date.git+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base >=4.16 && <5,+ attoparsec >=0.13 && <0.15,+ bytestring >=0.11 && <0.13,+ time >=1.11 && <1.17++test-suite spec+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ build-tool-depends: hspec-discover:hspec-discover+ hs-source-dirs: test+ other-modules:+ DateSpec+ Model++ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base,+ bytestring,+ hspec,+ http-date,+ time++benchmark bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ hs-source-dirs: bench test+ other-modules: Model+ default-language: Haskell2010+ ghc-options: -Wall+ build-depends:+ base,+ bytestring,+ criterion,+ http-date,+ time
test/DateSpec.hs view
@@ -1,41 +1,126 @@+{-# LANGUAGE OverloadedStrings #-}+ module DateSpec where import Control.Monad+import Data.Maybe (isJust) import Model import Network.HTTP.Date+import System.Posix.Types import Test.Hspec ---------------------------------------------------------------- +-- Every 100000 seconds hits few boundaries of a day, so add a step+-- coprime to 86400 from before 1970 to beyond year 9999.+epochs :: [EpochTime]+epochs =+ [0, 100000 .. 10000000000]+ ++ [-62135596800, -62135596800 + 9999991 .. 253402300799]++hd :: HTTPDate+hd =+ defaultHTTPDate+ { hdYear = 1994+ , hdMonth = 11+ , hdDay = 6+ , hdHour = 8+ , hdMinute = 49+ , hdSecond = 37+ , hdWkday = 7+ }+ spec :: Spec spec = do+ describe "epochTimeToHTTPDate" $ do+ it "behaves like utcToHTTPDate" $+ forM_ (epochs ++ [-1, -86400, 253402300800, 10 ^ (15 :: Int)]) $ \e ->+ epochTimeToHTTPDate e `shouldBe` utcToHTTPDate (epochTimeToUtcTime e)+ it "handles the extremes of EpochTime in constant time" $ do+ hdYear (epochTimeToHTTPDate 9223372036854775807) `shouldBe` 292277026596+ hdYear (epochTimeToHTTPDate (-9223372036854775808)) `shouldBe` -292277022657+ describe "formatHTTPDate" $ do it "behaves like the model" $- forM_ [0, 100000 .. 10000000000] $ \epochtime -> do- let m = model epochtime- o = ours epochtime- model = utcToDate . epochTimeToUtcTime- ours = formatHTTPDate . epochTimeToHTTPDate- o `shouldBe` m- it "handles negative epoch time" $- forM_ [-1, -86400, -100000000] $ \epochtime ->- (formatHTTPDate . epochTimeToHTTPDate) epochtime- `shouldBe` utcToDate (epochTimeToUtcTime epochtime)- describe "httpDateToUTC" $ do- it "behaves like the model" $- forM_ [0, 100000 .. 10000000000] $ \epochtime -> do- let m = epochTimeToUtcTime epochtime- o = httpDateToUTC $ epochTimeToHTTPDate epochtime- o `shouldBe` m+ forM_ epochs $ \e ->+ formatHTTPDate (epochTimeToHTTPDate e)+ `shouldBe` utcToDate (epochTimeToUtcTime e)+ it "renders out-of-range fields as underscores" $ do+ formatHTTPDate hd{hdYear = 10000} `shouldBe` "Sun, 06 Nov ____ 08:49:37 GMT"+ formatHTTPDate hd{hdYear = -1} `shouldBe` "Sun, 06 Nov ____ 08:49:37 GMT"+ formatHTTPDate hd{hdDay = 0, hdHour = 24, hdMinute = 60, hdSecond = 61}+ `shouldBe` "Sun, __ Nov 1994 __:__:__ GMT"+ formatHTTPDate hd{hdDay = 123, hdHour = -1}+ `shouldBe` "Sun, __ Nov 1994 __:49:37 GMT"+ describe "parseHTTPDate" $ do it "behaves like the model" $- forM_ [0, 100000 .. 10000000000] $ \epochtime -> do- let m = epochTimeToHTTPDate epochtime- Just o = parseHTTPDate $ formatHTTPDate m- o `shouldBe` m+ forM_ epochs $ \e -> do+ let m = epochTimeToHTTPDate e+ parseHTTPDate (formatHTTPDate m) `shouldBe` Just m+ it "accepts the three formats of RFC 9110" $ do+ parseHTTPDate "Sun, 06 Nov 1994 08:49:37 GMT" `shouldBe` Just hd+ parseHTTPDate "Sunday, 06-Nov-94 08:49:37 GMT" `shouldBe` Just hd+ parseHTTPDate "Sun Nov 6 08:49:37 1994" `shouldBe` Just hd+ parseHTTPDate "Sun Nov 06 08:49:37 1994" `shouldBe` Just hd+ it "ignores trailing whitespace" $ do+ parseHTTPDate "Sun, 06 Nov 1994 08:49:37 GMT \t " `shouldBe` Just hd+ parseHTTPDate "Sun Nov 6 08:49:37 1994 " `shouldBe` Just hd+ it "maps a two-digit year to 1970-2069" $ do+ hdYear <$> parseHTTPDate "Thursday, 01-Jan-70 00:00:00 GMT" `shouldBe` Just 1970+ hdYear <$> parseHTTPDate "Tuesday, 31-Dec-69 00:00:00 GMT" `shouldBe` Just 2069+ it "accepts a leap second only at 23:59" $ do+ parseHTTPDate "Sat, 31 Dec 2016 23:59:60 GMT" `shouldSatisfy` isJust+ parseHTTPDate "Sat, 31 Dec 2016 23:58:60 GMT" `shouldBe` Nothing+ it "rejects invalid dates and times"+ $ forM_+ [ "Sun, 06 Nov 1994 08:49:37 GMTgarbage"+ , " Sun, 06 Nov 1994 08:49:37 GMT"+ , "Sun, 00 Nov 1994 08:49:37 GMT"+ , "Sun, 31 Nov 1994 08:49:37 GMT"+ , "Sun, 29 Feb 1900 08:49:37 GMT"+ , "Sun, 06 Nov 1994 24:00:00 GMT"+ , "Sun, 06 Nov 1994 08:60:37 GMT"+ , "Sun, 06 Nov 1994 08:49:61 GMT"+ , "Sun, 06 Nov 1994 08:49:37"+ , "Sun, 6 Nov 1994 08:49:37 GMT"+ , "Sun,06 Nov 1994 08:49:37 GMT"+ , "Sun Nov 6 08:49:37 1994 GMT"+ , "Sunday, 06 Nov 1994 08:49:37 GMT"+ , ""+ ]+ $ \s -> parseHTTPDate s `shouldBe` Nothing++ describe "httpDateToUTC" $ do+ it "behaves like the model" $+ forM_ epochs $ \e ->+ httpDateToUTC (epochTimeToHTTPDate e) `shouldBe` epochTimeToUtcTime e+ it "keeps a leap second at 23:59" $ do+ let ls = hd{hdHour = 23, hdMinute = 59, hdSecond = 60}+ show (httpDateToUTC ls) `shouldBe` "1994-11-06 23:59:60 UTC"+ utcToHTTPDate (httpDateToUTC ls) `shouldBe` ls+ it "clips out-of-range fields" $ do+ show (httpDateToUTC hd{hdMonth = 2, hdDay = 31, hdHour = 25})+ `shouldBe` "1994-02-28 23:49:37 UTC"+ show (httpDateToUTC hd{hdMinute = -5, hdSecond = 60})+ `shouldBe` "1994-11-06 08:00:59 UTC"++ describe "httpDateToUTCValid" $ do+ it "agrees with httpDateToUTC on valid values" $+ forM_ epochs $ \e -> do+ let m = epochTimeToHTTPDate e+ httpDateToUTCValid m `shouldBe` Just (httpDateToUTC m)+ it "rejects invalid values"+ $ forM_+ [ hd{hdMonth = 2, hdDay = 30}+ , hd{hdMonth = 13}+ , hd{hdHour = 24}+ , hd{hdMinute = -1}+ , hd{hdSecond = 60}+ ]+ $ \x -> httpDateToUTCValid x `shouldBe` Nothing+ describe "utcToHTTPDate" $ do it "behaves like the model" $- forM_ [0, 100000 .. 10000000000] $ \epochtime -> do- let m = epochTimeToHTTPDate epochtime- o = utcToHTTPDate $ epochTimeToUtcTime epochtime- o `shouldBe` m+ forM_ epochs $ \e ->+ utcToHTTPDate (epochTimeToUtcTime e) `shouldBe` epochTimeToHTTPDate e
test/Model.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE CPP #-}- module Model where import Data.ByteString (ByteString)@@ -8,12 +6,8 @@ import Data.Time.Clock.POSIX import System.Posix.Types -#if !MIN_VERSION_time(1,5,0)-import System.Locale-#endif- epochTimeToUtcTime :: EpochTime -> UTCTime epochTimeToUtcTime = posixSecondsToUTCTime . realToFrac utcToDate :: UTCTime -> ByteString-utcToDate = BS8.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"+utcToDate = BS8.pack . formatTime defaultTimeLocale "%a, %d %b %0Y %H:%M:%S GMT"