9 module Network.HTTP.Lucu.RequestReader
13 import Control.Concurrent
14 import Control.Concurrent.STM
15 import Control.Exception hiding (block)
17 import Control.Monad.Trans.Maybe
18 import qualified Data.Attoparsec.Lazy as LP
19 import qualified Data.ByteString as Strict
20 import qualified Data.ByteString.Lazy as Lazy
21 import Data.Convertible.Base
22 import Data.Convertible.Instances.Text ()
26 import Data.Monoid.Unicode
27 import qualified Data.Sequence as S
28 import Network.HTTP.Lucu.Abortion
29 import Network.HTTP.Lucu.Config
30 import Network.HTTP.Lucu.Chunk
31 import Network.HTTP.Lucu.Dispatcher.Internal
32 import Network.HTTP.Lucu.HandleLike
33 import Network.HTTP.Lucu.Interaction
34 import Network.HTTP.Lucu.Preprocess
35 import Network.HTTP.Lucu.Request
36 import Network.HTTP.Lucu.Response
37 import Network.HTTP.Lucu.Response.StatusCode
38 import Network.HTTP.Lucu.Resource.Internal
39 import Network.HTTP.Lucu.Utils
41 import Prelude.Unicode
42 import System.IO (hPutStrLn, stderr)
51 , cQueue ∷ !InteractionQueue
54 data ChunkReceivingState
56 | InChunk !Int -- ^Number of remaining octets in the current
57 -- chunk. It's always positive.
59 requestReader ∷ (HostMapper hm, HandleLike h)
67 requestReader cnf hm h port addr tQueue
68 = do input ← hGetLBS h
69 acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input
71 [ Handler handleAsyncE
72 , Handler handleOthers
75 enqueue' tQueue EndOfInteraction
77 handleAsyncE ∷ AsyncException → IO ()
78 handleAsyncE ThreadKilled = return ()
79 handleAsyncE e = dump e
81 handleOthers ∷ SomeException → IO ()
84 dump ∷ Exception e ⇒ e → IO ()
86 = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
87 hPutStrLn stderr $ show e
89 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
90 acceptRequest ctx@(Context {..}) input
92 do queue ← readTVar cQueue
93 when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
94 -- Too many requests in the pipeline...
96 if Lazy.null input then
99 case LP.parse def input of
100 LP.Done input' req → acceptParsableRequest ctx req input'
101 LP.Fail _ _ _ → acceptNonparsableRequest ctx
103 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
104 acceptNonparsableRequest ctx@(Context {..})
105 = do syi ← mkSyntacticallyInvalidInteraction cConfig
108 acceptParsableRequest ∷ HandleLike h
113 acceptParsableRequest ctx@(Context {..}) req input
114 = do let ar = preprocess (cnfServerHost cConfig) cPort req
115 if isError $ arInitialStatus ar then
116 acceptSemanticallyInvalidRequest ctx ar input
118 do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
122 arInitialStatus = fromStatusCode NotFound
124 acceptSemanticallyInvalidRequest ctx ar' input
126 → acceptRequestForResource ctx ar input path rsrc
128 acceptSemanticallyInvalidRequest ∷ HandleLike h
133 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
134 = do sei ← mkSemanticallyInvalidInteraction cConfig ar
136 acceptRequest ctx input
138 acceptRequestForResource ∷ HandleLike h
142 → [Strict.ByteString]
145 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc
147 #if defined(HAVE_SSL)
148 cert ← hGetPeerCert cHandle
149 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
151 ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
153 tid ← spawnRsrc rsrc ni
155 if reqHasBody arRequest then
156 waitForReceiveBodyReq ctx ni tid input
158 acceptRequest ctx input
160 waitForReceiveBodyReq ∷ HandleLike h
166 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
167 = case fromJust niReqBodyLength of
169 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
171 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
173 -- Toooooo long name for a function...
174 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
180 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
183 do req ← takeTMVar niReceiveBodyReq
186 → do putTMVar niSendContinue niExpectedContinue
187 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
189 → do putTMVar niSendContinue False
190 return $ wasteAllChunks ctx rsrcTid input Initial
192 waitForReceiveChunkedBodyReq ∷ HandleLike h
197 → ChunkReceivingState
199 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
200 = do req ← atomically $ takeTMVar niReceiveBodyReq
203 → readCurrentChunk ctx ni rsrcTid wanted input st
205 → wasteAllChunks ctx rsrcTid input st
207 wasteAllChunks ∷ HandleLike h
211 → ChunkReceivingState
213 wasteAllChunks ctx rsrcTid = go
215 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
217 = case LP.parse chunkHeader input of
218 LP.Done input' chunkLen
219 | chunkLen ≡ 0 → gotFinalChunk input'
220 | otherwise → gotChunk input' chunkLen
222 → chunkWasMalformed rsrcTid eCtx e
223 "wasteAllChunks: chunkHeader"
224 go input (InChunk chunkLen)
225 = gotChunk input chunkLen
227 gotChunk ∷ Lazy.ByteString → Int → IO ()
228 gotChunk input chunkLen
229 = let input' = Lazy.drop (fromIntegral chunkLen) input
231 case LP.parse chunkFooter input' of
235 → chunkWasMalformed rsrcTid eCtx e
236 "wasteAllChunks: chunkFooter"
238 gotFinalChunk ∷ Lazy.ByteString → IO ()
240 = case LP.parse chunkTrailer input of
242 → acceptRequest ctx input'
244 → chunkWasMalformed rsrcTid eCtx e
245 "wasteAllChunks: chunkTrailer"
247 readCurrentChunk ∷ HandleLike h
253 → ChunkReceivingState
255 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
257 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
259 = case LP.parse chunkHeader input of
260 LP.Done input' chunkLen
262 → gotFinalChunk input'
264 → gotChunk input' chunkLen
266 → chunkWasMalformed rsrcTid eCtx e
267 "readCurrentChunk: chunkHeader"
268 go input (InChunk chunkLen)
269 = gotChunk input chunkLen
271 gotChunk ∷ Lazy.ByteString → Int → IO ()
272 gotChunk input chunkLen
273 = do let bytesToRead = min wanted chunkLen
274 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
275 block' = Strict.concat $ Lazy.toChunks block
276 actualReadBytes = Strict.length block'
277 chunkLen' = chunkLen - actualReadBytes
278 atomically $ putTMVar niReceivedBody block'
279 if chunkLen' ≡ 0 then
280 case LP.parse chunkFooter input' of
282 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
284 → chunkWasMalformed rsrcTid eCtx e
285 "readCurrentChunk: chunkFooter"
287 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
289 gotFinalChunk ∷ Lazy.ByteString → IO ()
291 = do atomically $ putTMVar niReceivedBody (∅)
292 case LP.parse chunkTrailer input of
294 → acceptRequest ctx input'
296 → chunkWasMalformed rsrcTid eCtx e
297 "readCurrentChunk: chunkTrailer"
299 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
300 chunkWasMalformed tid eCtx e msg
301 = let abo = mkAbortion BadRequest [("Connection", "close")]
303 $ "chunkWasMalformed: "
306 ⊕ cs (intercalate ", " eCtx)
312 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
318 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
321 do req ← takeTMVar niReceiveBodyReq
324 → do putTMVar niSendContinue niExpectedContinue
325 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
327 → do putTMVar niSendContinue False
328 return $ wasteNonChunkedRequestBody ctx input bodyLen
330 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
336 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
337 = do req ← atomically $ takeTMVar niReceiveBodyReq
340 → readNonChunkedRequestBody ctx ni input bodyLen wanted
342 → wasteNonChunkedRequestBody ctx input bodyLen
344 wasteNonChunkedRequestBody ∷ HandleLike h
349 wasteNonChunkedRequestBody ctx input bodyLen
350 = do let input' = Lazy.drop (fromIntegral bodyLen) input
351 acceptRequest ctx input'
353 readNonChunkedRequestBody ∷ HandleLike h
360 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
361 | bodyLen ≡ 0 = gotEndOfRequest
362 | otherwise = gotBody
366 = do let bytesToRead = min wanted bodyLen
367 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
368 block' = Strict.concat $ Lazy.toChunks block
369 actualReadBytes = Strict.length block'
370 bodyLen' = bodyLen - actualReadBytes
371 atomically $ putTMVar niReceivedBody block'
372 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
374 gotEndOfRequest ∷ IO ()
376 = do atomically $ putTMVar niReceivedBody (∅)
377 acceptRequest ctx input
379 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
380 enqueue (Context {..}) = enqueue' cQueue
382 enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
385 do queue ← readTVar tQueue
386 writeTVar tQueue (toInteraction itr ⊲ queue)