Chunked input now works!

darcs-hash:20070407025511-62b54-ee6b49926b68e9a63636395f41daae324e3485e6.gz

diff --git a/Network/HTTP/Lucu/Chunk.hs b/Network/HTTP/Lucu/Chunk.hs
new file mode 100644 (file)
index 0000000..342362c
--- /dev/null
+++ b/Network/HTTP/Lucu/Chunk.hs
@@ -0,0 +1,35 @@
+module Network.HTTP.Lucu.Chunk
+    ( chunkHeaderP  -- Num a => Parser a
+    , chunkFooterP  -- Parser ()
+    , chunkTrailerP -- Parser Headers
+    )
+    where
+
+import           Network.HTTP.Lucu.Headers
+import           Network.HTTP.Lucu.Parser
+import           Network.HTTP.Lucu.Parser.Http
+import           Numeric
+
+
+chunkHeaderP :: Num a => Parser a
+chunkHeaderP = do hexLen <- many1 hexDigit
+                  extension
+                  crlf
+
+                  let [(len, _)] = readHex hexLen
+                  return len
+    where
+      extension :: Parser ()
+      extension = do many $ do char ';'
+                               token
+                               char '='
+                               token <|> quotedStr
+                     return ()
+
+
+chunkFooterP :: Parser ()
+chunkFooterP = crlf >> return ()
+
+
+chunkTrailerP :: Parser Headers
+chunkTrailerP = headersP

diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs
index 0d33a858a6b44362abf8668bc26974fcc5c737fa..f99cdf58b5afdd5c2d2a610e1ee3786e056c221d 100644 (file)
--- a/Network/HTTP/Lucu/Parser.hs
+++ b/Network/HTTP/Lucu/Parser.hs
@@ -1,7 +1,9 @@
 module Network.HTTP.Lucu.Parser
     ( Parser(..)
     , ParserResult(..)
+
     , parse     -- Parser a -> ByteString -> ParserResult a
+
     , anyChar   -- Parser Char
     , satisfy   -- (Char -> Bool) -> Parser Char
     , char      -- Char -> Parser Char
@@ -9,6 +11,7 @@ module Network.HTTP.Lucu.Parser
     , (<|>)     -- Parser a -> Parser a -> Parser a
     , oneOf     -- [Char] -> Parser Char
     , digit     -- Parser Char
+    , hexDigit  -- Parser Char
     , notFollowedBy -- Parser a -> Parser ()
     , many      -- Parser a -> Parser [a]
     , many1     -- Parser a -> Parser [a]
@@ -33,6 +36,7 @@ data Parser a = Parser {
 data ParserResult a = Success a
                     | IllegalInput -- 受理出來ない入力があった
                     | ReachedEOF   -- 限界を越えて讀まうとした
+                      deriving (Eq, Show)
 
 
 --  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
@@ -98,7 +102,21 @@ notFollowedBy p = p >>= fail "" <|> return ()
 
 
 digit :: Parser Char
-digit = oneOf "0123456789"
+digit = do c <- anyChar
+           if c >= '0' && c <= '9' then
+               return c
+             else
+               fail ""
+
+
+hexDigit :: Parser Char
+hexDigit = do c <- anyChar
+              if (c >= '0' && c <= '9') ||
+                 (c >= 'a' && c <= 'f') ||
+                 (c >= 'A' && c <= 'F') then
+                  return c
+                else
+                  fail ""
 
 
 many :: Parser a -> Parser [a]

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index e3032ce583ea8afdae6c0802462ac283dcea2dbb..f2f3976f3a5c9adcb8345500018f9ef44447282a 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -15,6 +15,7 @@ import qualified Data.Sequence as S
 import           Data.Sequence (Seq, (<|), ViewR(..))
 import           Network
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
@@ -62,7 +63,6 @@ requestReader cnf tree h host tQueue
                            resVersion = HttpVersion 1 1
                          , resStatus  = status
                          , resHeaders = []
-
                          }
                atomically $ do writeItr itr itrResponse $ Just res
                                writeItr itr itrWillClose True
@@ -134,7 +134,109 @@ requestReader cnf tree h host tQueue
 
       observeChunkedRequest :: Interaction -> ByteString -> IO ()
       observeChunkedRequest itr input
-          = fail "FIXME: not implemented"
+          = do action
+                   <- atomically $
+                      do isOver <- readItr itr itrReqChunkIsOver id
+                         if isOver then
+                             return $ acceptRequest input
+                           else
+                             do wantedM <- readItr itr itrReqBodyWanted id
+                                if wantedM == Nothing then
+                                    do wasteAll <- readItr itr itrReqBodyWasteAll id
+                                       if wasteAll then
+                                           -- 破棄要求が來た
+                                           do remainingM <- readItr itr itrReqChunkRemaining id
+                                              if fmap (> 0) remainingM == Just True then
+                                                  -- 現在のチャンクをまだ
+                                                  -- 讀み終へてゐない
+                                                  do let (_, input') = B.splitAt (fromIntegral
+                                                                                  $ fromJust remainingM) input
+                                                         (footerR, input'') = parse chunkFooterP input'
+
+                                                     if footerR == Success () then
+                                                         -- チャンクフッタを正常に讀めた
+                                                         do writeItr itr itrReqChunkRemaining $ Just 0
+                                                         
+                                                            return $ observeChunkedRequest itr input''
+                                                       else
+                                                         return $ chunkWasMalformed itr
+                                                else
+                                                  -- 次のチャンクを讀み始める
+                                                  seekNextChunk itr input
+                                         else
+                                           -- 要求がまだ來ない
+                                           retry
+                                  else
+                                    -- 受信要求が來た
+                                    do remainingM <- readItr itr itrReqChunkRemaining id
+                                       if fmap (> 0) remainingM == Just True then
+                                           -- 現在のチャンクをまだ讀み
+                                           -- 終へてゐない
+                                           do let wanted             = fromJust wantedM
+                                                  remaining          = fromJust remainingM
+                                                  bytesToRead        = fromIntegral $ min wanted remaining
+                                                  (chunk, input')    = B.splitAt bytesToRead input
+                                                  actualReadBytes    = fromIntegral $ B.length chunk
+                                                  newWanted          = case wanted - actualReadBytes of
+                                                                         0 -> Nothing
+                                                                         n -> Just n
+                                                  newRemaining       = Just $ remaining - actualReadBytes
+                                                  updateStates
+                                                      = do writeItr itr itrReqChunkRemaining newRemaining
+                                                           writeItr itr itrReqBodyWanted newWanted
+                                                           updateItr itr itrReceivedBody $ flip B.append chunk
+
+                                              if newRemaining == Just 0 then
+                                                  -- チャンクフッタを讀む
+                                                  case parse chunkFooterP input' of
+                                                    (Success _, input'')
+                                                        -> do updateStates
+                                                              return $ observeChunkedRequest itr input''
+                                                    _   -> return $ chunkWasMalformed itr
+                                                else
+                                                  -- まだチャンクの終はりに達してゐない
+                                                  do updateStates
+                                                     return $ observeChunkedRequest itr input'
+                                         else
+                                           -- 次のチャンクを讀み始める
+                                           seekNextChunk itr input
+               action
+
+      seekNextChunk :: Interaction -> ByteString -> STM (IO ())
+      seekNextChunk itr input
+          = case parse chunkHeaderP input of
+              -- 最終チャンク (中身が空)
+              (Success 0, input')
+                  -> case parse chunkTrailerP input' of
+                       (Success _, input'')
+                           -> do writeItr itr itrReqChunkLength $ Nothing
+                                 writeItr itr itrReqChunkRemaining $ Nothing
+                                 writeItr itr itrReqChunkIsOver True
+                                 
+                                 return $ acceptRequest input''
+                       _   -> return $ chunkWasMalformed itr
+              -- 最終でないチャンク
+              (Success len, input')
+                  -> do writeItr itr itrReqChunkLength $ Just len
+                        writeItr itr itrReqChunkRemaining $ Just len
+                        
+                        return $ observeChunkedRequest itr input'
+              -- チャンクヘッダがをかしい
+              _   -> return $ chunkWasMalformed itr
+
+      chunkWasMalformed :: Interaction -> IO ()
+      chunkWasMalformed itr
+          = let res = Response {
+                        resVersion = HttpVersion 1 1
+                      , resStatus  = BadRequest
+                      , resHeaders = []
+                      }
+            in
+              atomically $ do writeItr itr itrResponse $ Just res
+                              writeItr itr itrWillClose True
+                              writeItr itr itrState Done
+                              writeDefaultPage itr
+                              postprocess itr
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input
@@ -154,8 +256,6 @@ requestReader cnf tree h host tQueue
 
                                        writeItr itr itrReqChunkRemaining $ Just 0
                                        writeItr itr itrReqChunkIsOver True
-                                       writeItr itr itrReqBodyWanted Nothing
-                                       writeItr itr itrReceivedBody B.empty
 
                                        return $ acceptRequest input'
                                   else
@@ -165,13 +265,13 @@ requestReader cnf tree h host tQueue
                                -- 受信要求が來た
                                do remainingM <- readItr itr itrReqChunkRemaining id
 
-                                  let wanted = fromJust wantedM
-                                      expectedChunkLen = fromIntegral $ maybe wanted (min wanted) remainingM
-                                      (chunk, input')  = B.splitAt expectedChunkLen input
-                                      newRemaining     = fmap
-                                                         (\ x -> x - (fromIntegral $ B.length chunk))
-                                                         remainingM
-                                      isOver           = B.length chunk < expectedChunkLen
+                                  let wanted          = fromJust wantedM
+                                      bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
+                                      (chunk, input') = B.splitAt bytesToRead input
+                                      newRemaining    = fmap
+                                                        (\ x -> x - (fromIntegral $ B.length chunk))
+                                                        remainingM
+                                      isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 
                                   writeItr itr itrReqChunkRemaining newRemaining
                                   writeItr itr itrReqChunkIsOver isOver

diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs
index 1d0e6aa1f78eb761f3f0b141ee3ce43691ac36bc..42ccb90ff639c88479a5c241568c40675244be42 100644 (file)
--- a/examples/HelloWorld.hs
+++ b/examples/HelloWorld.hs
@@ -26,11 +26,11 @@ helloWorld
                       outputChunk "World!\n"
       , resHead   = Nothing
       , resPost
-          = Just $ do --str1 <- inputChunk 3
-                      --str2 <- inputChunk 3
-                      --str3 <- inputChunk 3
+          = Just $ do str1 <- inputChunk 3
+                      str2 <- inputChunk 3
+                      str3 <- inputChunk 3
                       setHeader "Content-Type" "text/plain"
-                      --output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]")
+                      output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]")
       , resPut    = Nothing
       , resDelete = Nothing
       }
\ No newline at end of file