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,7 +1,14 @@ +{-# LANGUAGE BangPatterns #-} module Network.HTTP.Date.Converter (epochTimeToHTTPDate) where +import Control.Applicative +import Data.ByteString.Internal 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.Posix.Types {-| @@ -19,25 +26,25 @@ } where w64 :: Word64 - w64 = truncate . toRational $ x - (days',secs') = w64 `divMod` 86400 + w64 = fromIntegral $ fromEnum x + (days',secs') = w64 `quotRem` 86400 days = fromIntegral days' secs = fromIntegral secs' -- 1970/1/1 is Thu (4) - w = (days + 3) `mod` 7 + 1 + w = (days + 3) `rem` 7 + 1 (y,m,d) = toYYMMDD days (h,n,s) = toHHMMSS secs toYYMMDD :: Int -> (Int,Int,Int) toYYMMDD x = (yy, mm, dd) where - (y,d) = x `divMod` 365 + (y,d) = x `quotRem` 365 cy = 1970 + y cy' = cy - 1 - leap = cy' `div` 4 - cy' `div` 100 + cy' `div` 400 - 477 + leap = cy' `quot` 4 - cy' `quot` 100 + cy' `quot` 400 - 477 (yy,days) = adjust cy d leap - (mm,dd) = findMonth 1 monthDays (days + 1) - adjust ty td aj + (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) @@ -45,17 +52,15 @@ | otherwise = if td + 365 >= aj then (ty - 1, td + 365 - aj) else adjust (ty - 1) (td + 365) aj - isLeap year = year `mod` 4 == 0 - && (year `mod` 400 == 0 || - year `mod` 100 /= 0) - monthDays - | isLeap yy = leapMonthDays - | otherwise = normalMonthDays - findMonth _ [] _ = error "findMonth" - findMonth m (n:ns) z - | z <= n = (m,z) - | otherwise = findMonth (m+1) ns (z-n) + 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] @@ -63,8 +68,28 @@ 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 + +leapMonth :: Ptr Int +leapMonth = mkPtrInt leapMonthDays + +leapDayInMonth :: Ptr Int +leapDayInMonth = mkPtrInt2 leapMonthDays + +---------------------------------------------------------------- + toHHMMSS :: Int -> (Int,Int,Int) toHHMMSS x = (hh,mm,ss) where - (hhmm,ss) = x `divMod` 60 - (hh,mm) = hhmm `divMod` 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 @@ -2,9 +2,8 @@ module Network.HTTP.Date.Formatter (formatHTTPDate) where -import Data.Array -import Data.ByteString.Internal import Data.ByteString.Char8 () +import Data.ByteString.Internal import Data.Word import Foreign.ForeignPtr import Foreign.Ptr @@ -19,12 +18,12 @@ formatHTTPDate :: HTTPDate -> ByteString formatHTTPDate hd = unsafeCreate 29 $ \ptr -> do - cpy3 ptr week + 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) month + cpy3 (ptr `plusPtr` 8) months (3 * (m - 1)) poke (ptr `plusPtr` 11) spc int4 (ptr `plusPtr` 12) y poke (ptr `plusPtr` 16) spc @@ -45,29 +44,26 @@ n = hdMinute hd s = hdSecond hd w = hdWkday hd - week = weekDays ! w - month = months ! m + cpy3 :: Ptr Word8 -> ForeignPtr Word8 -> Int -> IO () + cpy3 ptr p o = withForeignPtr p $ \fp -> + memcpy ptr (fp `plusPtr` o) 3 ---------------------------------------------------------------- -cpy3 :: Ptr Word8 -> ByteString -> IO () -cpy3 ptr (PS p s l) = withForeignPtr p $ \fp -> - memcpy ptr (fp `plusPtr` s) (fromIntegral l) - 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 `div` 10)) - poke (ptr `plusPtr` 1) (i2w8 (n `mod` 10)) + 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 `divMod` 10 - (n2,x2) = n1 `divMod` 10 - (x4,x3) = n2 `divMod` 10 + 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) @@ -78,18 +74,11 @@ ---------------------------------------------------------------- -months :: Array Int ByteString -months = listArray (1,12) [ - "Jan", "Feb", "Mar" - , "Apr", "May", "Jun" - , "Jul", "Aug", "Sep" - , "Oct", "Nov", "Dec" - ] +months :: ForeignPtr Word8 +months = let (PS p _ _) = "JanFebMarAprMayJunJulAugSepOctNovDec" in p -weekDays :: Array Int ByteString -weekDays = listArray (1,7) [ - "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun" - ] +weekDays :: ForeignPtr Word8 +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 @@ -2,12 +2,12 @@ module Network.HTTP.Date.Parser (parseHTTPDate) where -import Data.ByteString -import Network.HTTP.Date.Types +import Control.Applicative import Data.Attoparsec import Data.Attoparsec.Char8 -import Control.Applicative +import Data.ByteString import Data.Char +import Network.HTTP.Date.Types ---------------------------------------------------------------- @@ -55,7 +55,7 @@ sp y <- year return (y,m,d) - where + where day = digit2 year = digit4 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.0 +Version: 0.0.1 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto License: BSD3