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)
22 responseWriter :: Handle -> InteractionQueue -> IO ()
23 responseWriter h tQueue
24 = awaitSomethingToWrite
26 awaitSomethingToWrite :: IO ()
31 queue <- readTVar tQueue
34 let _ :> itr = S.viewr queue
36 -- GettingBody 状態にあり、Continue が期待され
37 -- てゐて、それがまだ送信前なのであれば、
39 state <- readItr itr itrState id
41 if state == GettingBody then
42 writeContinueIfNecessary itr
44 if state >= DecidingBody then
45 writeHeaderOrBodyIfNecessary itr
50 writeContinueIfNecessary :: Interaction -> STM (IO ())
51 writeContinueIfNecessary itr
52 = do expectedContinue <- readItr itr itrExpectedContinue id
53 if expectedContinue then
55 do wroteContinue <- readItr itr itrWroteContinue id
60 return $ writeContinue itr
64 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
65 writeHeaderOrBodyIfNecessary itr
66 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
67 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
68 -- 空でなければ、それを出力する。空である時は、もし状態が
70 = do wroteHeader <- readItr itr itrWroteHeader id
72 if not wroteHeader then
73 return $ writeHeader itr
75 do bodyToSend <- readItr itr itrBodyToSend id
77 if B.null bodyToSend then
78 do state <- readItr itr itrState id
85 return $ writeBodyChunk itr
87 writeContinue :: Interaction -> IO ()
88 writeContinue itr = fail "FIXME: not implemented"
90 writeHeader :: Interaction -> IO ()
92 = do res <- atomically $ do writeItr itr itrWroteHeader True
93 readItr itr itrResponse id
94 hPutResponse h (fromJust res)
98 writeBodyChunk :: Interaction -> IO ()
100 = do willDiscardBody <- atomically $ readItr itr itrWillDiscardBody id
101 willChunkBody <- atomically $ readItr itr itrWillChunkBody id
102 chunk <- atomically $ do chunk <- readItr itr itrBodyToSend id
103 writeItr itr itrBodyToSend B.empty
105 unless willDiscardBody
106 $ do if willChunkBody then
107 fail "FIXME: not implemented"
111 awaitSomethingToWrite
113 finishBodyChunk :: Interaction -> IO ()
114 finishBodyChunk itr = return () -- FIXME: not implemented
116 finalize :: Interaction -> IO ()
118 = do finishBodyChunk itr
119 willClose <- atomically $ do queue <- readTVar tQueue
121 let (remaining :> _) = S.viewr queue
122 writeTVar tQueue remaining
124 readItr itr itrWillClose id
128 awaitSomethingToWrite