diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/HTTP/Date/Converter.hs b/Network/HTTP/Date/Converter.hs --- a/Network/HTTP/Date/Converter.hs +++ b/Network/HTTP/Date/Converter.hs @@ -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 diff --git a/Network/HTTP/Date/Formatter.hs b/Network/HTTP/Date/Formatter.hs --- a/Network/HTTP/Date/Formatter.hs +++ b/Network/HTTP/Date/Formatter.hs @@ -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 diff --git a/Network/HTTP/Date/Parser.hs b/Network/HTTP/Date/Parser.hs --- a/Network/HTTP/Date/Parser.hs +++ b/Network/HTTP/Date/Parser.hs @@ -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' diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -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 diff --git a/http-date.cabal b/http-date.cabal --- a/http-date.cabal +++ b/http-date.cabal @@ -1,45 +1,65 @@ -Name: http-date -Version: 0.0.12 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -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 +author: Kazu Yamamoto +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 diff --git a/test/DateSpec.hs b/test/DateSpec.hs --- a/test/DateSpec.hs +++ b/test/DateSpec.hs @@ -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 diff --git a/test/Model.hs b/test/Model.hs --- a/test/Model.hs +++ b/test/Model.hs @@ -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"