X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=0af4a69df02f1a78604b0bc46d3b71077a545768;hp=738207183ef8a04c387859dfdb1d16737b42d384;hb=246d66d6d3130e03834a6c3badc38711a1879aae;hpb=cc55fb9a095c9c583ed6fe2ded3eaf6401fb760f diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 7382071..0af4a69 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -9,21 +9,23 @@ 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 Control.Applicative +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.Ascii (AsciiBuilder) +import Data.Convertible.Utils +import GHC.IO.Exception (IOException(..), IOErrorType(..)) 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.Request +import Network.HTTP.Lucu.Response import Prelude.Unicode import System.IO (hPutStrLn, stderr) @@ -32,143 +34,227 @@ data Context h cConfig ∷ !Config , cHandle ∷ !h , cQueue ∷ !InteractionQueue - , cReader ∷ !ThreadId } responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () responseWriter cnf h tQueue readerTID - = awaitSomethingToWrite (Context cnf h tQueue readerTID) + = awaitSomethingToWrite (Context cnf h tQueue) `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 handleOthers ] + `finally` + do killThread readerTID + hClose h + where + handleIOE ∷ IOException → IO () + handleIOE e@(IOError {..}) + | ioe_type ≡ ResourceVanished = return () + | otherwise = dump e + + handleAsyncE ∷ AsyncException → IO () + handleAsyncE ThreadKilled = return () + handleAsyncE e = dump e + + handleOthers ∷ SomeException → IO () + handleOthers = dump + + dump ∷ Exception e ⇒ e → IO () + dump e + = do hPutStrLn stderr "Lucu: responseWriter caught an exception:" + hPutStrLn stderr $ show e 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 ← 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 - else - 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 - -writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeContinue ctx@(Context {..}) itr - = do let cont = Response { - resVersion = HttpVersion 1 1 - , resStatus = Continue - , resHeaders = (∅) - } - 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 - hPutBuilder cHandle $ A.toBuilder $ printResponse res + EmptyR → retry + queue' :> itr → do writeTVar cQueue queue' + return $ writeSomething ctx itr + +writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO () +writeSomething ctx itr + = let writer = writeResponseForNI ctx <$> fromInteraction itr <|> + writeResponseForSEI ctx <$> fromInteraction itr <|> + writeResponseForSYI ctx <$> fromInteraction itr <|> + endOfResponses <$> fromInteraction itr + in + case writer of + Just f → f + Nothing → fail "Internal error: unknown interaction type" + +writeResponseForNI ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeResponseForNI = writeContinueIfNeeded + +writeContinueIfNeeded ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..}) + = do isNeeded ← atomically $ readTMVar niSendContinue + when isNeeded + $ do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = fromStatusCode Continue + , resHeaders = (∅) + } + hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont + hFlush cHandle + writeHeader ctx ni + +writeHeader ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeHeader ctx@(Context {..}) ni@(NI {..}) + = do res ← atomically $ + do state ← readTVar niState + if state ≥ SendingBody then + readTVar niResponse + else + retry -- Too early to write header fields. + hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res hFlush cHandle - awaitSomethingToWrite ctx + writeBodyIfNeeded ctx ni -writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -writeBodyChunk ctx@(Context {..}) itr +writeBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeBodyIfNeeded ctx ni@(NI {..}) = join $ atomically $ - do willDiscardBody ← readItr itrWillDiscardBody itr - if willDiscardBody then - do _ ← tryTakeTMVar (itrBodyToSend itr) - return $ awaitSomethingToWrite ctx + do canHaveBody ← resCanHaveBody <$> readTVar niResponse + if canHaveBody ∧ reqMethod niRequest ≢ HEAD then + if niWillChunkBody then + return $ writeChunkedBody ctx ni + else + return $ writeNonChunkedBody ctx ni else - do willChunkBody ← readItr itrWillChunkBody itr - chunk ← takeTMVar (itrBodyToSend itr) - return $ - do if willChunkBody then - hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk - else - hPutBuilder cHandle chunk - hFlush cHandle - awaitSomethingToWrite ctx - -finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () -finishBodyChunk (Context {..}) itr + return $ discardBody ctx ni + +discardBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +discardBody ctx ni@(NI {..}) = join $ atomically $ - do willDiscardBody ← readItr itrWillDiscardBody itr - willChunkBody ← readItr itrWillChunkBody itr - if ((¬) willDiscardBody) ∧ willChunkBody then - return $ - do hPutBuilder cHandle BB.chunkedTransferTerminator - hFlush cHandle - else - return $ return () - -finalize ∷ HandleLike h ⇒ Context h → Interaction → IO () -finalize ctx@(Context {..}) itr - = 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 - if willClose then - -- reader は恐らく hWaitForInput してゐる最中なので、スレッ - -- ドを豫め殺して置かないとをかしくなる。 - do killThread cReader - hClose cHandle + do chunk ← tryTakeTMVar niBodyToSend + case chunk of + Just _ → return $ discardBody ctx ni + Nothing → do state ← readTVar niState + if state ≡ Done then + return $ finalize ctx ni + else + retry + +writeChunkedBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeChunkedBody ctx@(Context {..}) ni@(NI {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar niBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle $ BB.chunkedTransferEncoding b + hFlush cHandle + writeChunkedBody ctx ni + Nothing → do state ← readTVar niState + if state ≡ Done then + return $ + do hPutBuilder cHandle BB.chunkedTransferTerminator + hFlush cHandle + finalize ctx ni + else + retry + +writeNonChunkedBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeNonChunkedBody ctx@(Context {..}) ni@(NI {..}) + = join $ + atomically $ + do chunk ← tryTakeTMVar niBodyToSend + case chunk of + Just b → return $ + do hPutBuilder cHandle b + hFlush cHandle + writeNonChunkedBody ctx ni + Nothing → do state ← readTVar niState + if state ≡ Done then + return $ finalize ctx ni + else + retry + +finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO () +finalize ctx@(Context {..}) (NI {..}) + = join $ + atomically $ + do willClose ← readTVar niWillClose + sentContinue ← takeTMVar niSendContinue + return $ + if needToClose willClose sentContinue then + return () + else + awaitSomethingToWrite ctx + where + needToClose ∷ Bool → Bool → Bool + needToClose willClose sentContinue + -- Explicitly instructed to close the connection. + | willClose = True + -- 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. + | niExpectedContinue = True + -- The client didn't expect 100-continue so we haven't sent + -- one. No need to do anything special. + | otherwise = False + +writeResponseForSEI ∷ HandleLike h + ⇒ Context h + → SemanticallyInvalidInteraction + → IO () +writeResponseForSEI ctx@(Context {..}) (SEI {..}) + = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse + when (reqMethod seiRequest ≢ HEAD) $ + if seiWillChunkBody then + do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend + hPutBuilder cHandle BB.chunkedTransferTerminator + else + hPutBuilder cHandle seiBodyToSend + hFlush cHandle + if seiWillClose ∨ seiExpectedContinue then + return () else awaitSomethingToWrite ctx + +writeResponseForSYI ∷ HandleLike h + ⇒ Context h + → SyntacticallyInvalidInteraction + → IO () +writeResponseForSYI (Context {..}) (SYI {..}) + = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse + hPutBuilder cHandle syiBodyToSend + hFlush cHandle + return () + +endOfResponses ∷ EndOfInteraction → IO () +endOfResponses _ = return ()