http-date 0.0.4 → 0.0.13
raw patch · 12 files changed
Files
- ChangeLog.md +22/−0
- Network/HTTP/Date.hs +9/−9
- Network/HTTP/Date/Converter.hs +111/−81
- Network/HTTP/Date/Formatter.hs +43/−31
- Network/HTTP/Date/Parser.hs +125/−57
- Network/HTTP/Date/Types.hs +26/−26
- Setup.hs +1/−0
- bench/Bench.hs +30/−0
- http-date.cabal +61/−44
- test/DateSpec.hs +114/−13
- test/Model.hs +1/−2
- test/doctests.hs +0/−6
+ ChangeLog.md view
@@ -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.
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.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
Network/HTTP/Date/Converter.hs view
@@ -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
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,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
Network/HTTP/Date/Parser.hs view
@@ -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'
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
+ 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,48 +1,65 @@-Name: http-date-Version: 0.0.4-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.8-Build-Type: Simple+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- 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
test/DateSpec.hs view
@@ -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
test/Model.hs view
@@ -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"
− test/doctests.hs
@@ -1,6 +0,0 @@-module Main where--import Test.DocTest--main :: IO ()-main = doctest ["-XOverloadedStrings", "Network/HTTP/Date.hs"]