1 module Network.HTTP.Lucu.RequestReader
6 import Control.Concurrent.STM
7 import Control.Exception
9 import qualified Data.ByteString.Lazy.Char8 as B
10 import Data.ByteString.Lazy.Char8 (ByteString)
12 import qualified Data.Sequence as S
13 import Data.Sequence ((<|))
15 import Network.HTTP.Lucu.Config
16 import Network.HTTP.Lucu.Chunk
17 import Network.HTTP.Lucu.DefaultPage
18 import Network.HTTP.Lucu.Interaction
19 import Network.HTTP.Lucu.Parser
20 import Network.HTTP.Lucu.Postprocess
21 import Network.HTTP.Lucu.Preprocess
22 import Network.HTTP.Lucu.Request
23 import Network.HTTP.Lucu.Response
24 import Network.HTTP.Lucu.Resource.Tree
25 import Prelude hiding (catch)
29 requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
30 requestReader cnf tree h addr tQueue
31 = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq`
32 do catch (do input <- B.hGetContents h
33 acceptRequest input) $ \ exc ->
35 IOException _ -> return ()
36 AsyncException ThreadKilled -> return ()
37 BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
40 acceptRequest :: ByteString -> IO ()
42 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
44 = {-# SCC "acceptRequest" #-}
45 do atomically $ do queue <- readTVar tQueue
46 when (S.length queue >= cnfMaxPipelineDepth cnf)
49 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
50 -- Request 應答を設定し、それを出力してから切斷するやう
51 -- に ResponseWriter に通知する。
52 case parse requestP input of
53 (# Success req , input' #) -> acceptParsableRequest req input'
54 (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest
55 (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest
57 acceptNonparsableRequest :: StatusCode -> IO ()
58 acceptNonparsableRequest status
59 = {-# SCC "acceptNonparsableRequest" #-}
60 do itr <- newInteraction cnf addr Nothing
61 atomically $ do updateItr itr itrResponse
65 writeItr itr itrWillClose True
66 writeItr itr itrState Done
71 acceptParsableRequest :: Request -> ByteString -> IO ()
72 acceptParsableRequest req input
73 = {-# SCC "acceptParsableRequest" #-}
74 do itr <- newInteraction cnf addr (Just req)
78 isErr <- readItr itr itrResponse (isError . resStatus)
80 acceptSemanticallyInvalidRequest itr input
82 case findResource tree $ reqURI req of
83 Nothing -- Resource が無かった
84 -> acceptRequestForNonexistentResource itr input
86 Just (rsrcPath, rsrcDef) -- あった
87 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
90 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
91 acceptSemanticallyInvalidRequest itr input
92 = {-# SCC "acceptSemanticallyInvalidRequest" #-}
93 do writeItr itr itrState Done
97 return $ acceptRequest input
99 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
100 acceptRequestForNonexistentResource itr input
101 = {-# SCC "acceptRequestForNonexistentResource" #-}
102 do updateItr itr itrResponse
106 writeItr itr itrState Done
110 return $ acceptRequest input
112 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
113 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
114 = {-# SCC "acceptRequestForExistentResource" #-}
115 do let itr = oldItr { itrResourcePath = Just rsrcPath }
116 requestHasBody <- readItr itr itrRequestHasBody id
118 return $ do runResource rsrcDef itr
119 if requestHasBody then
120 observeRequest itr input
124 observeRequest :: Interaction -> ByteString -> IO ()
125 observeRequest itr input
126 = {-# SCC "observeRequest" #-}
127 do isChunked <- atomically $ readItr itr itrRequestIsChunked id
129 observeChunkedRequest itr input
131 observeNonChunkedRequest itr input
133 observeChunkedRequest :: Interaction -> ByteString -> IO ()
134 observeChunkedRequest itr input
135 = {-# SCC "observeChunkedRequest" #-}
138 do isOver <- readItr itr itrReqChunkIsOver id
140 return $ acceptRequest input
142 do wantedM <- readItr itr itrReqBodyWanted id
143 if wantedM == Nothing then
144 do wasteAll <- readItr itr itrReqBodyWasteAll id
147 do remainingM <- readItr itr itrReqChunkRemaining id
148 if fmap (> 0) remainingM == Just True then
151 do let (_, input') = B.splitAt (fromIntegral
152 $ fromJust remainingM) input
153 (# footerR, input'' #) = parse chunkFooterP input'
155 if footerR == Success () then
157 do writeItr itr itrReqChunkRemaining $ Just 0
159 return $ observeChunkedRequest itr input''
161 return $ chunkWasMalformed itr
164 seekNextChunk itr input
170 do remainingM <- readItr itr itrReqChunkRemaining id
171 if fmap (> 0) remainingM == Just True then
174 do let wanted = fromJust wantedM
175 remaining = fromJust remainingM
176 bytesToRead = fromIntegral $ min wanted remaining
177 (chunk, input') = B.splitAt bytesToRead input
178 actualReadBytes = fromIntegral $ B.length chunk
179 newWanted = case wanted - actualReadBytes of
182 newRemaining = Just $ remaining - actualReadBytes
184 = do writeItr itr itrReqChunkRemaining newRemaining
185 writeItr itr itrReqBodyWanted newWanted
186 updateItr itr itrReceivedBody $ flip B.append chunk
188 if newRemaining == Just 0 then
190 case parse chunkFooterP input' of
191 (# Success _, input'' #)
193 return $ observeChunkedRequest itr input''
195 -> return $ chunkWasMalformed itr
199 return $ observeChunkedRequest itr input'
202 seekNextChunk itr input
205 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
206 seekNextChunk itr input
207 = {-# SCC "seekNextChunk" #-}
208 case parse chunkHeaderP input of
210 (# Success 0, input' #)
211 -> case parse chunkTrailerP input' of
212 (# Success _, input'' #)
213 -> do writeItr itr itrReqChunkLength $ Nothing
214 writeItr itr itrReqChunkRemaining $ Nothing
215 writeItr itr itrReqChunkIsOver True
217 return $ acceptRequest input''
219 -> return $ chunkWasMalformed itr
221 (# Success len, input' #)
222 -> do writeItr itr itrReqChunkLength $ Just len
223 writeItr itr itrReqChunkRemaining $ Just len
225 return $ observeChunkedRequest itr input'
228 -> return $ chunkWasMalformed itr
230 chunkWasMalformed :: Interaction -> IO ()
231 chunkWasMalformed itr
232 = {-# SCC "chunkWasMalformed" #-}
233 atomically $ do updateItr itr itrResponse
235 resStatus = BadRequest
237 writeItr itr itrWillClose True
238 writeItr itr itrState Done
242 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
243 observeNonChunkedRequest itr input
244 = {-# SCC "observeNonChunkedRequest" #-}
247 do wantedM <- readItr itr itrReqBodyWanted id
248 if wantedM == Nothing then
249 do wasteAll <- readItr itr itrReqBodyWasteAll id
252 do remainingM <- readItr itr itrReqChunkRemaining id
254 let (_, input') = if remainingM == Nothing then
255 (B.takeWhile (\ _ -> True) input, B.empty)
257 B.splitAt (fromIntegral $ fromJust remainingM) input
259 writeItr itr itrReqChunkRemaining $ Just 0
260 writeItr itr itrReqChunkIsOver True
262 return $ acceptRequest input'
268 do remainingM <- readItr itr itrReqChunkRemaining id
270 let wanted = fromJust wantedM
271 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
272 (chunk, input') = B.splitAt bytesToRead input
274 (\ x -> x - (fromIntegral $ B.length chunk))
276 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
278 writeItr itr itrReqChunkRemaining newRemaining
279 writeItr itr itrReqChunkIsOver isOver
280 writeItr itr itrReqBodyWanted Nothing
281 writeItr itr itrReceivedBody chunk
284 return $ acceptRequest input'
286 return $ observeNonChunkedRequest itr input'
289 enqueue :: Interaction -> STM ()
290 enqueue itr = {-# SCC "enqueue" #-}
291 do queue <- readTVar tQueue
292 writeTVar tQueue (itr <| queue)