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 wanted ← readTVar $ itrReqBodyWanted itr
190 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
192 return $ wasteCurrentChunk ctx itr input remaining
195 _ → return $ readCurrentChunk ctx itr input wanted remaining
197 wasteCurrentChunk ∷ HandleLike h
203 wasteCurrentChunk ctx itr input len
205 = let input' = Lazy.drop (fromIntegral len) input
207 case LP.parse chunkFooterP input' of
209 → observeChunkedRequest ctx itr input'' 0
211 → chunkWasMalformed itr
213 = seekNextChunk ctx itr input
215 readCurrentChunk ∷ HandleLike h
222 readCurrentChunk ctx itr input wanted remaining
224 = do let bytesToRead = fromIntegral $ min wanted remaining
225 (chunk, input') = Lazy.splitAt bytesToRead input
226 actualReadBytes = fromIntegral $ Lazy.length chunk
227 newWanted = wanted - actualReadBytes
228 newRemaining = remaining - actualReadBytes
229 chunk' = S.fromList $ Lazy.toChunks chunk
230 updateStates = atomically $
231 do writeTVar (itrReqBodyWanted itr) newWanted
232 oldBody ← readTVar $ itrReceivedBody itr
233 oldBodyLen ← readTVar $ itrReceivedBodyLen itr
234 writeTVar (itrReceivedBody itr) $ oldBody ⋈ chunk'
235 writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes
236 if newRemaining ≡ 0 then
237 case LP.parse chunkFooterP input' of
240 observeChunkedRequest ctx itr input'' 0
242 → chunkWasMalformed itr
245 observeChunkedRequest ctx itr input' newRemaining
247 = seekNextChunk ctx itr input
249 seekNextChunk ∷ HandleLike h
254 seekNextChunk ctx itr input
255 = case LP.parse chunkHeaderP input of
257 | len ≡ 0 -- Final chunk
258 → case LP.parse chunkTrailerP input' of
261 writeTVar (itrReqChunkIsOver itr) True
262 acceptRequest ctx input''
264 → chunkWasMalformed itr
265 | otherwise -- Non-final chunk
266 → observeChunkedRequest ctx itr input' len
268 → chunkWasMalformed itr
270 chunkWasMalformed ∷ Interaction → IO ()
271 chunkWasMalformed itr
273 do setResponseStatus itr BadRequest
274 writeTVar (itrWillClose itr) True
275 writeTVar (itrState itr) Done
279 observeNonChunkedRequest ∷ HandleLike h
285 observeNonChunkedRequest ctx itr input remaining
288 do wanted ← readTVar $ itrReqBodyWanted itr
290 0 → do wasteAll ← readTVar $ itrReqBodyWasteAll itr
292 return $ wasteNonChunkedRequestBody ctx itr input remaining
295 _ → return $ readNonChunkedRequestBody ctx itr input wanted remaining
297 wasteNonChunkedRequestBody ∷ HandleLike h
303 wasteNonChunkedRequestBody ctx itr input remaining
304 = do let input' = Lazy.drop (fromIntegral remaining) input
305 atomically $ writeTVar (itrReqChunkIsOver itr) True
306 acceptRequest ctx input'
308 readNonChunkedRequestBody ∷ HandleLike h
315 readNonChunkedRequestBody ctx itr input wanted remaining
316 = do let bytesToRead = min wanted remaining
317 (chunk, input') = Lazy.splitAt (fromIntegral bytesToRead) input
318 actualReadBytes = fromIntegral $ Lazy.length chunk
319 newWanted = wanted - actualReadBytes
320 newRemaining = remaining - actualReadBytes
321 isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ 0
322 chunk' = S.fromList $ Lazy.toChunks chunk
324 do writeTVar (itrReqChunkIsOver itr) isOver
325 writeTVar (itrReqBodyWanted itr) newWanted
326 writeTVar (itrReceivedBody itr) chunk'
327 writeTVar (itrReceivedBodyLen itr) actualReadBytes
329 acceptRequest ctx input'
331 observeNonChunkedRequest ctx itr input' newRemaining
333 enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
334 enqueue (Context {..}) itr
335 = do queue ← readTVar cQueue
336 writeTVar cQueue (itr ⊲ queue)