5 module Network.HTTP.Lucu.ResponseWriter
10 import qualified Data.ByteString.Lazy.Char8 as C8
11 import Control.Concurrent
12 import Control.Concurrent.STM
13 import Control.Exception
15 import qualified Data.Sequence as S
16 import Data.Sequence (ViewR(..))
17 import Network.HTTP.Lucu.Config
18 import Network.HTTP.Lucu.Format
19 import Network.HTTP.Lucu.HandleLike
20 import Network.HTTP.Lucu.Headers
21 import Network.HTTP.Lucu.HttpVersion
22 import Network.HTTP.Lucu.Interaction
23 import Network.HTTP.Lucu.Postprocess
24 import Network.HTTP.Lucu.Response
25 import Prelude hiding (catch)
26 import System.IO (stderr)
29 responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
30 responseWriter !cnf !h !tQueue !readerTID
31 = awaitSomethingToWrite
33 [ Handler (( \ _ -> return () ) :: IOException -> IO ())
34 , Handler ( \ ThreadKilled -> return () )
35 , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
36 , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
39 awaitSomethingToWrite :: IO ()
41 = {-# SCC "awaitSomethingToWrite" #-}
45 do queue <- readTVar tQueue
46 -- GettingBody 状態にあり、Continue が期待されてゐ
47 -- て、それがまだ送信前なのであれば、Continue を送
51 _ :> itr -> do state <- readItr itr itrState id
53 if state == GettingBody then
54 writeContinueIfNecessary itr
56 if state >= DecidingBody then
57 writeHeaderOrBodyIfNecessary itr
61 writeContinueIfNecessary :: Interaction -> STM (IO ())
62 writeContinueIfNecessary !itr
63 = {-# SCC "writeContinueIfNecessary" #-}
64 do expectedContinue <- readItr itr itrExpectedContinue id
65 if expectedContinue then
66 do wroteContinue <- readItr itr itrWroteContinue id
71 do reqBodyWanted <- readItr itr itrReqBodyWanted id
72 if reqBodyWanted /= Nothing then
73 return $ writeContinue itr
79 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
80 writeHeaderOrBodyIfNecessary !itr
81 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
82 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
83 -- 空でなければ、それを出力する。空である時は、もし状態が
85 = {-# 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 C8.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" #-}
106 do let cont = Response {
107 resVersion = HttpVersion 1 1
108 , resStatus = Continue
109 , resHeaders = emptyHeaders
111 cont' <- completeUnconditionalHeaders cnf cont
114 atomically $! writeItr itr itrWroteContinue True
115 awaitSomethingToWrite
117 writeHeader :: Interaction -> IO ()
119 = {-# SCC "writeHeader" #-}
120 do res <- atomically $! do writeItr itr itrWroteHeader True
121 readItr itr itrResponse id
124 awaitSomethingToWrite
126 writeBodyChunk :: Interaction -> IO ()
128 = {-# SCC "writeBodyChunk" #-}
129 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
130 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
131 chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
132 writeItr itr itrBodyToSend C8.empty
134 unless willDiscardBody
135 $ do if willChunkBody then
136 do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
137 hPutLBS h (C8.pack "\r\n")
139 hPutLBS h (C8.pack "\r\n")
143 awaitSomethingToWrite
145 finishBodyChunk :: Interaction -> IO ()
147 = {-# SCC "finishBodyChunk" #-}
148 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
149 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
150 when (not willDiscardBody && willChunkBody)
151 $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
153 finalize :: Interaction -> IO ()
155 = {-# SCC "finalize" #-}
156 do finishBodyChunk itr
157 willClose <- atomically $!
158 do queue <- readTVar tQueue
160 case S.viewr queue of
161 EmptyR -> return () -- this should never happen
162 remaining :> _ -> writeTVar tQueue remaining
164 readItr itr itrWillClose id
166 -- reader は恐らく hWaitForInput してゐる最中なので、
167 -- スレッドを豫め殺して置かないとをかしくなる。
168 do killThread readerTID
171 awaitSomethingToWrite