-import Debug.Trace
-
-
-responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO ()
-responseWriter h tQueue readerTID
- = catch awaitSomethingToWrite $ \ exc ->
- case exc of
- IOException _ -> return ()
- AsyncException ThreadKilled -> return ()
- BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
- _ -> print exc
- where
- awaitSomethingToWrite :: IO ()
- awaitSomethingToWrite
- = do action
- <- atomically $
- do -- キューが空でなくなるまで待つ
- queue <- readTVar tQueue
- when (S.null queue)
- retry
- let _ :> itr = S.viewr queue
-
- -- GettingBody 状態にあり、Continue が期待され
- -- てゐて、それがまだ送信前なのであれば、
- -- Continue を送信する。
- 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
- = do expectedContinue <- readItr itr itrExpectedContinue id
- if expectedContinue then
-
- do wroteContinue <- readItr itr itrWroteContinue id
- if wroteContinue then
- -- 既に Continue を書込み濟
- retry
- else
- return $ writeContinue itr
- else
- retry
-
- writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
- writeHeaderOrBodyIfNecessary itr
- -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
- -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
- -- 空でなければ、それを出力する。空である時は、もし状態が
- -- Done であれば後処理をする。
- = do wroteHeader <- readItr itr itrWroteHeader id
-
- if not wroteHeader then
- return $ writeHeader itr
- else
- do bodyToSend <- readItr itr itrBodyToSend id
-
- if B.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 = fail "FIXME: not implemented"
-
- writeHeader :: Interaction -> IO ()
- writeHeader itr
- = do res <- atomically $ do writeItr itr itrWroteHeader True
- readItr itr itrResponse id
- hPutResponse h (fromJust res)
- hFlush h
- awaitSomethingToWrite
-
- writeBodyChunk :: Interaction -> IO ()
- writeBodyChunk itr
- = 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
- return chunk
- unless willDiscardBody
- $ do if willChunkBody then
- do hPrintf h "%x\r\n" (toInteger $ B.length chunk)
- B.hPut h chunk
- hPutStr h "\r\n"
- else
- B.hPut h chunk
- hFlush h
- awaitSomethingToWrite
-
- finishBodyChunk :: Interaction -> IO ()
- finishBodyChunk itr
- = 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
-
- finalize :: Interaction -> IO ()
- finalize itr
- = do finishBodyChunk itr
- willClose <- atomically $ do queue <- readTVar tQueue
-
- let (remaining :> _) = S.viewr queue
- writeTVar tQueue remaining
-
- readItr itr itrWillClose id
- if willClose then
- -- reader は恐らく hWaitForInput してゐる最中なので、
- -- スレッドを豫め殺して置かないとをかしくなる。
- do killThread readerTID
- hClose h
- else
- awaitSomethingToWrite
+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.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)
+
+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 $ \ (_ ∷ IOException) → return ()
+ , Handler $ \ e → case e of
+ ThreadKilled → return ()
+ _ → hPutStrLn stderr (show e)
+ , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
+ , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
+ ]
+
+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 ≡ GettingBody then
+ writeContinueIfNeeded ctx itr phase
+ else
+ 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
+ → 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