9 module Network.HTTP.Lucu.RequestReader
13 import Control.Concurrent
14 import Control.Concurrent.STM
15 import Control.Exception hiding (block)
17 import qualified Data.Attoparsec.Lazy as LP
18 import qualified Data.ByteString as Strict
19 import qualified Data.ByteString.Lazy as Lazy
22 import Data.Monoid.Unicode
23 import qualified Data.Sequence as S
24 import Data.Sequence.Unicode hiding ((∅))
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.HandleLike
30 import Network.HTTP.Lucu.Interaction
31 import Network.HTTP.Lucu.Preprocess
32 import Network.HTTP.Lucu.Request
33 import Network.HTTP.Lucu.Response
34 import Network.HTTP.Lucu.Resource.Internal
35 import Network.HTTP.Lucu.Resource.Tree
37 import Prelude.Unicode
38 import System.IO (hPutStrLn, stderr)
44 , cFallbacks ∷ ![FallbackHandler]
48 , cQueue ∷ !InteractionQueue
51 data ChunkReceivingState
53 | InChunk !Int -- ^Number of remaining octets in the current
54 -- chunk. It's always positive.
56 requestReader ∷ HandleLike h
65 requestReader cnf tree fbs h port addr tQueue
66 = do input ← hGetLBS h
67 acceptRequest (Context cnf tree fbs h port addr tQueue) input
69 [ Handler handleAsyncE
71 , Handler handleOthers
74 handleAsyncE ∷ AsyncException → IO ()
75 handleAsyncE ThreadKilled = return ()
76 handleAsyncE e = dump e
78 handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
81 handleOthers ∷ SomeException → IO ()
84 dump ∷ Exception e ⇒ e → IO ()
86 = do hPutStrLn stderr "requestReader caught an exception:"
87 hPutStrLn stderr (show $ toException e)
89 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
90 acceptRequest ctx@(Context {..}) input
91 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
94 do queue ← readTVar cQueue
95 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
97 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
98 -- Request 應答を設定し、それを出力してから切斷するやうに
99 -- ResponseWriter に通知する。
100 case LP.parse request input of
101 LP.Done input' req → acceptParsableRequest ctx req input'
102 LP.Fail _ _ _ → acceptNonparsableRequest ctx
104 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
105 acceptNonparsableRequest ctx@(Context {..})
106 = do syi ← mkSyntacticallyInvalidInteraction cConfig
109 acceptParsableRequest ∷ HandleLike h
114 acceptParsableRequest ctx@(Context {..}) req input
115 = do let ar = preprocess (cnfServerHost cConfig) cPort req
116 if isError $ arInitialStatus ar then
117 acceptSemanticallyInvalidRequest ctx ar input
119 do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
123 arInitialStatus = fromStatusCode NotFound
125 acceptSemanticallyInvalidRequest ctx ar' input
127 → acceptRequestForResource ctx ar input path def
129 acceptSemanticallyInvalidRequest ∷ HandleLike h
134 acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
135 = do sei ← mkSemanticallyInvalidInteraction cConfig ar
137 acceptRequest ctx input
139 acceptRequestForResource ∷ HandleLike h
143 → [Strict.ByteString]
146 acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
148 #if defined(HAVE_SSL)
149 cert ← hGetPeerCert cHandle
150 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
152 ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
154 tid ← spawnResource rsrcDef ni
156 if reqMustHaveBody arRequest then
157 waitForReceiveBodyReq ctx ni tid input
159 acceptRequest ctx input
161 waitForReceiveBodyReq ∷ HandleLike h
167 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
168 = case fromJust niReqBodyLength of
170 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
172 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
174 -- Toooooo long name for a function...
175 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
181 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
184 do req ← takeTMVar niReceiveBodyReq
187 → do putTMVar niSendContinue niExpectedContinue
188 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
190 → do putTMVar niSendContinue False
191 return $ wasteAllChunks ctx rsrcTid input Initial
193 waitForReceiveChunkedBodyReq ∷ HandleLike h
198 → ChunkReceivingState
200 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
201 = do req ← atomically $ takeTMVar niReceiveBodyReq
204 → readCurrentChunk ctx ni rsrcTid wanted input st
206 → wasteAllChunks ctx rsrcTid input st
208 wasteAllChunks ∷ HandleLike h
212 → ChunkReceivingState
214 wasteAllChunks ctx rsrcTid = go
216 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
218 = case LP.parse chunkHeader input of
219 LP.Done input' chunkLen
220 | chunkLen ≡ 0 → gotFinalChunk input'
221 | otherwise → gotChunk input' chunkLen
223 → chunkWasMalformed rsrcTid eCtx e
224 "wasteAllChunks: chunkHeader"
225 go input (InChunk chunkLen)
226 = gotChunk input chunkLen
228 gotChunk ∷ Lazy.ByteString → Int → IO ()
229 gotChunk input chunkLen
230 = let input' = Lazy.drop (fromIntegral chunkLen) input
232 case LP.parse chunkFooter input' of
236 → chunkWasMalformed rsrcTid eCtx e
237 "wasteAllChunks: chunkFooter"
239 gotFinalChunk ∷ Lazy.ByteString → IO ()
241 = case LP.parse chunkTrailer input of
243 → acceptRequest ctx input'
245 → chunkWasMalformed rsrcTid eCtx e
246 "wasteAllChunks: chunkTrailer"
248 readCurrentChunk ∷ HandleLike h
254 → ChunkReceivingState
256 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
258 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
260 = case LP.parse chunkHeader input of
261 LP.Done input' chunkLen
263 → gotFinalChunk input'
265 → gotChunk input' chunkLen
267 → chunkWasMalformed rsrcTid eCtx e
268 "readCurrentChunk: chunkHeader"
269 go input (InChunk chunkLen)
270 = gotChunk input chunkLen
272 gotChunk ∷ Lazy.ByteString → Int → IO ()
273 gotChunk input chunkLen
274 = do let bytesToRead = min wanted chunkLen
275 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
276 block' = Strict.concat $ Lazy.toChunks block
277 actualReadBytes = Strict.length block'
278 chunkLen' = chunkLen - actualReadBytes
279 atomically $ putTMVar niReceivedBody block'
280 if chunkLen' ≡ 0 then
281 case LP.parse chunkFooter input' of
283 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
285 → chunkWasMalformed rsrcTid eCtx e
286 "readCurrentChunk: chunkFooter"
288 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
290 gotFinalChunk ∷ Lazy.ByteString → IO ()
292 = do atomically $ putTMVar niReceivedBody (∅)
293 case LP.parse chunkTrailer input of
295 → acceptRequest ctx input'
297 → chunkWasMalformed rsrcTid eCtx e
298 "readCurrentChunk: chunkTrailer"
300 chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
301 chunkWasMalformed tid eCtx e msg
302 = let abo = mkAbortion BadRequest [("Connection", "close")]
304 $ "chunkWasMalformed: "
307 ⊕ T.pack (intercalate ", " eCtx)
313 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
319 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
322 do req ← takeTMVar niReceiveBodyReq
325 → do putTMVar niSendContinue niExpectedContinue
326 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
328 → do putTMVar niSendContinue False
329 return $ wasteNonChunkedRequestBody ctx input bodyLen
331 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
337 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
338 = do req ← atomically $ takeTMVar niReceiveBodyReq
341 → readNonChunkedRequestBody ctx ni input bodyLen wanted
343 → wasteNonChunkedRequestBody ctx input bodyLen
345 wasteNonChunkedRequestBody ∷ HandleLike h
350 wasteNonChunkedRequestBody ctx input bodyLen
351 = do let input' = Lazy.drop (fromIntegral bodyLen) input
352 acceptRequest ctx input'
354 readNonChunkedRequestBody ∷ HandleLike h
361 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
362 | bodyLen ≡ 0 = gotEndOfRequest
363 | otherwise = gotBody
367 = do let bytesToRead = min wanted bodyLen
368 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
369 block' = Strict.concat $ Lazy.toChunks block
370 actualReadBytes = Strict.length block'
371 bodyLen' = bodyLen - actualReadBytes
372 atomically $ putTMVar niReceivedBody block'
373 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
375 gotEndOfRequest ∷ IO ()
377 = do atomically $ putTMVar niReceivedBody (∅)
378 acceptRequest ctx input
380 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
381 {-# INLINEABLE enqueue #-}
382 enqueue (Context {..}) itr
384 do queue ← readTVar cQueue
385 writeTVar cQueue (toInteraction itr ⊲ queue)