X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=872e07807adc12c77245818e7dff61cbf947ea27;hb=ea2b7838f1b3d9d4923a220a601be2e04cc559d7;hp=ebd97e79d4d6c16584f354d50588abdbd8859e04;hpb=1e48e402adec79653203dc19a1800efa7b1c467b;p=Lucu.git diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs index ebd97e7..872e078 100644 --- a/Network/HTTP/Lucu/ResponseWriter.hs +++ b/Network/HTTP/Lucu/ResponseWriter.hs @@ -1,142 +1,194 @@ +{-# LANGUAGE + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables + , UnicodeSyntax + #-} module Network.HTTP.Lucu.ResponseWriter - ( responseWriter -- Handle -> InteractionQueue -> IO () + ( responseWriter ) where - -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) -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 Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Response -import Prelude hiding (catch) -import System.IO -import Text.Printf - +import qualified Blaze.ByteString.Builder.HTTP as BB import Control.Concurrent -import Debug.Trace - - -responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO () -responseWriter h tQueue readerTID - = catch awaitSomethingToWrite $ \ exc -> - case exc of - IOException _ -> return () - AsyncException ThreadKilled -> return () - BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely" - _ -> print exc - where - awaitSomethingToWrite :: IO () - awaitSomethingToWrite - = do action - <- atomically $ - do -- キューが空でなくなるまで待つ - queue <- readTVar tQueue - when (S.null queue) - retry - let _ :> itr = S.viewr queue - - -- GettingBody 状態にあり、Continue が期待され - -- てゐて、それがまだ送信前なのであれば、 - -- Continue を送信する。 - state <- readItr itr itrState id - - if state == GettingBody then - writeContinueIfNecessary itr - else - if state >= DecidingBody then - writeHeaderOrBodyIfNecessary itr - else - retry - action - - writeContinueIfNecessary :: Interaction -> STM (IO ()) - writeContinueIfNecessary itr - = do expectedContinue <- readItr itr itrExpectedContinue id - if expectedContinue then - - do wroteContinue <- readItr itr itrWroteContinue id - if wroteContinue then - -- 既に Continue を書込み濟 - retry - else - return $ writeContinue itr - else - retry - - writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ()) - writeHeaderOrBodyIfNecessary itr - -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ - -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が - -- 空でなければ、それを出力する。空である時は、もし状態が - -- Done であれば後処理をする。 - = do wroteHeader <- readItr itr itrWroteHeader id - - if not wroteHeader then - return $ writeHeader itr - else - do bodyToSend <- readItr itr itrBodyToSend id - - if B.null bodyToSend then - do state <- readItr itr itrState id - - if state == Done then - return $ finalize itr - else - retry - else - return $ writeBodyChunk itr - - writeContinue :: Interaction -> IO () - writeContinue itr = fail "FIXME: not implemented" - - writeHeader :: Interaction -> IO () - writeHeader itr - = do res <- atomically $ do writeItr itr itrWroteHeader True - readItr itr itrResponse id - hPutResponse h (fromJust res) - hFlush h - awaitSomethingToWrite - - writeBodyChunk :: Interaction -> IO () - writeBodyChunk itr - = 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 - return chunk - unless willDiscardBody - $ do if willChunkBody then - do hPrintf h "%x\r\n" (toInteger $ B.length chunk) - B.hPut h chunk - hPutStr h "\r\n" - else - B.hPut h chunk - hFlush h - awaitSomethingToWrite - - finishBodyChunk :: Interaction -> IO () - finishBodyChunk itr - = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id - willChunkBody <- atomically $ readItr itr itrWillChunkBody id - when (not willDiscardBody && willChunkBody) - $ hPutStr h "0\r\n" >> hFlush h - - finalize :: Interaction -> IO () - finalize itr - = do finishBodyChunk itr - willClose <- atomically $ do queue <- readTVar tQueue - - let (remaining :> _) = S.viewr queue - writeTVar tQueue remaining - - readItr itr itrWillClose id - if willClose then - do killThread readerTID - hClose h - else - awaitSomethingToWrite +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(..)) +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) + +data Context h + = Context { + cConfig ∷ !Config + , cHandle ∷ !h + , cQueue ∷ !InteractionQueue + , 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) + ] + +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 $ 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 + 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 reqBodyWanted ← readTVar itrReqBodyWanted + if reqBodyWanted > 0 then + return $ writeContinue ctx itr + else + retry + | otherwise + = retry + +-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ +-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを +-- 出力する。空である時は、もし状態がDone であれば後処理をする。 +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@(Interaction {..}) + = do let cont = Response { + resVersion = HttpVersion 1 1 + , resStatus = Continue + , resHeaders = (∅) + } + cont' ← completeUnconditionalHeaders cConfig cont + hPutBuilder cHandle $ A.toBuilder $ printResponse cont' + hFlush cHandle + 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 + awaitSomethingToWriteOn ctx itr WroteHeader + +writeBodyChunk ∷ HandleLike h + ⇒ Context h + → Interaction + → Phase + → IO () +writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase + = join $ + atomically $ + do willDiscardBody ← readTVar itrWillDiscardBody + if willDiscardBody then + do _ ← tryTakeTMVar itrBodyToSend + return $ awaitSomethingToWriteOn ctx itr phase + else + do willChunkBody ← readTVar itrWillChunkBody + chunk ← takeTMVar itrBodyToSend + return $ + do if willChunkBody then + hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk + else + hPutBuilder cHandle chunk + hFlush cHandle + awaitSomethingToWriteOn ctx itr phase + +finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO () +finishBodyChunk (Context {..}) (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 () + +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