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.Request
28 import Network.HTTP.Lucu.Response
29 import Network.HTTP.Lucu.Response.StatusCode
30 import Prelude.Unicode
31 import System.IO (hPutStrLn, stderr)
37 , cQueue ∷ !InteractionQueue
40 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
41 responseWriter cnf h tQueue readerTID
42 = awaitSomethingToWrite (Context cnf h tQueue)
45 , Handler handleAsyncE
46 , Handler handleOthers
49 do killThread readerTID
52 handleIOE ∷ IOException → IO ()
53 handleIOE e@(IOError {..})
54 | ioe_type ≡ ResourceVanished = return ()
57 handleAsyncE ∷ AsyncException → IO ()
58 handleAsyncE ThreadKilled = return ()
59 handleAsyncE e = dump e
61 handleOthers ∷ SomeException → IO ()
64 dump ∷ Exception e ⇒ e → IO ()
66 = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
67 hPutStrLn stderr $ show e
69 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
70 awaitSomethingToWrite ctx@(Context {..})
73 do queue ← readTVar cQueue
76 queue' :> itr → do writeTVar cQueue queue'
77 return $ writeSomething ctx itr
79 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
80 writeSomething ctx itr
81 = let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
82 writeResponseForSEI ctx <$> fromInteraction itr <|>
83 writeResponseForSYI ctx <$> fromInteraction itr <|>
84 endOfResponses <$> fromInteraction itr
88 Nothing → fail "Internal error: unknown interaction type"
90 writeResponseForNI ∷ HandleLike h
94 writeResponseForNI = writeContinueIfNeeded
96 writeContinueIfNeeded ∷ HandleLike h
100 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
101 = do isNeeded ← atomically $ readTMVar niSendContinue
103 $ do let cont = Response {
104 resVersion = HttpVersion 1 1
105 , resStatus = fromStatusCode Continue
108 hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
112 writeHeader ∷ HandleLike h
116 writeHeader ctx@(Context {..}) ni@(NI {..})
117 = do res ← atomically $
118 do state ← readTVar niState
119 if state ≥ SendingBody then
122 retry -- Too early to write header fields.
123 hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
125 writeBodyIfNeeded ctx ni
127 writeBodyIfNeeded ∷ HandleLike h
131 writeBodyIfNeeded ctx ni@(NI {..})
134 do canHaveBody ← resCanHaveBody <$> readTVar niResponse
135 if canHaveBody ∧ reqMethod niRequest ≢ HEAD then
136 if niWillChunkBody then
137 return $ writeChunkedBody ctx ni
139 return $ writeNonChunkedBody ctx ni
141 return $ discardBody ctx ni
143 discardBody ∷ HandleLike h
147 discardBody ctx ni@(NI {..})
150 do chunk ← tryTakeTMVar niBodyToSend
152 Just _ → return $ discardBody ctx ni
153 Nothing → do state ← readTVar niState
155 return $ finalize ctx ni
159 writeChunkedBody ∷ HandleLike h
163 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
166 do chunk ← tryTakeTMVar niBodyToSend
169 do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
171 writeChunkedBody ctx ni
172 Nothing → do state ← readTVar niState
175 do hPutBuilder cHandle BB.chunkedTransferTerminator
181 writeNonChunkedBody ∷ HandleLike h
185 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
188 do chunk ← tryTakeTMVar niBodyToSend
191 do hPutBuilder cHandle b
193 writeNonChunkedBody ctx ni
194 Nothing → do state ← readTVar niState
196 return $ finalize ctx ni
200 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
201 finalize ctx@(Context {..}) (NI {..})
204 do willClose ← readTVar niWillClose
205 sentContinue ← takeTMVar niSendContinue
207 if needToClose willClose sentContinue then
210 awaitSomethingToWrite ctx
212 needToClose ∷ Bool → Bool → Bool
213 needToClose willClose sentContinue
214 -- Explicitly instructed to close the connection.
216 -- We've sent both "HTTP/1.1 100 Continue" and a final
217 -- response, so nothing prevents our connection from keeping
219 | sentContinue = False
220 -- We've got "Expect: 100-continue" but have sent a final
221 -- response without sending "HTTP/1.1 100
222 -- Continue". According to the RFC 2616 (HTTP/1.1), it is
223 -- undecidable whether the client will send us its
224 -- (rejected) request body OR start a completely new request
225 -- in this situation. So the only possible thing to do is to
226 -- brutally shutdown the connection.
227 | niExpectedContinue = True
228 -- The client didn't expect 100-continue so we haven't sent
229 -- one. No need to do anything special.
232 writeResponseForSEI ∷ HandleLike h
234 → SemanticallyInvalidInteraction
236 writeResponseForSEI ctx@(Context {..}) (SEI {..})
237 = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
238 when (reqMethod seiRequest ≢ HEAD) $
239 if seiWillChunkBody then
240 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
241 hPutBuilder cHandle BB.chunkedTransferTerminator
243 hPutBuilder cHandle seiBodyToSend
245 if seiWillClose ∨ seiExpectedContinue then
248 awaitSomethingToWrite ctx
250 writeResponseForSYI ∷ HandleLike h
252 → SyntacticallyInvalidInteraction
254 writeResponseForSYI (Context {..}) (SYI {..})
255 = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
256 hPutBuilder cHandle syiBodyToSend
260 endOfResponses ∷ EndOfInteraction → IO ()
261 endOfResponses _ = return ()