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 -> HostName -> InteractionQueue -> IO ()
35 requestReader cnf tree h host 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 host Nothing
64 resVersion = HttpVersion 1 1
68 atomically $ do writeItr itr itrResponse $ Just res
69 writeItr itr itrWillClose True
70 writeItr itr itrState Done
75 acceptParsableRequest :: Request -> ByteString -> IO ()
76 acceptParsableRequest req input
77 = do itr <- newInteraction cnf host (Just req)
81 isErr <- readItrF itr itrResponse (isError . resStatus)
82 if isErr == Just True then
83 acceptSemanticallyInvalidRequest itr input
85 case findResource tree $ (reqURI . fromJust . itrRequest) itr of
86 Nothing -- Resource が無かった
87 -> acceptRequestForNonexistentResource itr input
89 Just (rsrcPath, rsrcDef) -- あった
90 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
93 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
94 acceptSemanticallyInvalidRequest itr input
95 = do writeItr itr itrState Done
99 return $ acceptRequest input
101 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
102 acceptRequestForNonexistentResource itr input
103 = do let res = Response {
104 resVersion = HttpVersion 1 1
105 , resStatus = NotFound
108 writeItr itr itrResponse $ Just res
109 writeItr itr itrState Done
113 return $ acceptRequest input
115 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
116 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
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 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
130 observeChunkedRequest itr input
132 observeNonChunkedRequest itr input
134 observeChunkedRequest :: Interaction -> ByteString -> IO ()
135 observeChunkedRequest itr input
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 = case parse chunkHeaderP input of
209 -> case parse chunkTrailerP input' of
211 -> do writeItr itr itrReqChunkLength $ Nothing
212 writeItr itr itrReqChunkRemaining $ Nothing
213 writeItr itr itrReqChunkIsOver True
215 return $ acceptRequest input''
216 _ -> return $ chunkWasMalformed itr
218 (Success len, input')
219 -> do writeItr itr itrReqChunkLength $ Just len
220 writeItr itr itrReqChunkRemaining $ Just len
222 return $ observeChunkedRequest itr input'
224 _ -> return $ chunkWasMalformed itr
226 chunkWasMalformed :: Interaction -> IO ()
227 chunkWasMalformed itr
228 = let res = Response {
229 resVersion = HttpVersion 1 1
230 , resStatus = BadRequest
234 atomically $ do writeItr itr itrResponse $ Just res
235 writeItr itr itrWillClose True
236 writeItr itr itrState Done
240 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
241 observeNonChunkedRequest itr input
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 = do queue <- readTVar tQueue
288 writeTVar tQueue (itr <| queue)