The library now compiles, and I'm now working on ImplantFile.hs

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

diff --git a/Network/HTTP/Lucu/ResponseWriter.hs b/Network/HTTP/Lucu/ResponseWriter.hs
index 034bd782aade719fa1a3beac140fdf2780e8d62b..872e07807adc12c77245818e7dff61cbf947ea27 100644 (file)
--- a/Network/HTTP/Lucu/ResponseWriter.hs
+++ b/Network/HTTP/Lucu/ResponseWriter.hs
@@ -9,11 +9,11 @@ module Network.HTTP.Lucu.ResponseWriter
     )
     where
 import qualified Blaze.ByteString.Builder.HTTP as BB
-import qualified Data.Ascii as A
 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(..))
@@ -34,6 +34,11 @@ data Context h
       , 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)
@@ -52,57 +57,69 @@ awaitSomethingToWrite ctx@(Context {..})
       atomically $
       -- キューが空でなくなるまで待つ
       do queue ← readTVar cQueue
-         -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
-         -- だ送信前なのであれば、Continue を送信する。
          case S.viewr queue of
-           EmptyR   → retry
-           _ :> itr → do state ← readTVar $ itrState itr
-                         if state ≡ GettingBody then
-                             writeContinueIfNeeded ctx itr
-                         else
-                             if state ≥ DecidingBody then
-                                 writeHeaderOrBodyIfNeeded ctx itr
-                             else
-                                 retry
+           EmptyR        → retry
+           queue' :> itr → do writeTVar cQueue queue'
+                              return $ awaitSomethingToWriteOn ctx itr Initial
 
-writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeContinueIfNeeded ctx itr@(Interaction {..})
-    = do expectedContinue ← readTVar itrExpectedContinue
-         if expectedContinue then
-             do wroteContinue ← readTVar itrWroteContinue
-                if wroteContinue then
-                    -- 既に Continue を書込み濟
-                    retry
-                else
-                    do reqBodyWanted ← readTVar itrReqBodyWanted
-                       if reqBodyWanted ≢ Nothing then
-                           return $ writeContinue ctx itr
-                       else
-                           retry
+-- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
+-- なのであれば、Continue を送信する。
+awaitSomethingToWriteOn ∷ HandleLike h
+                        ⇒ Context h
+                        → Interaction
+                        → Phase
+                        → IO ()
+awaitSomethingToWriteOn ctx itr phase
+    = join $
+      atomically $
+      do state ← readTVar $ itrState itr
+         if state ≡ GettingBody then
+             writeContinueIfNeeded ctx itr phase
          else
-             retry
+             if state ≥ DecidingBody 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 reqBodyWanted ← readTVar itrReqBodyWanted
+             if reqBodyWanted > 0 then
+                 return $ writeContinue ctx itr
+             else
+                 retry
+    | otherwise
+        = retry
 
 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
-writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
-writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..})
-    = do wroteHeader ← readTVar itrWroteHeader
-         if not wroteHeader then
-             return $ writeHeader ctx itr
-         else
-             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
+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 {..}) (Interaction {..})
+writeContinue ctx@(Context {..}) itr@(Interaction {..})
     = do let cont = Response {
                       resVersion = HttpVersion 1 1
                     , resStatus  = Continue
@@ -111,26 +128,30 @@ writeContinue ctx@(Context {..}) (Interaction {..})
          cont' ← completeUnconditionalHeaders cConfig cont
          hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
          hFlush cHandle
-         atomically $ writeTVar itrWroteContinue True
-         awaitSomethingToWrite ctx
+         awaitSomethingToWriteOn ctx itr WroteContinue
 
-writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) (Interaction {..})
-    = do res ← atomically
-               $ do writeTVar itrWroteHeader True
-                    readTVar itrResponse
+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
-         awaitSomethingToWrite ctx
+         awaitSomethingToWriteOn ctx itr WroteHeader
 
-writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeBodyChunk ctx@(Context {..}) (Interaction {..})
+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 $ awaitSomethingToWrite ctx
+                return $ awaitSomethingToWriteOn ctx itr phase
          else
              do willChunkBody ← readTVar itrWillChunkBody
                 chunk         ← takeTMVar itrBodyToSend
@@ -140,7 +161,7 @@ writeBodyChunk ctx@(Context {..}) (Interaction {..})
                        else
                            hPutBuilder cHandle chunk
                        hFlush cHandle
-                       awaitSomethingToWrite ctx
+                       awaitSomethingToWriteOn ctx itr phase
 
 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
 finishBodyChunk (Context {..}) (Interaction {..})