X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=42eda0e7cb8efcec541eed78f19ba4f1d557b241;hb=1000bdc46cfe7b3ae550ff24ccea9f440f11b42a;hp=567b98b6961c75206994a8eb94c4e036e71c9a94;hpb=1e48e402adec79653203dc19a1800efa7b1c467b;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 567b98b..42eda0e 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 @@ -31,7 +32,8 @@ import GHC.Conc (unsafeIOToSTM) requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () requestReader cnf tree h host tQueue - = do catch (acceptRequest B.empty) $ \ exc -> + = do catch (do input <- B.hGetContents h + acceptRequest input) $ \ exc -> case exc of IOException _ -> return () AsyncException ThreadKilled -> return () @@ -39,7 +41,7 @@ requestReader cnf tree h host tQueue _ -> print exc where acceptRequest :: ByteString -> IO () - acceptRequest soFar + acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 = do atomically $ do queue <- readTVar tQueue @@ -49,26 +51,17 @@ requestReader cnf tree h host tQueue -- リクエストを讀む。パースできない場合は直ちに 400 Bad -- Request 應答を設定し、それを出力してから切斷するやう -- に ResponseWriter に通知する。 - hWaitForInput h (-1) - chunk <- B.hGetNonBlocking h 1024 - - let input = B.append soFar chunk case parse requestP input of (Success req , input') -> acceptParsableRequest req input' - (IllegalInput, _ ) -> acceptNonparsableRequest - (ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then - -- ヘッダ長過ぎ - acceptNonparsableRequest - else - acceptRequest input - - - acceptNonparsableRequest :: IO () - acceptNonparsableRequest - = do itr <- newInteraction host Nothing + (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest + (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest + + acceptNonparsableRequest :: StatusCode -> IO () + acceptNonparsableRequest status + = do itr <- newInteraction cnf host Nothing let res = Response { resVersion = HttpVersion 1 1 - , resStatus = BadRequest + , resStatus = status , resHeaders = [] } atomically $ do writeItr itr itrResponse $ Just res @@ -79,33 +72,33 @@ requestReader cnf tree h host tQueue enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () - acceptParsableRequest req soFar - = do itr <- newInteraction host (Just req) + acceptParsableRequest req input + = do itr <- newInteraction cnf host (Just req) action <- atomically $ do preprocess itr isErr <- readItrF itr itrResponse (isError . resStatus) if isErr == Just True then - acceptSemanticallyInvalidRequest itr soFar + acceptSemanticallyInvalidRequest itr input else case findResource tree $ (reqURI . fromJust . itrRequest) itr of Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr soFar + -> acceptRequestForNonexistentResource itr input Just rsrcDef -- あった - -> acceptRequestForExistentResource itr soFar rsrcDef + -> acceptRequestForExistentResource itr input rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) - acceptSemanticallyInvalidRequest itr soFar + acceptSemanticallyInvalidRequest itr input = do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr - return $ acceptRequest soFar + return $ acceptRequest input acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) - acceptRequestForNonexistentResource itr soFar + acceptRequestForNonexistentResource itr input = do let res = Response { resVersion = HttpVersion 1 1 , resStatus = NotFound @@ -116,23 +109,177 @@ requestReader cnf tree h host tQueue writeDefaultPage itr postprocess itr enqueue itr - return $ acceptRequest soFar + return $ acceptRequest input acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) - acceptRequestForExistentResource itr soFar rsrcDef + acceptRequestForExistentResource itr input rsrcDef = do requestHasBody <- readItr itr itrRequestHasBody id - writeItr itr itrState (if requestHasBody - then ExaminingHeader - else DecidingHeader) enqueue itr return $ do runResource rsrcDef itr if requestHasBody then - observeRequest itr soFar + observeRequest itr input else - acceptRequest soFar + acceptRequest input observeRequest :: Interaction -> ByteString -> IO () - observeRequest itr soFar = fail "FIXME: Not Implemented" + observeRequest itr input + = do isChunked <- atomically $ readItr itr itrRequestIsChunked id + if isChunked then + observeChunkedRequest itr input + else + observeNonChunkedRequest itr input + + observeChunkedRequest :: Interaction -> ByteString -> IO () + observeChunkedRequest itr input + = 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 + = do action + <- atomically $ + 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 + + let (_, input') = if remainingM == Nothing then + (B.takeWhile (\ _ -> True) input, B.empty) + else + B.splitAt (fromIntegral $ fromJust remainingM) input + + writeItr itr itrReqChunkRemaining $ Just 0 + writeItr itr itrReqChunkIsOver True + + return $ acceptRequest input' + else + -- 要求がまだ来ない + retry + else + -- 受信要求が來た + do remainingM <- readItr itr itrReqChunkRemaining id + + 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 + writeItr itr itrReqBodyWanted Nothing + writeItr itr itrReceivedBody chunk + + if isOver then + return $ acceptRequest input' + else + return $ observeNonChunkedRequest itr input' + action enqueue :: Interaction -> STM () enqueue itr = do queue <- readTVar tQueue