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 = do atomically $ do queue <- readTVar tQueue
45 when (S.length queue >= cnfMaxPipelineDepth cnf)
48 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
49 -- Request 應答を設定し、それを出力してから切斷するやう
50 -- に ResponseWriter に通知する。
51 case parse requestP input of
52 (Success req , input') -> acceptParsableRequest req input'
53 (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
54 (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest
56 acceptNonparsableRequest :: StatusCode -> IO ()
57 acceptNonparsableRequest status
58 = do itr <- newInteraction cnf addr Nothing
59 atomically $ do updateItr itr itrResponse
63 writeItr itr itrWillClose True
64 writeItr itr itrState Done
69 acceptParsableRequest :: Request -> ByteString -> IO ()
70 acceptParsableRequest req input
71 = do itr <- newInteraction cnf addr (Just req)
75 isErr <- readItr itr itrResponse (isError . resStatus)
77 acceptSemanticallyInvalidRequest itr input
79 case findResource tree $ reqURI req of
80 Nothing -- Resource が無かった
81 -> acceptRequestForNonexistentResource itr input
83 Just (rsrcPath, rsrcDef) -- あった
84 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
87 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
88 acceptSemanticallyInvalidRequest itr input
89 = do writeItr itr itrState Done
93 return $ acceptRequest input
95 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
96 acceptRequestForNonexistentResource itr input
97 = do updateItr itr itrResponse
101 writeItr itr itrState Done
105 return $ acceptRequest input
107 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
108 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
109 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
110 requestHasBody <- readItr itr itrRequestHasBody id
112 return $ do runResource rsrcDef itr
113 if requestHasBody then
114 observeRequest itr input
118 observeRequest :: Interaction -> ByteString -> IO ()
119 observeRequest itr input
120 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
122 observeChunkedRequest itr input
124 observeNonChunkedRequest itr input
126 observeChunkedRequest :: Interaction -> ByteString -> IO ()
127 observeChunkedRequest itr input
130 do isOver <- readItr itr itrReqChunkIsOver id
132 return $ acceptRequest input
134 do wantedM <- readItr itr itrReqBodyWanted id
135 if wantedM == Nothing then
136 do wasteAll <- readItr itr itrReqBodyWasteAll id
139 do remainingM <- readItr itr itrReqChunkRemaining id
140 if fmap (> 0) remainingM == Just True then
143 do let (_, input') = B.splitAt (fromIntegral
144 $ fromJust remainingM) input
145 (footerR, input'') = parse chunkFooterP input'
147 if footerR == Success () then
149 do writeItr itr itrReqChunkRemaining $ Just 0
151 return $ observeChunkedRequest itr input''
153 return $ chunkWasMalformed itr
156 seekNextChunk itr input
162 do remainingM <- readItr itr itrReqChunkRemaining id
163 if fmap (> 0) remainingM == Just True then
166 do let wanted = fromJust wantedM
167 remaining = fromJust remainingM
168 bytesToRead = fromIntegral $ min wanted remaining
169 (chunk, input') = B.splitAt bytesToRead input
170 actualReadBytes = fromIntegral $ B.length chunk
171 newWanted = case wanted - actualReadBytes of
174 newRemaining = Just $ remaining - actualReadBytes
176 = do writeItr itr itrReqChunkRemaining newRemaining
177 writeItr itr itrReqBodyWanted newWanted
178 updateItr itr itrReceivedBody $ flip B.append chunk
180 if newRemaining == Just 0 then
182 case parse chunkFooterP input' of
185 return $ observeChunkedRequest itr input''
186 _ -> return $ chunkWasMalformed itr
190 return $ observeChunkedRequest itr input'
193 seekNextChunk itr input
196 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
197 seekNextChunk itr input
198 = case parse chunkHeaderP input of
201 -> case parse chunkTrailerP input' of
203 -> do writeItr itr itrReqChunkLength $ Nothing
204 writeItr itr itrReqChunkRemaining $ Nothing
205 writeItr itr itrReqChunkIsOver True
207 return $ acceptRequest input''
208 _ -> return $ chunkWasMalformed itr
210 (Success len, input')
211 -> do writeItr itr itrReqChunkLength $ Just len
212 writeItr itr itrReqChunkRemaining $ Just len
214 return $ observeChunkedRequest itr input'
216 _ -> return $ chunkWasMalformed itr
218 chunkWasMalformed :: Interaction -> IO ()
219 chunkWasMalformed itr
220 = atomically $ do updateItr itr itrResponse
222 resStatus = BadRequest
224 writeItr itr itrWillClose True
225 writeItr itr itrState Done
229 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
230 observeNonChunkedRequest itr input
233 do wantedM <- readItr itr itrReqBodyWanted id
234 if wantedM == Nothing then
235 do wasteAll <- readItr itr itrReqBodyWasteAll id
238 do remainingM <- readItr itr itrReqChunkRemaining id
240 let (_, input') = if remainingM == Nothing then
241 (B.takeWhile (\ _ -> True) input, B.empty)
243 B.splitAt (fromIntegral $ fromJust remainingM) input
245 writeItr itr itrReqChunkRemaining $ Just 0
246 writeItr itr itrReqChunkIsOver True
248 return $ acceptRequest input'
254 do remainingM <- readItr itr itrReqChunkRemaining id
256 let wanted = fromJust wantedM
257 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
258 (chunk, input') = B.splitAt bytesToRead input
260 (\ x -> x - (fromIntegral $ B.length chunk))
262 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
264 writeItr itr itrReqChunkRemaining newRemaining
265 writeItr itr itrReqChunkIsOver isOver
266 writeItr itr itrReqBodyWanted Nothing
267 writeItr itr itrReceivedBody chunk
270 return $ acceptRequest input'
272 return $ observeNonChunkedRequest itr input'
275 enqueue :: Interaction -> STM ()
276 enqueue itr = do queue <- readTVar tQueue
277 writeTVar tQueue (itr <| queue)