diff --git a/Network/HTTP/Date.hs b/Network/HTTP/Date.hs --- a/Network/HTTP/Date.hs +++ b/Network/HTTP/Date.hs @@ -2,11 +2,11 @@ Fast parser and formatter for HTTP Date. -} module Network.HTTP.Date ( - module Network.HTTP.Date.Types + module Network.HTTP.Date.Converter + , module Network.HTTP.Date.Types -- * Utility functions , parseHTTPDate , formatHTTPDate - , epochTimeToHTTPDate ) where import Network.HTTP.Date.Converter 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,14 +1,17 @@ {-# LANGUAGE BangPatterns #-} -module Network.HTTP.Date.Converter (epochTimeToHTTPDate) where +module Network.HTTP.Date.Converter ( epochTimeToHTTPDate + , httpDateToUTC + , utcToHTTPDate + ) where -import Control.Applicative -import Data.ByteString.Internal +import Data.Time +import Data.Time.Calendar.WeekDate import Data.Word import Foreign.Marshal.Array import Foreign.Ptr import Foreign.Storable import Network.HTTP.Date.Types -import System.IO.Unsafe (unsafePerformIO) +import System.IO.Unsafe (unsafeDupablePerformIO, unsafePerformIO) import System.Posix.Types {-| @@ -35,6 +38,40 @@ (y,m,d) = toYYMMDD days (h,n,s) = toHHMMSS secs +-- | Translating 'HTTPDate' to 'UTCTime'. +-- +-- 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 + 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) + } + where + (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 + toYYMMDD :: Int -> (Int,Int,Int) toYYMMDD x = (yy, mm, dd) where @@ -55,10 +92,10 @@ isLeap year = year `rem` 4 == 0 && (year `rem` 400 == 0 || year `rem` 100 /= 0) - (months, daysArr) = if isLeap yy + (mnths, daysArr) = if isLeap yy then (leapMonth, leapDayInMonth) else (normalMonth, normalDayInMonth) - findMonth n = inlinePerformIO $ (,) <$> (peekElemOff months n) <*> (peekElemOff daysArr n) + findMonth n = unsafeDupablePerformIO $ (,) <$> (peekElemOff mnths n) <*> (peekElemOff daysArr n) ---------------------------------------------------------------- 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 @@ -20,12 +20,12 @@ formatHTTPDate :: HTTPDate -> ByteString formatHTTPDate hd = unsafeCreate 29 $ \ptr -> do - cpy3 ptr weekDays (3 * (w - 1)) + 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 - 1)) + cpy3 (ptr `plusPtr` 8) months (3 * m) poke (ptr `plusPtr` 11) spc int4 (ptr `plusPtr` 12) y poke (ptr `plusPtr` 16) spc @@ -77,10 +77,10 @@ ---------------------------------------------------------------- months :: ForeignPtr Word8 -months = let (PS p _ _) = "JanFebMarAprMayJunJulAugSepOctNovDec" in p +months = let (PS p _ _) = "___JanFebMarAprMayJunJulAugSepOctNovDec" in p weekDays :: ForeignPtr Word8 -weekDays = let (PS p _ _) = "MonTueWedThuFriSatSun" in p +weekDays = let (PS p _ _) = "___MonTueWedThuFriSatSun" in p ---------------------------------------------------------------- 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,8 +4,8 @@ import Control.Applicative import Control.Monad -import Data.Attoparsec -import Data.Attoparsec.Char8 +import Data.Attoparsec.ByteString +import Data.Attoparsec.ByteString.Char8 import Data.ByteString import Data.Char import Network.HTTP.Date.Types @@ -31,7 +31,9 @@ sp (h,n,s) <- time sp - void $ string "GMT" + -- 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 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 @@ -22,7 +22,7 @@ , hdMinute :: !Int , hdSecond :: !Int , hdWkday :: !Int - } deriving (Eq,Show, Ord) + } deriving (Eq, Show, Ord) {-| A default value for 'HTTPDate'. 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.4 +Version: 0.0.11 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3 @@ -7,28 +7,31 @@ Synopsis: HTTP Date parser/formatter Description: Fast parser and formatter for HTTP Date Category: Network, Web -Cabal-Version: >= 1.8 +Cabal-Version: >= 1.10 Build-Type: Simple 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 && < 5 + Build-Depends: base >= 4.9 && < 5 , array , attoparsec , bytestring + , time Test-Suite spec + Default-Language: Haskell2010 Type: exitcode-stdio-1.0 HS-Source-Dirs: test Main-Is: Spec.hs Other-Modules: DateSpec Model - Build-Depends: base >= 4 && < 5 + Build-Depends: base >= 4.9 && < 5 , bytestring , hspec , http-date @@ -36,11 +39,12 @@ , 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 + Build-Depends: base >= 4.9 , doctest >= 0.8 Source-Repository head diff --git a/test/DateSpec.hs b/test/DateSpec.hs --- a/test/DateSpec.hs +++ b/test/DateSpec.hs @@ -9,7 +9,7 @@ spec :: Spec spec = do - describe "formatHTTPDat" $ do + describe "formatHTTPDate" $ do it "behaves like the model" $ forM_ [0,100000..10000000000] $ \epochtime -> do let m = model epochtime @@ -17,9 +17,21 @@ model = utcToDate . epochTimeToUtcTime ours = formatHTTPDate . epochTimeToHTTPDate o `shouldBe` m - describe "parseHTTPDate" $ do + 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 + 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 + 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 diff --git a/test/Model.hs b/test/Model.hs --- a/test/Model.hs +++ b/test/Model.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE CPP #-} + module Model where import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS8 import Data.Time import Data.Time.Clock.POSIX -import System.Locale import System.Posix.Types + +#if !MIN_VERSION_time(1,5,0) +import System.Locale +#endif epochTimeToUtcTime :: EpochTime -> UTCTime epochTimeToUtcTime = posixSecondsToUTCTime . realToFrac