http-date 0.0.11 → 0.0.12
raw patch · 10 files changed
+200/−178 lines, 10 filesdep −doctestdep ~basesetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies removed: doctest
Dependency ranges changed: base
API changes (from Hackage documentation)
- Network.HTTP.Date: hdDay :: HTTPDate -> Int
- Network.HTTP.Date: hdHour :: HTTPDate -> Int
- Network.HTTP.Date: hdMinute :: HTTPDate -> Int
- Network.HTTP.Date: hdMonth :: HTTPDate -> Int
- Network.HTTP.Date: hdSecond :: HTTPDate -> Int
- Network.HTTP.Date: hdWkday :: HTTPDate -> Int
- Network.HTTP.Date: hdYear :: HTTPDate -> Int
Files
- ChangeLog.md +9/−0
- Network/HTTP/Date.hs +9/−9
- Network/HTTP/Date/Converter.hs +75/−60
- Network/HTTP/Date/Formatter.hs +22/−19
- Network/HTTP/Date/Parser.hs +43/−40
- Network/HTTP/Date/Types.hs +26/−26
- Setup.hs +1/−0
- http-date.cabal +4/−11
- test/DateSpec.hs +11/−7
- test/doctests.hs +0/−6
+ ChangeLog.md view
@@ -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.
Network/HTTP/Date.hs view
@@ -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
Network/HTTP/Date/Converter.hs view
@@ -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
Network/HTTP/Date/Formatter.hs view
@@ -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)
Network/HTTP/Date/Parser.hs view
@@ -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
Network/HTTP/Date/Types.hs view
@@ -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
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
http-date.cabal view
@@ -1,5 +1,5 @@ Name: http-date-Version: 0.0.11+Version: 0.0.12 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> 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
test/DateSpec.hs view
@@ -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
− test/doctests.hs
@@ -1,6 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest ["-XOverloadedStrings", "Network/HTTP/Date.hs"]