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
193 return $ observeChunkedRequest itr input''
194 _ -> return $ chunkWasMalformed itr
198 return $ observeChunkedRequest itr input'
201 seekNextChunk itr input
204 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
205 seekNextChunk itr input
206 = {-# SCC "seekNextChunk" #-}
207 case parse chunkHeaderP input of
210 -> case parse chunkTrailerP input' of
212 -> do writeItr itr itrReqChunkLength $ Nothing
213 writeItr itr itrReqChunkRemaining $ Nothing
214 writeItr itr itrReqChunkIsOver True
216 return $ acceptRequest input''
217 _ -> return $ chunkWasMalformed itr
219 (Success len, input')
220 -> do writeItr itr itrReqChunkLength $ Just len
221 writeItr itr itrReqChunkRemaining $ Just len
223 return $ observeChunkedRequest itr input'
225 _ -> return $ chunkWasMalformed itr
227 chunkWasMalformed :: Interaction -> IO ()
228 chunkWasMalformed itr
229 = {-# SCC "chunkWasMalformed" #-}
230 atomically $ do updateItr itr itrResponse
232 resStatus = BadRequest
234 writeItr itr itrWillClose True
235 writeItr itr itrState Done
239 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
240 observeNonChunkedRequest itr input
241 = {-# SCC "observeNonChunkedRequest" #-}
244 do wantedM <- readItr itr itrReqBodyWanted id
245 if wantedM == Nothing then
246 do wasteAll <- readItr itr itrReqBodyWasteAll id
249 do remainingM <- readItr itr itrReqChunkRemaining id
251 let (_, input') = if remainingM == Nothing then
252 (B.takeWhile (\ _ -> True) input, B.empty)
254 B.splitAt (fromIntegral $ fromJust remainingM) input
256 writeItr itr itrReqChunkRemaining $ Just 0
257 writeItr itr itrReqChunkIsOver True
259 return $ acceptRequest input'
265 do remainingM <- readItr itr itrReqChunkRemaining id
267 let wanted = fromJust wantedM
268 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
269 (chunk, input') = B.splitAt bytesToRead input
271 (\ x -> x - (fromIntegral $ B.length chunk))
273 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
275 writeItr itr itrReqChunkRemaining newRemaining
276 writeItr itr itrReqChunkIsOver isOver
277 writeItr itr itrReqBodyWanted Nothing
278 writeItr itr itrReceivedBody chunk
281 return $ acceptRequest input'
283 return $ observeNonChunkedRequest itr input'
286 enqueue :: Interaction -> STM ()
287 enqueue itr = {-# SCC "enqueue" #-}
288 do queue <- readTVar tQueue
289 writeTVar tQueue (itr <| queue)