X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=1106f14e14dcf06111e8abb872b2bfe5905083db;hb=1f0a19cbad7c4b64a773d7f1c1ae9180448624e6;hp=738207183ef8a04c387859dfdb1d16737b42d384;hpb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f;p=Lucu.git diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7382071..1106f14 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,23 +9,23 @@ module Network.HTTP.Lucu.ResponseWriter ) where import qualified Blaze.ByteString.Builder.HTTP as BB +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad import qualified Data.Ascii as A -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad import Data.Monoid.Unicode import qualified Data.Sequence as S -import Data.Sequence (ViewR(..)) -import Network.HTTP.Lucu.Config -import Network.HTTP.Lucu.HandleLike -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 Data.Sequence (ViewR(..)) +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.HandleLike +import Network.HTTP.Lucu.HttpVersion +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Postprocess +import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) +import System.IO.Error data Context h = Context { @@ -35,17 +35,46 @@ data Context h , cReader ∷ !ThreadId } +data Phase = Initial + | WroteContinue + | WroteHeader + deriving (Eq, Ord, Show) + responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () responseWriter cnf h tQueue readerTID = awaitSomethingToWrite (Context cnf h tQueue readerTID) `catches` - [ Handler $ \ (_ ∷ IOException) → return () - , Handler $ \ e → case e of - ThreadKilled → return () - _ → hPutStrLn stderr (show e) - , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely" - , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e) + [ Handler handleIOE + , Handler handleAsyncE + , Handler handleBIOS + , Handler handleOthers ] + where + handleIOE ∷ IOException → IO () + handleIOE e + | isIllegalOperation e + = return () -- EPIPE: should be ignored at all. + | otherwise + = terminate e + + handleAsyncE ∷ AsyncException → IO () + handleAsyncE ThreadKilled = terminate' + handleAsyncE e = terminate e + + handleBIOS ∷ BlockedIndefinitelyOnSTM → IO () + handleBIOS = terminate + + handleOthers ∷ SomeException → IO () + handleOthers = terminate + + terminate ∷ Exception e ⇒ e → IO () + terminate e + = do hPutStrLn stderr "requestWriter caught an exception:" + hPutStrLn stderr (show $ toException e) + terminate' + + terminate' ∷ IO () + terminate' = hClose h awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO () awaitSomethingToWrite ctx@(Context {..}) @@ -53,57 +82,69 @@ awaitSomethingToWrite ctx@(Context {..}) atomically $ -- キューが空でなくなるまで待つ do queue ← readTVar cQueue - -- GettingBody 状態にあり、Continue が期待されてゐて、それがま - -- だ送信前なのであれば、Continue を送信する。 case S.viewr queue of - EmptyR → retry - _ :> itr → do state ← readItr itrState itr - if state ≡ GettingBody then - writeContinueIfNeeded ctx itr - else - if state ≥ DecidingBody then - writeHeaderOrBodyIfNeeded ctx itr - else - retry - -writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeContinueIfNeeded ctx itr - = do expectedContinue ← readItr itrExpectedContinue itr - if expectedContinue then - do wroteContinue ← readItr itrWroteContinue itr - if wroteContinue then - -- 既に Continue を書込み濟 - retry - else - do reqBodyWanted ← readItr itrReqBodyWanted itr - if reqBodyWanted ≢ Nothing then - return $ writeContinue ctx itr - else - retry + EmptyR → retry + queue' :> itr → do writeTVar cQueue queue' + return $ awaitSomethingToWriteOn ctx itr Initial + +-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前 +-- なのであれば、Continue を送信する。 +awaitSomethingToWriteOn ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → IO () +awaitSomethingToWriteOn ctx itr phase + = join $ + atomically $ + do state ← readTVar $ itrState itr + if state ≡ GettingBody then + writeContinueIfNeeded ctx itr phase else - retry + if state ≥ DecidingBody then + writeHeaderOrBodyIfNeeded ctx itr phase + else + retry + +writeContinueIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → STM (IO ()) +writeContinueIfNeeded ctx itr@(Interaction {..}) phase + | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True + = do isRequested ← isEmptyTMVar itrGetBodyRequest + if isRequested then + return $ writeContinue ctx itr + else + retry + | otherwise + = retry -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを -- 出力する。空である時は、もし状態がDone であれば後処理をする。 -writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeHeaderOrBodyIfNeeded ctx itr - = do wroteHeader ← readItr itrWroteHeader itr - if not wroteHeader then - return $ writeHeader ctx itr - else - do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr) - if noBodyToWrite then - do state ← readItr itrState itr - if state ≡ Done then - return $ finalize ctx itr - else - retry - else - return $ writeBodyChunk ctx itr +writeHeaderOrBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → STM (IO ()) +writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase + | phase < WroteHeader + = return $ writeHeader ctx itr + | otherwise + = do noBodyToWrite ← isEmptyTMVar itrBodyToSend + if noBodyToWrite then + do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry + else + return $ writeBodyChunk ctx itr phase writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeContinue ctx@(Context {..}) itr +writeContinue ctx@(Context {..}) itr@(Interaction {..}) = do let cont = Response { resVersion = HttpVersion 1 1 , resStatus = Continue @@ -112,43 +153,47 @@ writeContinue ctx@(Context {..}) itr cont' ← completeUnconditionalHeaders cConfig cont hPutBuilder cHandle $ A.toBuilder $ printResponse cont' hFlush cHandle - atomically $ writeItr itrWroteContinue True itr - awaitSomethingToWrite ctx - -writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeHeader ctx@(Context {..}) itr - = do res ← atomically - $ do writeItr itrWroteHeader True itr - readItr itrResponse itr + awaitSomethingToWriteOn ctx itr WroteContinue + +writeHeader ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeHeader ctx@(Context {..}) itr@(Interaction {..}) + = do res ← atomically $ readTVar itrResponse hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle - awaitSomethingToWrite ctx + awaitSomethingToWriteOn ctx itr WroteHeader -writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeBodyChunk ctx@(Context {..}) itr +writeBodyChunk ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → IO () +writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase = join $ atomically $ - do willDiscardBody ← readItr itrWillDiscardBody itr + do willDiscardBody ← readTVar itrWillDiscardBody if willDiscardBody then - do _ ← tryTakeTMVar (itrBodyToSend itr) - return $ awaitSomethingToWrite ctx + do _ ← tryTakeTMVar itrBodyToSend + return $ awaitSomethingToWriteOn ctx itr phase else - do willChunkBody ← readItr itrWillChunkBody itr - chunk ← takeTMVar (itrBodyToSend itr) + do willChunkBody ← readTVar itrWillChunkBody + chunk ← takeTMVar itrBodyToSend return $ do if willChunkBody then hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk else hPutBuilder cHandle chunk hFlush cHandle - awaitSomethingToWrite ctx + awaitSomethingToWriteOn ctx itr phase finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -finishBodyChunk (Context {..}) itr +finishBodyChunk (Context {..}) (Interaction {..}) = join $ atomically $ - do willDiscardBody ← readItr itrWillDiscardBody itr - willChunkBody ← readItr itrWillChunkBody itr + do willDiscardBody ← readTVar itrWillDiscardBody + willChunkBody ← readTVar itrWillChunkBody if ((¬) willDiscardBody) ∧ willChunkBody then return $ do hPutBuilder cHandle BB.chunkedTransferTerminator @@ -157,14 +202,14 @@ finishBodyChunk (Context {..}) itr return $ return () finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -finalize ctx@(Context {..}) itr +finalize ctx@(Context {..}) itr@(Interaction {..}) = do finishBodyChunk ctx itr willClose ← atomically $ do queue ← readTVar cQueue case S.viewr queue of EmptyR → return () -- this should never happen remaining :> _ → writeTVar cQueue remaining - readItr itrWillClose itr + readTVar itrWillClose if willClose then -- reader は恐らく hWaitForInput してゐる最中なので、スレッ -- ドを豫め殺して置かないとをかしくなる。