2 module Network.HTTP.Lucu.RequestReader
7 import Control.Concurrent.STM
8 import Control.Exception
10 import qualified Data.ByteString.Lazy.Char8 as B
11 import Data.ByteString.Lazy.Char8 (ByteString)
13 import qualified Data.Sequence as S
14 import Data.Sequence ((<|))
16 import Network.HTTP.Lucu.Config
17 import Network.HTTP.Lucu.Chunk
18 import Network.HTTP.Lucu.DefaultPage
19 import Network.HTTP.Lucu.Interaction
20 import Network.HTTP.Lucu.Parser
21 import Network.HTTP.Lucu.Postprocess
22 import Network.HTTP.Lucu.Preprocess
23 import Network.HTTP.Lucu.Request
24 import Network.HTTP.Lucu.Response
25 import Network.HTTP.Lucu.Resource.Tree
26 import Prelude hiding (catch)
30 requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
31 requestReader cnf tree h addr tQueue
32 = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq`
33 do catch (do input <- B.hGetContents h
34 acceptRequest input) $ \ exc ->
36 IOException _ -> return ()
37 AsyncException ThreadKilled -> return ()
38 BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
41 acceptRequest :: ByteString -> IO ()
43 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
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 = do itr <- newInteraction cnf addr Nothing
60 atomically $ do updateItr itr itrResponse
64 writeItr itr itrWillClose True
65 writeItr itr itrState Done
70 acceptParsableRequest :: Request -> ByteString -> IO ()
71 acceptParsableRequest req input
72 = do itr <- newInteraction cnf addr (Just req)
76 isErr <- readItr itr itrResponse (isError . resStatus)
78 acceptSemanticallyInvalidRequest itr input
80 case findResource tree $ reqURI req of
81 Nothing -- Resource が無かった
82 -> acceptRequestForNonexistentResource itr input
84 Just (rsrcPath, rsrcDef) -- あった
85 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
88 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
89 acceptSemanticallyInvalidRequest itr input
90 = do writeItr itr itrState Done
94 return $ acceptRequest input
96 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
97 acceptRequestForNonexistentResource itr input
98 = do updateItr itr itrResponse
102 writeItr itr itrState Done
106 return $ acceptRequest input
108 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
109 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
110 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
111 requestHasBody <- readItr itr itrRequestHasBody id
113 return $ do runResource rsrcDef itr
114 if requestHasBody then
115 observeRequest itr input
119 observeRequest :: Interaction -> ByteString -> IO ()
120 observeRequest itr input
121 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
123 observeChunkedRequest itr input
125 observeNonChunkedRequest itr input
127 observeChunkedRequest :: Interaction -> ByteString -> IO ()
128 observeChunkedRequest itr input
131 do isOver <- readItr itr itrReqChunkIsOver id
133 return $ acceptRequest input
135 do wantedM <- readItr itr itrReqBodyWanted id
136 if wantedM == Nothing then
137 do wasteAll <- readItr itr itrReqBodyWasteAll id
140 do remainingM <- readItr itr itrReqChunkRemaining id
141 if fmap (> 0) remainingM == Just True then
144 do let (_, input') = B.splitAt (fromIntegral
145 $ fromJust remainingM) input
146 (footerR, input'') = parse chunkFooterP input'
148 if footerR == Success () then
150 do writeItr itr itrReqChunkRemaining $ Just 0
152 return $ observeChunkedRequest itr input''
154 return $ chunkWasMalformed itr
157 seekNextChunk itr input
163 do remainingM <- readItr itr itrReqChunkRemaining id
164 if fmap (> 0) remainingM == Just True then
167 do let wanted = fromJust wantedM
168 remaining = fromJust remainingM
169 bytesToRead = fromIntegral $ min wanted remaining
170 (chunk, input') = B.splitAt bytesToRead input
171 actualReadBytes = fromIntegral $ B.length chunk
172 newWanted = case wanted - actualReadBytes of
175 newRemaining = Just $ remaining - actualReadBytes
177 = do writeItr itr itrReqChunkRemaining newRemaining
178 writeItr itr itrReqBodyWanted newWanted
179 updateItr itr itrReceivedBody $ flip B.append chunk
181 if newRemaining == Just 0 then
183 case parse chunkFooterP input' of
186 return $ observeChunkedRequest itr input''
187 _ -> return $ chunkWasMalformed itr
191 return $ observeChunkedRequest itr input'
194 seekNextChunk itr input
197 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
198 seekNextChunk itr input
199 = case parse chunkHeaderP input of
202 -> case parse chunkTrailerP input' of
204 -> do writeItr itr itrReqChunkLength $ Nothing
205 writeItr itr itrReqChunkRemaining $ Nothing
206 writeItr itr itrReqChunkIsOver True
208 return $ acceptRequest input''
209 _ -> return $ chunkWasMalformed itr
211 (Success len, input')
212 -> do writeItr itr itrReqChunkLength $ Just len
213 writeItr itr itrReqChunkRemaining $ Just len
215 return $ observeChunkedRequest itr input'
217 _ -> return $ chunkWasMalformed itr
219 chunkWasMalformed :: Interaction -> IO ()
220 chunkWasMalformed itr
221 = atomically $ do updateItr itr itrResponse
223 resStatus = BadRequest
225 writeItr itr itrWillClose True
226 writeItr itr itrState Done
230 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
231 observeNonChunkedRequest itr input
234 do wantedM <- readItr itr itrReqBodyWanted id
235 if wantedM == Nothing then
236 do wasteAll <- readItr itr itrReqBodyWasteAll id
239 do remainingM <- readItr itr itrReqChunkRemaining id
241 let (_, input') = if remainingM == Nothing then
242 (B.takeWhile (\ _ -> True) input, B.empty)
244 B.splitAt (fromIntegral $ fromJust remainingM) input
246 writeItr itr itrReqChunkRemaining $ Just 0
247 writeItr itr itrReqChunkIsOver True
249 return $ acceptRequest input'
255 do remainingM <- readItr itr itrReqChunkRemaining id
257 let wanted = fromJust wantedM
258 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
259 (chunk, input') = B.splitAt bytesToRead input
261 (\ x -> x - (fromIntegral $ B.length chunk))
263 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
265 writeItr itr itrReqChunkRemaining newRemaining
266 writeItr itr itrReqChunkIsOver isOver
267 writeItr itr itrReqBodyWanted Nothing
268 writeItr itr itrReceivedBody chunk
271 return $ acceptRequest input'
273 return $ observeNonChunkedRequest itr input'
276 enqueue :: Interaction -> STM ()
277 enqueue itr = do queue <- readTVar tQueue
278 writeTVar tQueue (itr <| queue)