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)
28 import System.IO.Error
34 , cQueue ∷ !InteractionQueue
41 deriving (Eq, Ord, Show)
43 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
44 responseWriter cnf h tQueue readerTID
45 = awaitSomethingToWrite (Context cnf h tQueue readerTID)
48 , Handler handleAsyncE
50 , Handler handleOthers
53 handleIOE ∷ IOException → IO ()
55 | isIllegalOperation e
56 = return () -- EPIPE: should be ignored at all.
60 handleAsyncE ∷ AsyncException → IO ()
61 handleAsyncE ThreadKilled = terminate'
62 handleAsyncE e = terminate e
64 handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
65 handleBIOS = terminate
67 handleOthers ∷ SomeException → IO ()
68 handleOthers = terminate
70 terminate ∷ Exception e ⇒ e → IO ()
72 = do hPutStrLn stderr "requestWriter caught an exception:"
73 hPutStrLn stderr (show $ toException e)
79 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
80 awaitSomethingToWrite ctx@(Context {..})
84 do queue ← readTVar cQueue
87 queue' :> itr → do writeTVar cQueue queue'
88 return $ awaitSomethingToWriteOn ctx itr Initial
90 -- GettingBody 状態にあり、Continue が期待されてゐて、それがまだ送信前
91 -- なのであれば、Continue を送信する。
92 awaitSomethingToWriteOn ∷ HandleLike h
97 awaitSomethingToWriteOn ctx itr phase
100 do state ← readTVar $ itrState itr
101 if state ≡ GettingBody then
102 writeContinueIfNeeded ctx itr phase
104 if state ≥ DecidingBody then
105 writeHeaderOrBodyIfNeeded ctx itr phase
109 writeContinueIfNeeded ∷ HandleLike h
114 writeContinueIfNeeded ctx itr@(Interaction {..}) phase
115 | phase ≡ Initial ∧ itrExpectedContinue ≡ Just True
116 = do isRequested ← isEmptyTMVar itrGetBodyRequest
118 return $ writeContinue ctx itr
124 -- DecidingBody 以降の状態にあり、まだヘッダを出力する前であれば、ヘッ
125 -- ダを出力する。ヘッダ出力後であり、bodyToSend が空でなければ、それを
126 -- 出力する。空である時は、もし状態がDone であれば後処理をする。
127 writeHeaderOrBodyIfNeeded ∷ HandleLike h
132 writeHeaderOrBodyIfNeeded ctx itr@(Interaction {..}) phase
133 | phase < WroteHeader
134 = return $ writeHeader ctx itr
136 = do noBodyToWrite ← isEmptyTMVar itrBodyToSend
137 if noBodyToWrite then
138 do state ← readTVar itrState
140 return $ finalize ctx itr
144 return $ writeBodyChunk ctx itr phase
146 writeContinue ∷ HandleLike h ⇒ Context h → Interaction → IO ()
147 writeContinue ctx@(Context {..}) itr@(Interaction {..})
148 = do let cont = Response {
149 resVersion = HttpVersion 1 1
150 , resStatus = Continue
153 cont' ← completeUnconditionalHeaders cConfig cont
154 hPutBuilder cHandle $ A.toBuilder $ printResponse cont'
156 awaitSomethingToWriteOn ctx itr WroteContinue
158 writeHeader ∷ HandleLike h
162 writeHeader ctx@(Context {..}) itr@(Interaction {..})
163 = do res ← atomically $ readTVar itrResponse
164 hPutBuilder cHandle $ A.toBuilder $ printResponse res
166 awaitSomethingToWriteOn ctx itr WroteHeader
168 writeBodyChunk ∷ HandleLike h
173 writeBodyChunk ctx@(Context {..}) itr@(Interaction {..}) phase
176 do willDiscardBody ← readTVar itrWillDiscardBody
177 if willDiscardBody then
178 do _ ← tryTakeTMVar itrBodyToSend
179 return $ awaitSomethingToWriteOn ctx itr phase
181 do willChunkBody ← readTVar itrWillChunkBody
182 chunk ← takeTMVar itrBodyToSend
184 do if willChunkBody then
185 hPutBuilder cHandle $ BB.chunkedTransferEncoding chunk
187 hPutBuilder cHandle chunk
189 awaitSomethingToWriteOn ctx itr phase
191 finishBodyChunk ∷ HandleLike h ⇒ Context h → Interaction → IO ()
192 finishBodyChunk (Context {..}) (Interaction {..})
195 do willDiscardBody ← readTVar itrWillDiscardBody
196 willChunkBody ← readTVar itrWillChunkBody
197 if ((¬) willDiscardBody) ∧ willChunkBody then
199 do hPutBuilder cHandle BB.chunkedTransferTerminator
204 finalize ∷ HandleLike h ⇒ Context h → Interaction → IO ()
205 finalize ctx@(Context {..}) itr@(Interaction {..})
206 = do finishBodyChunk ctx itr
207 willClose ← atomically $
208 do queue ← readTVar cQueue
209 case S.viewr queue of
210 EmptyR → return () -- this should never happen
211 remaining :> _ → writeTVar cQueue remaining
212 readTVar itrWillClose
214 -- reader は恐らく hWaitForInput してゐる最中なので、スレッ
215 -- ドを豫め殺して置かないとをかしくなる。
216 do killThread cReader
219 awaitSomethingToWrite ctx