From: pho Date: Sat, 7 Apr 2007 02:55:11 +0000 (+0900) Subject: Chunked input now works! X-Git-Tag: RELEASE-0_2_1~62 X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=cd1b58b84ff354e3fc2a7d2c8fd548a7b59fe138;p=Lucu.git 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 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 0d33a85..f99cdf5 100644 --- 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 e3032ce..f2f3976 100644 --- 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 1d0e6aa..42ccb90 100644 --- 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