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
19 import qualified Data.Strict.Maybe as S
20 import Data.Monoid.Unicode
21 import qualified Data.Sequence as S
22 import Data.Sequence.Unicode hiding ((∅))
23 import qualified Data.Text as T
24 import Network.HTTP.Lucu.Abortion
25 import Network.HTTP.Lucu.Config
26 import Network.HTTP.Lucu.Chunk
27 import Network.HTTP.Lucu.HandleLike
28 import Network.HTTP.Lucu.Interaction
29 import Network.HTTP.Lucu.Preprocess
30 import Network.HTTP.Lucu.Request
31 import Network.HTTP.Lucu.Response
32 import Network.HTTP.Lucu.Resource.Internal
33 import Network.HTTP.Lucu.Resource.Tree
35 import Prelude.Unicode
36 import System.IO (hPutStrLn, stderr)
42 , cFallbacks ∷ ![FallbackHandler]
46 , cQueue ∷ !InteractionQueue
49 data ChunkReceivingState
51 | InChunk !Int -- ^Number of remaining octets in the current
52 -- chunk. It's always positive.
54 requestReader ∷ HandleLike h
63 requestReader cnf tree fbs h port addr tQueue
64 = do input ← hGetLBS h
65 acceptRequest (Context cnf tree fbs h port addr tQueue) input
67 [ Handler handleAsyncE
69 , Handler handleOthers
72 handleAsyncE ∷ AsyncException → IO ()
73 handleAsyncE ThreadKilled = return ()
74 handleAsyncE e = dump e
76 handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
79 handleOthers ∷ SomeException → IO ()
82 dump ∷ Exception e ⇒ e → IO ()
84 = do hPutStrLn stderr "requestReader caught an exception:"
85 hPutStrLn stderr (show $ toException e)
87 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
88 acceptRequest ctx@(Context {..}) input
89 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
92 do queue ← readTVar cQueue
93 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
95 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
96 -- Request 應答を設定し、それを出力してから切斷するやうに
97 -- ResponseWriter に通知する。
98 case LP.parse requestP 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 rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
120 → do let ar' = ar { arInitialStatus = 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
143 = do cert ← hGetPeerCert cHandle
144 ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
145 tid ← spawnResource rsrcDef ni
146 if reqMustHaveBody arRequest then
147 waitForReceiveBodyReq ctx ni tid input
149 acceptRequest ctx input
151 waitForReceiveBodyReq ∷ HandleLike h
157 waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
158 = case S.fromJust niReqBodyLength of
160 → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
162 → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
164 -- Toooooo long name for a function...
165 waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
171 waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
174 do req ← takeTMVar niReceiveBodyReq
177 → do putTMVar niSendContinue niExpectedContinue
178 return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
180 → do putTMVar niSendContinue False
181 return $ wasteAllChunks ctx rsrcTid input Initial
183 waitForReceiveChunkedBodyReq ∷ HandleLike h
188 → ChunkReceivingState
190 waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
191 = do req ← atomically $ takeTMVar niReceiveBodyReq
194 → readCurrentChunk ctx ni rsrcTid wanted input st
196 → wasteAllChunks ctx rsrcTid input st
198 wasteAllChunks ∷ HandleLike h
202 → ChunkReceivingState
204 wasteAllChunks ctx rsrcTid = go
206 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
208 = case LP.parse chunkHeaderP input of
209 LP.Done input' chunkLen
210 | chunkLen ≡ 0 → gotFinalChunk input'
211 | otherwise → gotChunk input' chunkLen
213 → chunkWasMalformed rsrcTid
214 $ "wasteAllChunks: chunkHeaderP: " ⧺ msg
215 go input (InChunk chunkLen)
216 = gotChunk input chunkLen
218 gotChunk ∷ Lazy.ByteString → Int → IO ()
219 gotChunk input chunkLen
220 = let input' = Lazy.drop (fromIntegral chunkLen) input
222 case LP.parse chunkFooterP input' of
226 → chunkWasMalformed rsrcTid
227 $ "wasteAllChunks: chunkFooterP: " ⧺ msg
229 gotFinalChunk ∷ Lazy.ByteString → IO ()
231 = case LP.parse chunkTrailerP input of
233 → acceptRequest ctx input'
235 → chunkWasMalformed rsrcTid
236 $ "wasteAllChunks: chunkTrailerP: " ⧺ msg
238 readCurrentChunk ∷ HandleLike h
244 → ChunkReceivingState
246 readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
248 go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
250 = case LP.parse chunkHeaderP input of
251 LP.Done input' chunkLen
253 → gotFinalChunk input'
255 → gotChunk input' chunkLen
257 → chunkWasMalformed rsrcTid
258 $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
259 go input (InChunk chunkLen)
260 = gotChunk input chunkLen
262 gotChunk ∷ Lazy.ByteString → Int → IO ()
263 gotChunk input chunkLen
264 = do let bytesToRead = min wanted chunkLen
265 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
266 block' = Strict.concat $ Lazy.toChunks block
267 actualReadBytes = Strict.length block'
268 chunkLen' = chunkLen - actualReadBytes
269 atomically $ putTMVar niReceivedBody block'
270 if chunkLen' ≡ 0 then
271 case LP.parse chunkFooterP input' of
273 → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
275 → chunkWasMalformed rsrcTid
276 $ "readCurrentChunk: chunkFooterP: " ⧺ msg
278 waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
280 gotFinalChunk ∷ Lazy.ByteString → IO ()
282 = do atomically $ putTMVar niReceivedBody (∅)
283 case LP.parse chunkTrailerP input of
285 → acceptRequest ctx input'
287 → chunkWasMalformed rsrcTid
288 $ "readCurrentChunk: chunkTrailerP: " ⧺ msg
290 chunkWasMalformed ∷ ThreadId → String → IO ()
291 chunkWasMalformed tid msg
292 = let abo = mkAbortion BadRequest [("Connection", "close")]
294 $ "chunkWasMalformed: " ⊕ T.pack msg
298 waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
304 waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
307 do req ← takeTMVar niReceiveBodyReq
310 → do putTMVar niSendContinue niExpectedContinue
311 return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
313 → do putTMVar niSendContinue False
314 return $ wasteNonChunkedRequestBody ctx input bodyLen
316 waitForReceiveNonChunkedBodyReq ∷ HandleLike h
322 waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
323 = do req ← atomically $ takeTMVar niReceiveBodyReq
326 → readNonChunkedRequestBody ctx ni input bodyLen wanted
328 → wasteNonChunkedRequestBody ctx input bodyLen
330 wasteNonChunkedRequestBody ∷ HandleLike h
335 wasteNonChunkedRequestBody ctx input bodyLen
336 = do let input' = Lazy.drop (fromIntegral bodyLen) input
337 acceptRequest ctx input'
339 readNonChunkedRequestBody ∷ HandleLike h
346 readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
347 | bodyLen ≡ 0 = gotEndOfRequest
348 | otherwise = gotBody
352 = do let bytesToRead = min wanted bodyLen
353 (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
354 block' = Strict.concat $ Lazy.toChunks block
355 actualReadBytes = Strict.length block'
356 bodyLen' = bodyLen - actualReadBytes
357 atomically $ putTMVar niReceivedBody block'
358 waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'
360 gotEndOfRequest ∷ IO ()
362 = do atomically $ putTMVar niReceivedBody (∅)
363 acceptRequest ctx input
365 enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
366 {-# INLINEABLE enqueue #-}
367 enqueue (Context {..}) itr
369 do queue ← readTVar cQueue
370 writeTVar cQueue (toInteraction itr ⊲ queue)