http-date (empty) → 0.0.0

raw patch · 8 files changed

+383/−0 lines, 8 filesdep +arraydep +attoparsecdep +basesetup-changed

Dependencies added: array, attoparsec, base, bytestring

Files

LICENSE +29/−0
Network/HTTP/Date.hs +15/−0
Network/HTTP/Date/Converter.hs +70/−0
Network/HTTP/Date/Formatter.hs +106/−0
Network/HTTP/Date/Parser.hs +103/−0
Network/HTTP/Date/Types.hs +32/−0
Setup.hs +2/−0
http-date.cabal +26/−0

+ LICENSE view

@@ -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.

+ Network/HTTP/Date.hs view

@@ -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

+ Network/HTTP/Date/Converter.hs view

@@ -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

+ Network/HTTP/Date/Formatter.hs view

@@ -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

+ Network/HTTP/Date/Parser.hs view

@@ -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'

+ Network/HTTP/Date/Types.hs view

@@ -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

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ http-date.cabal view

@@ -0,0 +1,26 @@+Name:                   http-date+Version:                0.0.0+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.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