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.Resource.Internal
38 import Network.HTTP.Lucu.Utils
40 import Prelude.Unicode
41 import System.IO (hPutStrLn, stderr)
50 , cQueue ∷ !InteractionQueue
53 data ChunkReceivingState
55 | InChunk !Int -- ^Number of remaining octets in the current
56 -- chunk. It's always positive.
58 requestReader ∷ (HostMapper hm, HandleLike h)
66 requestReader cnf hm h port addr tQueue
67 = do input ← hGetLBS h
68 acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input
70 [ Handler handleAsyncE
71 , Handler handleOthers
74 enqueue' tQueue EndOfInteraction
76 handleAsyncE ∷ AsyncException → IO ()
77 handleAsyncE ThreadKilled = return ()
78 handleAsyncE e = dump e
80 handleOthers ∷ SomeException → IO ()
83 dump ∷ Exception e ⇒ e → IO ()
85 = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
86 hPutStrLn stderr $ show e
88 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
89 acceptRequest ctx@(Context {..}) input
91 do queue ← readTVar cQueue
92 when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
93 -- Too many requests in the pipeline...
95 if Lazy.null input then
98 case LP.parse def input of
99 LP.Done input' req → acceptParsableRequest ctx req input'
100 LP.Fail _ _ _ → acceptNonparsableRequest ctx
102 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
103 acceptNonparsableRequest ctx@(Context {..})
104 = do syi ← mkSyntacticallyInvalidInteraction cConfig
107 acceptParsableRequest ∷ HandleLike h
112 acceptParsableRequest ctx@(Context {..}) req input
113 = do let ar = preprocess (cnfServerHost cConfig) cPort req
114 if isError $ arInitialStatus ar then
115 acceptSemanticallyInvalidRequest ctx ar input
117 do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
121 arInitialStatus = fromStatusCode NotFound
123 acceptSemanticallyInvalidRequest ctx ar' input
125 → acceptRequestForResource ctx ar input path rsrc
127 acceptSemanticallyInvalidRequest ∷ HandleLike h
132 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
133 = do sei ← mkSemanticallyInvalidInteraction cConfig ar
135 acceptRequest ctx input
137 acceptRequestForResource ∷ HandleLike h
141 → [Strict.ByteString]
144 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc
146 #if defined(HAVE_SSL)
147 cert ← hGetPeerCert cHandle
148 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
150 ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
152 tid ← spawnRsrc rsrc ni
154 if reqHasBody arRequest then
155 waitForReceiveBodyReq ctx ni tid input
157 acceptRequest ctx input
159 waitForReceiveBodyReq ∷ HandleLike h
165 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
166 = case fromJust niReqBodyLength of
168 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
170 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
172 -- Toooooo long name for a function...
173 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
179 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
182 do req ← takeTMVar niReceiveBodyReq
185 → do putTMVar niSendContinue niExpectedContinue
186 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
188 → do putTMVar niSendContinue False
189 return $ wasteAllChunks ctx rsrcTid input Initial
191 waitForReceiveChunkedBodyReq ∷ HandleLike h
196 → ChunkReceivingState
198 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
199 = do req ← atomically $ takeTMVar niReceiveBodyReq
202 → readCurrentChunk ctx ni rsrcTid wanted input st
204 → wasteAllChunks ctx rsrcTid input st
206 wasteAllChunks ∷ HandleLike h
210 → ChunkReceivingState
212 wasteAllChunks ctx rsrcTid = go
214 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
216 = case LP.parse chunkHeader input of
217 LP.Done input' chunkLen
218 | chunkLen ≡ 0 → gotFinalChunk input'
219 | otherwise → gotChunk input' chunkLen
221 → chunkWasMalformed rsrcTid eCtx e
222 "wasteAllChunks: chunkHeader"
223 go input (InChunk chunkLen)
224 = gotChunk input chunkLen
226 gotChunk ∷ Lazy.ByteString → Int → IO ()
227 gotChunk input chunkLen
228 = let input' = Lazy.drop (fromIntegral chunkLen) input
230 case LP.parse chunkFooter input' of
234 → chunkWasMalformed rsrcTid eCtx e
235 "wasteAllChunks: chunkFooter"
237 gotFinalChunk ∷ Lazy.ByteString → IO ()
239 = case LP.parse chunkTrailer input of
241 → acceptRequest ctx input'
243 → chunkWasMalformed rsrcTid eCtx e
244 "wasteAllChunks: chunkTrailer"
246 readCurrentChunk ∷ HandleLike h
252 → ChunkReceivingState
254 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
256 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
258 = case LP.parse chunkHeader input of
259 LP.Done input' chunkLen
261 → gotFinalChunk input'
263 → gotChunk input' chunkLen
265 → chunkWasMalformed rsrcTid eCtx e
266 "readCurrentChunk: chunkHeader"
267 go input (InChunk chunkLen)
268 = gotChunk input chunkLen
270 gotChunk ∷ Lazy.ByteString → Int → IO ()
271 gotChunk input chunkLen
272 = do let bytesToRead = min wanted chunkLen
273 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
274 block' = Strict.concat $ Lazy.toChunks block
275 actualReadBytes = Strict.length block'
276 chunkLen' = chunkLen - actualReadBytes
277 atomically $ putTMVar niReceivedBody block'
278 if chunkLen' ≡ 0 then
279 case LP.parse chunkFooter input' of
281 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
283 → chunkWasMalformed rsrcTid eCtx e
284 "readCurrentChunk: chunkFooter"
286 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
288 gotFinalChunk ∷ Lazy.ByteString → IO ()
290 = do atomically $ putTMVar niReceivedBody (∅)
291 case LP.parse chunkTrailer input of
293 → acceptRequest ctx input'
295 → chunkWasMalformed rsrcTid eCtx e
296 "readCurrentChunk: chunkTrailer"
298 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
299 chunkWasMalformed tid eCtx e msg
300 = let abo = mkAbortion BadRequest [("Connection", "close")]
302 $ "chunkWasMalformed: "
305 ⊕ cs (intercalate ", " eCtx)
311 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
317 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
320 do req ← takeTMVar niReceiveBodyReq
323 → do putTMVar niSendContinue niExpectedContinue
324 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
326 → do putTMVar niSendContinue False
327 return $ wasteNonChunkedRequestBody ctx input bodyLen
329 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
335 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
336 = do req ← atomically $ takeTMVar niReceiveBodyReq
339 → readNonChunkedRequestBody ctx ni input bodyLen wanted
341 → wasteNonChunkedRequestBody ctx input bodyLen
343 wasteNonChunkedRequestBody ∷ HandleLike h
348 wasteNonChunkedRequestBody ctx input bodyLen
349 = do let input' = Lazy.drop (fromIntegral bodyLen) input
350 acceptRequest ctx input'
352 readNonChunkedRequestBody ∷ HandleLike h
359 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
360 | bodyLen ≡ 0 = gotEndOfRequest
361 | otherwise = gotBody
365 = do let bytesToRead = min wanted bodyLen
366 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
367 block' = Strict.concat $ Lazy.toChunks block
368 actualReadBytes = Strict.length block'
369 bodyLen' = bodyLen - actualReadBytes
370 atomically $ putTMVar niReceivedBody block'
371 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
373 gotEndOfRequest ∷ IO ()
375 = do atomically $ putTMVar niReceivedBody (∅)
376 acceptRequest ctx input
378 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
379 enqueue (Context {..}) = enqueue' cQueue
381 enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
384 do queue ← readTVar tQueue
385 writeTVar tQueue (toInteraction itr ⊲ queue)