X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=b0c22be45d93ab9e36612f7d635b4b10df955492;hb=e624f0db8c4610b36da9e4463a656e0cb8a104dd;hp=12cad2040039a95fd30426076ebfc45534a4c3b0;hpb=a9e9f50818285bf66cd64e5a248175eecb8e1fea;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 12cad20..b0c22be 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -31,37 +31,43 @@ import GHC.Conc (unsafeIOToSTM) requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () requestReader cnf tree h host tQueue - = do input <- B.hGetContents h - catch (acceptRequest input) $ \ exc -> + = do catch (acceptRequest B.empty) $ \ exc -> case exc of - IOException _ -> return () - _ -> print exc + IOException _ -> return () + AsyncException ThreadKilled -> return () + BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely" + _ -> print exc where acceptRequest :: ByteString -> IO () - acceptRequest input + acceptRequest soFar -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 - = do action - <- atomically $ - do queue <- readTVar tQueue - when (S.length queue >= cnfMaxPipelineDepth cnf) - retry - - -- リクエストを讀む。パースできない場合は直ち - -- に 400 Bad Request 應答を設定し、それを出力 - -- してから切斷するやうに ResponseWriter に通 - -- 知する。 - case parse requestP input of - Nothing -> return acceptNonparsableRequest - Just (req, input') -> return $ acceptParsableRequest req input' - action - - acceptNonparsableRequest :: IO () - acceptNonparsableRequest - = do itr <- newInteraction host Nothing + = do atomically $ do queue <- readTVar tQueue + when (S.length queue >= cnfMaxPipelineDepth cnf) + retry + + -- リクエストを讀む。パースできない場合は直ちに 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 BadRequest + (ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then + -- ヘッダ長過ぎ + acceptNonparsableRequest RequestEntityTooLarge + else + acceptRequest input + + 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 @@ -72,33 +78,33 @@ requestReader cnf tree h host tQueue enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () - acceptParsableRequest req input' - = do itr <- newInteraction host (Just req) + acceptParsableRequest req soFar + = 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 input' + acceptSemanticallyInvalidRequest itr soFar else case findResource tree $ (reqURI . fromJust . itrRequest) itr of Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr input' + -> acceptRequestForNonexistentResource itr soFar Just rsrcDef -- あった - -> acceptRequestForExistentResource itr input' rsrcDef + -> acceptRequestForExistentResource itr soFar rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) - acceptSemanticallyInvalidRequest itr input + acceptSemanticallyInvalidRequest itr soFar = do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr - return $ acceptRequest input + return $ acceptRequest soFar acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) - acceptRequestForNonexistentResource itr input + acceptRequestForNonexistentResource itr soFar = do let res = Response { resVersion = HttpVersion 1 1 , resStatus = NotFound @@ -109,10 +115,10 @@ requestReader cnf tree h host tQueue writeDefaultPage itr postprocess itr enqueue itr - return $ acceptRequest input + return $ acceptRequest soFar acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) - acceptRequestForExistentResource itr input rsrcDef + acceptRequestForExistentResource itr soFar rsrcDef = do requestHasBody <- readItr itr itrRequestHasBody id writeItr itr itrState (if requestHasBody then ExaminingHeader @@ -120,12 +126,91 @@ requestReader cnf tree h host tQueue enqueue itr return $ do runResource rsrcDef itr if requestHasBody then - observeRequest itr input + observeRequest itr soFar else - acceptRequest input + acceptRequest soFar observeRequest :: Interaction -> ByteString -> IO () - observeRequest itr input = fail "FIXME: Not Implemented" + observeRequest itr soFar + = do isChunked <- atomically $ readItr itr itrRequestIsChunked id + if isChunked then + observeChunkedRequest itr soFar + else + observeNonChunkedRequest itr soFar + + observeChunkedRequest :: Interaction -> ByteString -> IO () + observeChunkedRequest itr soFar + = fail "FIXME: not implemented" + + observeNonChunkedRequest :: Interaction -> ByteString -> IO () + observeNonChunkedRequest itr soFar + = fail "FIXME: not implemented" +{- + = do action + <- atomically $ + do wantedM <- readItr itr itrReqBodyWanted id + if wantedM == Nothing then + do wasteAll <- readItr itr itrReqBodyWasteAll id + if wasteAll then + return $ wasteAllReqBody itr soFar + else + retry + else + -- 受信要求が來た。 + if B.empty soFar then + return $ receiveNonChunkedReqBody itr + else + do remaining <- readItr itr itrReqChunkRemaining fromJust + + let wanted = fromJust wanted + (chunk, input') = B.splitAt (min wanted remaining) soFar + newRemaining = remaining - B.length chunk + isOver = newRemaining == 0 + + writeItr itr itrReqChunkRemaining newRemaining + writeItr itr itrReqChunkIsOver isOver + writeItr itr itrReqBodyWanted (if isOver then + Nothing + else + Just wanted) + writeItr itr itrReceivedBody chunk + + if isOver then + return $ acceptRequest input' + else + return $ observeNonChunkedRequest itr input' + action + + receiveNonChunkedReqBody :: Interaction -> IO () + receiveNonChunkedReqBody itr + = do wanted <- atomically $ readItr itr itrReqBodyWanted fromJust + remaining <- atomically $ readItr itr itrReqChunkRemaining fromJust + + hWaitForInput h (-1) + chunk <- B.hGetNonBlocking h (min wanted remaining) + + let newRemaining = remaining - B.length chunk + isOver = newRemaining == 0 + + atomically $ do writeItr itr itrReqChunkRemaining newRemaining + writeItr itr itrReqChunkIsOver isOver + writeItr itr itrReqBodyWanted (if isOver then + Nothing + else + Just wanted) + writeItr itr itrReceivedBody chunk + + if isOver then + return $ acceptRequest B.empty + else + return $ observeNonChunkedRequest itr B.empty + + + wasteAllReqBody :: Interaction -> ByteString -> IO () + wasteAllReqBody itr soFar + = + +-} enqueue :: Interaction -> STM () enqueue itr = do queue <- readTVar tQueue