1 module Network.HTTP.Lucu.ResponseWriter
2 ( responseWriter -- Config -> Handle -> InteractionQueue -> IO ()
6 import qualified Data.ByteString.Lazy.Char8 as B
7 import Data.ByteString.Lazy.Char8 (ByteString)
8 import Control.Concurrent.STM
9 import Control.Exception
12 import qualified Data.Sequence as S
13 import Data.Sequence (Seq, ViewR(..))
14 import Network.HTTP.Lucu.Config
15 import Network.HTTP.Lucu.HttpVersion
16 import Network.HTTP.Lucu.Interaction
17 import Network.HTTP.Lucu.Postprocess
18 import Network.HTTP.Lucu.Response
19 import Prelude hiding (catch)
23 import Control.Concurrent
25 import GHC.Conc (unsafeIOToSTM)
28 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
29 responseWriter cnf h tQueue readerTID
30 = catch awaitSomethingToWrite $ \ exc ->
32 IOException _ -> return ()
33 AsyncException ThreadKilled -> return ()
34 BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
37 awaitSomethingToWrite :: IO ()
42 queue <- readTVar tQueue
45 let _ :> itr = S.viewr queue
47 -- GettingBody 状態にあり、Continue が期待され
48 -- てゐて、それがまだ送信前なのであれば、
50 state <- readItr itr itrState id
52 if state == GettingBody then
53 writeContinueIfNecessary itr
55 if state >= DecidingBody then
56 writeHeaderOrBodyIfNecessary itr
61 writeContinueIfNecessary :: Interaction -> STM (IO ())
62 writeContinueIfNecessary itr
63 = do expectedContinue <- readItr itr itrExpectedContinue id
64 if expectedContinue then
65 do wroteContinue <- readItr itr itrWroteContinue id
70 do reqBodyWanted <- readItr itr itrReqBodyWanted id
71 if reqBodyWanted /= Nothing then
72 return $ writeContinue itr
78 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
79 writeHeaderOrBodyIfNecessary itr
80 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
81 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
82 -- 空でなければ、それを出力する。空である時は、もし状態が
84 = do wroteHeader <- readItr itr itrWroteHeader id
86 if not wroteHeader then
87 return $ writeHeader itr
89 do bodyToSend <- readItr itr itrBodyToSend id
91 if B.null bodyToSend then
92 do state <- readItr itr itrState id
99 return $ writeBodyChunk itr
101 writeContinue :: Interaction -> IO ()
103 = do let cont = Response {
104 resVersion = HttpVersion 1 1
105 , resStatus = Continue
108 cont' <- completeUnconditionalHeaders cnf cont
111 atomically $ writeItr itr itrWroteContinue True
112 awaitSomethingToWrite
114 writeHeader :: Interaction -> IO ()
116 = do res <- atomically $ do writeItr itr itrWroteHeader True
117 readItr itr itrResponse id
118 hPutResponse h (fromJust res)
120 awaitSomethingToWrite
122 writeBodyChunk :: Interaction -> IO ()
124 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
125 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
126 chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id
127 writeItr itr itrBodyToSend B.empty
129 unless willDiscardBody
130 $ do if willChunkBody then
131 do hPrintf h "%x\r\n" (toInteger $ B.length chunk)
137 awaitSomethingToWrite
139 finishBodyChunk :: Interaction -> IO ()
141 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
142 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
143 when (not willDiscardBody && willChunkBody)
144 $ hPutStr h "0\r\n\r\n" >> hFlush h
146 finalize :: Interaction -> IO ()
148 = do finishBodyChunk itr
149 willClose <- atomically $ do queue <- readTVar tQueue
151 let (remaining :> _) = S.viewr queue
152 writeTVar tQueue remaining
154 readItr itr itrWillClose id
156 -- reader は恐らく hWaitForInput してゐる最中なので、
157 -- スレッドを豫め殺して置かないとをかしくなる。
158 do killThread readerTID
161 awaitSomethingToWrite