X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=6ccc2864c8e984c06f266326d212b3ee340a40a6;hb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;hp=266f825c4d8a0ce8e4d9190703d90dc050cc6a21;hpb=f812da5cfe314ab2a29f5e68aac1a7a7b39240d6;p=Lucu.git

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 266f825..6ccc286 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,5 +1,6 @@
+-- #hide
 module Network.HTTP.Lucu.ResponseWriter
-    ( responseWriter -- Handle -> InteractionQueue -> IO ()
+    ( responseWriter
     )
     where
 
@@ -11,21 +12,28 @@ import           Control.Monad
 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
+responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
+responseWriter cnf h tQueue readerTID
     = catch awaitSomethingToWrite $ \ exc ->
       case exc of
-        IOException _ -> return ()
-        _             -> print exc
+        IOException _               -> return ()
+        AsyncException ThreadKilled -> return ()
+        BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
+        _                           -> print exc
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
@@ -55,13 +63,16 @@ responseWriter h tQueue
       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
 
@@ -89,13 +100,23 @@ responseWriter h tQueue
                           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
           = do res <- atomically $ do writeItr itr itrWroteHeader True
                                       readItr itr itrResponse id
-               hPutResponse h (fromJust res)
+               hPutResponse h res
                hFlush h
                awaitSomethingToWrite
       
@@ -121,7 +142,7 @@ responseWriter h tQueue
           = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
                willChunkBody   <- atomically $ readItr itr itrWillChunkBody   id
                when (not willDiscardBody && willChunkBody)
-                        $ hPutStr h "0\r\n" >> hFlush h
+                        $ hPutStr h "0\r\n\r\n" >> hFlush h
 
       finalize :: Interaction -> IO ()
       finalize itr
@@ -133,6 +154,9 @@ responseWriter h tQueue
 
                                             readItr itr itrWillClose id
                if willClose then
-                   hClose h
+                   -- reader は恐らく hWaitForInput してゐる最中なので、
+                   -- スレッドを豫め殺して置かないとをかしくなる。
+                   do killThread readerTID
+                      hClose h
                  else
                    awaitSomethingToWrite