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 ((<|))
14 import GHC.Conc (unsafeIOToSTM)
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 -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()
31 requestReader !cnf !tree !fbs !h !addr !tQueue
32 = do input <- B.hGetContents h
35 [ Handler (( \ _ -> return () ) :: IOException -> IO ())
36 , Handler ( \ ThreadKilled -> return () )
37 , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" )
38 , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
41 acceptRequest :: ByteString -> IO ()
43 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
45 = {-# SCC "acceptRequest" #-}
46 do atomically $ do queue <- readTVar tQueue
47 when (S.length queue >= cnfMaxPipelineDepth cnf)
50 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
51 -- Request 應答を設定し、それを出力してから切斷するやう
52 -- に ResponseWriter に通知する。
53 case parse requestP input of
54 (# Success req , input' #) -> acceptParsableRequest req input'
55 (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest
56 (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest
58 acceptNonparsableRequest :: StatusCode -> IO ()
59 acceptNonparsableRequest status
60 = {-# SCC "acceptNonparsableRequest" #-}
61 do itr <- newInteraction cnf addr Nothing
62 atomically $ do updateItr itr itrResponse
66 writeItr itr itrWillClose True
67 writeItr itr itrState Done
72 acceptParsableRequest :: Request -> ByteString -> IO ()
73 acceptParsableRequest req input
74 = {-# SCC "acceptParsableRequest" #-}
75 do itr <- newInteraction cnf addr (Just req)
79 isErr <- readItr itr itrResponse (isError . resStatus)
81 acceptSemanticallyInvalidRequest itr input
83 do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
85 Nothing -- Resource が無かった
86 -> acceptRequestForNonexistentResource itr input
88 Just (rsrcPath, rsrcDef) -- あった
89 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
92 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
93 acceptSemanticallyInvalidRequest itr input
94 = {-# SCC "acceptSemanticallyInvalidRequest" #-}
95 do writeItr itr itrState Done
99 return $ acceptRequest input
101 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
102 acceptRequestForNonexistentResource itr input
103 = {-# SCC "acceptRequestForNonexistentResource" #-}
104 do updateItr itr itrResponse
108 writeItr itr itrState Done
112 return $ acceptRequest input
114 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
115 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
116 = {-# SCC "acceptRequestForExistentResource" #-}
117 do let itr = oldItr { itrResourcePath = Just rsrcPath }
118 requestHasBody <- readItr itr itrRequestHasBody id
120 return $ do runResource rsrcDef itr
121 if requestHasBody then
122 observeRequest itr input
126 observeRequest :: Interaction -> ByteString -> IO ()
127 observeRequest itr input
128 = {-# SCC "observeRequest" #-}
129 do isChunked <- atomically $ readItr itr itrRequestIsChunked id
131 observeChunkedRequest itr input
133 observeNonChunkedRequest itr input
135 observeChunkedRequest :: Interaction -> ByteString -> IO ()
136 observeChunkedRequest itr input
137 = {-# SCC "observeChunkedRequest" #-}
140 do isOver <- readItr itr itrReqChunkIsOver id
142 return $ acceptRequest input
144 do wantedM <- readItr itr itrReqBodyWanted id
145 if wantedM == Nothing then
146 do wasteAll <- readItr itr itrReqBodyWasteAll id
149 do remainingM <- readItr itr itrReqChunkRemaining id
150 if fmap (> 0) remainingM == Just True then
153 do let (_, input') = B.splitAt (fromIntegral
154 $ fromJust remainingM) input
155 (# footerR, input'' #) = parse chunkFooterP input'
157 if footerR == Success () then
159 do writeItr itr itrReqChunkRemaining $ Just 0
161 return $ observeChunkedRequest itr input''
163 return $ chunkWasMalformed itr
166 seekNextChunk itr input
172 do remainingM <- readItr itr itrReqChunkRemaining id
173 if fmap (> 0) remainingM == Just True then
176 do let wanted = fromJust wantedM
177 remaining = fromJust remainingM
178 bytesToRead = fromIntegral $ min wanted remaining
179 (chunk, input') = B.splitAt bytesToRead input
180 actualReadBytes = fromIntegral $ B.length chunk
181 newWanted = case wanted - actualReadBytes of
184 newRemaining = Just $ remaining - actualReadBytes
186 = do writeItr itr itrReqChunkRemaining newRemaining
187 writeItr itr itrReqBodyWanted newWanted
188 updateItr itr itrReceivedBody $ flip B.append chunk
190 if newRemaining == Just 0 then
192 case parse chunkFooterP input' of
193 (# Success _, input'' #)
195 return $ observeChunkedRequest itr input''
197 -> return $ chunkWasMalformed itr
201 return $ observeChunkedRequest itr input'
204 seekNextChunk itr input
207 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
208 seekNextChunk itr input
209 = {-# SCC "seekNextChunk" #-}
210 case parse chunkHeaderP input of
212 (# Success 0, input' #)
213 -> case parse chunkTrailerP input' of
214 (# Success _, input'' #)
215 -> do writeItr itr itrReqChunkLength $ Nothing
216 writeItr itr itrReqChunkRemaining $ Nothing
217 writeItr itr itrReqChunkIsOver True
219 return $ acceptRequest input''
221 -> return $ chunkWasMalformed itr
223 (# Success len, input' #)
224 -> do writeItr itr itrReqChunkLength $ Just len
225 writeItr itr itrReqChunkRemaining $ Just len
227 return $ observeChunkedRequest itr input'
230 -> return $ chunkWasMalformed itr
232 chunkWasMalformed :: Interaction -> IO ()
233 chunkWasMalformed itr
234 = {-# SCC "chunkWasMalformed" #-}
235 atomically $ do updateItr itr itrResponse
237 resStatus = BadRequest
239 writeItr itr itrWillClose True
240 writeItr itr itrState Done
244 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
245 observeNonChunkedRequest itr input
246 = {-# SCC "observeNonChunkedRequest" #-}
249 do wantedM <- readItr itr itrReqBodyWanted id
250 if wantedM == Nothing then
251 do wasteAll <- readItr itr itrReqBodyWasteAll id
254 do remainingM <- readItr itr itrReqChunkRemaining id
256 let (_, input') = if remainingM == Nothing then
257 (B.takeWhile (\ _ -> True) input, B.empty)
259 B.splitAt (fromIntegral $ fromJust remainingM) input
261 writeItr itr itrReqChunkRemaining $ Just 0
262 writeItr itr itrReqChunkIsOver True
264 return $ acceptRequest input'
270 do remainingM <- readItr itr itrReqChunkRemaining id
272 let wanted = fromJust wantedM
273 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
274 (chunk, input') = B.splitAt bytesToRead input
276 (\ x -> x - (fromIntegral $ B.length chunk))
278 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
280 writeItr itr itrReqChunkRemaining newRemaining
281 writeItr itr itrReqChunkIsOver isOver
282 writeItr itr itrReqBodyWanted Nothing
283 writeItr itr itrReceivedBody chunk
286 return $ acceptRequest input'
288 return $ observeNonChunkedRequest itr input'
291 enqueue :: Interaction -> STM ()
292 enqueue itr = {-# SCC "enqueue" #-}
293 do queue <- readTVar tQueue
294 writeTVar tQueue (itr <| queue)