From 1e48e402adec79653203dc19a1800efa7b1c467b Mon Sep 17 00:00:00 2001 From: pho Date: Sat, 31 Mar 2007 16:08:12 +0900 Subject: [PATCH] Yay! Deadlock problem has finally been solved! darcs-hash:20070331070812-62b54-6f1dbe38a242406458b503fc14ada4e456885b7a.gz --- Network/HTTP/Lucu/Httpd.hs | 4 +- Network/HTTP/Lucu/Parser.hs | 37 +++++++++------- Network/HTTP/Lucu/RequestReader.hs | 67 ++++++++++++++++------------- Network/HTTP/Lucu/ResponseWriter.hs | 14 +++--- 4 files changed, 69 insertions(+), 53 deletions(-) diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index 8fc36ac..a49a81d 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -26,6 +26,6 @@ runHttpd cnf table loop so = do (h, host, _) <- accept so tQueue <- newInteractionQueue - forkIO $ requestReader cnf table h host tQueue - forkIO $ responseWriter h tQueue + readerTID <- forkIO $ requestReader cnf table h host tQueue + writerTID <- forkIO $ responseWriter h tQueue readerTID loop so diff --git a/Network/HTTP/Lucu/Parser.hs b/Network/HTTP/Lucu/Parser.hs index 3fa4c15..0d33a85 100644 --- a/Network/HTTP/Lucu/Parser.hs +++ b/Network/HTTP/Lucu/Parser.hs @@ -1,6 +1,7 @@ module Network.HTTP.Lucu.Parser ( Parser(..) - , parse -- Parser a -> ByteString -> Maybe (a, ByteString) + , ParserResult(..) + , parse -- Parser a -> ByteString -> ParserResult a , anyChar -- Parser Char , satisfy -- (Char -> Bool) -> Parser Char , char -- Char -> Parser Char @@ -26,36 +27,39 @@ import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) data Parser a = Parser { - runParser :: State ByteString (Maybe a) + runParser :: State ByteString (ParserResult a) } +data ParserResult a = Success a + | IllegalInput -- 受理出來ない入力があった + | ReachedEOF -- 限界を越えて讀まうとした + -- (>>=) :: Parser a -> (a -> Parser b) -> Parser b instance Monad Parser where p >>= f = Parser $ do saved <- get -- 失敗した時の爲に状態を保存 result <- runParser p case result of - Just a -> runParser (f a) - Nothing -> do put saved -- 状態を復歸 - return Nothing - return = Parser . return . Just - fail _ = Parser $ return Nothing + Success a -> runParser (f a) + IllegalInput -> do put saved -- 状態を復歸 + return IllegalInput + ReachedEOF -> return ReachedEOF + return = Parser . return . Success + fail _ = Parser $ return IllegalInput -parse :: Parser a -> ByteString -> Maybe (a, ByteString) -parse p input = case runState (runParser p) input of - (Just a , input') -> Just (a, input') - (Nothing, _ ) -> Nothing +parse :: Parser a -> ByteString -> (ParserResult a, ByteString) +parse p input = runState (runParser p) input anyChar :: Parser Char anyChar = Parser $ do input <- get if B.null input then - return Nothing + return ReachedEOF else do let c = B.head input put (B.tail input) - return (Just c) + return (Success c) satisfy :: (Char -> Bool) -> Parser Char @@ -79,9 +83,10 @@ infixr 0 <|> f <|> g = Parser $ do saved <- get -- 状態を保存 result <- runParser f case result of - Just a -> return (Just a) - Nothing -> do put saved -- 状態を復歸 - runParser g + Success a -> return $ Success a + IllegalInput -> do put saved -- 状態を復歸 + runParser g + ReachedEOF -> return ReachedEOF oneOf :: [Char] -> Parser Char diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 12cad20..567b98b 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -31,30 +31,37 @@ 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 + = 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 + (ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then + -- ヘッダ長過ぎ + acceptNonparsableRequest + else + acceptRequest input - -- リクエストを讀む。パースできない場合は直ち - -- に 400 Bad Request 應答を設定し、それを出力 - -- してから切斷するやうに ResponseWriter に通 - -- 知する。 - case parse requestP input of - Nothing -> return acceptNonparsableRequest - Just (req, input') -> return $ acceptParsableRequest req input' - action acceptNonparsableRequest :: IO () acceptNonparsableRequest @@ -72,33 +79,33 @@ requestReader cnf tree h host tQueue enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () - acceptParsableRequest req input' + acceptParsableRequest req soFar = do itr <- newInteraction 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 +116,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 +127,12 @@ 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 = fail "FIXME: Not Implemented" enqueue :: Interaction -> STM () enqueue itr = do queue <- readTVar tQueue diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 266f825..ebd97e7 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -17,15 +17,18 @@ import Prelude hiding (catch) import System.IO import Text.Printf +import Control.Concurrent import Debug.Trace -responseWriter :: Handle -> InteractionQueue -> IO () -responseWriter h tQueue +responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO () +responseWriter h tQueue readerTID = catch awaitSomethingToWrite $ \ exc -> case exc of - IOException _ -> return () - _ -> print exc + IOException _ -> return () + AsyncException ThreadKilled -> return () + BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely" + _ -> print exc where awaitSomethingToWrite :: IO () awaitSomethingToWrite @@ -133,6 +136,7 @@ responseWriter h tQueue readItr itr itrWillClose id if willClose then - hClose h + do killThread readerTID + hClose h else awaitSomethingToWrite -- 2.40.0