7 module Network.HTTP.Lucu.ResponseWriter
11 import qualified Blaze.ByteString.Builder.HTTP as BB
12 import Control.Concurrent
13 import Control.Concurrent.STM
14 import Control.Exception
16 import qualified Data.Ascii as A
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.Unicode
27 import System.IO (hPutStrLn, stderr)
33 , cQueue ∷ !InteractionQueue
40 deriving (Eq, Ord, Show)
42 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
43 responseWriter cnf h tQueue readerTID
44 = awaitSomethingToWrite (Context cnf h tQueue readerTID)
46 [ Handler $ \ (_ ∷ IOException) → return ()
47 , Handler $ \ e → case e of
48 ThreadKilled → return ()
49 _ → hPutStrLn stderr (show e)
50 , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestWriter: blocked indefinitely"
51 , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
54 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
55 awaitSomethingToWrite ctx@(Context {..})
59 do queue ← readTVar cQueue
62 queue' :> itr → do writeTVar cQueue queue'
63 return $ awaitSomethingToWriteOn ctx itr Initial
65 -- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
66 -- なのであれば、Continue を送信する。
67 awaitSomethingToWriteOn ∷ HandleLike h
72 awaitSomethingToWriteOn ctx itr phase
75 do state ← readTVar $ itrState itr
76 if state ≡ GettingBody then
77 writeContinueIfNeeded ctx itr phase
79 if state ≥ DecidingBody then
80 writeHeaderOrBodyIfNeeded ctx itr phase
84 writeContinueIfNeeded ∷ HandleLike h
89 writeContinueIfNeeded ctx itr@(Interaction {..}) phase
90 | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
91 = do reqBodyWanted ← readTVar itrReqBodyWanted
92 if reqBodyWanted > 0 then
93 return $ writeContinue ctx itr
99 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
100 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
101 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
102 writeHeaderOrBodyIfNeeded ∷ HandleLike h
107 writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
108 | phase < WroteHeader
109 = return $ writeHeader ctx itr
111 = do noBodyToWrite ← isEmptyTMVar itrBodyToSend
112 if noBodyToWrite then
113 do state ← readTVar itrState
115 return $ finalize ctx itr
119 return $ writeBodyChunk ctx itr phase
121 writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
122 writeContinue ctx@(Context {..}) itr@(Interaction {..})
123 = do let cont = Response {
124 resVersion = HttpVersion 1 1
125 , resStatus = Continue
128 cont' ← completeUnconditionalHeaders cConfig cont
129 hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
131 awaitSomethingToWriteOn ctx itr WroteContinue
133 writeHeader ∷ HandleLike h
137 writeHeader ctx@(Context {..}) itr@(Interaction {..})
138 = do res ← atomically $ readTVar itrResponse
139 hPutBuilder cHandle $ A.toBuilder $ printResponse res
141 awaitSomethingToWriteOn ctx itr WroteHeader
143 writeBodyChunk ∷ HandleLike h
148 writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
151 do willDiscardBody ← readTVar itrWillDiscardBody
152 if willDiscardBody then
153 do _ ← tryTakeTMVar itrBodyToSend
154 return $ awaitSomethingToWriteOn ctx itr phase
156 do willChunkBody ← readTVar itrWillChunkBody
157 chunk ← takeTMVar itrBodyToSend
159 do if willChunkBody then
160 hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
162 hPutBuilder cHandle chunk
164 awaitSomethingToWriteOn ctx itr phase
166 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
167 finishBodyChunk (Context {..}) (Interaction {..})
170 do willDiscardBody ← readTVar itrWillDiscardBody
171 willChunkBody ← readTVar itrWillChunkBody
172 if ((¬) willDiscardBody) ∧ willChunkBody then
174 do hPutBuilder cHandle BB.chunkedTransferTerminator
179 finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
180 finalize ctx@(Context {..}) itr@(Interaction {..})
181 = do finishBodyChunk ctx itr
182 willClose ← atomically $
183 do queue ← readTVar cQueue
184 case S.viewr queue of
185 EmptyR → return () -- this should never happen
186 remaining :> _ → writeTVar cQueue remaining
187 readTVar itrWillClose
189 -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
190 -- ドを豫め殺して置かないとをかしくなる。
191 do killThread cReader
194 awaitSomethingToWrite ctx