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 Data.Ascii (AsciiBuilder)
18 import Data.Convertible.Utils
19 import GHC.IO.Exception (IOException(..), IOErrorType(..))
20 import Data.Monoid.Unicode
21 import qualified Data.Sequence as S
22 import Data.Sequence (ViewR(..))
23 import Network.HTTP.Lucu.Config
24 import Network.HTTP.Lucu.HandleLike
25 import Network.HTTP.Lucu.HttpVersion
26 import Network.HTTP.Lucu.Interaction
27 import Network.HTTP.Lucu.Response
28 import Prelude.Unicode
29 import System.IO (hPutStrLn, stderr)
35 , cQueue ∷ !InteractionQueue
38 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
39 responseWriter cnf h tQueue readerTID
40 = awaitSomethingToWrite (Context cnf h tQueue)
43 , 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 handleOthers ∷ SomeException → IO ()
62 dump ∷ Exception e ⇒ e → IO ()
64 = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
65 hPutStrLn stderr $ show e
67 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
68 awaitSomethingToWrite ctx@(Context {..})
71 do queue ← readTVar cQueue
74 queue' :> itr → do writeTVar cQueue queue'
75 return $ writeSomething ctx itr
77 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
78 writeSomething ctx itr
79 = let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
80 writeResponseForSEI ctx <$> fromInteraction itr <|>
81 writeResponseForSYI ctx <$> fromInteraction itr <|>
82 endOfResponses <$> fromInteraction itr
86 Nothing → fail "Internal error: unknown interaction type"
88 writeResponseForNI ∷ HandleLike h
92 writeResponseForNI = writeContinueIfNeeded
94 writeContinueIfNeeded ∷ HandleLike h
98 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
99 = do isNeeded ← atomically $ readTMVar niSendContinue
101 $ do let cont = Response {
102 resVersion = HttpVersion 1 1
103 , resStatus = fromStatusCode Continue
106 hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
110 writeHeader ∷ HandleLike h
114 writeHeader ctx@(Context {..}) ni@(NI {..})
115 = do res ← atomically $
116 do state ← readTVar niState
117 if state ≥ SendingBody then
120 retry -- Too early to write header fields.
121 hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
123 writeBodyIfNeeded ctx ni
125 writeBodyIfNeeded ∷ HandleLike h
129 writeBodyIfNeeded ctx ni@(NI {..})
132 do willDiscardBody ← readTVar niWillDiscardBody
133 if willDiscardBody then
134 return $ discardBody ctx ni
136 if niWillChunkBody then
137 return $ writeChunkedBody ctx ni
139 return $ writeNonChunkedBody ctx ni
141 discardBody ∷ HandleLike h
145 discardBody ctx ni@(NI {..})
148 do chunk ← tryTakeTMVar niBodyToSend
150 Just _ → return $ discardBody ctx ni
151 Nothing → do state ← readTVar niState
153 return $ finalize ctx ni
157 writeChunkedBody ∷ HandleLike h
161 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
164 do chunk ← tryTakeTMVar niBodyToSend
167 do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
169 writeChunkedBody ctx ni
170 Nothing → do state ← readTVar niState
173 do hPutBuilder cHandle BB.chunkedTransferTerminator
179 writeNonChunkedBody ∷ HandleLike h
183 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
186 do chunk ← tryTakeTMVar niBodyToSend
189 do hPutBuilder cHandle b
191 writeNonChunkedBody ctx ni
192 Nothing → do state ← readTVar niState
194 return $ finalize ctx ni
198 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
199 finalize ctx@(Context {..}) (NI {..})
202 do willClose ← readTVar niWillClose
203 sentContinue ← takeTMVar niSendContinue
205 if needToClose willClose sentContinue then
208 awaitSomethingToWrite ctx
210 needToClose ∷ Bool → Bool → Bool
211 needToClose willClose sentContinue
212 -- Explicitly instructed to close the connection.
214 -- We've sent both "HTTP/1.1 100 Continue" and a final
215 -- response, so nothing prevents our connection from keeping
217 | sentContinue = False
218 -- We've got "Expect: 100-continue" but have sent a final
219 -- response without sending "HTTP/1.1 100
220 -- Continue". According to the RFC 2616 (HTTP/1.1), it is
221 -- undecidable whether the client will send us its
222 -- (rejected) request body OR start a completely new request
223 -- in this situation. So the only possible thing to do is to
224 -- brutally shutdown the connection.
225 | niExpectedContinue = True
226 -- The client didn't expect 100-continue so we haven't sent
227 -- one. No need to do anything special.
230 writeResponseForSEI ∷ HandleLike h
232 → SemanticallyInvalidInteraction
234 writeResponseForSEI ctx@(Context {..}) (SEI {..})
235 = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
236 unless seiWillDiscardBody $
237 if seiWillChunkBody then
238 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
239 hPutBuilder cHandle BB.chunkedTransferTerminator
241 hPutBuilder cHandle seiBodyToSend
243 if seiWillClose ∨ seiExpectedContinue then
246 awaitSomethingToWrite ctx
248 writeResponseForSYI ∷ HandleLike h
250 → SyntacticallyInvalidInteraction
252 writeResponseForSYI (Context {..}) (SYI {..})
253 = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
254 hPutBuilder cHandle syiBodyToSend
258 endOfResponses ∷ EndOfInteraction → IO ()
259 endOfResponses _ = return ()