X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResponseWriter.hs;h=3ab4bda714fc37295a3f2992e854e4179518e722;hb=1196f43ecedbb123515065f0440844864af906fb;hp=52f6cf3476e1613c3e99c07805b1b467d33ccf85;hpb=50e8fe7af585a8d33d93b3721be8f8f01905b891;p=Lucu.git

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 52f6cf3..3ab4bda 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -22,29 +22,27 @@ import           System.IO
 
 
 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter cnf h tQueue readerTID
-    = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
-      catch awaitSomethingToWrite $ \ exc ->
-      case exc of
-        IOException _               -> return ()
-        AsyncException ThreadKilled -> return ()
-        BlockedIndefinitely         -> putStrLn "requestWriter: blocked indefinitely"
-        _                           -> print exc
+responseWriter !cnf !h !tQueue !readerTID
+    = awaitSomethingToWrite
+      `catches`
+      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
+      , Handler  ( \ ThreadKilled        -> return () )
+      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
+      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+      ]
     where
       awaitSomethingToWrite :: IO ()
       awaitSomethingToWrite 
           = {-# SCC "awaitSomethingToWrite" #-}
             do action
                    <- atomically $!
-                      do -- キューが空でなくなるまで待つ
-                         queue <- readTVar tQueue
-                         when (S.null queue)
-                              retry
-
+                      -- キューが空でなくなるまで待つ
+                      do queue <- readTVar tQueue
                          -- GettingBody 状態にあり、Continue が期待され
                          -- てゐて、それがまだ送信前なのであれば、
                          -- Continue を送信する。
                          case S.viewr queue of
+                           EmptyR   -> retry
                            _ :> itr -> do state <- readItr itr itrState id
 
                                           if state == GettingBody then
@@ -163,6 +161,7 @@ responseWriter cnf h tQueue readerTID
                             do queue <- readTVar tQueue
 
                                case S.viewr queue of
+                                 EmptyR         -> return () -- this should never happen
                                  remaining :> _ -> writeTVar tQueue remaining
 
                                readItr itr itrWillClose id