X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=3ab4bda714fc37295a3f2992e854e4179518e722;hb=1196f43ecedbb123515065f0440844864af906fb;hp=373930a24c178f5797c4420858e333e1242f45f0;hpb=e624f0db8c4610b36da9e4463a656e0cb8a104dd;p=Lucu.git diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 373930a..3ab4bda 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,70 +1,75 @@ module Network.HTTP.Lucu.ResponseWriter - ( responseWriter -- Handle -> InteractionQueue -> IO () + ( responseWriter ) where -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +import qualified Data.ByteString.Lazy.Char8 as C8 +import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad -import Data.Maybe import qualified Data.Sequence as S -import Data.Sequence (Seq, ViewR(..)) +import Data.Sequence (ViewR(..)) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Format +import Network.HTTP.Lucu.Headers +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 - -responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO () -responseWriter h tQueue readerTID - = catch awaitSomethingToWrite $ \ exc -> - case exc of - IOException _ -> return () - AsyncException ThreadKilled -> return () - BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely" - _ -> print exc +responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO () +responseWriter !cnf !h !tQueue !readerTID + = awaitSomethingToWrite + `catches` + [ Handler (( \ _ -> return () ) :: IOException -> IO ()) + , Handler ( \ ThreadKilled -> return () ) + , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" ) + , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + ] where awaitSomethingToWrite :: IO () awaitSomethingToWrite - = do action - <- atomically $ - do -- キューが空でなくなるまで待つ - queue <- readTVar tQueue - when (S.null queue) - retry - let _ :> itr = S.viewr queue - + = {-# SCC "awaitSomethingToWrite" #-} + do action + <- atomically $! + -- キューが空でなくなるまで待つ + do queue <- readTVar tQueue -- 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 + EmptyR -> retry + _ :> 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 + = {-# SCC "writeContinueIfNecessary" #-} + itr `seq` + do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then - do wroteContinue <- readItr itr itrWroteContinue id if wroteContinue then -- 既に Continue を書込み濟 retry else - return $ writeContinue itr + do reqBodyWanted <- readItr itr itrReqBodyWanted id + if reqBodyWanted /= Nothing then + return $ writeContinue itr + else + retry else retry @@ -74,67 +79,92 @@ responseWriter h tQueue readerTID -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 - = do wroteHeader <- readItr itr itrWroteHeader id + = {-# SCC "writeHeaderOrBodyIfNecessary" #-} + itr `seq` + do wroteHeader <- readItr itr itrWroteHeader id if not wroteHeader then - return $ writeHeader itr + return $! writeHeader itr else do bodyToSend <- readItr itr itrBodyToSend id - if B.null bodyToSend then + if C8.null bodyToSend then 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 = fail "FIXME: not implemented" + writeContinue itr + = {-# SCC "writeContinue" #-} + itr `seq` + do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = emptyHeaders + } + cont' <- completeUnconditionalHeaders cnf cont + hPutResponse h cont' + hFlush h + atomically $! writeItr itr itrWroteContinue True + awaitSomethingToWrite writeHeader :: Interaction -> IO () writeHeader itr - = do res <- atomically $ do writeItr itr itrWroteHeader True - readItr itr itrResponse id - hPutResponse h (fromJust res) + = {-# SCC "writeHeader" #-} + 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 + = {-# SCC "writeBodyChunk" #-} + 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 C8.empty + return chunk unless willDiscardBody $ do if willChunkBody then - do hPrintf h "%x\r\n" (toInteger $ B.length chunk) - B.hPut h chunk - hPutStr h "\r\n" + do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk) + C8.hPut h (C8.pack "\r\n") + C8.hPut h chunk + C8.hPut h (C8.pack "\r\n") else - B.hPut h chunk + C8.hPut h chunk hFlush h awaitSomethingToWrite finishBodyChunk :: Interaction -> IO () finishBodyChunk itr - = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id - willChunkBody <- atomically $ readItr itr itrWillChunkBody id + = {-# SCC "finishBodyChunk" #-} + 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 + $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h finalize :: Interaction -> IO () finalize itr - = do finishBodyChunk itr - willClose <- atomically $ do queue <- readTVar tQueue + = {-# SCC "finalize" #-} + itr `seq` + do finishBodyChunk itr + willClose <- atomically $! + do queue <- readTVar tQueue - let (remaining :> _) = S.viewr queue - writeTVar tQueue remaining + case S.viewr queue of + EmptyR -> return () -- this should never happen + remaining :> _ -> writeTVar tQueue remaining - readItr itr itrWillClose id + readItr itr itrWillClose id if willClose then -- reader は恐らく hWaitForInput してゐる最中なので、 -- スレッドを豫め殺して置かないとをかしくなる。