ETag and Last Modified

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 373930a24c178f5797c4420858e333e1242f45f0..7dca25bb0e33f9ac46e0de7745ec792cf413abf9 100644 (file)
--- 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,7 +11,10 @@ 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
@@ -21,8 +24,8 @@ import Control.Concurrent
 import Debug.Trace
 
 
-responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter h tQueue readerTID
+responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
+responseWriter cnf h tQueue readerTID
     = catch awaitSomethingToWrite $ \ exc ->
       case exc of
         IOException _               -> return ()
@@ -58,13 +61,16 @@ responseWriter h tQueue readerTID
       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
 
@@ -92,7 +98,17 @@ responseWriter h tQueue readerTID
                           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