1 module Network.HTTP.Lucu.ResponseWriter
6 import qualified Data.ByteString.Lazy.Char8 as C8
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 = awaitSomethingToWrite
28 [ Handler (( \ _ -> return () ) :: IOException -> IO ())
29 , Handler ( \ ThreadKilled -> return () )
30 , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
31 , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
34 awaitSomethingToWrite :: IO ()
36 = {-# SCC "awaitSomethingToWrite" #-}
40 do queue <- readTVar tQueue
41 -- GettingBody 状態にあり、Continue が期待され
42 -- てゐて、それがまだ送信前なのであれば、
46 _ :> itr -> do state <- readItr itr itrState id
48 if state == GettingBody then
49 writeContinueIfNecessary itr
51 if state >= DecidingBody then
52 writeHeaderOrBodyIfNecessary itr
57 writeContinueIfNecessary :: Interaction -> STM (IO ())
58 writeContinueIfNecessary itr
59 = {-# SCC "writeContinueIfNecessary" #-}
61 do expectedContinue <- readItr itr itrExpectedContinue id
62 if expectedContinue then
63 do wroteContinue <- readItr itr itrWroteContinue id
68 do reqBodyWanted <- readItr itr itrReqBodyWanted id
69 if reqBodyWanted /= Nothing then
70 return $ writeContinue itr
76 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
77 writeHeaderOrBodyIfNecessary itr
78 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
79 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
80 -- 空でなければ、それを出力する。空である時は、もし状態が
82 = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
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 C8.null bodyToSend then
92 do state <- readItr itr itrState id
95 return $! finalize itr
99 return $! writeBodyChunk itr
101 writeContinue :: Interaction -> IO ()
103 = {-# SCC "writeContinue" #-}
105 do let cont = Response {
106 resVersion = HttpVersion 1 1
107 , resStatus = Continue
108 , resHeaders = emptyHeaders
110 cont' <- completeUnconditionalHeaders cnf cont
113 atomically $! writeItr itr itrWroteContinue True
114 awaitSomethingToWrite
116 writeHeader :: Interaction -> IO ()
118 = {-# 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" #-}
130 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
131 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
132 chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
133 writeItr itr itrBodyToSend C8.empty
135 unless willDiscardBody
136 $ do if willChunkBody then
137 do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
138 C8.hPut h (C8.pack "\r\n")
140 C8.hPut h (C8.pack "\r\n")
144 awaitSomethingToWrite
146 finishBodyChunk :: Interaction -> IO ()
148 = {-# SCC "finishBodyChunk" #-}
150 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
151 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
152 when (not willDiscardBody && willChunkBody)
153 $ C8.hPut h (C8.pack "0\r\n\r\n") >> hFlush h
155 finalize :: Interaction -> IO ()
157 = {-# SCC "finalize" #-}
159 do finishBodyChunk itr
160 willClose <- atomically $!
161 do queue <- readTVar tQueue
163 case S.viewr queue of
164 EmptyR -> return () -- this should never happen
165 remaining :> _ -> writeTVar tQueue remaining
167 readItr itr itrWillClose id
169 -- reader は恐らく hWaitForInput してゐる最中なので、
170 -- スレッドを豫め殺して置かないとをかしくなる。
171 do killThread readerTID
174 awaitSomethingToWrite