7 module Network.HTTP.Lucu.ResponseWriter
11 import qualified Blaze.ByteString.Builder.HTTP as BB
12 import qualified Data.Ascii as A
13 import Control.Concurrent
14 import Control.Concurrent.STM
15 import Control.Exception
17 import Data.Monoid.Unicode
18 import qualified Data.Sequence as S
19 import Data.Sequence (ViewR(..))
20 import Network.HTTP.Lucu.Config
21 import Network.HTTP.Lucu.HandleLike
22 import Network.HTTP.Lucu.HttpVersion
23 import Network.HTTP.Lucu.Interaction
24 import Network.HTTP.Lucu.Postprocess
25 import Network.HTTP.Lucu.Response
26 import Prelude hiding (catch)
27 import Prelude.Unicode
28 import System.IO (hPutStrLn, stderr)
34 , cQueue ∷ !InteractionQueue
38 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
39 responseWriter cnf h tQueue readerTID
40 = awaitSomethingToWrite (Context cnf h tQueue readerTID)
42 [ Handler $ \ (_ ∷ IOException) → return ()
43 , Handler $ \ e → case e of
44 ThreadKilled → return ()
45 _ → hPutStrLn stderr (show e)
46 , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
47 , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
50 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
51 awaitSomethingToWrite ctx@(Context {..})
55 do queue ← readTVar cQueue
56 -- GettingBody 状態にあり、Continue が期待されてゐて、それがま
57 -- だ送信前なのであれば、Continue を送信する。
60 _ :> itr → do state ← readItr itrState itr
61 if state ≡ GettingBody then
62 writeContinueIfNeeded ctx itr
64 if state ≥ DecidingBody then
65 writeHeaderOrBodyIfNeeded ctx itr
69 writeContinueIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
70 writeContinueIfNeeded ctx itr
71 = do expectedContinue ← readItr itrExpectedContinue itr
72 if expectedContinue then
73 do wroteContinue ← readItr itrWroteContinue itr
78 do reqBodyWanted ← readItr itrReqBodyWanted itr
79 if reqBodyWanted ≢ Nothing then
80 return $ writeContinue ctx itr
86 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
87 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
88 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
89 writeHeaderOrBodyIfNeeded ∷ HandleLike h ⇒ Context h → Interaction → STM (IO ())
90 writeHeaderOrBodyIfNeeded ctx itr
91 = do wroteHeader ← readItr itrWroteHeader itr
92 if not wroteHeader then
93 return $ writeHeader ctx itr
95 do noBodyToWrite ← isEmptyTMVar (itrBodyToSend itr)
97 do state ← readItr itrState itr
99 return $ finalize ctx itr
103 return $ writeBodyChunk ctx itr
105 writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
106 writeContinue ctx@(Context {..}) itr
107 = do let cont = Response {
108 resVersion = HttpVersion 1 1
109 , resStatus = Continue
112 cont' ← completeUnconditionalHeaders cConfig cont
113 hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
115 atomically $ writeItr itrWroteContinue True itr
116 awaitSomethingToWrite ctx
118 writeHeader ∷ HandleLike h ⇒ Context h → Interaction → IO ()
119 writeHeader ctx@(Context {..}) itr
120 = do res ← atomically
121 $ do writeItr itrWroteHeader True itr
122 readItr itrResponse itr
123 hPutBuilder cHandle $ A.toBuilder $ printResponse res
125 awaitSomethingToWrite ctx
127 writeBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
128 writeBodyChunk ctx@(Context {..}) itr
131 do willDiscardBody ← readItr itrWillDiscardBody itr
132 if willDiscardBody then
133 do _ ← tryTakeTMVar (itrBodyToSend itr)
134 return $ awaitSomethingToWrite ctx
136 do willChunkBody ← readItr itrWillChunkBody itr
137 chunk ← takeTMVar (itrBodyToSend itr)
139 do if willChunkBody then
140 hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
142 hPutBuilder cHandle chunk
144 awaitSomethingToWrite ctx
146 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
147 finishBodyChunk (Context {..}) itr
150 do willDiscardBody ← readItr itrWillDiscardBody itr
151 willChunkBody ← readItr itrWillChunkBody itr
152 if ((¬) willDiscardBody) ∧ willChunkBody then
154 do hPutBuilder cHandle BB.chunkedTransferTerminator
159 finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
160 finalize ctx@(Context {..}) itr
161 = do finishBodyChunk ctx itr
162 willClose ← atomically $
163 do queue ← readTVar cQueue
164 case S.viewr queue of
165 EmptyR → return () -- this should never happen
166 remaining :> _ → writeTVar cQueue remaining
167 readItr itrWillClose itr
169 -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
170 -- ドを豫め殺して置かないとをかしくなる。
171 do killThread cReader
174 awaitSomethingToWrite ctx