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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 7891db1..3ab4bda 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,10 +1,9 @@
--- #hide
 module Network.HTTP.Lucu.ResponseWriter
     ( responseWriter
     )
     where
 
-import qualified Data.ByteString.Lazy.Char8 as B
+import qualified Data.ByteString.Lazy.Char8 as C8
 import           Control.Concurrent
 import           Control.Concurrent.STM
 import           Control.Exception
@@ -13,6 +12,7 @@ import qualified Data.Sequence as S
 import           Data.Sequence (ViewR(..))
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Format
+import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Postprocess
@@ -22,28 +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 
-          = do action
+          = {-# 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
@@ -57,7 +56,8 @@ responseWriter cnf h tQueue readerTID
 
       writeContinueIfNecessary :: Interaction -> STM (IO ())
       writeContinueIfNecessary itr
-          = itr `seq`
+          = {-# SCC "writeContinueIfNecessary" #-}
+            itr `seq`
             do expectedContinue <- readItr itr itrExpectedContinue id
                if expectedContinue then
                    do wroteContinue <- readItr itr itrWroteContinue id
@@ -79,15 +79,16 @@ responseWriter cnf h tQueue readerTID
           -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
           -- 空でなければ、それを出力する。空である時は、もし状態が
           -- Done であれば後処理をする。
-          = itr `seq`
+          = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
+            itr `seq`
             do wroteHeader <- readItr itr itrWroteHeader id
                
                if not wroteHeader then
-                   return $ writeHeader itr
+                   return $! writeHeader itr
                  else
                    do bodyToSend <- readItr itr itrBodyToSend id
 
-                      if B.null bodyToSend then
+                      if C8.null bodyToSend then
                           do state <- readItr itr itrState id
 
                              if state == Done then
@@ -99,11 +100,12 @@ responseWriter cnf h tQueue readerTID
 
       writeContinue :: Interaction -> IO ()
       writeContinue itr
-          = itr `seq`
+          = {-# SCC "writeContinue" #-}
+            itr `seq`
             do let cont = Response {
                             resVersion = HttpVersion 1 1
                           , resStatus  = Continue
-                          , resHeaders = []
+                          , resHeaders = emptyHeaders
                           }
                cont' <- completeUnconditionalHeaders cnf cont
                hPutResponse h cont'
@@ -113,7 +115,8 @@ responseWriter cnf h tQueue readerTID
 
       writeHeader :: Interaction -> IO ()
       writeHeader itr
-          = itr `seq`
+          = {-# SCC "writeHeader" #-}
+            itr `seq`
             do res <- atomically $! do writeItr itr itrWroteHeader True
                                        readItr itr itrResponse id
                hPutResponse h res
@@ -122,39 +125,43 @@ responseWriter cnf h tQueue readerTID
       
       writeBodyChunk :: Interaction -> IO ()
       writeBodyChunk itr
-          = itr `seq`
+          = {-# SCC "writeBodyChunk" #-}
+            itr `seq`
             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
+                                                   writeItr itr itrBodyToSend C8.empty
                                                    return chunk
                unless willDiscardBody
                           $ do if willChunkBody then
-                                   do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
-                                      hPutStr h "\r\n"
-                                      B.hPut  h chunk
-                                      hPutStr h "\r\n"
+                                   do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
+                                      C8.hPut h (C8.pack "\r\n")
+                                      C8.hPut h chunk
+                                      C8.hPut h (C8.pack "\r\n")
                                  else
-                                   B.hPut h chunk
+                                   C8.hPut h chunk
                                hFlush h
                awaitSomethingToWrite
 
       finishBodyChunk :: Interaction -> IO ()
       finishBodyChunk itr
-          = itr `seq`
+          = {-# SCC "finishBodyChunk" #-}
+            itr `seq`
             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
+                        $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
 
       finalize :: Interaction -> IO ()
       finalize itr
-          = itr `seq`
+          = {-# SCC "finalize" #-}
+            itr `seq`
             do finishBodyChunk itr
                willClose <- atomically $!
                             do queue <- readTVar tQueue
 
                                case S.viewr queue of
+                                 EmptyR         -> return () -- this should never happen
                                  remaining :> _ -> writeTVar tQueue remaining
 
                                readItr itr itrWillClose id