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
20 import qualified Data.Strict.Maybe as S
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 requestP 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
121 → do let ar' = ar { arInitialStatus = NotFound }
122 acceptSemanticallyInvalidRequest ctx ar' input
124 → acceptRequestForResource ctx ar input path def
126 acceptSemanticallyInvalidRequest ∷ HandleLike h
131 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
132 = do sei ← mkSemanticallyInvalidInteraction cConfig ar
134 acceptRequest ctx input
136 acceptRequestForResource ∷ HandleLike h
140 → [Strict.ByteString]
143 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
144 = do cert ← hGetPeerCert cHandle
145 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
146 tid ← spawnResource rsrcDef ni
148 if reqMustHaveBody arRequest then
149 waitForReceiveBodyReq ctx ni tid input
151 acceptRequest ctx input
153 waitForReceiveBodyReq ∷ HandleLike h
159 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
160 = case S.fromJust niReqBodyLength of
162 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
164 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
166 -- Toooooo long name for a function...
167 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
173 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
176 do req ← takeTMVar niReceiveBodyReq
179 → do putTMVar niSendContinue niExpectedContinue
180 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
182 → do putTMVar niSendContinue False
183 return $ wasteAllChunks ctx rsrcTid input Initial
185 waitForReceiveChunkedBodyReq ∷ HandleLike h
190 → ChunkReceivingState
192 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
193 = do req ← atomically $ takeTMVar niReceiveBodyReq
196 → readCurrentChunk ctx ni rsrcTid wanted input st
198 → wasteAllChunks ctx rsrcTid input st
200 wasteAllChunks ∷ HandleLike h
204 → ChunkReceivingState
206 wasteAllChunks ctx rsrcTid = go
208 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
210 = case LP.parse chunkHeaderP input of
211 LP.Done input' chunkLen
212 | chunkLen ≡ 0 → gotFinalChunk input'
213 | otherwise → gotChunk input' chunkLen
215 → chunkWasMalformed rsrcTid eCtx e
216 "wasteAllChunks: chunkHeaderP"
217 go input (InChunk chunkLen)
218 = gotChunk input chunkLen
220 gotChunk ∷ Lazy.ByteString → Int → IO ()
221 gotChunk input chunkLen
222 = let input' = Lazy.drop (fromIntegral chunkLen) input
224 case LP.parse chunkFooterP input' of
228 → chunkWasMalformed rsrcTid eCtx e
229 "wasteAllChunks: chunkFooterP"
231 gotFinalChunk ∷ Lazy.ByteString → IO ()
233 = case LP.parse chunkTrailerP input of
235 → acceptRequest ctx input'
237 → chunkWasMalformed rsrcTid eCtx e
238 "wasteAllChunks: chunkTrailerP"
240 readCurrentChunk ∷ HandleLike h
246 → ChunkReceivingState
248 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
250 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
252 = case LP.parse chunkHeaderP input of
253 LP.Done input' chunkLen
255 → gotFinalChunk input'
257 → gotChunk input' chunkLen
259 → chunkWasMalformed rsrcTid eCtx e
260 "readCurrentChunk: chunkHeaderP"
261 go input (InChunk chunkLen)
262 = gotChunk input chunkLen
264 gotChunk ∷ Lazy.ByteString → Int → IO ()
265 gotChunk input chunkLen
266 = do let bytesToRead = min wanted chunkLen
267 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
268 block' = Strict.concat $ Lazy.toChunks block
269 actualReadBytes = Strict.length block'
270 chunkLen' = chunkLen - actualReadBytes
271 atomically $ putTMVar niReceivedBody block'
272 if chunkLen' ≡ 0 then
273 case LP.parse chunkFooterP input' of
275 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
277 → chunkWasMalformed rsrcTid eCtx e
278 "readCurrentChunk: chunkFooterP: "
280 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
282 gotFinalChunk ∷ Lazy.ByteString → IO ()
284 = do atomically $ putTMVar niReceivedBody (∅)
285 case LP.parse chunkTrailerP input of
287 → acceptRequest ctx input'
289 → chunkWasMalformed rsrcTid eCtx e
290 "readCurrentChunk: chunkTrailerP"
292 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
293 chunkWasMalformed tid eCtx e msg
294 = let abo = mkAbortion BadRequest [("Connection", "close")]
296 $ "chunkWasMalformed: "
299 ⊕ T.pack (intercalate ", " eCtx)
305 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
311 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
314 do req ← takeTMVar niReceiveBodyReq
317 → do putTMVar niSendContinue niExpectedContinue
318 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
320 → do putTMVar niSendContinue False
321 return $ wasteNonChunkedRequestBody ctx input bodyLen
323 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
329 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
330 = do req ← atomically $ takeTMVar niReceiveBodyReq
333 → readNonChunkedRequestBody ctx ni input bodyLen wanted
335 → wasteNonChunkedRequestBody ctx input bodyLen
337 wasteNonChunkedRequestBody ∷ HandleLike h
342 wasteNonChunkedRequestBody ctx input bodyLen
343 = do let input' = Lazy.drop (fromIntegral bodyLen) input
344 acceptRequest ctx input'
346 readNonChunkedRequestBody ∷ HandleLike h
353 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
354 | bodyLen ≡ 0 = gotEndOfRequest
355 | otherwise = gotBody
359 = do let bytesToRead = min wanted bodyLen
360 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
361 block' = Strict.concat $ Lazy.toChunks block
362 actualReadBytes = Strict.length block'
363 bodyLen' = bodyLen - actualReadBytes
364 atomically $ putTMVar niReceivedBody block'
365 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
367 gotEndOfRequest ∷ IO ()
369 = do atomically $ putTMVar niReceivedBody (∅)
370 acceptRequest ctx input
372 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
373 {-# INLINEABLE enqueue #-}
374 enqueue (Context {..}) itr
376 do queue ← readTVar cQueue
377 writeTVar cQueue (toInteraction itr ⊲ queue)