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
43 , Handler handleOthers
46 do killThread readerTID
49 handleIOE ∷ IOException → IO ()
50 handleIOE e@(IOError {..})
51 | ioe_type ≡ ResourceVanished = return ()
54 handleAsyncE ∷ AsyncException → IO ()
55 handleAsyncE ThreadKilled = return ()
56 handleAsyncE e = dump e
58 handleOthers ∷ SomeException → IO ()
61 dump ∷ Exception e ⇒ e → IO ()
63 = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
64 hPutStrLn stderr $ show e
66 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
67 awaitSomethingToWrite ctx@(Context {..})
70 do queue ← readTVar cQueue
73 queue' :> itr → do writeTVar cQueue queue'
74 return $ writeSomething ctx itr
76 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
77 writeSomething ctx itr
78 = let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
79 writeResponseForSEI ctx <$> fromInteraction itr <|>
80 writeResponseForSYI ctx <$> fromInteraction itr <|>
81 endOfResponses <$> fromInteraction itr
85 Nothing → fail "Internal error: unknown interaction type"
87 writeResponseForNI ∷ HandleLike h
91 writeResponseForNI = writeContinueIfNeeded
93 writeContinueIfNeeded ∷ HandleLike h
97 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
98 = do isNeeded ← atomically $ readTMVar niSendContinue
100 $ do let cont = Response {
101 resVersion = HttpVersion 1 1
102 , resStatus = fromStatusCode Continue
105 hPutBuilder cHandle $ A.toBuilder $ printResponse cont
109 writeHeader ∷ HandleLike h
113 writeHeader ctx@(Context {..}) ni@(NI {..})
114 = do res ← atomically $
115 do state ← readTVar niState
116 if state ≥ SendingBody then
119 retry -- Too early to write header fields.
120 hPutBuilder cHandle $ A.toBuilder $ printResponse res
122 writeBodyIfNeeded ctx ni
124 writeBodyIfNeeded ∷ HandleLike h
128 writeBodyIfNeeded ctx ni@(NI {..})
131 do willDiscardBody ← readTVar niWillDiscardBody
132 if willDiscardBody then
133 return $ discardBody ctx ni
135 if niWillChunkBody then
136 return $ writeChunkedBody ctx ni
138 return $ writeNonChunkedBody ctx ni
140 discardBody ∷ HandleLike h
144 discardBody ctx ni@(NI {..})
147 do chunk ← tryTakeTMVar niBodyToSend
149 Just _ → return $ discardBody ctx ni
150 Nothing → do state ← readTVar niState
152 return $ finalize ctx ni
156 writeChunkedBody ∷ HandleLike h
160 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
163 do chunk ← tryTakeTMVar niBodyToSend
166 do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
168 writeChunkedBody ctx ni
169 Nothing → do state ← readTVar niState
172 do hPutBuilder cHandle BB.chunkedTransferTerminator
178 writeNonChunkedBody ∷ HandleLike h
182 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
185 do chunk ← tryTakeTMVar niBodyToSend
188 do hPutBuilder cHandle b
190 writeNonChunkedBody ctx ni
191 Nothing → do state ← readTVar niState
193 return $ finalize ctx ni
197 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
198 finalize ctx@(Context {..}) (NI {..})
201 do willClose ← readTVar niWillClose
202 sentContinue ← takeTMVar niSendContinue
204 if needToClose willClose sentContinue then
207 awaitSomethingToWrite ctx
209 needToClose ∷ Bool → Bool → Bool
210 needToClose willClose sentContinue
211 -- Explicitly instructed to close the connection.
213 -- We've sent both "HTTP/1.1 100 Continue" and a final
214 -- response, so nothing prevents our connection from keeping
216 | sentContinue = False
217 -- We've got "Expect: 100-continue" but have sent a final
218 -- response without sending "HTTP/1.1 100
219 -- Continue". According to the RFC 2616 (HTTP/1.1), it is
220 -- undecidable whether the client will send us its
221 -- (rejected) request body OR start a completely new request
222 -- in this situation. So the only possible thing to do is to
223 -- brutally shutdown the connection.
224 | niExpectedContinue = True
225 -- The client didn't expect 100-continue so we haven't sent
226 -- one. No need to do anything special.
229 writeResponseForSEI ∷ HandleLike h
231 → SemanticallyInvalidInteraction
233 writeResponseForSEI ctx@(Context {..}) (SEI {..})
234 = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
235 unless seiWillDiscardBody $
236 if seiWillChunkBody then
237 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
238 hPutBuilder cHandle BB.chunkedTransferTerminator
240 hPutBuilder cHandle seiBodyToSend
242 if seiWillClose ∨ seiExpectedContinue then
245 awaitSomethingToWrite ctx
247 writeResponseForSYI ∷ HandleLike h
249 → SyntacticallyInvalidInteraction
251 writeResponseForSYI (Context {..}) (SYI {..})
252 = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
253 hPutBuilder cHandle syiBodyToSend
257 endOfResponses ∷ EndOfInteraction → IO ()
258 endOfResponses _ = return ()