diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,22 @@ +# 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 + `hdWkday` was out of range (a huge value could crash). Such values + are now rendered as `___`. +* `epochTimeToHTTPDate` with a negative value spent a lot of CPU + time and returned a wrong date. It now returns the correct date. diff --git a/Network/HTTP/Date.hs b/Network/HTTP/Date.hs --- a/Network/HTTP/Date.hs +++ b/Network/HTTP/Date.hs @@ -1,13 +1,13 @@ -{-| - Fast parser and formatter for HTTP Date. --} +-- | +-- Fast parser and formatter for HTTP Date. module Network.HTTP.Date ( - module Network.HTTP.Date.Types - -- * Utility functions - , parseHTTPDate - , formatHTTPDate - , epochTimeToHTTPDate - ) where + module Network.HTTP.Date.Converter, + module Network.HTTP.Date.Types, + + -- * Utility functions + parseHTTPDate, + formatHTTPDate, +) where import Network.HTTP.Date.Converter import Network.HTTP.Date.Formatter 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,95 +1,125 @@ -{-# LANGUAGE BangPatterns #-} -module Network.HTTP.Date.Converter (epochTimeToHTTPDate) where +module Network.HTTP.Date.Converter ( + epochTimeToHTTPDate, + httpDateToUTC, + httpDateToUTCValid, + utcToHTTPDate, +) where -import Control.Applicative -import Data.ByteString.Internal -import Data.Word -import Foreign.Marshal.Array -import Foreign.Ptr -import Foreign.Storable +import Data.Time +import Data.Time.Calendar.WeekDate +import Foreign.C.Types (CTime (..)) import Network.HTTP.Date.Types -import System.IO.Unsafe (unsafePerformIO) import System.Posix.Types -{-| - Translating 'EpochTime' to 'HTTPDate'. --} +-- | +-- 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 = 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 -toYYMMDD :: Int -> (Int,Int,Int) -toYYMMDD x = (yy, mm, dd) +-- 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 - (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) - (months, daysArr) = if isLeap yy - then (leapMonth, leapDayInMonth) - else (normalMonth, normalDayInMonth) - findMonth n = inlinePerformIO $ (,) <$> (peekElemOff months 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 + 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 -leapMonth :: Ptr Int -leapMonth = mkPtrInt leapMonthDays +-- | 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) + where + y = fromIntegral $ hdYear x + m = hdMonth x + d = hdDay x + 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 -leapDayInMonth :: Ptr Int -leapDayInMonth = mkPtrInt2 leapMonthDays +-- | 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) -toHHMMSS :: Int -> (Int,Int,Int) -toHHMMSS x = (hh,mm,ss) +-- | Translating 'UTCTime' to 'HTTPDate'. +-- +-- Since 0.0.7. +utcToHTTPDate :: UTCTime -> HTTPDate +utcToHTTPDate x = + defaultHTTPDate + { hdYear = fromIntegral y + , hdMonth = m + , hdDay = d + , hdHour = h + , hdMinute = n + , hdSecond = truncate s + , hdWkday = w + } where - (hhmm,ss) = x `quotRem` 60 - (hh,mm) = hhmm `quotRem` 60 + (y, m, d) = toGregorian day + (h, n, s) = (todHour tod, todMin tod, todSec tod) + (_, _, w) = toWeekDate day + day = localDay time + tod = localTimeOfDay time + time = utcToLocalTime utc x 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,60 +17,68 @@ -- -- >>> formatHTTPDate defaultHTTPDate {hdYear = 1994, hdMonth = 11, hdDay = 15, hdHour = 8, hdMinute = 12, hdSecond = 31, hdWkday = 2} -- "Tue, 15 Nov 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 - 1)) - poke (ptr `plusPtr` 3) comma - poke (ptr `plusPtr` 4) spc - int2 (ptr `plusPtr` 5) d - poke (ptr `plusPtr` 7) spc - cpy3 (ptr `plusPtr` 8) months (3 * (m - 1)) + cpy3 ptr weekDays (3 * w) + poke (ptr `plusPtr` 3) comma + poke (ptr `plusPtr` 4) spc + 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) poke (ptr `plusPtr` 28) (84 :: Word8) where y = hdYear hd - m = hdMonth hd + -- Out-of-range values are rendered as "___" to avoid reading + -- outside the tables. + m = let m0 = hdMonth hd in if m0 < 1 || m0 > 12 then 0 else m0 d = hdDay hd h = hdHour hd n = hdMinute hd s = hdSecond hd - w = hdWkday hd + 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) - | otherwise = do - poke ptr (i2w8 (n `quot` 10)) - poke (ptr `plusPtr` 1) (i2w8 (n `rem` 10)) +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 @@ -77,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 ---------------------------------------------------------------- @@ -95,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,104 +4,172 @@ import Control.Applicative import Control.Monad -import Data.Attoparsec -import Data.Attoparsec.Char8 -import Data.ByteString +import Data.Attoparsec.ByteString.Char8 +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 - _ -> Nothing +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 - void $ string "GMT" - 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 -wkday :: Parser Int -wkday = 1 <$ string "Mon" - <|> 2 <$ string "Tue" - <|> 3 <$ string "Wed" - <|> 4 <$ string "Thu" - <|> 5 <$ string "Fri" - <|> 6 <$ string "Sat" - <|> 7 <$ string "Sun" +-- 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 -date1 :: Parser (Int,Int,Int) -date1 = do - d <- day +-- Sun Nov 6 08:49:37 1994 +asctimeDate :: Parser HTTPDate +asctimeDate = do + w <- wkday sp m <- month sp - y <- year - return (y,m,d) - where - day = digit2 - year = digit4 + 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" + <|> 2 <$ string "Tue" + <|> 3 <$ string "Wed" + <|> 4 <$ string "Thu" + <|> 5 <$ string "Fri" + <|> 6 <$ string "Sat" + <|> 7 <$ string "Sun" + +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 ' ' -time :: Parser (Int,Int,Int) +time :: Parser (Int, Int, Int) time = do h <- digit2 void $ char ':' m <- digit2 void $ char ':' s <- digit2 - return (h,m,s) + return (h, m, s) month :: Parser Int -month = 1 <$ string "Jan" - <|> 2 <$ string "Feb" - <|> 3 <$ string "Mar" - <|> 4 <$ string "Apr" - <|> 5 <$ string "May" - <|> 6 <$ string "Jun" - <|> 7 <$ string "Jul" - <|> 8 <$ string "Aug" - <|> 9 <$ string "Sep" - <|> 10 <$ string "Oct" - <|> 11 <$ string "Nov" - <|> 12 <$ string "Dec" +month = + 1 <$ string "Jan" + <|> 2 <$ string "Feb" + <|> 3 <$ string "Mar" + <|> 4 <$ string "Apr" + <|> 5 <$ string "May" + <|> 6 <$ string "Jun" + <|> 7 <$ string "Jul" + <|> 8 <$ string "Aug" + <|> 9 <$ string "Sep" + <|> 10 <$ string "Oct" + <|> 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/Network/HTTP/Date/Types.hs b/Network/HTTP/Date/Types.hs --- a/Network/HTTP/Date/Types.hs +++ b/Network/HTTP/Date/Types.hs @@ -1,32 +1,32 @@ module Network.HTTP.Date.Types ( - HTTPDate - , hdYear - , hdMonth - , hdDay - , hdHour - , hdMinute - , hdSecond - , hdWkday - , defaultHTTPDate - ) where + HTTPDate, + hdYear, + hdMonth, + hdDay, + hdHour, + hdMinute, + hdSecond, + hdWkday, + defaultHTTPDate, +) where -{-| - Data structure for HTTP Date. This value should be specified - with 'defaultHTTPDate' and its field labels. --} -data HTTPDate = HTTPDate { - hdYear :: !Int - , hdMonth :: !Int - , hdDay :: !Int - , hdHour :: !Int - , hdMinute :: !Int - , hdSecond :: !Int - , hdWkday :: !Int - } deriving (Eq,Show, Ord) +-- | +-- Data structure for HTTP Date. This value should be specified +-- with 'defaultHTTPDate' and its field labels. +data HTTPDate = HTTPDate + { hdYear :: !Int + , hdMonth :: !Int + , hdDay :: !Int + , hdHour :: !Int + , hdMinute :: !Int + , hdSecond :: !Int + , hdWkday :: !Int + } + deriving (Eq, Show, Ord) -{-| - A default value for 'HTTPDate'. --} +-- | +-- A default value for 'HTTPDate'. + -- 1970/1/1 is Thu (4) defaultHTTPDate :: HTTPDate defaultHTTPDate = HTTPDate 1970 1 1 0 0 0 4 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain 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,48 +1,65 @@ -Name: http-date -Version: 0.0.4 -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.8 -Build-Type: Simple +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 - 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 && < 5 - , array - , attoparsec - , bytestring +source-repository head + type: git + location: https://github.com/kazu-yamamoto/http-date.git -Test-Suite spec - Type: exitcode-stdio-1.0 - HS-Source-Dirs: test - Main-Is: Spec.hs - Other-Modules: DateSpec - Model - Build-Depends: base >= 4 && < 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 -Test-Suite doctests - Type: exitcode-stdio-1.0 - HS-Source-Dirs: test - Ghc-Options: -threaded - Main-Is: doctests.hs - Build-Depends: base - , doctest >= 0.8 + 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 -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/http-date +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,25 +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 "formatHTTPDat" $ 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 + 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_ 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 + it "behaves like the model" $ + 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_ 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 @@ -4,11 +4,10 @@ import qualified Data.ByteString.Char8 as BS8 import Data.Time import Data.Time.Clock.POSIX -import System.Locale import System.Posix.Types 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" diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,6 +0,0 @@ -module Main where - -import Test.DocTest - -main :: IO () -main = doctest ["-XOverloadedStrings", "Network/HTTP/Date.hs"]