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.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 responseWriter :: Config -> Handle -> InteractionQueue -> ThreadId -> IO ()
24 responseWriter cnf h tQueue readerTID
25 = cnf `seq` h `seq` tQueue `seq` readerTID `seq`
26 catch awaitSomethingToWrite $ \ exc ->
28 IOException _ -> return ()
29 AsyncException ThreadKilled -> return ()
30 BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
33 awaitSomethingToWrite :: IO ()
35 = {-# SCC "awaitSomethingToWrite" #-}
39 queue <- readTVar tQueue
43 -- GettingBody 状態にあり、Continue が期待され
44 -- てゐて、それがまだ送信前なのであれば、
47 _ :> itr -> do state <- readItr itr itrState id
49 if state == GettingBody then
50 writeContinueIfNecessary itr
52 if state >= DecidingBody then
53 writeHeaderOrBodyIfNecessary itr
58 writeContinueIfNecessary :: Interaction -> STM (IO ())
59 writeContinueIfNecessary itr
60 = {-# SCC "writeContinueIfNecessary" #-}
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 = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
85 do wroteHeader <- readItr itr itrWroteHeader id
87 if not wroteHeader then
88 return $! writeHeader itr
90 do bodyToSend <- readItr itr itrBodyToSend id
92 if B.null bodyToSend then
93 do state <- readItr itr itrState id
96 return $! finalize itr
100 return $! writeBodyChunk itr
102 writeContinue :: Interaction -> IO ()
104 = {-# SCC "writeContinue" #-}
106 do let cont = Response {
107 resVersion = HttpVersion 1 1
108 , resStatus = Continue
111 cont' <- completeUnconditionalHeaders cnf cont
114 atomically $! writeItr itr itrWroteContinue True
115 awaitSomethingToWrite
117 writeHeader :: Interaction -> IO ()
119 = {-# SCC "writeHeader" #-}
121 do res <- atomically $! do writeItr itr itrWroteHeader True
122 readItr itr itrResponse id
125 awaitSomethingToWrite
127 writeBodyChunk :: Interaction -> IO ()
129 = {-# SCC "writeBodyChunk" #-}
131 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
132 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
133 chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
134 writeItr itr itrBodyToSend B.empty
136 unless willDiscardBody
137 $ do if willChunkBody then
138 do hPutStr h (fmtHex False 0 $! fromIntegral $! B.length chunk)
145 awaitSomethingToWrite
147 finishBodyChunk :: Interaction -> IO ()
149 = {-# SCC "finishBodyChunk" #-}
151 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
152 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
153 when (not willDiscardBody && willChunkBody)
154 $ hPutStr h "0\r\n\r\n" >> hFlush h
156 finalize :: Interaction -> IO ()
158 = {-# SCC "finalize" #-}
160 do finishBodyChunk itr
161 willClose <- atomically $!
162 do queue <- readTVar tQueue
164 case S.viewr queue of
165 remaining :> _ -> writeTVar tQueue remaining
167 readItr itr itrWillClose id
169 -- reader は恐らく hWaitForInput してゐる最中なので、
170 -- スレッドを豫め殺して置かないとをかしくなる。
171 do killThread readerTID
174 awaitSomethingToWrite