7 module Network.HTTP.Lucu.RequestReader
11 import Control.Applicative
12 import Control.Concurrent.STM
13 import Control.Exception
15 import qualified Data.Attoparsec.Lazy as LP
16 import qualified Data.ByteString.Lazy as Lazy
18 import qualified Data.Sequence as S
19 import Data.Sequence.Unicode
20 import Data.Text (Text)
21 import Network.HTTP.Lucu.Config
22 import Network.HTTP.Lucu.Chunk
23 import Network.HTTP.Lucu.HandleLike
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Postprocess
26 import Network.HTTP.Lucu.Preprocess
27 import Network.HTTP.Lucu.Request
28 import Network.HTTP.Lucu.Response
29 import Network.HTTP.Lucu.Resource.Tree
32 import Prelude.Unicode
33 import System.IO (hPutStrLn, stderr)
39 , cFallbacks ∷ ![FallbackHandler]
43 , cQueue ∷ !InteractionQueue
46 requestReader ∷ HandleLike h
55 requestReader cnf tree fbs h port addr tQueue
56 = do input ← hGetLBS h
57 acceptRequest (Context cnf tree fbs h port addr tQueue) input
59 [ Handler handleAsyncE
61 , Handler handleOthers
64 handleAsyncE ∷ AsyncException → IO ()
65 handleAsyncE ThreadKilled = return ()
66 handleAsyncE e = dump e
68 handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
71 handleOthers ∷ SomeException → IO ()
74 dump ∷ Exception e ⇒ e → IO ()
76 = do hPutStrLn stderr "requestReader caught an exception:"
77 hPutStrLn stderr (show $ toException e)
79 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
80 acceptRequest ctx@(Context {..}) input
81 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
84 do queue ← readTVar cQueue
85 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
87 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
88 -- Request 應答を設定し、それを出力してから切斷するやうに
89 -- ResponseWriter に通知する。
90 case LP.parse requestP input of
91 LP.Done input' req → acceptParsableRequest ctx req input'
92 LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest
94 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
95 acceptNonparsableRequest ctx@(Context {..}) sc
96 = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
98 do writeTVar (itrState itr) Done
102 acceptParsableRequest ∷ HandleLike h
107 acceptParsableRequest ctx@(Context {..}) req input
108 = do cert ← hGetPeerCert cHandle
109 itr ← newInteraction cConfig cPort cAddr cert (Right req)
111 $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
113 acceptSemanticallyInvalidRequest ctx itr input
115 return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
117 acceptSemanticallyInvalidRequest ∷ HandleLike h
122 acceptSemanticallyInvalidRequest ctx itr input
123 = do writeTVar (itrState itr) Done
126 return $ acceptRequest ctx input
128 acceptSemanticallyValidRequest ∷ HandleLike h
134 acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
135 = do rsrcM ← findResource cResTree cFallbacks uri
138 → acceptRequestForNonexistentResource ctx itr input
139 Just (rsrcPath, rsrcDef)
140 → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
142 acceptRequestForNonexistentResource ∷ HandleLike h
147 acceptRequestForNonexistentResource ctx itr input
149 do setResponseStatus itr NotFound
150 writeTVar (itrState itr) Done
153 acceptRequest ctx input
155 acceptRequestForExistentResource ∷ HandleLike h
162 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
163 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
164 atomically $ enqueue ctx itr
165 do _ ← runResource rsrcDef itr
166 if reqMustHaveBody $ fromJust $ itrRequest itr then
167 observeRequest ctx itr input
169 acceptRequest ctx input
171 observeRequest ∷ HandleLike h
176 observeRequest ctx itr input
177 = case fromJust $ itrReqBodyLength itr of
179 → observeChunkedRequest ctx itr input 0
181 → observeNonChunkedRequest ctx itr input len
183 observeChunkedRequest ∷ HandleLike h
189 observeChunkedRequest ctx itr input remaining
192 do isOver ← readTVar $ itrReqChunkIsOver itr
194 return $ acceptRequest ctx input
196 do wanted ← readTVar $ itrReqBodyWanted itr
198 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
200 return $ wasteCurrentChunk ctx itr input remaining
203 _ → return $ readCurrentChunk ctx itr input wanted remaining
205 wasteCurrentChunk ∷ HandleLike h
211 wasteCurrentChunk ctx itr input len
213 = let input' = Lazy.drop (fromIntegral len) input
215 case LP.parse chunkFooterP input' of
217 → observeChunkedRequest ctx itr input'' 0
219 → chunkWasMalformed itr
221 = seekNextChunk ctx itr input
223 readCurrentChunk ∷ HandleLike h
230 readCurrentChunk ctx itr input wanted remaining
232 = do let bytesToRead = fromIntegral $ min wanted remaining
233 (chunk, input') = Lazy.splitAt bytesToRead input
234 actualReadBytes = fromIntegral $ Lazy.length chunk
235 newWanted = wanted - actualReadBytes
236 newRemaining = remaining - actualReadBytes
237 chunk' = S.fromList $ Lazy.toChunks chunk
238 updateStates = atomically $
239 do writeTVar (itrReqBodyWanted itr) newWanted
240 oldBody ← readTVar $ itrReceivedBody itr
241 oldBodyLen ← readTVar $ itrReceivedBodyLen itr
242 writeTVar (itrReceivedBody itr) $ oldBody ⋈ chunk'
243 writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
244 if newRemaining ≡ 0 then
245 case LP.parse chunkFooterP input' of
248 observeChunkedRequest ctx itr input'' 0
250 → chunkWasMalformed itr
253 observeChunkedRequest ctx itr input' newRemaining
255 = seekNextChunk ctx itr input
257 seekNextChunk ∷ HandleLike h
262 seekNextChunk ctx itr input
263 = case LP.parse chunkHeaderP input of
265 | len ≡ 0 -- Final chunk
266 → case LP.parse chunkTrailerP input' of
269 writeTVar (itrReqChunkIsOver itr) True
270 acceptRequest ctx input''
272 → chunkWasMalformed itr
273 | otherwise -- Non-final chunk
274 → observeChunkedRequest ctx itr input' len
276 → chunkWasMalformed itr
278 chunkWasMalformed ∷ Interaction → IO ()
279 chunkWasMalformed itr
281 do setResponseStatus itr BadRequest
282 writeTVar (itrWillClose itr) True
283 writeTVar (itrState itr) Done
286 observeNonChunkedRequest ∷ HandleLike h
292 observeNonChunkedRequest ctx itr input remaining
295 do wanted ← readTVar $ itrReqBodyWanted itr
297 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
299 return $ wasteNonChunkedRequestBody ctx itr input remaining
302 _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
304 wasteNonChunkedRequestBody ∷ HandleLike h
310 wasteNonChunkedRequestBody ctx itr input remaining
311 = do let input' = Lazy.drop (fromIntegral remaining) input
312 atomically $ writeTVar (itrReqChunkIsOver itr) True
313 acceptRequest ctx input'
315 readNonChunkedRequestBody ∷ HandleLike h
322 readNonChunkedRequestBody ctx itr input wanted remaining
323 = do let bytesToRead = min wanted remaining
324 (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
325 actualReadBytes = fromIntegral $ Lazy.length chunk
326 newWanted = wanted - actualReadBytes
327 newRemaining = remaining - actualReadBytes
328 isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
329 chunk' = S.fromList $ Lazy.toChunks chunk
331 do writeTVar (itrReqChunkIsOver itr) isOver
332 writeTVar (itrReqBodyWanted itr) newWanted
333 writeTVar (itrReceivedBody itr) chunk'
334 writeTVar (itrReceivedBodyLen itr) actualReadBytes
336 acceptRequest ctx input'
338 observeNonChunkedRequest ctx itr input' newRemaining
340 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
341 enqueue (Context {..}) itr
342 = do queue ← readTVar cQueue
343 writeTVar cQueue (itr ⊲ queue)