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 Prelude.Unicode
30 import System.IO (hPutStrLn, stderr)
36 , cQueue ∷ !InteractionQueue
39 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
40 responseWriter cnf h tQueue readerTID
41 = awaitSomethingToWrite (Context cnf h tQueue)
44 , Handler handleAsyncE
45 , Handler handleOthers
48 do killThread readerTID
51 handleIOE ∷ IOException → IO ()
52 handleIOE e@(IOError {..})
53 | ioe_type ≡ ResourceVanished = return ()
56 handleAsyncE ∷ AsyncException → IO ()
57 handleAsyncE ThreadKilled = return ()
58 handleAsyncE e = dump e
60 handleOthers ∷ SomeException → IO ()
63 dump ∷ Exception e ⇒ e → IO ()
65 = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
66 hPutStrLn stderr $ show e
68 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
69 awaitSomethingToWrite ctx@(Context {..})
72 do queue ← readTVar cQueue
75 queue' :> itr → do writeTVar cQueue queue'
76 return $ writeSomething ctx itr
78 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
79 writeSomething ctx itr
80 = let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
81 writeResponseForSEI ctx <$> fromInteraction itr <|>
82 writeResponseForSYI ctx <$> fromInteraction itr <|>
83 endOfResponses <$> fromInteraction itr
87 Nothing → fail "Internal error: unknown interaction type"
89 writeResponseForNI ∷ HandleLike h
93 writeResponseForNI = writeContinueIfNeeded
95 writeContinueIfNeeded ∷ HandleLike h
99 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
100 = do isNeeded ← atomically $ readTMVar niSendContinue
102 $ do let cont = Response {
103 resVersion = HttpVersion 1 1
104 , resStatus = fromStatusCode Continue
107 hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
111 writeHeader ∷ HandleLike h
115 writeHeader ctx@(Context {..}) ni@(NI {..})
116 = do res ← atomically $
117 do state ← readTVar niState
118 if state ≥ SendingBody then
121 retry -- Too early to write header fields.
122 hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
124 writeBodyIfNeeded ctx ni
126 writeBodyIfNeeded ∷ HandleLike h
130 writeBodyIfNeeded ctx ni@(NI {..})
133 do canHaveBody ← resCanHaveBody <$> readTVar niResponse
134 if canHaveBody ∧ reqMethod niRequest ≢ HEAD then
135 if niWillChunkBody then
136 return $ writeChunkedBody ctx ni
138 return $ writeNonChunkedBody ctx ni
140 return $ discardBody ctx ni
142 discardBody ∷ HandleLike h
146 discardBody ctx ni@(NI {..})
149 do chunk ← tryTakeTMVar niBodyToSend
151 Just _ → return $ discardBody ctx ni
152 Nothing → do state ← readTVar niState
154 return $ finalize ctx ni
158 writeChunkedBody ∷ HandleLike h
162 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
165 do chunk ← tryTakeTMVar niBodyToSend
168 do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
170 writeChunkedBody ctx ni
171 Nothing → do state ← readTVar niState
174 do hPutBuilder cHandle BB.chunkedTransferTerminator
180 writeNonChunkedBody ∷ HandleLike h
184 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
187 do chunk ← tryTakeTMVar niBodyToSend
190 do hPutBuilder cHandle b
192 writeNonChunkedBody ctx ni
193 Nothing → do state ← readTVar niState
195 return $ finalize ctx ni
199 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
200 finalize ctx@(Context {..}) (NI {..})
203 do willClose ← readTVar niWillClose
204 sentContinue ← takeTMVar niSendContinue
206 if needToClose willClose sentContinue then
209 awaitSomethingToWrite ctx
211 needToClose ∷ Bool → Bool → Bool
212 needToClose willClose sentContinue
213 -- Explicitly instructed to close the connection.
215 -- We've sent both "HTTP/1.1 100 Continue" and a final
216 -- response, so nothing prevents our connection from keeping
218 | sentContinue = False
219 -- We've got "Expect: 100-continue" but have sent a final
220 -- response without sending "HTTP/1.1 100
221 -- Continue". According to the RFC 2616 (HTTP/1.1), it is
222 -- undecidable whether the client will send us its
223 -- (rejected) request body OR start a completely new request
224 -- in this situation. So the only possible thing to do is to
225 -- brutally shutdown the connection.
226 | niExpectedContinue = True
227 -- The client didn't expect 100-continue so we haven't sent
228 -- one. No need to do anything special.
231 writeResponseForSEI ∷ HandleLike h
233 → SemanticallyInvalidInteraction
235 writeResponseForSEI ctx@(Context {..}) (SEI {..})
236 = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
237 when (reqMethod seiRequest ≢ HEAD) $
238 if seiWillChunkBody then
239 do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
240 hPutBuilder cHandle BB.chunkedTransferTerminator
242 hPutBuilder cHandle seiBodyToSend
244 if seiWillClose ∨ seiExpectedContinue then
247 awaitSomethingToWrite ctx
249 writeResponseForSYI ∷ HandleLike h
251 → SyntacticallyInvalidInteraction
253 writeResponseForSYI (Context {..}) (SYI {..})
254 = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
255 hPutBuilder cHandle syiBodyToSend
259 endOfResponses ∷ EndOfInteraction → IO ()
260 endOfResponses _ = return ()