diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2009, IIJ Innovation Institute Inc. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in + the documentation and/or other materials provided with the + distribution. + * Neither the name of the copyright holders nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/Network/HTTP/Date.hs b/Network/HTTP/Date.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Date.hs @@ -0,0 +1,15 @@ +{-| + Fast parser and formatter for HTTP Date. +-} +module Network.HTTP.Date ( + module Network.HTTP.Date.Types + -- * Utility functions + , parseHTTPDate + , formatHTTPDate + , epochTimeToHTTPDate + ) where + +import Network.HTTP.Date.Converter +import Network.HTTP.Date.Formatter +import Network.HTTP.Date.Parser +import Network.HTTP.Date.Types diff --git a/Network/HTTP/Date/Converter.hs b/Network/HTTP/Date/Converter.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Date/Converter.hs @@ -0,0 +1,70 @@ +module Network.HTTP.Date.Converter (epochTimeToHTTPDate) where + +import Data.Word +import Network.HTTP.Date.Types +import System.Posix.Types + +{-| + Translating 'EpochTime' to 'HTTPDate'. +-} +epochTimeToHTTPDate :: EpochTime -> HTTPDate +epochTimeToHTTPDate x = defaultHTTPDate { + hdYear = y + , hdMonth = m + , hdDay = d + , hdHour = h + , hdMinute = n + , hdSecond = s + , hdWkday = w + } + where + w64 :: Word64 + w64 = truncate . toRational $ x + (days',secs') = w64 `divMod` 86400 + days = fromIntegral days' + secs = fromIntegral secs' + -- 1970/1/1 is Thu (4) + w = (days + 3) `mod` 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 + cy = 1970 + y + cy' = cy - 1 + leap = cy' `div` 4 - cy' `div` 100 + cy' `div` 400 - 477 + (yy,days) = adjust cy d leap + (mm,dd) = findMonth 1 monthDays (days + 1) + 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 `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) + + +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] + +toHHMMSS :: Int -> (Int,Int,Int) +toHHMMSS x = (hh,mm,ss) + where + (hhmm,ss) = x `divMod` 60 + (hh,mm) = hhmm `divMod` 60 diff --git a/Network/HTTP/Date/Formatter.hs b/Network/HTTP/Date/Formatter.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Date/Formatter.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Date.Formatter (formatHTTPDate) where + +import Data.Array +import Data.ByteString.Internal +import Data.ByteString.Char8 () +import Data.Word +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable +import Network.HTTP.Date.Types + +---------------------------------------------------------------- + +{-| + Generating HTTP Date in RFC1123 style. +-} +formatHTTPDate :: HTTPDate -> ByteString +formatHTTPDate hd = + unsafeCreate 29 $ \ptr -> do + cpy3 ptr week + 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 + poke (ptr `plusPtr` 11) spc + int4 (ptr `plusPtr` 12) y + poke (ptr `plusPtr` 16) spc + int2 (ptr `plusPtr` 17) h + poke (ptr `plusPtr` 19) colon + int2 (ptr `plusPtr` 20) n + poke (ptr `plusPtr` 22) colon + int2 (ptr `plusPtr` 23) 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 + d = hdDay hd + h = hdHour hd + n = hdMinute hd + s = hdSecond hd + w = hdWkday hd + week = weekDays ! w + month = months ! m + +---------------------------------------------------------------- + +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)) + +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 + 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 + +---------------------------------------------------------------- + +months :: Array Int ByteString +months = listArray (1,12) [ + "Jan", "Feb", "Mar" + , "Apr", "May", "Jun" + , "Jul", "Aug", "Sep" + , "Oct", "Nov", "Dec" + ] + +weekDays :: Array Int ByteString +weekDays = listArray (1,7) [ + "Mon", "Tue", "Wed", "Thu", "Fri", "Sat", "Sun" + ] + +---------------------------------------------------------------- + +spc :: Word8 +spc = 32 + +comma :: Word8 +comma = 44 + +colon :: Word8 +colon = 58 + +zero :: Word8 +zero = 48 diff --git a/Network/HTTP/Date/Parser.hs b/Network/HTTP/Date/Parser.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Date/Parser.hs @@ -0,0 +1,103 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.HTTP.Date.Parser (parseHTTPDate) where + +import Data.ByteString +import Network.HTTP.Date.Types +import Data.Attoparsec +import Data.Attoparsec.Char8 +import Control.Applicative +import Data.Char + +---------------------------------------------------------------- + +{-| + Parsing HTTP Date. Currently only RFC1123 style is supported. +-} +parseHTTPDate :: ByteString -> Maybe HTTPDate +parseHTTPDate bs = case feed (parse rfc1123Date bs) "" of + Done _ ut -> Just ut + _ -> Nothing + +rfc1123Date :: Parser HTTPDate +rfc1123Date = do + w <- wkday + string ", " + (y,m,d) <- date1 + sp + (h,n,s) <- time + sp + string "GMT" + 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" + +date1 :: Parser (Int,Int,Int) +date1 = do + d <- day + sp + m <- month + sp + y <- year + return (y,m,d) + where + day = digit2 + year = digit4 + +sp :: Parser () +sp = () <$ char ' ' + +time :: Parser (Int,Int,Int) +time = do + h <- digit2 + char ':' + m <- digit2 + char ':' + s <- digit2 + 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" + +digit2 :: Parser Int +digit2 = do + x1 <- toInt <$> digit + x2 <- toInt <$> digit + 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 + +toInt :: Char -> Int +toInt c = ord c - ord '0' diff --git a/Network/HTTP/Date/Types.hs b/Network/HTTP/Date/Types.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Date/Types.hs @@ -0,0 +1,32 @@ +module Network.HTTP.Date.Types ( + 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) + +{-| + 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 new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/http-date.cabal b/http-date.cabal new file mode 100644 --- /dev/null +++ b/http-date.cabal @@ -0,0 +1,26 @@ +Name: http-date +Version: 0.0.0 +Author: Kazu Yamamoto +Maintainer: Kazu Yamamoto +License: BSD3 +License-File: LICENSE +Synopsis: HTTP Date parser/formatter +Description: Fast parser and formatter for HTTP Date +Category: Network, Web +Cabal-Version: >= 1.6 +Build-Type: Simple +library + if impl(ghc >= 6.12) + GHC-Options: -Wall -fno-warn-unused-do-bind + else + 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, + bytestring, array, attoparsec +Source-Repository head + Type: git + Location: git://github.com/kazu-yamamoto/http-date