Yay! Deadlock problem has finally been solved!

[Lucu.git] / Network / HTTP / Lucu / RequestReader.hs

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 12cad2040039a95fd30426076ebfc45534a4c3b0..567b98b6961c75206994a8eb94c4e036e71c9a94 100644 (file)
--- 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