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)
15 import qualified Data.Sequence as S
16 import Data.Sequence (Seq, (<|), ViewR(..))
18 import Network.HTTP.Lucu.Config
19 import Network.HTTP.Lucu.Chunk
20 import Network.HTTP.Lucu.DefaultPage
21 import Network.HTTP.Lucu.HttpVersion
22 import Network.HTTP.Lucu.Interaction
23 import Network.HTTP.Lucu.Parser
24 import Network.HTTP.Lucu.Postprocess
25 import Network.HTTP.Lucu.Preprocess
26 import Network.HTTP.Lucu.Request
27 import Network.HTTP.Lucu.Response
28 import Network.HTTP.Lucu.Resource
29 import Network.HTTP.Lucu.Resource.Tree
30 import Prelude hiding (catch)
34 requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
35 requestReader cnf tree h addr tQueue
36 = do catch (do input <- B.hGetContents h
37 acceptRequest input) $ \ exc ->
39 IOException _ -> return ()
40 AsyncException ThreadKilled -> return ()
41 BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
44 acceptRequest :: ByteString -> IO ()
46 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
48 = do atomically $ do queue <- readTVar tQueue
49 when (S.length queue >= cnfMaxPipelineDepth cnf)
52 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
53 -- Request 應答を設定し、それを出力してから切斷するやう
54 -- に ResponseWriter に通知する。
55 case parse requestP input of
56 (Success req , input') -> acceptParsableRequest req input'
57 (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
58 (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest
60 acceptNonparsableRequest :: StatusCode -> IO ()
61 acceptNonparsableRequest status
62 = do itr <- newInteraction cnf addr Nothing
63 atomically $ do updateItr itr itrResponse
67 writeItr itr itrWillClose True
68 writeItr itr itrState Done
73 acceptParsableRequest :: Request -> ByteString -> IO ()
74 acceptParsableRequest req input
75 = do itr <- newInteraction cnf addr (Just req)
79 isErr <- readItr itr itrResponse (isError . resStatus)
81 acceptSemanticallyInvalidRequest itr input
83 case findResource tree $ reqURI req of
84 Nothing -- Resource が無かった
85 -> acceptRequestForNonexistentResource itr input
87 Just (rsrcPath, rsrcDef) -- あった
88 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
91 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
92 acceptSemanticallyInvalidRequest itr input
93 = do writeItr itr itrState Done
97 return $ acceptRequest input
99 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
100 acceptRequestForNonexistentResource itr input
101 = do updateItr itr itrResponse
105 writeItr itr itrState Done
109 return $ acceptRequest input
111 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
112 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
113 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
114 requestHasBody <- readItr itr itrRequestHasBody id
116 return $ do runResource rsrcDef itr
117 if requestHasBody then
118 observeRequest itr input
122 observeRequest :: Interaction -> ByteString -> IO ()
123 observeRequest itr input
124 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
126 observeChunkedRequest itr input
128 observeNonChunkedRequest itr input
130 observeChunkedRequest :: Interaction -> ByteString -> IO ()
131 observeChunkedRequest itr input
134 do isOver <- readItr itr itrReqChunkIsOver id
136 return $ acceptRequest input
138 do wantedM <- readItr itr itrReqBodyWanted id
139 if wantedM == Nothing then
140 do wasteAll <- readItr itr itrReqBodyWasteAll id
143 do remainingM <- readItr itr itrReqChunkRemaining id
144 if fmap (> 0) remainingM == Just True then
147 do let (_, input') = B.splitAt (fromIntegral
148 $ fromJust remainingM) input
149 (footerR, input'') = parse chunkFooterP input'
151 if footerR == Success () then
153 do writeItr itr itrReqChunkRemaining $ Just 0
155 return $ observeChunkedRequest itr input''
157 return $ chunkWasMalformed itr
160 seekNextChunk itr input
166 do remainingM <- readItr itr itrReqChunkRemaining id
167 if fmap (> 0) remainingM == Just True then
170 do let wanted = fromJust wantedM
171 remaining = fromJust remainingM
172 bytesToRead = fromIntegral $ min wanted remaining
173 (chunk, input') = B.splitAt bytesToRead input
174 actualReadBytes = fromIntegral $ B.length chunk
175 newWanted = case wanted - actualReadBytes of
178 newRemaining = Just $ remaining - actualReadBytes
180 = do writeItr itr itrReqChunkRemaining newRemaining
181 writeItr itr itrReqBodyWanted newWanted
182 updateItr itr itrReceivedBody $ flip B.append chunk
184 if newRemaining == Just 0 then
186 case parse chunkFooterP input' of
189 return $ observeChunkedRequest itr input''
190 _ -> return $ chunkWasMalformed itr
194 return $ observeChunkedRequest itr input'
197 seekNextChunk itr input
200 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
201 seekNextChunk itr input
202 = case parse chunkHeaderP input of
205 -> case parse chunkTrailerP input' of
207 -> do writeItr itr itrReqChunkLength $ Nothing
208 writeItr itr itrReqChunkRemaining $ Nothing
209 writeItr itr itrReqChunkIsOver True
211 return $ acceptRequest input''
212 _ -> return $ chunkWasMalformed itr
214 (Success len, input')
215 -> do writeItr itr itrReqChunkLength $ Just len
216 writeItr itr itrReqChunkRemaining $ Just len
218 return $ observeChunkedRequest itr input'
220 _ -> return $ chunkWasMalformed itr
222 chunkWasMalformed :: Interaction -> IO ()
223 chunkWasMalformed itr
224 = atomically $ do updateItr itr itrResponse
226 resStatus = BadRequest
228 writeItr itr itrWillClose True
229 writeItr itr itrState Done
233 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
234 observeNonChunkedRequest itr input
237 do wantedM <- readItr itr itrReqBodyWanted id
238 if wantedM == Nothing then
239 do wasteAll <- readItr itr itrReqBodyWasteAll id
242 do remainingM <- readItr itr itrReqChunkRemaining id
244 let (_, input') = if remainingM == Nothing then
245 (B.takeWhile (\ _ -> True) input, B.empty)
247 B.splitAt (fromIntegral $ fromJust remainingM) input
249 writeItr itr itrReqChunkRemaining $ Just 0
250 writeItr itr itrReqChunkIsOver True
252 return $ acceptRequest input'
258 do remainingM <- readItr itr itrReqChunkRemaining id
260 let wanted = fromJust wantedM
261 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
262 (chunk, input') = B.splitAt bytesToRead input
264 (\ x -> x - (fromIntegral $ B.length chunk))
266 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
268 writeItr itr itrReqChunkRemaining newRemaining
269 writeItr itr itrReqChunkIsOver isOver
270 writeItr itr itrReqBodyWanted Nothing
271 writeItr itr itrReceivedBody chunk
274 return $ acceptRequest input'
276 return $ observeNonChunkedRequest itr input'
279 enqueue :: Interaction -> STM ()
280 enqueue itr = do queue <- readTVar tQueue
281 writeTVar tQueue (itr <| queue)