]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/RequestReader.hs
Rename: Resource --> Rsrc; ResourceDef --> Resource
[Lucu.git] / Network / HTTP / Lucu / RequestReader.hs
1 {-# LANGUAGE
2     CPP
3   , DoAndIfThenElse
4   , OverloadedStrings
5   , RecordWildCards
6   , ScopedTypeVariables
7   , UnicodeSyntax
8   #-}
9 module Network.HTTP.Lucu.RequestReader
10     ( requestReader
11     )
12     where
13 import Control.Concurrent
14 import Control.Concurrent.STM
15 import Control.Exception hiding (block)
16 import Control.Monad
17 import qualified Data.Attoparsec.Lazy as LP
18 import qualified Data.ByteString as Strict
19 import qualified Data.ByteString.Lazy as Lazy
20 import Data.List
21 import Data.Maybe
22 import Data.Monoid.Unicode
23 import qualified Data.Sequence as S
24 import qualified Data.Text as T
25 import Network.HTTP.Lucu.Abortion
26 import Network.HTTP.Lucu.Config
27 import Network.HTTP.Lucu.Chunk
28 import Network.HTTP.Lucu.HandleLike
29 import Network.HTTP.Lucu.Interaction
30 import Network.HTTP.Lucu.Preprocess
31 import Network.HTTP.Lucu.Request
32 import Network.HTTP.Lucu.Response
33 import Network.HTTP.Lucu.Resource.Internal
34 import Network.HTTP.Lucu.Resource.Tree
35 import Network.HTTP.Lucu.Utils
36 import Network.Socket
37 import Prelude.Unicode
38 import System.IO (hPutStrLn, stderr)
39
40 data Context h
41     = Context {
42         cConfig    ∷ !Config
43       , cResTree   ∷ !ResTree
44       , cFallbacks ∷ ![FallbackHandler]
45       , cHandle    ∷ !h
46       , cPort      ∷ !PortNumber
47       , cAddr      ∷ !SockAddr
48       , cQueue     ∷ !InteractionQueue
49       }
50
51 data ChunkReceivingState
52     = Initial
53     | InChunk !Int -- ^Number of remaining octets in the current
54                    -- chunk. It's always positive.
55
56 requestReader ∷ HandleLike h
57               ⇒ Config
58               → ResTree
59               → [FallbackHandler]
60               → h
61               → PortNumber
62               → SockAddr
63               → InteractionQueue
64               → IO ()
65 requestReader cnf tree fbs h port addr tQueue
66     = do input ← hGetLBS h
67          acceptRequest (Context cnf tree fbs h port addr tQueue) input
68       `catches`
69       [ Handler handleAsyncE
70       , Handler handleOthers
71       ]
72       `finally`
73       enqueue' tQueue EndOfInteraction
74     where
75       handleAsyncE ∷ AsyncException → IO ()
76       handleAsyncE ThreadKilled = return ()
77       handleAsyncE e            = dump e
78
79       handleOthers ∷ SomeException → IO ()
80       handleOthers = dump
81
82       dump ∷ Exception e ⇒ e → IO ()
83       dump e
84           = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
85                hPutStrLn stderr $ show e
86
87 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
88 acceptRequest ctx@(Context {..}) input
89     = do atomically $
90              do queue ← readTVar cQueue
91                 when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
92                     -- Too many requests in the pipeline...
93                     retry
94          if Lazy.null input then
95              return ()
96          else
97              case LP.parse request input of
98                LP.Done input' req → acceptParsableRequest ctx req input'
99                LP.Fail _ _ _      → acceptNonparsableRequest ctx
100
101 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
102 acceptNonparsableRequest ctx@(Context {..})
103     = do syi ← mkSyntacticallyInvalidInteraction cConfig
104          enqueue ctx syi
105
106 acceptParsableRequest ∷ HandleLike h
107                       ⇒ Context h
108                       → Request
109                       → Lazy.ByteString
110                       → IO ()
111 acceptParsableRequest ctx@(Context {..}) req input
112     = do let ar = preprocess (cnfServerHost cConfig) cPort req
113          if isError $ arInitialStatus ar then
114              acceptSemanticallyInvalidRequest ctx ar input
115          else
116              do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
117                 case rsrc of
118                   Nothing
119                       → do let ar' = ar {
120                                        arInitialStatus = fromStatusCode NotFound
121                                      }
122                            acceptSemanticallyInvalidRequest ctx ar' input
123                   Just (path, def)
124                       → acceptRequestForResource ctx ar input path def
125
126 acceptSemanticallyInvalidRequest ∷ HandleLike h
127                                  ⇒ Context h
128                                  → AugmentedRequest
129                                  → Lazy.ByteString
130                                  → IO ()
131 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
132     = do sei ← mkSemanticallyInvalidInteraction cConfig ar
133          enqueue ctx sei
134          acceptRequest ctx input
135
136 acceptRequestForResource ∷ HandleLike h
137                          ⇒ Context h
138                          → AugmentedRequest
139                          → Lazy.ByteString
140                          → [Strict.ByteString]
141                          → Resource
142                          → IO ()
143 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
144     = do
145 #if defined(HAVE_SSL)
146          cert ← hGetPeerCert cHandle
147          ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
148 #else
149          ni   ← mkNormalInteraction cConfig cAddr ar rsrcPath
150 #endif
151          tid  ← spawnRsrc rsrcDef ni
152          enqueue ctx ni
153          if reqMustHaveBody arRequest then
154              waitForReceiveBodyReq ctx ni tid input
155          else
156              acceptRequest ctx input
157
158 waitForReceiveBodyReq ∷ HandleLike h
159                       ⇒ Context h
160                       → NormalInteraction
161                       → ThreadId
162                       → Lazy.ByteString
163                       → IO ()
164 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
165     = case fromJust niReqBodyLength of
166         Chunked
167             → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
168         Fixed len
169             → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
170
171 -- Toooooo long name for a function...
172 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
173                                             ⇒ Context h
174                                             → NormalInteraction
175                                             → ThreadId
176                                             → Lazy.ByteString
177                                             → IO ()
178 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
179     = join $
180       atomically $
181       do req ← takeTMVar niReceiveBodyReq
182          case req of
183            ReceiveBody wanted
184                → do putTMVar niSendContinue niExpectedContinue
185                     return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
186            WasteAll
187                → do putTMVar niSendContinue False
188                     return $ wasteAllChunks ctx rsrcTid input Initial
189
190 waitForReceiveChunkedBodyReq ∷ HandleLike h
191                              ⇒ Context h
192                              → NormalInteraction
193                              → ThreadId
194                              → Lazy.ByteString
195                              → ChunkReceivingState
196                              → IO ()
197 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
198     = do req ← atomically $ takeTMVar niReceiveBodyReq
199          case req of
200            ReceiveBody wanted
201                → readCurrentChunk ctx ni rsrcTid wanted input st
202            WasteAll
203                → wasteAllChunks ctx rsrcTid input st
204
205 wasteAllChunks ∷ HandleLike h
206                ⇒ Context h
207                → ThreadId
208                → Lazy.ByteString
209                → ChunkReceivingState
210                → IO ()
211 wasteAllChunks ctx rsrcTid = go
212     where
213       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
214       go input Initial
215           = case LP.parse chunkHeader input of
216               LP.Done input' chunkLen
217                   | chunkLen ≡ 0 → gotFinalChunk input'
218                   | otherwise    → gotChunk input' chunkLen
219               LP.Fail _ eCtx e
220                   → chunkWasMalformed rsrcTid eCtx e
221                        "wasteAllChunks: chunkHeader"
222       go input (InChunk chunkLen)
223           = gotChunk input chunkLen
224
225       gotChunk ∷ Lazy.ByteString → Int → IO ()
226       gotChunk input chunkLen
227           = let input' = Lazy.drop (fromIntegral chunkLen) input
228             in
229               case LP.parse chunkFooter input' of
230                 LP.Done input'' _
231                     → go input'' Initial
232                 LP.Fail _ eCtx e
233                     → chunkWasMalformed rsrcTid eCtx e
234                           "wasteAllChunks: chunkFooter"
235
236       gotFinalChunk ∷ Lazy.ByteString → IO ()
237       gotFinalChunk input
238           = case LP.parse chunkTrailer input of
239               LP.Done input' _
240                   → acceptRequest ctx input'
241               LP.Fail _ eCtx e
242                   → chunkWasMalformed rsrcTid eCtx e
243                         "wasteAllChunks: chunkTrailer"
244
245 readCurrentChunk ∷ HandleLike h
246                  ⇒ Context h
247                  → NormalInteraction
248                  → ThreadId
249                  → Int
250                  → Lazy.ByteString
251                  → ChunkReceivingState
252                  → IO ()
253 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
254     where
255       go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
256       go input Initial
257           = case LP.parse chunkHeader input of
258               LP.Done input' chunkLen
259                   | chunkLen ≡ 0
260                       → gotFinalChunk input'
261                   | otherwise
262                       → gotChunk input' chunkLen
263               LP.Fail _ eCtx e
264                   → chunkWasMalformed rsrcTid eCtx e
265                         "readCurrentChunk: chunkHeader"
266       go input (InChunk chunkLen)
267           = gotChunk input chunkLen
268
269       gotChunk ∷ Lazy.ByteString → Int → IO ()
270       gotChunk input chunkLen
271           = do let bytesToRead     = min wanted chunkLen
272                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
273                    block'          = Strict.concat $ Lazy.toChunks block
274                    actualReadBytes = Strict.length block'
275                    chunkLen'       = chunkLen - actualReadBytes
276                atomically $ putTMVar niReceivedBody block'
277                if chunkLen' ≡ 0 then
278                    case LP.parse chunkFooter input' of
279                      LP.Done input'' _
280                          → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
281                      LP.Fail _ eCtx e
282                          → chunkWasMalformed rsrcTid eCtx e
283                                "readCurrentChunk: chunkFooter"
284                else
285                    waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
286
287       gotFinalChunk ∷ Lazy.ByteString → IO ()
288       gotFinalChunk input
289           = do atomically $ putTMVar niReceivedBody (∅)
290                case LP.parse chunkTrailer input of
291                  LP.Done input' _
292                      → acceptRequest ctx input'
293                  LP.Fail _ eCtx e
294                      → chunkWasMalformed rsrcTid eCtx e
295                            "readCurrentChunk: chunkTrailer"
296
297 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
298 chunkWasMalformed tid eCtx e msg
299     = let abo = mkAbortion BadRequest [("Connection", "close")]
300                 $ Just
301                 $ "chunkWasMalformed: "
302                 ⊕ T.pack msg
303                 ⊕ ": "
304                 ⊕ T.pack (intercalate ", " eCtx)
305                 ⊕ ": "
306                 ⊕ T.pack e
307       in
308         throwTo tid abo
309
310 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
311                                                ⇒ Context h
312                                                → NormalInteraction
313                                                → Lazy.ByteString
314                                                → Int
315                                                → IO ()
316 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
317     = join $
318       atomically $
319       do req ← takeTMVar niReceiveBodyReq
320          case req of
321            ReceiveBody wanted
322                → do putTMVar niSendContinue niExpectedContinue
323                     return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
324            WasteAll
325                → do putTMVar niSendContinue False
326                     return $ wasteNonChunkedRequestBody ctx input bodyLen
327
328 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
329                                 ⇒ Context h
330                                 → NormalInteraction
331                                 → Lazy.ByteString
332                                 → Int
333                                 → IO ()
334 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
335     = do req ← atomically $ takeTMVar niReceiveBodyReq
336          case req of
337            ReceiveBody wanted
338                → readNonChunkedRequestBody ctx ni input bodyLen wanted
339            WasteAll
340                → wasteNonChunkedRequestBody ctx input bodyLen
341
342 wasteNonChunkedRequestBody ∷ HandleLike h
343                            ⇒ Context h
344                            → Lazy.ByteString
345                            → Int
346                            → IO ()
347 wasteNonChunkedRequestBody ctx input bodyLen
348     = do let input' = Lazy.drop (fromIntegral bodyLen) input
349          acceptRequest ctx input'
350
351 readNonChunkedRequestBody ∷ HandleLike h
352                           ⇒ Context h
353                           → NormalInteraction
354                           → Lazy.ByteString
355                           → Int
356                           → Int
357                           → IO ()
358 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
359     | bodyLen ≡ 0 = gotEndOfRequest
360     | otherwise   = gotBody
361     where
362       gotBody ∷ IO ()
363       gotBody
364           = do let bytesToRead     = min wanted bodyLen
365                    (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
366                    block'          = Strict.concat $ Lazy.toChunks block
367                    actualReadBytes = Strict.length block'
368                    bodyLen'        = bodyLen - actualReadBytes
369                atomically $ putTMVar niReceivedBody block'
370                waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
371
372       gotEndOfRequest ∷ IO ()
373       gotEndOfRequest
374           = do atomically $ putTMVar niReceivedBody (∅)
375                acceptRequest ctx input
376
377 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
378 enqueue (Context {..}) = enqueue' cQueue
379
380 enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
381 enqueue' tQueue itr
382     = atomically $
383       do queue ← readTVar tQueue
384          writeTVar tQueue (toInteraction itr ⊲ queue)