7 module Network.HTTP.Lucu.ResponseWriter
11 import qualified Blaze.ByteString.Builder.HTTP as BB
12 import Control.Applicative
13 import Control.Concurrent
14 import Control.Concurrent.STM
15 import Control.Exception
17 import GHC.IO.Exception (IOException(..), IOErrorType(..))
18 import qualified Data.Ascii as A
19 import Data.Monoid.Unicode
20 import qualified Data.Sequence as S
21 import Data.Sequence (ViewR(..))
22 import Network.HTTP.Lucu.Config
23 import Network.HTTP.Lucu.HandleLike
24 import Network.HTTP.Lucu.HttpVersion
25 import Network.HTTP.Lucu.Interaction
26 import Network.HTTP.Lucu.Response
27 import Prelude.Unicode
28 import System.IO (hPutStrLn, stderr)
34 , cQueue ∷ !InteractionQueue
37 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
38 responseWriter cnf h tQueue readerTID
39 = awaitSomethingToWrite (Context cnf h tQueue)
42 , Handler handleAsyncE
44 , Handler handleOthers
47 do killThread readerTID
50 handleIOE ∷ IOException → IO ()
51 handleIOE e@(IOError {..})
52 | ioe_type ≡ ResourceVanished = return ()
55 handleAsyncE ∷ AsyncException → IO ()
56 handleAsyncE ThreadKilled = return ()
57 handleAsyncE e = dump e
59 handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
62 handleOthers ∷ SomeException → IO ()
65 dump ∷ Exception e ⇒ e → IO ()
67 = do hPutStrLn stderr "requestWriter caught an exception:"
68 hPutStrLn stderr $ show e
70 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
71 awaitSomethingToWrite ctx@(Context {..})
74 do queue ← readTVar cQueue
77 queue' :> itr → do writeTVar cQueue queue'
78 return $ writeSomething ctx itr
80 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
81 writeSomething ctx itr
82 = let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
83 writeResponseForSEI ctx <$> fromInteraction itr <|>
84 writeResponseForSYI ctx <$> fromInteraction itr <|>
85 endOfResponses <$> fromInteraction itr
89 Nothing → fail "Internal error: unknown interaction type"
91 writeResponseForNI ∷ HandleLike h
95 writeResponseForNI = writeContinueIfNeeded
97 writeContinueIfNeeded ∷ HandleLike h
101 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
102 = do isNeeded ← atomically $ readTMVar niSendContinue
104 $ do let cont = Response {
105 resVersion = HttpVersion 1 1
106 , resStatus = fromStatusCode Continue
109 hPutBuilder cHandle $ A.toBuilder $ printResponse cont
113 writeHeader ∷ HandleLike h
117 writeHeader ctx@(Context {..}) ni@(NI {..})
118 = do res ← atomically $
119 do state ← readTVar niState
120 if state ≥ SendingBody then
123 retry -- Too early to write header fields.
124 hPutBuilder cHandle $ A.toBuilder $ printResponse res
126 writeBodyIfNeeded ctx ni
128 writeBodyIfNeeded ∷ HandleLike h
132 writeBodyIfNeeded ctx ni@(NI {..})
135 do willDiscardBody ← readTVar niWillDiscardBody
136 if willDiscardBody then
137 return $ discardBody ctx ni
139 if niWillChunkBody then
140 return $ writeChunkedBody ctx ni
142 return $ writeNonChunkedBody ctx ni
144 discardBody ∷ HandleLike h
148 discardBody ctx ni@(NI {..})
151 do chunk ← tryTakeTMVar niBodyToSend
153 Just _ → return $ discardBody ctx ni
154 Nothing → do state ← readTVar niState
156 return $ finalize ctx ni
160 writeChunkedBody ∷ HandleLike h
164 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
167 do chunk ← tryTakeTMVar niBodyToSend
170 do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
172 writeChunkedBody ctx ni
173 Nothing → do state ← readTVar niState
176 do hPutBuilder cHandle BB.chunkedTransferTerminator
182 writeNonChunkedBody ∷ HandleLike h
186 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
189 do chunk ← tryTakeTMVar niBodyToSend
192 do hPutBuilder cHandle b
194 writeNonChunkedBody ctx ni
195 Nothing → do state ← readTVar niState
197 return $ finalize ctx ni
201 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
202 finalize ctx@(Context {..}) (NI {..})
205 do willClose ← readTVar niWillClose
206 sentContinue ← takeTMVar niSendContinue
208 if needToClose willClose sentContinue then
211 awaitSomethingToWrite ctx
213 needToClose ∷ Bool → Bool → Bool
214 needToClose willClose sentContinue
215 -- Explicitly instructed to close the connection.
217 -- We've sent both "HTTP/1.1 100 Continue" and a final
218 -- response, so nothing prevents our connection from keeping
220 | sentContinue = False
221 -- We've got "Expect: 100-continue" but have sent a final
222 -- response without sending "HTTP/1.1 100
223 -- Continue". According to the RFC 2616 (HTTP/1.1), it is
224 -- undecidable whether the client will send us its
225 -- (rejected) request body OR start a completely new request
226 -- in this situation. So the only possible thing to do is to
227 -- brutally shutdown the connection.
228 | niExpectedContinue = True
229 -- The client didn't expect 100-continue so we haven't sent
230 -- one. No need to do anything special.
233 writeResponseForSEI ∷ HandleLike h
235 → SemanticallyInvalidInteraction
237 writeResponseForSEI ctx@(Context {..}) (SEI {..})
238 = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
239 unless seiWillDiscardBody $
240 if seiWillChunkBody then
241 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
242 hPutBuilder cHandle BB.chunkedTransferTerminator
244 hPutBuilder cHandle seiBodyToSend
246 if seiWillClose ∨ seiExpectedContinue then
249 awaitSomethingToWrite ctx
251 writeResponseForSYI ∷ HandleLike h
253 → SyntacticallyInvalidInteraction
255 writeResponseForSYI (Context {..}) (SYI {..})
256 = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
257 hPutBuilder cHandle syiBodyToSend
261 endOfResponses ∷ EndOfInteraction → IO ()
262 endOfResponses _ = return ()