]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/ResponseWriter.hs
25f2ffbead481571c609fcd221d877390a6031d5
[Lucu.git] / Network / HTTP / Lucu / ResponseWriter.hs
1 {-# LANGUAGE
2     DoAndIfThenElse
3   , RecordWildCards
4   , ScopedTypeVariables
5   , UnicodeSyntax
6   #-}
7 module Network.HTTP.Lucu.ResponseWriter
8     ( responseWriter
9     )
10     where
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
16 import Control.Monad
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)
29
30 data Context h
31     = Context {
32         cConfig ∷ !Config
33       , cHandle ∷ !h
34       , cQueue  ∷ !InteractionQueue
35       }
36
37 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
38 responseWriter cnf h tQueue readerTID
39     = awaitSomethingToWrite (Context cnf h tQueue)
40       `catches`
41       [ Handler handleIOE
42       , Handler handleAsyncE
43       , Handler handleBIOS
44       , Handler handleOthers
45       ]
46       `finally`
47       do killThread readerTID
48          hClose h
49     where
50       handleIOE ∷ IOException → IO ()
51       handleIOE e@(IOError {..})
52           | ioe_type ≡ ResourceVanished = return ()
53           | otherwise                   = dump e
54
55       handleAsyncE ∷ AsyncException → IO ()
56       handleAsyncE ThreadKilled = return ()
57       handleAsyncE e            = dump e
58
59       handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
60       handleBIOS = dump
61
62       handleOthers ∷ SomeException → IO ()
63       handleOthers = dump
64
65       dump ∷ Exception e ⇒ e → IO ()
66       dump e
67           = do hPutStrLn stderr "requestWriter caught an exception:"
68                hPutStrLn stderr $ show e
69
70 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
71 awaitSomethingToWrite ctx@(Context {..})
72     = join $
73       atomically $
74       do queue ← readTVar cQueue
75          case S.viewr queue of
76            EmptyR        → retry
77            queue' :> itr → do writeTVar cQueue queue'
78                               return $ writeSomething ctx itr
79
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
86       in
87         case writer of
88           Just f  → f
89           Nothing → fail "Internal error: unknown interaction type"
90
91 writeResponseForNI ∷ HandleLike h
92                    ⇒ Context h
93                    → NormalInteraction
94                    → IO ()
95 writeResponseForNI = writeContinueIfNeeded
96
97 writeContinueIfNeeded ∷ HandleLike h
98                       ⇒ Context h
99                       → NormalInteraction
100                       → IO ()
101 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
102     = do isNeeded ← atomically $ readTMVar niSendContinue
103          when isNeeded
104              $ do let cont = Response {
105                                resVersion = HttpVersion 1 1
106                              , resStatus  = fromStatusCode Continue
107                              , resHeaders = (∅)
108                              }
109                   hPutBuilder cHandle $ A.toBuilder $ printResponse cont
110                   hFlush cHandle
111          writeHeader ctx ni
112
113 writeHeader ∷ HandleLike h
114             ⇒ Context h
115             → NormalInteraction
116             → IO ()
117 writeHeader ctx@(Context {..}) ni@(NI {..})
118     = do res ← atomically $
119                do state ← readTVar niState
120                   if state ≥ SendingBody then
121                       readTVar niResponse
122                   else
123                       retry -- Too early to write header fields.
124          hPutBuilder cHandle $ A.toBuilder $ printResponse res
125          hFlush cHandle
126          writeBodyIfNeeded ctx ni
127
128 writeBodyIfNeeded ∷ HandleLike h
129                   ⇒ Context h
130                   → NormalInteraction
131                   → IO ()
132 writeBodyIfNeeded ctx ni@(NI {..})
133     = join $
134       atomically $
135       do willDiscardBody ← readTVar niWillDiscardBody
136          if willDiscardBody then
137              return $ discardBody ctx ni
138          else
139              if niWillChunkBody then
140                  return $ writeChunkedBody    ctx ni
141              else
142                  return $ writeNonChunkedBody ctx ni
143
144 discardBody ∷ HandleLike h
145             ⇒ Context h
146             → NormalInteraction
147             → IO ()
148 discardBody ctx ni@(NI {..})
149     = join $
150       atomically $
151       do chunk ← tryTakeTMVar niBodyToSend
152          case chunk of
153            Just _  → return $ discardBody ctx ni
154            Nothing → do state ← readTVar niState
155                         if state ≡ Done then
156                             return $ finalize ctx ni
157                         else
158                             retry
159
160 writeChunkedBody ∷ HandleLike h
161                  ⇒ Context h
162                  → NormalInteraction
163                  → IO ()
164 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
165     = join $
166       atomically $
167       do chunk ← tryTakeTMVar niBodyToSend
168          case chunk of
169            Just b  → return $
170                      do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
171                         hFlush cHandle
172                         writeChunkedBody ctx ni
173            Nothing → do state ← readTVar niState
174                         if state ≡ Done then
175                             return $
176                             do hPutBuilder cHandle BB.chunkedTransferTerminator
177                                hFlush cHandle
178                                finalize ctx ni
179                         else
180                             retry
181
182 writeNonChunkedBody ∷ HandleLike h
183                     ⇒ Context h
184                     → NormalInteraction
185                     → IO ()
186 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
187     = join $
188       atomically $
189       do chunk ← tryTakeTMVar niBodyToSend
190          case chunk of
191            Just b  → return $
192                      do hPutBuilder cHandle b
193                         hFlush cHandle
194                         writeNonChunkedBody ctx ni
195            Nothing → do state ← readTVar niState
196                         if state ≡ Done then
197                             return $ finalize ctx ni
198                         else
199                             retry
200
201 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
202 finalize ctx@(Context {..}) (NI {..})
203     = join $
204       atomically $
205       do willClose    ← readTVar  niWillClose
206          sentContinue ← takeTMVar niSendContinue
207          return $
208              if needToClose willClose sentContinue then
209                  return ()
210              else
211                  awaitSomethingToWrite ctx
212     where
213       needToClose ∷ Bool → Bool → Bool
214       needToClose willClose sentContinue
215           -- Explicitly instructed to close the connection.
216           | willClose = True
217           -- We've sent both "HTTP/1.1 100 Continue" and a final
218           -- response, so nothing prevents our connection from keeping
219           -- alive.
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.
231           | otherwise = False
232
233 writeResponseForSEI ∷ HandleLike h
234                     ⇒ Context h
235                     → SemanticallyInvalidInteraction
236                     → IO ()
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
243              else
244                  hPutBuilder cHandle seiBodyToSend
245          hFlush cHandle
246          if seiWillClose ∨ seiExpectedContinue then
247              return ()
248          else
249              awaitSomethingToWrite ctx
250
251 writeResponseForSYI ∷ HandleLike h
252                     ⇒ Context h
253                     → SyntacticallyInvalidInteraction
254                     → IO ()
255 writeResponseForSYI (Context {..}) (SYI {..})
256     = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
257          hPutBuilder cHandle syiBodyToSend
258          hFlush cHandle
259          return ()
260
261 endOfResponses ∷ EndOfInteraction → IO ()
262 endOfResponses _ = return ()