X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Lucu.git;a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=0af4a69df02f1a78604b0bc46d3b71077a545768;hp=9751a7699c7b175ba062ae750d4c5f710fffeac0;hb=246d66d6d3130e03834a6c3badc38711a1879aae;hpb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index 9751a76..0af4a69 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,171 +1,260 @@ {-# LANGUAGE - BangPatterns + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.ResponseWriter ( responseWriter ) where - -import qualified Data.ByteString.Lazy.Char8 as C8 -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad +import qualified Blaze.ByteString.Builder.HTTP as BB +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.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 (stderr) - - -responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO () -responseWriter !cnf !h !tQueue !readerTID - = awaitSomethingToWrite +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) + +data Context h + = Context { + cConfig ∷ !Config + , cHandle ∷ !h + , cQueue ∷ !InteractionQueue + } + +responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO () +responseWriter cnf h tQueue readerTID + = awaitSomethingToWrite (Context cnf h tQueue) `catches` - [ Handler (( \ _ -> return () ) :: IOException -> IO ()) - , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" ) - , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + [ Handler handleIOE + , Handler handleAsyncE + , Handler handleOthers ] + `finally` + do killThread readerTID + hClose h where - awaitSomethingToWrite :: IO () - awaitSomethingToWrite - = {-# 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 - = {-# SCC "writeContinueIfNecessary" #-} - do expectedContinue <- readItr itr itrExpectedContinue id - if expectedContinue then - do wroteContinue <- readItr itr itrWroteContinue id - if wroteContinue then - -- 既に Continue を書込み濟 - retry + 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 + case S.viewr queue of + 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 + writeBodyIfNeeded ctx ni + +writeBodyIfNeeded ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +writeBodyIfNeeded ctx ni@(NI {..}) + = join $ + atomically $ + do canHaveBody ← resCanHaveBody <$> readTVar niResponse + if canHaveBody ∧ reqMethod niRequest ≢ HEAD then + if niWillChunkBody then + return $ writeChunkedBody ctx ni + else + return $ writeNonChunkedBody ctx ni + else + return $ discardBody ctx ni + +discardBody ∷ HandleLike h + ⇒ Context h + → NormalInteraction + → IO () +discardBody ctx ni@(NI {..}) + = join $ + atomically $ + 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 - do reqBodyWanted <- readItr itr itrReqBodyWanted id - if reqBodyWanted /= Nothing then - return $ writeContinue itr - else - retry - else - retry - - writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) - writeHeaderOrBodyIfNecessary !itr - -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ - -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が - -- 空でなければ、それを出力する。空である時は、もし状態が - -- Done であれば後処理をする。 - = {-# SCC "writeHeaderOrBodyIfNecessary" #-} - do wroteHeader <- readItr itr itrWroteHeader id - - if not wroteHeader then - return $! writeHeader itr - else - do bodyToSend <- readItr itr itrBodyToSend id - - if C8.null bodyToSend then - do state <- readItr itr itrState id - - if state == Done then - return $! finalize itr - else - retry + 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 - return $! writeBodyChunk itr - - writeContinue :: Interaction -> IO () - writeContinue !itr - = {-# SCC "writeContinue" #-} - 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 - = {-# SCC "writeHeader" #-} - do res <- atomically $! do writeItr itr itrWroteHeader True - readItr itr itrResponse id - hPutResponse h res - hFlush h - awaitSomethingToWrite - - writeBodyChunk :: Interaction -> IO () - 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 C8.empty - return chunk - unless willDiscardBody - $ do if willChunkBody then - 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 - hPutLBS h chunk - hFlush h - awaitSomethingToWrite - - finishBodyChunk :: Interaction -> IO () - finishBodyChunk !itr - = {-# SCC "finishBodyChunk" #-} - do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id - willChunkBody <- atomically $! readItr itr itrWillChunkBody id - when (not willDiscardBody && willChunkBody) - $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h - - finalize :: Interaction -> IO () - 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 - if willClose then - -- reader は恐らく hWaitForInput してゐる最中なので、 - -- スレッドを豫め殺して置かないとをかしくなる。 - do killThread readerTID - hClose h - else - awaitSomethingToWrite + 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 ()