X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=02e3938644b2122269d9c98e708c58352b68535d;hb=8225cc5;hp=034bd782aade719fa1a3beac140fdf2780e8d62b;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 034bd78..02e3938 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,11 +9,11 @@ module Network.HTTP.Lucu.ResponseWriter ) where import qualified Blaze.ByteString.Builder.HTTP as BB -import qualified Data.Ascii as A import Control.Concurrent import Control.Concurrent.STM import Control.Exception import Control.Monad +import qualified Data.Ascii as A import Data.Monoid.Unicode import qualified Data.Sequence as S import Data.Sequence (ViewR(..)) @@ -25,6 +25,7 @@ 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 { @@ -38,136 +39,193 @@ responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → Thread 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 {..}) = join $ atomically $ - -- キューが空でなくなるまで待つ do queue ← readTVar cQueue - -- GettingBody 状態にあり、Continue が期待されてゐて、それがま - -- だ送信前なのであれば、Continue を送信する。 case S.viewr queue of - EmptyR → retry - _ :> itr → do state ← readTVar $ itrState itr - if state ≡ GettingBody then - writeContinueIfNeeded ctx itr - else - if state ≥ DecidingBody then - writeHeaderOrBodyIfNeeded ctx itr - else - retry + EmptyR → retry + queue' :> itr → do writeTVar cQueue queue' + return $ writeContinueIfNeeded ctx itr -writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeContinueIfNeeded ctx itr@(Interaction {..}) - = do expectedContinue ← readTVar itrExpectedContinue - if expectedContinue then - do wroteContinue ← readTVar itrWroteContinue - if wroteContinue then - -- 既に Continue を書込み濟 - retry - else - do reqBodyWanted ← readTVar itrReqBodyWanted - if reqBodyWanted ≢ Nothing then - return $ writeContinue ctx itr - else - retry - else - retry - --- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ --- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを --- 出力する。空である時は、もし状態がDone であれば後処理をする。 -writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ()) -writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) - = do wroteHeader ← readTVar itrWroteHeader - if not wroteHeader then - return $ writeHeader ctx itr - else - 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 - -writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeContinue ctx@(Context {..}) (Interaction {..}) - = do let cont = Response { - resVersion = HttpVersion 1 1 - , resStatus = Continue - , resHeaders = (∅) - } - cont' ← completeUnconditionalHeaders cConfig cont - hPutBuilder cHandle $ A.toBuilder $ printResponse cont' - hFlush cHandle - atomically $ writeTVar itrWroteContinue True - awaitSomethingToWrite ctx +writeContinueIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeContinueIfNeeded ctx@(Context {..}) itr@(Interaction {..}) + = do isNeeded ← atomically $ readTMVar itrSendContinue + when isNeeded + $ do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = (∅) + } + cont' ← completeUnconditionalHeaders cConfig cont + hPutBuilder cHandle $ A.toBuilder $ printResponse cont' + hFlush cHandle + writeHeader ctx itr -writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeHeader ctx@(Context {..}) (Interaction {..}) - = do res ← atomically - $ do writeTVar itrWroteHeader True - readTVar itrResponse +writeHeader ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeHeader ctx@(Context {..}) itr@(Interaction {..}) + = do res ← atomically $ + do state ← readTVar itrState + if state ≥ SendingBody then + readTVar itrResponse + else + retry -- Too early to write header fields. hPutBuilder cHandle $ A.toBuilder $ printResponse res hFlush cHandle - awaitSomethingToWrite ctx + writeBodyIfNeeded ctx itr -writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeBodyChunk ctx@(Context {..}) (Interaction {..}) +writeBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeBodyIfNeeded ctx itr@(Interaction {..}) = join $ atomically $ do willDiscardBody ← readTVar itrWillDiscardBody if willDiscardBody then - do _ ← tryTakeTMVar itrBodyToSend - return $ awaitSomethingToWrite ctx + return $ discardBody ctx itr else 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 + if willChunkBody then + return $ writeChunkedBody ctx itr + else + return $ writeNonChunkedBody ctx itr -finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -finishBodyChunk (Context {..}) (Interaction {..}) +discardBody ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +discardBody ctx itr@(Interaction {..}) = join $ atomically $ - do willDiscardBody ← readTVar itrWillDiscardBody - willChunkBody ← readTVar itrWillChunkBody - if ((¬) willDiscardBody) ∧ willChunkBody then - return $ - do hPutBuilder cHandle BB.chunkedTransferTerminator - hFlush cHandle - else - return $ return () + do chunk ← tryTakeTMVar itrBodyToSend + case chunk of + Just _ → return $ discardBody ctx itr + Nothing → do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry + +writeChunkedBody ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeChunkedBody ctx@(Context {..}) itr@(Interaction {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar itrBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle $ BB.chunkedTransferEncoding b + hFlush cHandle + writeChunkedBody ctx itr + Nothing → do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry + +writeNonChunkedBody ∷ HandleLike h + ⇒ Context h + → Interaction + → IO () +writeNonChunkedBody ctx@(Context {..}) itr@(Interaction {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar itrBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle b + hFlush cHandle + writeNonChunkedBody ctx itr + Nothing → do state ← readTVar itrState + if state ≡ Done then + return $ finalize ctx itr + else + retry finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -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 - readTVar itrWillClose - if willClose then - -- reader は恐らく hWaitForInput してゐる最中なので、スレッ - -- ドを豫め殺して置かないとをかしくなる。 - do killThread cReader - hClose cHandle - else - awaitSomethingToWrite ctx +finalize ctx@(Context {..}) (Interaction {..}) + = join $ + atomically $ + do sentContinue ← takeTMVar itrSendContinue + willDiscardBody ← readTVar itrWillDiscardBody + willChunkBody ← readTVar itrWillChunkBody + willClose ← readTVar itrWillClose + queue ← readTVar cQueue + case S.viewr queue of + queue' :> _ + → writeTVar cQueue queue' + EmptyR + → fail "finalize: cQueue is empty, which should never happen." + return $ + do when (((¬) willDiscardBody) ∧ willChunkBody) + $ do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + if willClose ∨ needToClose sentContinue then + -- The RequestReader is probably blocking on + -- hWaitForInput so we have to kill it before + -- closing the socket. + -- THINKME: Couldn't that somehow be avoided? + do killThread cReader + hClose cHandle + else + awaitSomethingToWrite ctx + where + needToClose ∷ Bool → Bool + needToClose sentContinue + -- We've sent both "HTTP/1.1 100 Continue" and a final + -- response, so nothing prevents our connection from keeping + -- alive. + | sentContinue = False + -- We've got "Expect: 100-continue" but have sent a final + -- response without sending "HTTP/1.1 100 + -- Continue". According to the RFC 2616 (HTTP/1.1), it is + -- undecidable whether the client will send us its + -- (rejected) request body OR start a completely new request + -- in this situation. So the only possible thing to do is to + -- brutally shutdown the connection. + | itrExpectedContinue ≡ Just True = True + -- The client didn't expect 100-continue so we haven't sent + -- one. No need to do anything special. + | otherwise = False