module Network.HTTP.Lucu.ResponseWriter
- ( responseWriter -- Handle -> InteractionQueue -> IO ()
+ ( responseWriter -- Config -> Handle -> InteractionQueue -> IO ()
)
where
import Data.Maybe
import qualified Data.Sequence as S
import Data.Sequence (Seq, ViewR(..))
+import Network.HTTP.Lucu.Config
+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
+import Text.Printf
+import Control.Concurrent
import Debug.Trace
+import GHC.Conc (unsafeIOToSTM)
-responseWriter :: Handle -> InteractionQueue -> IO ()
-responseWriter h tQueue
- = awaitSomethingToWrite
+responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
+responseWriter cnf 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
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
+ do reqBodyWanted <- readItr itr itrReqBodyWanted id
+ if reqBodyWanted /= Nothing then
+ return $ writeContinue itr
+ else
+ retry
else
retry
return $ writeBodyChunk itr
writeContinue :: Interaction -> IO ()
- writeContinue itr = fail "FIXME: not implemented"
+ writeContinue itr
+ = do let cont = Response {
+ resVersion = HttpVersion 1 1
+ , resStatus = Continue
+ , resHeaders = []
+ }
+ cont' <- completeUnconditionalHeaders cnf cont
+ hPutResponse h cont'
+ hFlush h
+ atomically $ writeItr itr itrWroteContinue True
+ awaitSomethingToWrite
writeHeader :: Interaction -> IO ()
writeHeader itr
return chunk
unless willDiscardBody
$ do if willChunkBody then
- fail "FIXME: not implemented"
+ 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
readItr itr itrWillClose id
if willClose then
- hClose h
+ -- reader は恐らく hWaitForInput してゐる最中なので、
+ -- スレッドを豫め殺して置かないとをかしくなる。
+ do killThread readerTID
+ hClose h
else
awaitSomethingToWrite