X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=00e6f46b523849315c9ac833d44fe947ab5239f5;hp=6ccc2864c8e984c06f266326d212b3ee340a40a6;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hpb=5b255535f2c7d2a6d4622ad164b31e63746b906e diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 6ccc286..00e6f46 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -13,13 +13,13 @@ import Data.Maybe import qualified Data.Sequence as S import Data.Sequence (Seq, ViewR(..)) import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Response import Prelude hiding (catch) import System.IO -import Text.Printf import Control.Concurrent import Debug.Trace @@ -28,7 +28,8 @@ import GHC.Conc (unsafeIOToSTM) responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO () responseWriter cnf h tQueue readerTID - = catch awaitSomethingToWrite $ \ exc -> + = cnf `seq` h `seq` tQueue `seq` readerTID `seq` + catch awaitSomethingToWrite $ \ exc -> case exc of IOException _ -> return () AsyncException ThreadKilled -> return () @@ -38,30 +39,31 @@ responseWriter cnf h tQueue readerTID awaitSomethingToWrite :: IO () awaitSomethingToWrite = do action - <- atomically $ + <- atomically $! do -- キューが空でなくなるまで待つ queue <- readTVar tQueue when (S.null queue) retry - let _ :> itr = S.viewr queue - + -- GettingBody 状態にあり、Continue が期待され -- てゐて、それがまだ送信前なのであれば、 -- Continue を送信する。 - state <- readItr itr itrState id - - if state == GettingBody then - writeContinueIfNecessary itr - else - if state >= DecidingBody then - writeHeaderOrBodyIfNecessary itr - else - retry + case S.viewr queue of + _ :> itr -> do state <- readItr itr itrState id + + if state == GettingBody then + writeContinueIfNecessary itr + else + if state >= DecidingBody then + writeHeaderOrBodyIfNecessary itr + else + retry action writeContinueIfNecessary :: Interaction -> STM (IO ()) writeContinueIfNecessary itr - = do expectedContinue <- readItr itr itrExpectedContinue id + = itr `seq` + do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then do wroteContinue <- readItr itr itrWroteContinue id if wroteContinue then @@ -82,7 +84,8 @@ responseWriter cnf h tQueue readerTID -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 - = do wroteHeader <- readItr itr itrWroteHeader id + = itr `seq` + do wroteHeader <- readItr itr itrWroteHeader id if not wroteHeader then return $ writeHeader itr @@ -93,15 +96,16 @@ responseWriter cnf h tQueue readerTID do state <- readItr itr itrState id if state == Done then - return $ finalize itr + return $! finalize itr else retry else - return $ writeBodyChunk itr + return $! writeBodyChunk itr writeContinue :: Interaction -> IO () writeContinue itr - = do let cont = Response { + = itr `seq` + do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue , resHeaders = [] @@ -109,27 +113,30 @@ responseWriter cnf h tQueue readerTID cont' <- completeUnconditionalHeaders cnf cont hPutResponse h cont' hFlush h - atomically $ writeItr itr itrWroteContinue True + atomically $! writeItr itr itrWroteContinue True awaitSomethingToWrite writeHeader :: Interaction -> IO () writeHeader itr - = do res <- atomically $ do writeItr itr itrWroteHeader True - readItr itr itrResponse id + = itr `seq` + do res <- atomically $! do writeItr itr itrWroteHeader True + readItr itr itrResponse id hPutResponse h res hFlush h awaitSomethingToWrite writeBodyChunk :: Interaction -> IO () writeBodyChunk itr - = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id - willChunkBody <- atomically $ readItr itr itrWillChunkBody id - chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id - writeItr itr itrBodyToSend B.empty - return chunk + = itr `seq` + do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id + willChunkBody <- atomically $! readItr itr itrWillChunkBody id + chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id + writeItr itr itrBodyToSend B.empty + return chunk unless willDiscardBody $ do if willChunkBody then - do hPrintf h "%x\r\n" (toInteger $ B.length chunk) + do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk) + hPutStr h "\r\n" B.hPut h chunk hPutStr h "\r\n" else @@ -139,20 +146,23 @@ responseWriter cnf h tQueue readerTID finishBodyChunk :: Interaction -> IO () finishBodyChunk itr - = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id - willChunkBody <- atomically $ readItr itr itrWillChunkBody id + = itr `seq` + do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id + willChunkBody <- atomically $! readItr itr itrWillChunkBody id when (not willDiscardBody && willChunkBody) $ hPutStr h "0\r\n\r\n" >> hFlush h finalize :: Interaction -> IO () finalize itr - = do finishBodyChunk itr - willClose <- atomically $ do queue <- readTVar tQueue + = itr `seq` + do finishBodyChunk itr + willClose <- atomically $! + do queue <- readTVar tQueue - let (remaining :> _) = S.viewr queue - writeTVar tQueue remaining + case S.viewr queue of + remaining :> _ -> writeTVar tQueue remaining - readItr itr itrWillClose id + readItr itr itrWillClose id if willClose then -- reader は恐らく hWaitForInput してゐる最中なので、 -- スレッドを豫め殺して置かないとをかしくなる。