8 module Network.HTTP.Lucu.RequestReader
12 import Control.Concurrent
13 import Control.Concurrent.STM
14 import Control.Exception hiding (block)
16 import qualified Data.Attoparsec.Lazy as LP
17 import qualified Data.ByteString as Strict
18 import qualified Data.ByteString.Lazy as Lazy
21 import Data.Monoid.Unicode
22 import qualified Data.Sequence as S
23 import Data.Sequence.Unicode hiding ((∅))
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
36 import Prelude.Unicode
37 import System.IO (hPutStrLn, stderr)
43 , cFallbacks ∷ ![FallbackHandler]
47 , cQueue ∷ !InteractionQueue
50 data ChunkReceivingState
52 | InChunk !Int -- ^Number of remaining octets in the current
53 -- chunk. It's always positive.
55 requestReader ∷ HandleLike h
64 requestReader cnf tree fbs h port addr tQueue
65 = do input ← hGetLBS h
66 acceptRequest (Context cnf tree fbs h port addr tQueue) input
68 [ Handler handleAsyncE
70 , Handler handleOthers
73 handleAsyncE ∷ AsyncException → IO ()
74 handleAsyncE ThreadKilled = return ()
75 handleAsyncE e = dump e
77 handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
80 handleOthers ∷ SomeException → IO ()
83 dump ∷ Exception e ⇒ e → IO ()
85 = do hPutStrLn stderr "requestReader caught an exception:"
86 hPutStrLn stderr (show $ toException e)
88 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
89 acceptRequest ctx@(Context {..}) input
90 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
93 do queue ← readTVar cQueue
94 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
96 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
97 -- Request 應答を設定し、それを出力してから切斷するやうに
98 -- ResponseWriter に通知する。
99 case LP.parse request 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 rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
122 arInitialStatus = fromStatusCode NotFound
124 acceptSemanticallyInvalidRequest ctx ar' input
126 → acceptRequestForResource ctx ar input path def
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 rsrcDef
146 = do cert ← hGetPeerCert cHandle
147 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
148 tid ← spawnResource rsrcDef ni
150 if reqMustHaveBody arRequest then
151 waitForReceiveBodyReq ctx ni tid input
153 acceptRequest ctx input
155 waitForReceiveBodyReq ∷ HandleLike h
161 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
162 = case fromJust niReqBodyLength of
164 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
166 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
168 -- Toooooo long name for a function...
169 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
175 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
178 do req ← takeTMVar niReceiveBodyReq
181 → do putTMVar niSendContinue niExpectedContinue
182 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
184 → do putTMVar niSendContinue False
185 return $ wasteAllChunks ctx rsrcTid input Initial
187 waitForReceiveChunkedBodyReq ∷ HandleLike h
192 → ChunkReceivingState
194 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
195 = do req ← atomically $ takeTMVar niReceiveBodyReq
198 → readCurrentChunk ctx ni rsrcTid wanted input st
200 → wasteAllChunks ctx rsrcTid input st
202 wasteAllChunks ∷ HandleLike h
206 → ChunkReceivingState
208 wasteAllChunks ctx rsrcTid = go
210 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
212 = case LP.parse chunkHeader input of
213 LP.Done input' chunkLen
214 | chunkLen ≡ 0 → gotFinalChunk input'
215 | otherwise → gotChunk input' chunkLen
217 → chunkWasMalformed rsrcTid eCtx e
218 "wasteAllChunks: chunkHeader"
219 go input (InChunk chunkLen)
220 = gotChunk input chunkLen
222 gotChunk ∷ Lazy.ByteString → Int → IO ()
223 gotChunk input chunkLen
224 = let input' = Lazy.drop (fromIntegral chunkLen) input
226 case LP.parse chunkFooter input' of
230 → chunkWasMalformed rsrcTid eCtx e
231 "wasteAllChunks: chunkFooter"
233 gotFinalChunk ∷ Lazy.ByteString → IO ()
235 = case LP.parse chunkTrailer input of
237 → acceptRequest ctx input'
239 → chunkWasMalformed rsrcTid eCtx e
240 "wasteAllChunks: chunkTrailer"
242 readCurrentChunk ∷ HandleLike h
248 → ChunkReceivingState
250 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
252 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
254 = case LP.parse chunkHeader input of
255 LP.Done input' chunkLen
257 → gotFinalChunk input'
259 → gotChunk input' chunkLen
261 → chunkWasMalformed rsrcTid eCtx e
262 "readCurrentChunk: chunkHeader"
263 go input (InChunk chunkLen)
264 = gotChunk input chunkLen
266 gotChunk ∷ Lazy.ByteString → Int → IO ()
267 gotChunk input chunkLen
268 = do let bytesToRead = min wanted chunkLen
269 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
270 block' = Strict.concat $ Lazy.toChunks block
271 actualReadBytes = Strict.length block'
272 chunkLen' = chunkLen - actualReadBytes
273 atomically $ putTMVar niReceivedBody block'
274 if chunkLen' ≡ 0 then
275 case LP.parse chunkFooter input' of
277 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
279 → chunkWasMalformed rsrcTid eCtx e
280 "readCurrentChunk: chunkFooter"
282 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
284 gotFinalChunk ∷ Lazy.ByteString → IO ()
286 = do atomically $ putTMVar niReceivedBody (∅)
287 case LP.parse chunkTrailer input of
289 → acceptRequest ctx input'
291 → chunkWasMalformed rsrcTid eCtx e
292 "readCurrentChunk: chunkTrailer"
294 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
295 chunkWasMalformed tid eCtx e msg
296 = let abo = mkAbortion BadRequest [("Connection", "close")]
298 $ "chunkWasMalformed: "
301 ⊕ T.pack (intercalate ", " eCtx)
307 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
313 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
316 do req ← takeTMVar niReceiveBodyReq
319 → do putTMVar niSendContinue niExpectedContinue
320 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
322 → do putTMVar niSendContinue False
323 return $ wasteNonChunkedRequestBody ctx input bodyLen
325 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
331 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
332 = do req ← atomically $ takeTMVar niReceiveBodyReq
335 → readNonChunkedRequestBody ctx ni input bodyLen wanted
337 → wasteNonChunkedRequestBody ctx input bodyLen
339 wasteNonChunkedRequestBody ∷ HandleLike h
344 wasteNonChunkedRequestBody ctx input bodyLen
345 = do let input' = Lazy.drop (fromIntegral bodyLen) input
346 acceptRequest ctx input'
348 readNonChunkedRequestBody ∷ HandleLike h
355 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
356 | bodyLen ≡ 0 = gotEndOfRequest
357 | otherwise = gotBody
361 = do let bytesToRead = min wanted bodyLen
362 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
363 block' = Strict.concat $ Lazy.toChunks block
364 actualReadBytes = Strict.length block'
365 bodyLen' = bodyLen - actualReadBytes
366 atomically $ putTMVar niReceivedBody block'
367 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
369 gotEndOfRequest ∷ IO ()
371 = do atomically $ putTMVar niReceivedBody (∅)
372 acceptRequest ctx input
374 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
375 {-# INLINEABLE enqueue #-}
376 enqueue (Context {..}) itr
378 do queue ← readTVar cQueue
379 writeTVar cQueue (toInteraction itr ⊲ queue)