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
27 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
28 responseWriter cnf h tQueue readerTID
29 = catch awaitSomethingToWrite $ \ exc ->
31 IOException _ -> return ()
32 AsyncException ThreadKilled -> return ()
33 BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
36 awaitSomethingToWrite :: IO ()
41 queue <- readTVar tQueue
44 let _ :> itr = S.viewr queue
46 -- GettingBody 状態にあり、Continue が期待され
47 -- てゐて、それがまだ送信前なのであれば、
49 state <- readItr itr itrState id
51 if state == GettingBody then
52 writeContinueIfNecessary itr
54 if state >= DecidingBody then
55 writeHeaderOrBodyIfNecessary itr
60 writeContinueIfNecessary :: Interaction -> STM (IO ())
61 writeContinueIfNecessary itr
62 = do expectedContinue <- readItr itr itrExpectedContinue id
63 if expectedContinue then
64 do wroteContinue <- readItr itr itrWroteContinue id
69 do reqBodyWanted <- readItr itr itrReqBodyWanted id
70 if reqBodyWanted /= Nothing then
71 return $ writeContinue itr
77 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
78 writeHeaderOrBodyIfNecessary itr
79 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
80 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
81 -- 空でなければ、それを出力する。空である時は、もし状態が
83 = do wroteHeader <- readItr itr itrWroteHeader id
85 if not wroteHeader then
86 return $ writeHeader itr
88 do bodyToSend <- readItr itr itrBodyToSend id
90 if B.null bodyToSend then
91 do state <- readItr itr itrState id
98 return $ writeBodyChunk itr
100 writeContinue :: Interaction -> IO ()
102 = do let cont = Response {
103 resVersion = HttpVersion 1 1
104 , resStatus = Continue
107 cont' <- completeUnconditionalHeaders cnf cont
110 atomically $ writeItr itr itrWroteContinue True
111 awaitSomethingToWrite
113 writeHeader :: Interaction -> IO ()
115 = do res <- atomically $ do writeItr itr itrWroteHeader True
116 readItr itr itrResponse id
117 hPutResponse h (fromJust res)
119 awaitSomethingToWrite
121 writeBodyChunk :: Interaction -> IO ()
123 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
124 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
125 chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id
126 writeItr itr itrBodyToSend B.empty
128 unless willDiscardBody
129 $ do if willChunkBody then
130 do hPrintf h "%x\r\n" (toInteger $ B.length chunk)
136 awaitSomethingToWrite
138 finishBodyChunk :: Interaction -> IO ()
140 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
141 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
142 when (not willDiscardBody && willChunkBody)
143 $ hPutStr h "0\r\n\r\n" >> hFlush h
145 finalize :: Interaction -> IO ()
147 = do finishBodyChunk itr
148 willClose <- atomically $ do queue <- readTVar tQueue
150 let (remaining :> _) = S.viewr queue
151 writeTVar tQueue remaining
153 readItr itr itrWillClose id
155 -- reader は恐らく hWaitForInput してゐる最中なので、
156 -- スレッドを豫め殺して置かないとをかしくなる。
157 do killThread readerTID
160 awaitSomethingToWrite