)
where
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 Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception
-import Control.Monad
import Data.Monoid.Unicode
import qualified Data.Sequence as S
-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 hiding (catch)
+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)
, 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)
atomically $
-- キューが空でなくなるまで待つ
do queue ← readTVar cQueue
- -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
- -- だ送信前なのであれば、Continue を送信する。
case S.viewr queue of
- EmptyR → retry
- _ :> itr → do state ← readItr 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
- = do expectedContinue ← readItr itrExpectedContinue itr
- if expectedContinue then
- do wroteContinue ← readItr itrWroteContinue itr
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
- else
- do reqBodyWanted ← readItr itrReqBodyWanted itr
- 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
- = do wroteHeader ← readItr itrWroteHeader itr
- if not wroteHeader then
- return $ writeHeader ctx itr
- else
- do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr)
- if noBodyToWrite then
- do state ← readItr itrState itr
- 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 {..}) itr
+writeContinue ctx@(Context {..}) itr@(Interaction {..})
= do let cont = Response {
resVersion = HttpVersion 1 1
, resStatus = Continue
cont' ← completeUnconditionalHeaders cConfig cont
hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
hFlush cHandle
- atomically $ writeItr itrWroteContinue True itr
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr WroteContinue
-writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-writeHeader ctx@(Context {..}) itr
- = do res ← atomically
- $ do writeItr itrWroteHeader True itr
- readItr itrResponse itr
+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 {..}) itr
+writeBodyChunk ∷ HandleLike h
+ ⇒ Context h
+ → Interaction
+ → Phase
+ → IO ()
+writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
= join $
atomically $
- do willDiscardBody ← readItr itrWillDiscardBody itr
+ do willDiscardBody ← readTVar itrWillDiscardBody
if willDiscardBody then
- do _ ← tryTakeTMVar (itrBodyToSend itr)
- return $ awaitSomethingToWrite ctx
+ do _ ← tryTakeTMVar itrBodyToSend
+ return $ awaitSomethingToWriteOn ctx itr phase
else
- do willChunkBody ← readItr itrWillChunkBody itr
- chunk ← takeTMVar (itrBodyToSend itr)
+ do willChunkBody ← readTVar itrWillChunkBody
+ chunk ← takeTMVar itrBodyToSend
return $
do if willChunkBody then
hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
else
hPutBuilder cHandle chunk
hFlush cHandle
- awaitSomethingToWrite ctx
+ awaitSomethingToWriteOn ctx itr phase
finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finishBodyChunk (Context {..}) itr
+finishBodyChunk (Context {..}) (Interaction {..})
= join $
atomically $
- do willDiscardBody ← readItr itrWillDiscardBody itr
- willChunkBody ← readItr itrWillChunkBody itr
+ do willDiscardBody ← readTVar itrWillDiscardBody
+ willChunkBody ← readTVar itrWillChunkBody
if ((¬) willDiscardBody) ∧ willChunkBody then
return $
do hPutBuilder cHandle BB.chunkedTransferTerminator
return $ return ()
finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
-finalize ctx@(Context {..}) itr
+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
- readItr itrWillClose itr
+ readTVar itrWillClose
if willClose then
-- reader は恐らく hWaitForInput してゐる最中なので、スレッ
-- ドを豫め殺して置かないとをかしくなる。