X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=9751a7699c7b175ba062ae750d4c5f710fffeac0;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=00e6f46b523849315c9ac833d44fe947ab5239f5;hpb=858129cb755aa09da2b7bd758efb8519f2c89103;p=Lucu.git diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 00e6f46..9751a76 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,68 +1,66 @@ --- #hide +{-# LANGUAGE + BangPatterns + , UnicodeSyntax + #-} module Network.HTTP.Lucu.ResponseWriter ( 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.HandleLike +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 Control.Concurrent -import Debug.Trace -import GHC.Conc (unsafeIOToSTM) - - -responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO () -responseWriter cnf h tQueue readerTID - = cnf `seq` h `seq` tQueue `seq` readerTID `seq` - catch awaitSomethingToWrite $ \ exc -> - case exc of - IOException _ -> return () - AsyncException ThreadKilled -> return () - BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely" - _ -> print exc +import System.IO (stderr) + + +responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO () +responseWriter !cnf !h !tQueue !readerTID + = awaitSomethingToWrite + `catches` + [ Handler (( \ _ -> return () ) :: IOException -> IO ()) + , Handler ( \ ThreadKilled -> return () ) + , Handler ( \ BlockedIndefinitelyOnSTM -> 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 - - -- GettingBody 状態にあり、Continue が期待され - -- てゐて、それがまだ送信前なのであれば、 - -- Continue を送信する。 - 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 + = {-# SCC "awaitSomethingToWrite" #-} + join $! + atomically $! + -- キューが空でなくなるまで待つ + do queue <- readTVar tQueue + -- GettingBody 状態にあり、Continue が期待されてゐ + -- て、それがまだ送信前なのであれば、Continue を送 + -- 信する。 + 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 writeContinueIfNecessary :: Interaction -> STM (IO ()) - writeContinueIfNecessary itr - = itr `seq` + writeContinueIfNecessary !itr + = {-# SCC "writeContinueIfNecessary" #-} do expectedContinue <- readItr itr itrExpectedContinue id if expectedContinue then do wroteContinue <- readItr itr itrWroteContinue id @@ -79,20 +77,20 @@ responseWriter cnf h tQueue readerTID retry writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) - writeHeaderOrBodyIfNecessary itr + writeHeaderOrBodyIfNecessary !itr -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が -- 空でなければ、それを出力する。空である時は、もし状態が -- Done であれば後処理をする。 - = itr `seq` + = {-# SCC "writeHeaderOrBodyIfNecessary" #-} 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 @@ -103,12 +101,12 @@ responseWriter cnf h tQueue readerTID return $! writeBodyChunk itr writeContinue :: Interaction -> IO () - writeContinue itr - = itr `seq` + writeContinue !itr + = {-# SCC "writeContinue" #-} do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue - , resHeaders = [] + , resHeaders = emptyHeaders } cont' <- completeUnconditionalHeaders cnf cont hPutResponse h cont' @@ -117,8 +115,8 @@ responseWriter cnf h tQueue readerTID awaitSomethingToWrite writeHeader :: Interaction -> IO () - writeHeader itr - = itr `seq` + writeHeader !itr + = {-# SCC "writeHeader" #-} do res <- atomically $! do writeItr itr itrWroteHeader True readItr itr itrResponse id hPutResponse h res @@ -126,40 +124,41 @@ responseWriter cnf h tQueue readerTID awaitSomethingToWrite writeBodyChunk :: Interaction -> IO () - writeBodyChunk itr - = itr `seq` + writeBodyChunk !itr + = {-# SCC "writeBodyChunk" #-} 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 + writeItr itr itrBodyToSend C8.empty return chunk unless willDiscardBody $ do if willChunkBody then - do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk) - hPutStr h "\r\n" - B.hPut h chunk - hPutStr h "\r\n" + do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk) + hPutLBS h (C8.pack "\r\n") + hPutLBS h chunk + hPutLBS h (C8.pack "\r\n") else - B.hPut h chunk + hPutLBS h chunk hFlush h awaitSomethingToWrite finishBodyChunk :: Interaction -> IO () - finishBodyChunk itr - = itr `seq` + finishBodyChunk !itr + = {-# SCC "finishBodyChunk" #-} 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 + $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h finalize :: Interaction -> IO () - finalize itr - = itr `seq` + finalize !itr + = {-# SCC "finalize" #-} do finishBodyChunk itr willClose <- atomically $! do queue <- readTVar tQueue case S.viewr queue of + EmptyR -> return () -- this should never happen remaining :> _ -> writeTVar tQueue remaining readItr itr itrWillClose id