1 module Network.HTTP.Lucu.ResponseWriter
2 ( responseWriter -- Handle -> InteractionQueue -> IO ()
6 import qualified Data.ByteString.Lazy.Char8 as B
7 import Data.ByteString.Lazy.Char8 (ByteString)
8 import Control.Concurrent.STM
9 import Control.Exception
12 import qualified Data.Sequence as S
13 import Data.Sequence (Seq, ViewR(..))
14 import Network.HTTP.Lucu.Interaction
15 import Network.HTTP.Lucu.Response
16 import Prelude hiding (catch)
20 import Control.Concurrent
24 responseWriter :: Handle -> InteractionQueue -> ThreadId -> IO ()
25 responseWriter h tQueue readerTID
26 = catch awaitSomethingToWrite $ \ exc ->
28 IOException _ -> return ()
29 AsyncException ThreadKilled -> return ()
30 BlockedIndefinitely -> putStrLn "requestWriter: blocked indefinitely"
33 awaitSomethingToWrite :: IO ()
38 queue <- readTVar tQueue
41 let _ :> itr = S.viewr queue
43 -- GettingBody 状態にあり、Continue が期待され
44 -- てゐて、それがまだ送信前なのであれば、
46 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 = do expectedContinue <- readItr itr itrExpectedContinue id
60 if expectedContinue then
62 do wroteContinue <- readItr itr itrWroteContinue id
67 return $ writeContinue itr
71 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
72 writeHeaderOrBodyIfNecessary itr
73 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
74 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
75 -- 空でなければ、それを出力する。空である時は、もし状態が
77 = do wroteHeader <- readItr itr itrWroteHeader id
79 if not wroteHeader then
80 return $ writeHeader itr
82 do bodyToSend <- readItr itr itrBodyToSend id
84 if B.null bodyToSend then
85 do state <- readItr itr itrState id
92 return $ writeBodyChunk itr
94 writeContinue :: Interaction -> IO ()
95 writeContinue itr = fail "FIXME: not implemented"
97 writeHeader :: Interaction -> IO ()
99 = do res <- atomically $ do writeItr itr itrWroteHeader True
100 readItr itr itrResponse id
101 hPutResponse h (fromJust res)
103 awaitSomethingToWrite
105 writeBodyChunk :: Interaction -> IO ()
107 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
108 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
109 chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id
110 writeItr itr itrBodyToSend B.empty
112 unless willDiscardBody
113 $ do if willChunkBody then
114 do hPrintf h "%x\r\n" (toInteger $ B.length chunk)
120 awaitSomethingToWrite
122 finishBodyChunk :: Interaction -> IO ()
124 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
125 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
126 when (not willDiscardBody && willChunkBody)
127 $ hPutStr h "0\r\n" >> hFlush h
129 finalize :: Interaction -> IO ()
131 = do finishBodyChunk itr
132 willClose <- atomically $ do queue <- readTVar tQueue
134 let (remaining :> _) = S.viewr queue
135 writeTVar tQueue remaining
137 readItr itr itrWillClose id
139 do killThread readerTID
142 awaitSomethingToWrite