1 module Network.HTTP.Lucu.ResponseWriter
6 import qualified Data.ByteString.Lazy.Char8 as B
7 import Control.Concurrent
8 import Control.Concurrent.STM
9 import Control.Exception
11 import qualified Data.Sequence as S
12 import Data.Sequence (ViewR(..))
13 import Network.HTTP.Lucu.Config
14 import Network.HTTP.Lucu.Format
15 import Network.HTTP.Lucu.Headers
16 import Network.HTTP.Lucu.HttpVersion
17 import Network.HTTP.Lucu.Interaction
18 import Network.HTTP.Lucu.Postprocess
19 import Network.HTTP.Lucu.Response
20 import Prelude hiding (catch)
24 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
25 responseWriter cnf h tQueue readerTID
26 = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
27 catch awaitSomethingToWrite $ \ exc ->
29 IOException _ -> return ()
30 AsyncException ThreadKilled -> return ()
31 BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
34 awaitSomethingToWrite :: IO ()
36 = {-# SCC "awaitSomethingToWrite" #-}
40 queue <- readTVar tQueue
44 -- GettingBody 状態にあり、Continue が期待され
45 -- てゐて、それがまだ送信前なのであれば、
48 _ :> itr -> do state <- readItr itr itrState id
50 if state == GettingBody then
51 writeContinueIfNecessary itr
53 if state >= DecidingBody then
54 writeHeaderOrBodyIfNecessary itr
59 writeContinueIfNecessary :: Interaction -> STM (IO ())
60 writeContinueIfNecessary itr
61 = {-# SCC "writeContinueIfNecessary" #-}
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 = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
86 do wroteHeader <- readItr itr itrWroteHeader id
88 if not wroteHeader then
89 return $! writeHeader itr
91 do bodyToSend <- readItr itr itrBodyToSend id
93 if B.null bodyToSend then
94 do state <- readItr itr itrState id
97 return $! finalize itr
101 return $! writeBodyChunk itr
103 writeContinue :: Interaction -> IO ()
105 = {-# SCC "writeContinue" #-}
107 do let cont = Response {
108 resVersion = HttpVersion 1 1
109 , resStatus = Continue
110 , resHeaders = emptyHeaders
112 cont' <- completeUnconditionalHeaders cnf cont
115 atomically $! writeItr itr itrWroteContinue True
116 awaitSomethingToWrite
118 writeHeader :: Interaction -> IO ()
120 = {-# SCC "writeHeader" #-}
122 do res <- atomically $! do writeItr itr itrWroteHeader True
123 readItr itr itrResponse id
126 awaitSomethingToWrite
128 writeBodyChunk :: Interaction -> IO ()
130 = {-# SCC "writeBodyChunk" #-}
132 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
133 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
134 chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
135 writeItr itr itrBodyToSend B.empty
137 unless willDiscardBody
138 $ do if willChunkBody then
139 do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
146 awaitSomethingToWrite
148 finishBodyChunk :: Interaction -> IO ()
150 = {-# SCC "finishBodyChunk" #-}
152 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
153 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
154 when (not willDiscardBody && willChunkBody)
155 $ hPutStr h "0\r\n\r\n" >> hFlush h
157 finalize :: Interaction -> IO ()
159 = {-# SCC "finalize" #-}
161 do finishBodyChunk itr
162 willClose <- atomically $!
163 do queue <- readTVar tQueue
165 case S.viewr queue of
166 remaining :> _ -> writeTVar tQueue remaining
168 readItr itr itrWillClose id
170 -- reader は恐らく hWaitForInput してゐる最中なので、
171 -- スレッドを豫め殺して置かないとをかしくなる。
172 do killThread readerTID
175 awaitSomethingToWrite