]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/ResponseWriter.hs
Use Data.Map.foldlWithKey' when possible
[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 qualified Data.Ascii as A
18 import Data.Monoid.Unicode
19 import qualified Data.Sequence as S
20 import Data.Sequence (ViewR(..))
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.HandleLike
23 import Network.HTTP.Lucu.HttpVersion
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Response
26 import Prelude.Unicode
27 import System.IO (hPutStrLn, stderr)
28 import System.IO.Error
29
30 data Context h
31     = Context {
32         cConfig ∷ !Config
33       , cHandle ∷ !h
34       , cQueue  ∷ !InteractionQueue
35       , cReader ∷ !ThreadId
36       }
37
38 responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
39 responseWriter cnf h tQueue readerTID
40     = awaitSomethingToWrite (Context cnf h tQueue readerTID)
41       `catches`
42       [ Handler handleIOE
43       , Handler handleAsyncE
44       , Handler handleBIOS
45       , Handler handleOthers
46       ]
47     where
48       handleIOE ∷ IOException → IO ()
49       handleIOE e
50           | isIllegalOperation e
51               = return () -- EPIPE: should be ignored at all.
52           | otherwise
53               = terminate e
54
55       handleAsyncE ∷ AsyncException → IO ()
56       handleAsyncE ThreadKilled = terminate'
57       handleAsyncE e            = terminate e
58
59       handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
60       handleBIOS = terminate
61
62       handleOthers ∷ SomeException → IO ()
63       handleOthers = terminate
64
65       terminate ∷ Exception e ⇒ e → IO ()
66       terminate e
67           = do hPutStrLn stderr "requestWriter caught an exception:"
68                hPutStrLn stderr (show $ toException e)
69                terminate'
70
71       terminate' ∷ IO ()
72       terminate' = hClose h
73
74 awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
75 awaitSomethingToWrite ctx@(Context {..})
76     = join $
77       atomically $
78       do queue ← readTVar cQueue
79          case S.viewr queue of
80            EmptyR        → retry
81            queue' :> itr → do writeTVar cQueue queue'
82                               return $ writeSomething ctx itr
83
84 writeSomething ∷ HandleLike h ⇒ Context h → SomeInteraction → IO ()
85 writeSomething ctx itr
86     = let writer = writeResponseForNI  ctx <$> fromInteraction itr <|>
87                    writeResponseForSEI ctx <$> fromInteraction itr <|>
88                    writeResponseForSYI ctx <$> fromInteraction itr
89       in
90         case writer of
91           Just f  → f
92           Nothing → fail "Internal error: unknown interaction type"
93
94 writeResponseForNI ∷ HandleLike h
95                    ⇒ Context h
96                    → NormalInteraction
97                    → IO ()
98 writeResponseForNI = writeContinueIfNeeded
99
100 writeContinueIfNeeded ∷ HandleLike h
101                       ⇒ Context h
102                       → NormalInteraction
103                       → IO ()
104 writeContinueIfNeeded ctx@(Context {..}) ni@(NI {..})
105     = do isNeeded ← atomically $ readTMVar niSendContinue
106          when isNeeded
107              $ do let cont = Response {
108                                resVersion = HttpVersion 1 1
109                              , resStatus  = fromStatusCode Continue
110                              , resHeaders = (∅)
111                              }
112                   hPutBuilder cHandle $ A.toBuilder $ printResponse cont
113                   hFlush cHandle
114          writeHeader ctx ni
115
116 writeHeader ∷ HandleLike h
117             ⇒ Context h
118             → NormalInteraction
119             → IO ()
120 writeHeader ctx@(Context {..}) ni@(NI {..})
121     = do res ← atomically $
122                do state ← readTVar niState
123                   if state ≥ SendingBody then
124                       readTVar niResponse
125                   else
126                       retry -- Too early to write header fields.
127          hPutBuilder cHandle $ A.toBuilder $ printResponse res
128          hFlush cHandle
129          writeBodyIfNeeded ctx ni
130
131 writeBodyIfNeeded ∷ HandleLike h
132                   ⇒ Context h
133                   → NormalInteraction
134                   → IO ()
135 writeBodyIfNeeded ctx ni@(NI {..})
136     = join $
137       atomically $
138       do willDiscardBody ← readTVar niWillDiscardBody
139          if willDiscardBody then
140              return $ discardBody ctx ni
141          else
142              if niWillChunkBody then
143                  return $ writeChunkedBody    ctx ni
144              else
145                  return $ writeNonChunkedBody ctx ni
146
147 discardBody ∷ HandleLike h
148             ⇒ Context h
149             → NormalInteraction
150             → IO ()
151 discardBody ctx ni@(NI {..})
152     = join $
153       atomically $
154       do chunk ← tryTakeTMVar niBodyToSend
155          case chunk of
156            Just _  → return $ discardBody ctx ni
157            Nothing → do state ← readTVar niState
158                         if state ≡ Done then
159                             return $ finalize ctx ni
160                         else
161                             retry
162
163 writeChunkedBody ∷ HandleLike h
164                  ⇒ Context h
165                  → NormalInteraction
166                  → IO ()
167 writeChunkedBody ctx@(Context {..}) ni@(NI {..})
168     = join $
169       atomically $
170       do chunk ← tryTakeTMVar niBodyToSend
171          case chunk of
172            Just b  → return $
173                      do hPutBuilder cHandle $ BB.chunkedTransferEncoding b
174                         hFlush cHandle
175                         writeChunkedBody ctx ni
176            Nothing → do state ← readTVar niState
177                         if state ≡ Done then
178                             return $
179                             do hPutBuilder cHandle BB.chunkedTransferTerminator
180                                hFlush cHandle
181                                finalize ctx ni
182                         else
183                             retry
184
185 writeNonChunkedBody ∷ HandleLike h
186                     ⇒ Context h
187                     → NormalInteraction
188                     → IO ()
189 writeNonChunkedBody ctx@(Context {..}) ni@(NI {..})
190     = join $
191       atomically $
192       do chunk ← tryTakeTMVar niBodyToSend
193          case chunk of
194            Just b  → return $
195                      do hPutBuilder cHandle b
196                         hFlush cHandle
197                         writeNonChunkedBody ctx ni
198            Nothing → do state ← readTVar niState
199                         if state ≡ Done then
200                             return $ finalize ctx ni
201                         else
202                             retry
203
204 finalize ∷ HandleLike h ⇒ Context h → NormalInteraction → IO ()
205 finalize ctx@(Context {..}) (NI {..})
206     = join $
207       atomically $
208       do willClose    ← readTVar  niWillClose
209          sentContinue ← takeTMVar niSendContinue
210          return $
211              if needToClose willClose sentContinue then
212                  -- The RequestReader is probably blocking on
213                  -- hWaitForInput so we have to kill it before closing
214                  -- the socket.  THINKME: Couldn't that somehow be
215                  -- avoided?
216                  do killThread cReader
217                     hClose cHandle
218              else
219                  awaitSomethingToWrite ctx
220     where
221       needToClose ∷ Bool → Bool → Bool
222       needToClose willClose sentContinue
223           -- Explicitly instructed to close the connection.
224           | willClose = True
225           -- We've sent both "HTTP/1.1 100 Continue" and a final
226           -- response, so nothing prevents our connection from keeping
227           -- alive.
228           | sentContinue = False
229           -- We've got "Expect: 100-continue" but have sent a final
230           -- response without sending "HTTP/1.1 100
231           -- Continue". According to the RFC 2616 (HTTP/1.1), it is
232           -- undecidable whether the client will send us its
233           -- (rejected) request body OR start a completely new request
234           -- in this situation. So the only possible thing to do is to
235           -- brutally shutdown the connection.
236           | niExpectedContinue = True
237           -- The client didn't expect 100-continue so we haven't sent
238           -- one. No need to do anything special.
239           | otherwise = False
240
241 writeResponseForSEI ∷ HandleLike h
242                     ⇒ Context h
243                     → SemanticallyInvalidInteraction
244                     → IO ()
245 writeResponseForSEI ctx@(Context {..}) (SEI {..})
246     = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
247          unless seiWillDiscardBody $
248              if seiWillChunkBody then
249                  do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
250                     hPutBuilder cHandle BB.chunkedTransferTerminator
251              else
252                  hPutBuilder cHandle seiBodyToSend
253          hFlush cHandle
254          if seiWillClose ∨ seiExpectedContinue then
255              do killThread cReader
256                 hClose cHandle
257          else
258              awaitSomethingToWrite ctx
259
260 writeResponseForSYI ∷ HandleLike h
261                     ⇒ Context h
262                     → SyntacticallyInvalidInteraction
263                     → IO ()
264 writeResponseForSYI (Context {..}) (SYI {..})
265     = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
266          hPutBuilder cHandle syiBodyToSend
267          hFlush cHandle
268          killThread cReader
269          hClose cHandle