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
23 import Data.Monoid.Unicode
24 import qualified Data.Sequence as S
25 import qualified Data.Text as T
26 import Network.HTTP.Lucu.Abortion
27 import Network.HTTP.Lucu.Config
28 import Network.HTTP.Lucu.Chunk
29 import Network.HTTP.Lucu.Dispatcher.Internal
30 import Network.HTTP.Lucu.HandleLike
31 import Network.HTTP.Lucu.Interaction
32 import Network.HTTP.Lucu.Preprocess
33 import Network.HTTP.Lucu.Request
34 import Network.HTTP.Lucu.Response
35 import Network.HTTP.Lucu.Resource.Internal
36 import Network.HTTP.Lucu.Utils
38 import Prelude.Unicode
39 import System.IO (hPutStrLn, stderr)
48 , cQueue ∷ !InteractionQueue
51 data ChunkReceivingState
53 | InChunk !Int -- ^Number of remaining octets in the current
54 -- chunk. It's always positive.
56 requestReader ∷ (HostMapper hm, HandleLike h)
64 requestReader cnf hm h port addr tQueue
65 = do input ← hGetLBS h
66 acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input
68 [ Handler handleAsyncE
69 , Handler handleOthers
72 enqueue' tQueue EndOfInteraction
74 handleAsyncE ∷ AsyncException → IO ()
75 handleAsyncE ThreadKilled = return ()
76 handleAsyncE e = dump e
78 handleOthers ∷ SomeException → IO ()
81 dump ∷ Exception e ⇒ e → IO ()
83 = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
84 hPutStrLn stderr $ show e
86 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
87 acceptRequest ctx@(Context {..}) input
89 do queue ← readTVar cQueue
90 when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
91 -- Too many requests in the pipeline...
93 if Lazy.null input then
96 case LP.parse request input of
97 LP.Done input' req → acceptParsableRequest ctx req input'
98 LP.Fail _ _ _ → acceptNonparsableRequest ctx
100 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
101 acceptNonparsableRequest ctx@(Context {..})
102 = do syi ← mkSyntacticallyInvalidInteraction cConfig
105 acceptParsableRequest ∷ HandleLike h
110 acceptParsableRequest ctx@(Context {..}) req input
111 = do let ar = preprocess (cnfServerHost cConfig) cPort req
112 if isError $ arInitialStatus ar then
113 acceptSemanticallyInvalidRequest ctx ar input
115 do rsrc ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
119 arInitialStatus = fromStatusCode NotFound
121 acceptSemanticallyInvalidRequest ctx ar' input
123 → acceptRequestForResource ctx ar input path def
125 acceptSemanticallyInvalidRequest ∷ HandleLike h
130 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
131 = do sei ← mkSemanticallyInvalidInteraction cConfig ar
133 acceptRequest ctx input
135 acceptRequestForResource ∷ HandleLike h
139 → [Strict.ByteString]
142 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
144 #if defined(HAVE_SSL)
145 cert ← hGetPeerCert cHandle
146 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
148 ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
150 tid ← spawnRsrc rsrcDef ni
152 if reqMustHaveBody arRequest then
153 waitForReceiveBodyReq ctx ni tid input
155 acceptRequest ctx input
157 waitForReceiveBodyReq ∷ HandleLike h
163 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
164 = case fromJust niReqBodyLength of
166 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
168 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
170 -- Toooooo long name for a function...
171 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
177 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
180 do req ← takeTMVar niReceiveBodyReq
183 → do putTMVar niSendContinue niExpectedContinue
184 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
186 → do putTMVar niSendContinue False
187 return $ wasteAllChunks ctx rsrcTid input Initial
189 waitForReceiveChunkedBodyReq ∷ HandleLike h
194 → ChunkReceivingState
196 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
197 = do req ← atomically $ takeTMVar niReceiveBodyReq
200 → readCurrentChunk ctx ni rsrcTid wanted input st
202 → wasteAllChunks ctx rsrcTid input st
204 wasteAllChunks ∷ HandleLike h
208 → ChunkReceivingState
210 wasteAllChunks ctx rsrcTid = go
212 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
214 = case LP.parse chunkHeader input of
215 LP.Done input' chunkLen
216 | chunkLen ≡ 0 → gotFinalChunk input'
217 | otherwise → gotChunk input' chunkLen
219 → chunkWasMalformed rsrcTid eCtx e
220 "wasteAllChunks: chunkHeader"
221 go input (InChunk chunkLen)
222 = gotChunk input chunkLen
224 gotChunk ∷ Lazy.ByteString → Int → IO ()
225 gotChunk input chunkLen
226 = let input' = Lazy.drop (fromIntegral chunkLen) input
228 case LP.parse chunkFooter input' of
232 → chunkWasMalformed rsrcTid eCtx e
233 "wasteAllChunks: chunkFooter"
235 gotFinalChunk ∷ Lazy.ByteString → IO ()
237 = case LP.parse chunkTrailer input of
239 → acceptRequest ctx input'
241 → chunkWasMalformed rsrcTid eCtx e
242 "wasteAllChunks: chunkTrailer"
244 readCurrentChunk ∷ HandleLike h
250 → ChunkReceivingState
252 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
254 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
256 = case LP.parse chunkHeader input of
257 LP.Done input' chunkLen
259 → gotFinalChunk input'
261 → gotChunk input' chunkLen
263 → chunkWasMalformed rsrcTid eCtx e
264 "readCurrentChunk: chunkHeader"
265 go input (InChunk chunkLen)
266 = gotChunk input chunkLen
268 gotChunk ∷ Lazy.ByteString → Int → IO ()
269 gotChunk input chunkLen
270 = do let bytesToRead = min wanted chunkLen
271 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
272 block' = Strict.concat $ Lazy.toChunks block
273 actualReadBytes = Strict.length block'
274 chunkLen' = chunkLen - actualReadBytes
275 atomically $ putTMVar niReceivedBody block'
276 if chunkLen' ≡ 0 then
277 case LP.parse chunkFooter input' of
279 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
281 → chunkWasMalformed rsrcTid eCtx e
282 "readCurrentChunk: chunkFooter"
284 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
286 gotFinalChunk ∷ Lazy.ByteString → IO ()
288 = do atomically $ putTMVar niReceivedBody (∅)
289 case LP.parse chunkTrailer input of
291 → acceptRequest ctx input'
293 → chunkWasMalformed rsrcTid eCtx e
294 "readCurrentChunk: chunkTrailer"
296 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
297 chunkWasMalformed tid eCtx e msg
298 = let abo = mkAbortion BadRequest [("Connection", "close")]
300 $ "chunkWasMalformed: "
303 ⊕ T.pack (intercalate ", " eCtx)
309 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
315 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
318 do req ← takeTMVar niReceiveBodyReq
321 → do putTMVar niSendContinue niExpectedContinue
322 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
324 → do putTMVar niSendContinue False
325 return $ wasteNonChunkedRequestBody ctx input bodyLen
327 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
333 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
334 = do req ← atomically $ takeTMVar niReceiveBodyReq
337 → readNonChunkedRequestBody ctx ni input bodyLen wanted
339 → wasteNonChunkedRequestBody ctx input bodyLen
341 wasteNonChunkedRequestBody ∷ HandleLike h
346 wasteNonChunkedRequestBody ctx input bodyLen
347 = do let input' = Lazy.drop (fromIntegral bodyLen) input
348 acceptRequest ctx input'
350 readNonChunkedRequestBody ∷ HandleLike h
357 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
358 | bodyLen ≡ 0 = gotEndOfRequest
359 | otherwise = gotBody
363 = do let bytesToRead = min wanted bodyLen
364 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
365 block' = Strict.concat $ Lazy.toChunks block
366 actualReadBytes = Strict.length block'
367 bodyLen' = bodyLen - actualReadBytes
368 atomically $ putTMVar niReceivedBody block'
369 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
371 gotEndOfRequest ∷ IO ()
373 = do atomically $ putTMVar niReceivedBody (∅)
374 acceptRequest ctx input
376 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
377 enqueue (Context {..}) = enqueue' cQueue
379 enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
382 do queue ← readTVar tQueue
383 writeTVar tQueue (toInteraction itr ⊲ queue)