import Network.HTTP.Lucu.Response
import Prelude hiding (catch)
import System.IO
+import Text.Printf
+import Control.Concurrent
import Debug.Trace
-responseWriter :: Handle -> InteractionQueue -> IO ()
-responseWriter h tQueue
- = catch awaitSomethingToWrite $ \ exc
- -> case exc of
- IOException _ -> return ()
- _ -> print exc
+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
-- GettingBody 状態にあり、Continue が期待され
-- てゐて、それがまだ送信前なのであれば、
-- Continue を送信する。
- state <- readTVar (itrState itr)
+ state <- readItr itr itrState id
if state == GettingBody then
writeContinueIfNecessary itr
writeContinueIfNecessary :: Interaction -> STM (IO ())
writeContinueIfNecessary itr
- = do expectedContinue <- readTVar (itrExpectedContinue itr)
+ = do expectedContinue <- readItr itr itrExpectedContinue id
if expectedContinue then
- do wroteContinue <- readTVar $ itrWroteContinue itr
+ do wroteContinue <- readItr itr itrWroteContinue id
if wroteContinue then
-- 既に Continue を書込み濟
retry
-- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
-- 空でなければ、それを出力する。空である時は、もし状態が
-- Done であれば後処理をする。
- = do wroteHeader <- readTVar (itrWroteHeader itr)
+ = do wroteHeader <- readItr itr itrWroteHeader id
if not wroteHeader then
return $ writeHeader itr
else
- do bodyToSend <- readTVar (itrBodyToSend itr)
+ do bodyToSend <- readItr itr itrBodyToSend id
if B.null bodyToSend then
- do state <- readTVar (itrState itr)
+ do state <- readItr itr itrState id
if state == Done then
return $ finalize itr
writeHeader :: Interaction -> IO ()
writeHeader itr
- = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
- readTVar (itrResponse 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 = fail "FIXME: not implemented"
+ 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 = return () -- FIXME: not implemented
+ finishBodyChunk itr
+ = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
+ willChunkBody <- atomically $ readItr itr itrWillChunkBody id
+ when (not willDiscardBody && willChunkBody)
+ $ hPutStr h "0\r\n\r\n" >> hFlush h
finalize :: Interaction -> IO ()
finalize itr
let (remaining :> _) = S.viewr queue
writeTVar tQueue remaining
- readTVar $ itrWillClose itr
+ readItr itr itrWillClose id
if willClose then
- hClose h
+ -- reader は恐らく hWaitForInput してゐる最中なので、
+ -- スレッドを豫め殺して置かないとをかしくなる。
+ do killThread readerTID
+ hClose h
else
awaitSomethingToWrite