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 ( \ BlockedIndefinitely -> 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 -- てゐて、それがまだ送信前なのであれば、
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 C8.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
109 , resHeaders = emptyHeaders
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 C8.empty
136 unless willDiscardBody
137 $ do if willChunkBody then
138 do hPutStr h (fmtHex False 0 $! fromIntegral $! C8.length chunk)
139 hPutLBS h (C8.pack "\r\n")
141 hPutLBS h (C8.pack "\r\n")
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 $ hPutLBS h (C8.pack "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 EmptyR -> return () -- this should never happen
166 remaining :> _ -> writeTVar tQueue remaining
168 readItr itr itrWillClose id
170 -- reader は恐らく hWaitForInput してゐる最中なので、
171 -- スレッドを豫め殺して置かないとをかしくなる。
172 do killThread readerTID
175 awaitSomethingToWrite