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.HandleLike
16 import Network.HTTP.Lucu.Headers
17 import Network.HTTP.Lucu.HttpVersion
18 import Network.HTTP.Lucu.Interaction
19 import Network.HTTP.Lucu.Postprocess
20 import Network.HTTP.Lucu.Response
21 import Prelude hiding (catch)
22 import System.IO (stderr)
25 responseWriter :: HandleLike h => Config -> h -> InteractionQueue -> ThreadId -> IO ()
26 responseWriter !cnf !h !tQueue !readerTID
27 = awaitSomethingToWrite
29 [ Handler (( \ _ -> return () ) :: IOException -> IO ())
30 , Handler ( \ ThreadKilled -> return () )
31 , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestWriter: blocked indefinitely" )
32 , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
35 awaitSomethingToWrite :: IO ()
37 = {-# SCC "awaitSomethingToWrite" #-}
41 do queue <- readTVar tQueue
42 -- GettingBody 状態にあり、Continue が期待されてゐ
43 -- て、それがまだ送信前なのであれば、Continue を送
47 _ :> itr -> do state <- readItr itr itrState id
49 if state == GettingBody then
50 writeContinueIfNecessary itr
52 if state >= DecidingBody then
53 writeHeaderOrBodyIfNecessary itr
57 writeContinueIfNecessary :: Interaction -> STM (IO ())
58 writeContinueIfNecessary !itr
59 = {-# SCC "writeContinueIfNecessary" #-}
60 do expectedContinue <- readItr itr itrExpectedContinue id
61 if expectedContinue then
62 do wroteContinue <- readItr itr itrWroteContinue id
67 do reqBodyWanted <- readItr itr itrReqBodyWanted id
68 if reqBodyWanted /= Nothing then
69 return $ writeContinue itr
75 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
76 writeHeaderOrBodyIfNecessary !itr
77 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
78 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
79 -- 空でなければ、それを出力する。空である時は、もし状態が
81 = {-# SCC "writeHeaderOrBodyIfNecessary" #-}
82 do wroteHeader <- readItr itr itrWroteHeader id
84 if not wroteHeader then
85 return $! writeHeader itr
87 do bodyToSend <- readItr itr itrBodyToSend id
89 if C8.null bodyToSend then
90 do state <- readItr itr itrState id
93 return $! finalize itr
97 return $! writeBodyChunk itr
99 writeContinue :: Interaction -> IO ()
101 = {-# SCC "writeContinue" #-}
102 do let cont = Response {
103 resVersion = HttpVersion 1 1
104 , resStatus = Continue
105 , resHeaders = emptyHeaders
107 cont' <- completeUnconditionalHeaders cnf cont
110 atomically $! writeItr itr itrWroteContinue True
111 awaitSomethingToWrite
113 writeHeader :: Interaction -> IO ()
115 = {-# SCC "writeHeader" #-}
116 do res <- atomically $! do writeItr itr itrWroteHeader True
117 readItr itr itrResponse id
120 awaitSomethingToWrite
122 writeBodyChunk :: Interaction -> IO ()
124 = {-# SCC "writeBodyChunk" #-}
125 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
126 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
127 chunk <- atomically $! do chunk <- readItr itr itrBodyToSend id
128 writeItr itr itrBodyToSend C8.empty
130 unless willDiscardBody
131 $ do if willChunkBody then
132 do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
133 hPutLBS h (C8.pack "\r\n")
135 hPutLBS h (C8.pack "\r\n")
139 awaitSomethingToWrite
141 finishBodyChunk :: Interaction -> IO ()
143 = {-# SCC "finishBodyChunk" #-}
144 do willDiscardBody <- atomically $! readItr itr itrWillDiscardBody id
145 willChunkBody <- atomically $! readItr itr itrWillChunkBody id
146 when (not willDiscardBody && willChunkBody)
147 $ hPutLBS h (C8.pack "0\r\n\r\n") >> hFlush h
149 finalize :: Interaction -> IO ()
151 = {-# SCC "finalize" #-}
152 do finishBodyChunk itr
153 willClose <- atomically $!
154 do queue <- readTVar tQueue
156 case S.viewr queue of
157 EmptyR -> return () -- this should never happen
158 remaining :> _ -> writeTVar tQueue remaining
160 readItr itr itrWillClose id
162 -- reader は恐らく hWaitForInput してゐる最中なので、
163 -- スレッドを豫め殺して置かないとをかしくなる。
164 do killThread readerTID
167 awaitSomethingToWrite