diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,9 @@ +# ChangeLog for http-date + +## 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.Converter - , module Network.HTTP.Date.Types - -- * Utility functions - , parseHTTPDate - , formatHTTPDate - ) 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,11 +1,14 @@ {-# LANGUAGE BangPatterns #-} -module Network.HTTP.Date.Converter ( epochTimeToHTTPDate - , httpDateToUTC - , utcToHTTPDate - ) where +module Network.HTTP.Date.Converter ( + epochTimeToHTTPDate, + httpDateToUTC, + 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 @@ -14,29 +17,31 @@ import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) import System.Posix.Types -{-| - Translating 'EpochTime' to 'HTTPDate'. --} +-- | +-- Translating 'EpochTime' to 'HTTPDate'. epochTimeToHTTPDate :: EpochTime -> HTTPDate -epochTimeToHTTPDate x = defaultHTTPDate { - hdYear = y - , hdMonth = m - , hdDay = d - , hdHour = h - , hdMinute = n - , hdSecond = s - , hdWkday = w - } +epochTimeToHTTPDate x + | x < 0 = utcToHTTPDate $ posixSecondsToUTCTime $ realToFrac x + | otherwise = + 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', secs') = w64 `quotRem` 86400 days = fromIntegral days' secs = fromIntegral secs' -- 1970/1/1 is Thu (4) w = (days + 3) `rem` 7 + 1 - (y,m,d) = toYYMMDD days - (h,n,s) = toHHMMSS secs + (y, m, d) = toYYMMDD days + (h, n, s) = toHHMMSS secs -- | Translating 'HTTPDate' to 'UTCTime'. -- @@ -47,66 +52,76 @@ 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) + s = + fromIntegral $ + (hdHour x `rem` 24) * 3600 + + (hdMinute x `rem` 60) * 60 + + (hdSecond x `rem` 60) -- | 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 = fromEnum (w :: Int) - } +utcToHTTPDate x = + defaultHTTPDate + { hdYear = fromIntegral y + , hdMonth = m + , hdDay = d + , hdHour = h + , hdMinute = n + , hdSecond = truncate s + , hdWkday = fromEnum (w :: Int) + } where (y, m, d) = toGregorian day - (h, n, s) = ((todHour tod), (todMin tod), (todSec tod)) + (h, n, s) = (todHour tod, todMin tod, todSec tod) (_, _, w) = toWeekDate day - day = localDay time - tod = localTimeOfDay time - time = utcToLocalTime utc x + day = localDay time + tod = localTimeOfDay time + time = utcToLocalTime utc x -toYYMMDD :: Int -> (Int,Int,Int) +toYYMMDD :: Int -> (Int, Int, Int) toYYMMDD x = (yy, mm, dd) where - (y,d) = x `quotRem` 365 + (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 + (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) + | 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] +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] +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..] +mkPtrInt = unsafePerformIO . newArray . concat . zipWith (flip replicate) [1 ..] mkPtrInt2 :: [Int] -> Ptr Int mkPtrInt2 = unsafePerformIO . newArray . concatMap (enumFromTo 1) @@ -125,8 +140,8 @@ ---------------------------------------------------------------- -toHHMMSS :: Int -> (Int,Int,Int) -toHHMMSS x = (hh,mm,ss) +toHHMMSS :: Int -> (Int, Int, Int) +toHHMMSS x = (hh, mm, ss) where - (hhmm,ss) = x `quotRem` 60 - (hh,mm) = hhmm `quotRem` 60 + (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 @@ -16,16 +16,17 @@ -- -- >>> 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" 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 - poke (ptr `plusPtr` 7) spc - cpy3 (ptr `plusPtr` 8) months (3 * m) + 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) poke (ptr `plusPtr` 11) spc int4 (ptr `plusPtr` 12) y poke (ptr `plusPtr` 16) spc @@ -40,33 +41,35 @@ 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 + memcpy 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)) + | 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)) 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) + 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) 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 @@ -15,81 +15,84 @@ -- | -- Parsing HTTP Date. Currently only RFC1123 style is supported. -- +-- >>> :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 :: ByteString -> Maybe HTTPDate parseHTTPDate bs = case parseOnly rfc1123Date bs of Right ut -> Just ut - _ -> Nothing + _ -> Nothing rfc1123Date :: Parser HTTPDate rfc1123Date = do w <- wkday void $ string ", " - (y,m,d) <- date1 + (y, m, d) <- date1 sp - (h,n,s) <- time + (h, n, s) <- time sp - -- RFC 2616 defines GMT only but there are actually ill-formed ones such + -- 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 - } + return $ + defaultHTTPDate + { hdYear = y + , hdMonth = m + , hdDay = d + , hdHour = h + , hdMinute = n + , hdSecond = s + , hdWkday = w + } 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" +wkday = + 1 <$ string "Mon" + <|> 2 <$ string "Tue" + <|> 3 <$ string "Wed" + <|> 4 <$ string "Thu" + <|> 5 <$ string "Fri" + <|> 6 <$ string "Sat" + <|> 7 <$ string "Sun" -date1 :: Parser (Int,Int,Int) +date1 :: Parser (Int, Int, Int) date1 = do d <- day sp m <- month sp y <- year - return (y,m,d) - where - day = digit2 - year = digit4 + return (y, m, d) + where + day = digit2 + year = digit4 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" digit2 :: Parser Int digit2 = do 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/http-date.cabal b/http-date.cabal --- a/http-date.cabal +++ b/http-date.cabal @@ -1,5 +1,5 @@ Name: http-date -Version: 0.0.11 +Version: 0.0.12 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -9,6 +9,7 @@ Category: Network, Web Cabal-Version: >= 1.10 Build-Type: Simple +Extra-Source-Files: ChangeLog.md Library Default-Language: Haskell2010 @@ -31,6 +32,7 @@ Main-Is: Spec.hs Other-Modules: DateSpec Model + Build-Tool-Depends: hspec-discover:hspec-discover Build-Depends: base >= 4.9 && < 5 , bytestring , hspec @@ -38,15 +40,6 @@ , old-locale , time -Test-Suite doctests - Default-Language: Haskell2010 - Type: exitcode-stdio-1.0 - HS-Source-Dirs: test - Ghc-Options: -threaded - Main-Is: doctests.hs - Build-Depends: base >= 4.9 - , doctest >= 0.8 - Source-Repository head Type: git - Location: git://github.com/kazu-yamamoto/http-date + Location: https://github.com/kazu-yamamoto/http-date.git diff --git a/test/DateSpec.hs b/test/DateSpec.hs --- a/test/DateSpec.hs +++ b/test/DateSpec.hs @@ -10,28 +10,32 @@ spec :: Spec spec = do describe "formatHTTPDate" $ do - it "behaves like the model" $ - forM_ [0,100000..10000000000] $ \epochtime -> 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 + 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 + it "behaves like the model" $ + forM_ [0, 100000 .. 10000000000] $ \epochtime -> do let m = epochTimeToUtcTime epochtime o = httpDateToUTC $ epochTimeToHTTPDate epochtime o `shouldBe` m describe "parseHTTPDate" $ do it "behaves like the model" $ - forM_ [0,100000..10000000000] $ \epochtime -> do + forM_ [0, 100000 .. 10000000000] $ \epochtime -> do let m = epochTimeToHTTPDate epochtime Just o = parseHTTPDate $ formatHTTPDate m o `shouldBe` m describe "utcToHTTPDate" $ do it "behaves like the model" $ - forM_ [0,100000..10000000000] $ \epochtime -> do + forM_ [0, 100000 .. 10000000000] $ \epochtime -> do let m = epochTimeToHTTPDate epochtime o = utcToHTTPDate $ epochTimeToUtcTime epochtime o `shouldBe` m 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"]