Many improvements

[Lucu.git] / Network / HTTP / Lucu / ResponseWriter.hs

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index f47e1f0fcb744dada3e486bd84c07bf469757880..373930a24c178f5797c4420858e333e1242f45f0 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -15,13 +15,20 @@ import           Network.HTTP.Lucu.Interaction
 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
-    = awaitSomethingToWrite
+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 
@@ -104,14 +111,20 @@ responseWriter h tQueue
                                                   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
@@ -123,6 +136,9 @@ responseWriter h tQueue
 
                                             readItr itr itrWillClose id
                if willClose then
-                   hClose h
+                   -- reader は恐らく hWaitForInput してゐる最中なので、
+                   -- スレッドを豫め殺して置かないとをかしくなる。
+                   do killThread readerTID
+                      hClose h
                  else
                    awaitSomethingToWrite