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.DefaultPage
24 import Network.HTTP.Lucu.HandleLike
25 import Network.HTTP.Lucu.Interaction
26 import Network.HTTP.Lucu.Postprocess
27 import Network.HTTP.Lucu.Preprocess
28 import Network.HTTP.Lucu.Request
29 import Network.HTTP.Lucu.Response
30 import Network.HTTP.Lucu.Resource.Tree
33 import Prelude.Unicode
34 import System.IO (hPutStrLn, stderr)
40 , cFallbacks ∷ ![FallbackHandler]
44 , cQueue ∷ !InteractionQueue
47 requestReader ∷ HandleLike h
56 requestReader cnf tree fbs h port addr tQueue
57 = do input ← hGetLBS h
58 acceptRequest (Context cnf tree fbs h port addr tQueue) input
60 [ Handler $ \ (_ ∷ IOException) → return ()
61 , Handler $ \ e → case e of
62 ThreadKilled → return ()
63 _ → hPutStrLn stderr (show e)
64 , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely"
65 , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
68 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
69 acceptRequest ctx@(Context {..}) input
70 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
73 do queue ← readTVar cQueue
74 when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
76 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
77 -- Request 應答を設定し、それを出力してから切斷するやうに
78 -- ResponseWriter に通知する。
79 case LP.parse requestP input of
80 LP.Done input' req → acceptParsableRequest ctx req input'
81 LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest
83 acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
84 acceptNonparsableRequest ctx@(Context {..}) sc
85 = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
87 do writeTVar (itrState itr) Done
92 acceptParsableRequest ∷ HandleLike h
97 acceptParsableRequest ctx@(Context {..}) req input
98 = do cert ← hGetPeerCert cHandle
99 itr ← newInteraction cConfig cPort cAddr cert (Right req)
101 $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
103 acceptSemanticallyInvalidRequest ctx itr input
105 return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input
107 acceptSemanticallyInvalidRequest ∷ HandleLike h
112 acceptSemanticallyInvalidRequest ctx itr input
113 = do writeTVar (itrState itr) Done
117 return $ acceptRequest ctx input
119 acceptSemanticallyValidRequest ∷ HandleLike h
125 acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
126 = do rsrcM ← findResource cResTree cFallbacks uri
129 → acceptRequestForNonexistentResource ctx itr input
130 Just (rsrcPath, rsrcDef)
131 → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef
133 acceptRequestForNonexistentResource ∷ HandleLike h
138 acceptRequestForNonexistentResource ctx itr input
140 do setResponseStatus itr NotFound
141 writeTVar (itrState itr) Done
145 acceptRequest ctx input
147 acceptRequestForExistentResource ∷ HandleLike h
154 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
155 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
156 atomically $ enqueue ctx itr
157 do _ ← runResource rsrcDef itr
158 if reqHasBody $ fromJust $ itrRequest itr then
159 observeRequest ctx itr input
161 acceptRequest ctx input
163 observeRequest ∷ HandleLike h
168 observeRequest ctx itr input
169 = case fromJust $ itrReqBodyLength itr of
171 → observeChunkedRequest ctx itr input 0
173 → observeNonChunkedRequest ctx itr input len
175 observeChunkedRequest ∷ HandleLike h
181 observeChunkedRequest ctx itr input remaining
184 do isOver ← readTVar $ itrReqChunkIsOver itr
186 return $ acceptRequest ctx input
188 do wantedM ← readTVar $ itrReqBodyWanted itr
191 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
193 return $ wasteCurrentChunk ctx itr input remaining
197 → return $ readCurrentChunk ctx itr input wanted remaining
199 wasteCurrentChunk ∷ HandleLike h
205 wasteCurrentChunk ctx itr input len
207 = let input' = Lazy.drop (fromIntegral len) input
209 case LP.parse chunkFooterP input' of
211 → observeChunkedRequest ctx itr input'' 0
213 → chunkWasMalformed itr
215 = seekNextChunk ctx itr input
217 readCurrentChunk ∷ HandleLike h
224 readCurrentChunk ctx itr input wanted remaining
226 = do let bytesToRead = fromIntegral $ min wanted remaining
227 (chunk, input') = Lazy.splitAt bytesToRead input
228 actualReadBytes = fromIntegral $ Lazy.length chunk
229 newWanted = case wanted - actualReadBytes of
232 newRemaining = remaining - actualReadBytes
233 chunk' = S.fromList $ Lazy.toChunks chunk
234 updateStates = atomically $
235 do writeTVar (itrReqBodyWanted itr) newWanted
236 oldBody ← readTVar $ itrReceivedBody itr
237 oldBodyLen ← readTVar $ itrReceivedBodyLen itr
238 writeTVar (itrReceivedBody itr) $ oldBody ⋈ chunk'
239 writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
240 if newRemaining ≡ 0 then
241 case LP.parse chunkFooterP input' of
244 observeChunkedRequest ctx itr input'' 0
246 → chunkWasMalformed itr
249 observeChunkedRequest ctx itr input' newRemaining
251 = seekNextChunk ctx itr input
253 seekNextChunk ∷ HandleLike h
258 seekNextChunk ctx itr input
259 = case LP.parse chunkHeaderP input of
261 | len ≡ 0 -- Final chunk
262 → case LP.parse chunkTrailerP input' of
265 writeTVar (itrReqChunkIsOver itr) True
266 acceptRequest ctx input''
268 → chunkWasMalformed itr
269 | otherwise -- Non-final chunk
270 → observeChunkedRequest ctx itr input' len
272 → chunkWasMalformed itr
274 chunkWasMalformed ∷ Interaction → IO ()
275 chunkWasMalformed itr
277 do setResponseStatus itr BadRequest
278 writeTVar (itrWillClose itr) True
279 writeTVar (itrState itr) Done
283 observeNonChunkedRequest ∷ HandleLike h
289 observeNonChunkedRequest ctx itr input remaining
292 do wantedM ← readTVar $ itrReqBodyWanted itr
295 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
297 return $ wasteNonChunkedRequestBody ctx itr input remaining
301 → return $ readNonChunkedRequestBody ctx itr input wanted remaining
303 wasteNonChunkedRequestBody ∷ HandleLike h
309 wasteNonChunkedRequestBody ctx itr input remaining
310 = do let input' = Lazy.drop (fromIntegral remaining) input
311 atomically $ writeTVar (itrReqChunkIsOver itr) True
312 acceptRequest ctx input'
314 readNonChunkedRequestBody ∷ HandleLike h
321 readNonChunkedRequestBody ctx itr input wanted remaining
322 = do let bytesToRead = min wanted remaining
323 (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
324 actualReadBytes = fromIntegral $ Lazy.length chunk
325 newRemaining = remaining - actualReadBytes
326 isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
327 chunk' = S.fromList $ Lazy.toChunks chunk
329 do writeTVar (itrReqChunkIsOver itr) isOver
330 writeTVar (itrReqBodyWanted itr) Nothing
331 writeTVar (itrReceivedBody itr) chunk'
332 writeTVar (itrReceivedBodyLen itr) actualReadBytes
334 acceptRequest ctx input'
336 observeNonChunkedRequest ctx itr input' newRemaining
338 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
339 enqueue (Context {..}) itr
340 = do queue ← readTVar cQueue
341 writeTVar cQueue (itr ⊲ queue)