X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=1e2eacb2df7f462b99316c2c5e3a11608f3c3b1c;hb=a44a96d95b5fcbaf24a21c0336046ce0c3bab614;hp=f87447891e5f086c9885548d71675b9c34f8dace;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index f874478..1e2eacb 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,5 +1,5 @@
 module Network.HTTP.Lucu.ResponseWriter
-    ( responseWriter -- Handle -> InteractionQueue -> IO ()
+    ( responseWriter -- Config -> Handle -> InteractionQueue -> IO ()
     )
     where
 
@@ -11,20 +11,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
-    = catch awaitSomethingToWrite $ \ exc
-    -> case exc of
-         IOException _ -> return ()
-         _             -> print exc
+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 
@@ -39,7 +47,7 @@ responseWriter h tQueue
                          -- GettingBody 状態にあり、Continue が期待され
                          -- てゐて、それがまだ送信前なのであれば、
                          -- Continue を送信する。
-                         state <- readTVar (itrState itr)
+                         state <- readItr itr itrState id
 
                          if state == GettingBody then
                              writeContinueIfNecessary itr
@@ -52,15 +60,18 @@ responseWriter h tQueue
 
       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
                         else
-                          return $ writeContinue itr
+                          do reqBodyWanted <- readItr itr itrReqBodyWanted id
+                             if reqBodyWanted /= Nothing then
+                                 return $ writeContinue itr
+                               else
+                                 retry
                  else
                    retry
 
@@ -70,15 +81,15 @@ responseWriter h tQueue
           -- れば、ヘッダを出力する。ヘッダ出力後であり、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
@@ -88,21 +99,49 @@ 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 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
@@ -112,8 +151,11 @@ responseWriter h tQueue
                                             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