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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 3ab4bda..d13dd84 100644
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -1,174 +1,219 @@
+{-# LANGUAGE
+    DoAndIfThenElse
+  , RecordWildCards
+  , ScopedTypeVariables
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.ResponseWriter
     ( responseWriter
     )
     where
-
-import qualified Data.ByteString.Lazy.Char8 as C8
-import           Control.Concurrent
-import           Control.Concurrent.STM
-import           Control.Exception
-import           Control.Monad
+import qualified Blaze.ByteString.Builder.HTTP as BB
+import Control.Concurrent
+import Control.Concurrent.STM
+import Control.Exception
+import Control.Monad
+import qualified Data.Ascii as A
+import Data.Monoid.Unicode
 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
-import           Network.HTTP.Lucu.Response
-import           Prelude hiding (catch)
-import           System.IO
-
-
-responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter !cnf !h !tQueue !readerTID
-    = awaitSomethingToWrite
+import Data.Sequence (ViewR(..))
+import Network.HTTP.Lucu.Config
+import Network.HTTP.Lucu.HandleLike
+import Network.HTTP.Lucu.HttpVersion
+import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Postprocess
+import Network.HTTP.Lucu.Response
+import Prelude.Unicode
+import System.IO (hPutStrLn, stderr)
+import System.IO.Error
+
+data Context h
+    = Context {
+        cConfig ∷ !Config
+      , cHandle ∷ !h
+      , cQueue  ∷ !InteractionQueue
+      , cReader ∷ !ThreadId
+      }
+
+data Phase = Initial
+           | WroteContinue
+           | WroteHeader
+             deriving (Eq, Ord, Show)
+
+responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
+responseWriter cnf h tQueue readerTID
+    = awaitSomethingToWrite (Context cnf h tQueue readerTID)
       `catches`
-      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
-      , Handler  ( \ ThreadKilled        -> return () )
-      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
-      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+      [ Handler handleIOE
+      , Handler handleAsyncE
+      , Handler handleBIOS
+      , Handler handleOthers
       ]
     where
-      awaitSomethingToWrite :: IO ()
-      awaitSomethingToWrite 
-          = {-# SCC "awaitSomethingToWrite" #-}
-            do action
-                   <- atomically $!
-                      -- キューが空でなくなるまで待つ
-                      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
-                                              writeContinueIfNecessary itr
-                                            else
-                                              if state >= DecidingBody then
-                                                  writeHeaderOrBodyIfNecessary itr
-                                              else
-                                                  retry
-               action
-
-      writeContinueIfNecessary :: Interaction -> STM (IO ())
-      writeContinueIfNecessary itr
-          = {-# SCC "writeContinueIfNecessary" #-}
-            itr `seq`
-            do expectedContinue <- readItr itr itrExpectedContinue id
-               if expectedContinue then
-                   do wroteContinue <- readItr itr itrWroteContinue id
-                      if wroteContinue then
-                          -- 既に Continue を書込み濟
-                          retry
-                        else
-                          do reqBodyWanted <- readItr itr itrReqBodyWanted id
-                             if reqBodyWanted /= Nothing then
-                                 return $ writeContinue itr
-                               else
-                                 retry
-                 else
-                   retry
-
-      writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
-      writeHeaderOrBodyIfNecessary itr
-          -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
-          -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
-          -- 空でなければ、それを出力する。空である時は、もし状態が
-          -- Done であれば後処理をする。
-          = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
-            itr `seq`
-            do wroteHeader <- readItr itr itrWroteHeader id
-               
-               if not wroteHeader then
-                   return $! writeHeader itr
-                 else
-                   do bodyToSend <- readItr itr itrBodyToSend id
-
-                      if C8.null bodyToSend then
-                          do state <- readItr itr itrState id
-
-                             if state == Done then
-                                 return $! finalize itr
-                               else
-                                 retry
-                        else
-                          return $! writeBodyChunk itr
-
-      writeContinue :: Interaction -> IO ()
-      writeContinue itr
-          = {-# SCC "writeContinue" #-}
-            itr `seq`
-            do let cont = Response {
-                            resVersion = HttpVersion 1 1
-                          , resStatus  = Continue
-                          , resHeaders = emptyHeaders
-                          }
-               cont' <- completeUnconditionalHeaders cnf cont
-               hPutResponse h cont'
-               hFlush h
-               atomically $! writeItr itr itrWroteContinue True
-               awaitSomethingToWrite
-
-      writeHeader :: Interaction -> IO ()
-      writeHeader itr
-          = {-# SCC "writeHeader" #-}
-            itr `seq`
-            do res <- atomically $! do writeItr itr itrWroteHeader True
-                                       readItr itr itrResponse id
-               hPutResponse h res
-               hFlush h
-               awaitSomethingToWrite
-      
-      writeBodyChunk :: Interaction -> IO ()
-      writeBodyChunk itr
-          = {-# 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 C8.empty
-                                                   return chunk
-               unless willDiscardBody
-                          $ do if willChunkBody then
-                                   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
-                                   C8.hPut h chunk
-                               hFlush h
-               awaitSomethingToWrite
-
-      finishBodyChunk :: Interaction -> IO ()
-      finishBodyChunk itr
-          = {-# SCC "finishBodyChunk" #-}
-            itr `seq`
-            do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
-               willChunkBody   <- atomically $! readItr itr itrWillChunkBody   id
-               when (not willDiscardBody && willChunkBody)
-                        $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
-
-      finalize :: Interaction -> IO ()
-      finalize itr
-          = {-# 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
-               if willClose then
-                   -- reader は恐らく hWaitForInput してゐる最中なので、
-                   -- スレッドを豫め殺して置かないとをかしくなる。
-                   do killThread readerTID
-                      hClose h
-                 else
-                   awaitSomethingToWrite
+      handleIOE ∷ IOException → IO ()
+      handleIOE e
+          | isIllegalOperation e
+              = return () -- EPIPE: should be ignored at all.
+          | otherwise
+              = terminate e
+
+      handleAsyncE ∷ AsyncException → IO ()
+      handleAsyncE ThreadKilled = terminate'
+      handleAsyncE e            = terminate e
+
+      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
+      handleBIOS = terminate
+
+      handleOthers ∷ SomeException → IO ()
+      handleOthers = terminate
+
+      terminate ∷ Exception e ⇒ e → IO ()
+      terminate e
+          = do hPutStrLn stderr "requestWriter caught an exception:"
+               hPutStrLn stderr (show $ toException e)
+               terminate'
+
+      terminate' ∷ IO ()
+      terminate' = hClose h
+
+awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
+awaitSomethingToWrite ctx@(Context {..})
+    = join $
+      atomically $
+      -- キューが空でなくなるまで待つ
+      do queue ← readTVar cQueue
+         case S.viewr queue of
+           EmptyR        → retry
+           queue' :> itr → do writeTVar cQueue queue'
+                              return $ awaitSomethingToWriteOn ctx itr Initial
+
+-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
+-- なのであれば、Continue を送信する。
+awaitSomethingToWriteOn ∷ HandleLike h
+                        ⇒ Context h
+                        → Interaction
+                        → Phase
+                        → IO ()
+awaitSomethingToWriteOn ctx itr phase
+    = join $
+      atomically $
+      do state ← readTVar $ itrState itr
+         if state ≡ ReceivingBody then
+             writeContinueIfNeeded ctx itr phase
+         else
+             if state ≥ SendingBody then
+                 writeHeaderOrBodyIfNeeded ctx itr phase
+             else
+                 retry
+
+writeContinueIfNeeded ∷ HandleLike h
+                      ⇒ Context h
+                      → Interaction
+                      → Phase
+                      → STM (IO ())
+writeContinueIfNeeded ctx itr@(Interaction {..}) phase
+    | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
+        = do isRequested ← isEmptyTMVar itrReceiveBodyReq
+             if isRequested then
+                 return $ writeContinue ctx itr
+             else
+                 retry
+    | otherwise
+        = retry
+
+-- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
+-- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
+-- 出力する。空である時は、もし状態がDone であれば後処理をする。
+writeHeaderOrBodyIfNeeded ∷ HandleLike h
+                          ⇒ Context h
+                          → Interaction
+                          → Phase
+                          → STM (IO ())
+writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
+    | phase < WroteHeader
+        = return $ writeHeader ctx itr
+    | otherwise
+        = do noBodyToWrite ← isEmptyTMVar itrBodyToSend
+             if noBodyToWrite then
+                 do state ← readTVar itrState
+                    if state ≡ Done then
+                        return $ finalize ctx itr
+                    else
+                        retry
+             else
+                 return $ writeBodyChunk ctx itr phase
+
+writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+writeContinue ctx@(Context {..}) itr@(Interaction {..})
+    = do let cont = Response {
+                      resVersion = HttpVersion 1 1
+                    , resStatus  = Continue
+                    , resHeaders = (∅)
+                    }
+         cont' ← completeUnconditionalHeaders cConfig cont
+         hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
+         hFlush cHandle
+         awaitSomethingToWriteOn ctx itr WroteContinue
+
+writeHeader ∷ HandleLike h
+            ⇒ Context h
+            → Interaction
+            → IO ()
+writeHeader ctx@(Context {..}) itr@(Interaction {..})
+    = do res ← atomically $ readTVar itrResponse
+         hPutBuilder cHandle $ A.toBuilder $ printResponse res
+         hFlush cHandle
+         awaitSomethingToWriteOn ctx itr WroteHeader
+
+writeBodyChunk ∷ HandleLike h
+               ⇒ Context h
+               → Interaction
+               → Phase
+               → IO ()
+writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
+    = join $
+      atomically $
+      do willDiscardBody ← readTVar itrWillDiscardBody
+         if willDiscardBody then
+             do _ ← tryTakeTMVar itrBodyToSend
+                return $ awaitSomethingToWriteOn ctx itr phase
+         else
+             do willChunkBody ← readTVar itrWillChunkBody
+                chunk         ← takeTMVar itrBodyToSend
+                return $
+                    do if willChunkBody then
+                           hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
+                       else
+                           hPutBuilder cHandle chunk
+                       hFlush cHandle
+                       awaitSomethingToWriteOn ctx itr phase
+
+finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+finishBodyChunk (Context {..}) (Interaction {..})
+    = join $
+      atomically $
+      do willDiscardBody ← readTVar itrWillDiscardBody
+         willChunkBody   ← readTVar itrWillChunkBody
+         if ((¬) willDiscardBody) ∧ willChunkBody then
+             return $
+                 do hPutBuilder cHandle BB.chunkedTransferTerminator
+                    hFlush cHandle
+         else
+             return $ return ()
+
+finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
+finalize ctx@(Context {..}) itr@(Interaction {..})
+    = do finishBodyChunk ctx itr
+         willClose ← atomically $
+                     do queue ← readTVar cQueue
+                        case S.viewr queue of
+                          EmptyR         → return () -- this should never happen
+                          remaining :> _ → writeTVar cQueue remaining
+                        readTVar itrWillClose
+         if willClose then
+             -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
+             -- ドを豫め殺して置かないとをかしくなる。
+             do killThread cReader
+                hClose cHandle
+         else
+             awaitSomethingToWrite ctx