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 = catch awaitSomethingToWrite $ \ exc
26 IOException _ -> return ()
29 awaitSomethingToWrite :: IO ()
34 queue <- readTVar tQueue
37 let _ :> itr = S.viewr queue
39 -- GettingBody 状態にあり、Continue が期待され
40 -- てゐて、それがまだ送信前なのであれば、
42 state <- readTVar (itrState itr)
44 if state == GettingBody then
45 writeContinueIfNecessary itr
47 if state >= DecidingBody then
48 writeHeaderOrBodyIfNecessary itr
53 writeContinueIfNecessary :: Interaction -> STM (IO ())
54 writeContinueIfNecessary itr
55 = do expectedContinue <- readTVar (itrExpectedContinue itr)
56 if expectedContinue then
58 do wroteContinue <- readTVar $ itrWroteContinue itr
63 return $ writeContinue itr
67 writeHeaderOrBodyIfNecessary :: Interaction -> STM (IO ())
68 writeHeaderOrBodyIfNecessary itr
69 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であ
70 -- れば、ヘッダを出力する。ヘッダ出力後であり、bodyToSend が
71 -- 空でなければ、それを出力する。空である時は、もし状態が
73 = do wroteHeader <- readTVar (itrWroteHeader itr)
75 if not wroteHeader then
76 return $ writeHeader itr
78 do bodyToSend <- readTVar (itrBodyToSend itr)
80 if B.null bodyToSend then
81 do state <- readTVar (itrState itr)
88 return $ writeBodyChunk itr
90 writeContinue :: Interaction -> IO ()
91 writeContinue itr = fail "FIXME: not implemented"
93 writeHeader :: Interaction -> IO ()
95 = do res <- atomically $ do writeTVar (itrWroteHeader itr) True
96 readTVar (itrResponse itr)
97 hPutResponse h (fromJust res)
101 writeBodyChunk :: Interaction -> IO ()
102 writeBodyChunk itr = fail "FIXME: not implemented"
104 finishBodyChunk :: Interaction -> IO ()
105 finishBodyChunk itr = return () -- FIXME: not implemented
107 finalize :: Interaction -> IO ()
109 = do finishBodyChunk itr
110 willClose <- atomically $ do queue <- readTVar tQueue
112 let (remaining :> _) = S.viewr queue
113 writeTVar tQueue remaining
115 readTVar $ itrWillClose itr
119 awaitSomethingToWrite