1 module Network.HTTP.Lucu.RequestReader
2 ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
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)
14 import qualified Data.Sequence as S
15 import Data.Sequence (Seq, (<|), ViewR(..))
17 import Network.HTTP.Lucu.Config
18 import Network.HTTP.Lucu.Chunk
19 import Network.HTTP.Lucu.DefaultPage
20 import Network.HTTP.Lucu.HttpVersion
21 import Network.HTTP.Lucu.Interaction
22 import Network.HTTP.Lucu.Parser
23 import Network.HTTP.Lucu.Postprocess
24 import Network.HTTP.Lucu.Preprocess
25 import Network.HTTP.Lucu.Request
26 import Network.HTTP.Lucu.Response
27 import Network.HTTP.Lucu.Resource
28 import Network.HTTP.Lucu.Resource.Tree
29 import Prelude hiding (catch)
33 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
34 requestReader cnf tree h host tQueue
35 = do catch (do input <- B.hGetContents h
36 acceptRequest input) $ \ exc ->
38 IOException _ -> return ()
39 AsyncException ThreadKilled -> return ()
40 BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely"
43 acceptRequest :: ByteString -> IO ()
45 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
47 = do atomically $ do queue <- readTVar tQueue
48 when (S.length queue >= cnfMaxPipelineDepth cnf)
51 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
52 -- Request 應答を設定し、それを出力してから切斷するやう
53 -- に ResponseWriter に通知する。
54 case parse requestP input of
55 (Success req , input') -> acceptParsableRequest req input'
56 (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest
57 (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest
59 acceptNonparsableRequest :: StatusCode -> IO ()
60 acceptNonparsableRequest status
61 = do itr <- newInteraction cnf host Nothing
63 resVersion = HttpVersion 1 1
67 atomically $ do writeItr itr itrResponse $ Just res
68 writeItr itr itrWillClose True
69 writeItr itr itrState Done
74 acceptParsableRequest :: Request -> ByteString -> IO ()
75 acceptParsableRequest req input
76 = do itr <- newInteraction cnf host (Just req)
80 isErr <- readItrF itr itrResponse (isError . resStatus)
81 if isErr == Just True then
82 acceptSemanticallyInvalidRequest itr input
84 case findResource tree $ (reqURI . fromJust . itrRequest) itr of
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 = do writeItr itr itrState Done
98 return $ acceptRequest input
100 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
101 acceptRequestForNonexistentResource itr input
102 = do let res = Response {
103 resVersion = HttpVersion 1 1
104 , resStatus = NotFound
107 writeItr itr itrResponse $ Just res
108 writeItr itr itrState Done
112 return $ acceptRequest input
114 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
115 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
116 = do let itr = oldItr { itrResourcePath = Just rsrcPath }
117 requestHasBody <- readItr itr itrRequestHasBody id
119 return $ do runResource rsrcDef itr
120 if requestHasBody then
121 observeRequest itr input
125 observeRequest :: Interaction -> ByteString -> IO ()
126 observeRequest itr input
127 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
129 observeChunkedRequest itr input
131 observeNonChunkedRequest itr input
133 observeChunkedRequest :: Interaction -> ByteString -> IO ()
134 observeChunkedRequest itr input
137 do isOver <- readItr itr itrReqChunkIsOver id
139 return $ acceptRequest input
141 do wantedM <- readItr itr itrReqBodyWanted id
142 if wantedM == Nothing then
143 do wasteAll <- readItr itr itrReqBodyWasteAll id
146 do remainingM <- readItr itr itrReqChunkRemaining id
147 if fmap (> 0) remainingM == Just True then
150 do let (_, input') = B.splitAt (fromIntegral
151 $ fromJust remainingM) input
152 (footerR, input'') = parse chunkFooterP input'
154 if footerR == Success () then
156 do writeItr itr itrReqChunkRemaining $ Just 0
158 return $ observeChunkedRequest itr input''
160 return $ chunkWasMalformed itr
163 seekNextChunk itr input
169 do remainingM <- readItr itr itrReqChunkRemaining id
170 if fmap (> 0) remainingM == Just True then
173 do let wanted = fromJust wantedM
174 remaining = fromJust remainingM
175 bytesToRead = fromIntegral $ min wanted remaining
176 (chunk, input') = B.splitAt bytesToRead input
177 actualReadBytes = fromIntegral $ B.length chunk
178 newWanted = case wanted - actualReadBytes of
181 newRemaining = Just $ remaining - actualReadBytes
183 = do writeItr itr itrReqChunkRemaining newRemaining
184 writeItr itr itrReqBodyWanted newWanted
185 updateItr itr itrReceivedBody $ flip B.append chunk
187 if newRemaining == Just 0 then
189 case parse chunkFooterP input' of
192 return $ observeChunkedRequest itr input''
193 _ -> return $ chunkWasMalformed itr
197 return $ observeChunkedRequest itr input'
200 seekNextChunk itr input
203 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
204 seekNextChunk itr input
205 = case parse chunkHeaderP input of
208 -> case parse chunkTrailerP input' of
210 -> do writeItr itr itrReqChunkLength $ Nothing
211 writeItr itr itrReqChunkRemaining $ Nothing
212 writeItr itr itrReqChunkIsOver True
214 return $ acceptRequest input''
215 _ -> return $ chunkWasMalformed itr
217 (Success len, input')
218 -> do writeItr itr itrReqChunkLength $ Just len
219 writeItr itr itrReqChunkRemaining $ Just len
221 return $ observeChunkedRequest itr input'
223 _ -> return $ chunkWasMalformed itr
225 chunkWasMalformed :: Interaction -> IO ()
226 chunkWasMalformed itr
227 = let res = Response {
228 resVersion = HttpVersion 1 1
229 , resStatus = BadRequest
233 atomically $ do writeItr itr itrResponse $ Just res
234 writeItr itr itrWillClose True
235 writeItr itr itrState Done
239 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
240 observeNonChunkedRequest itr input
243 do wantedM <- readItr itr itrReqBodyWanted id
244 if wantedM == Nothing then
245 do wasteAll <- readItr itr itrReqBodyWasteAll id
248 do remainingM <- readItr itr itrReqChunkRemaining id
250 let (_, input') = if remainingM == Nothing then
251 (B.takeWhile (\ _ -> True) input, B.empty)
253 B.splitAt (fromIntegral $ fromJust remainingM) input
255 writeItr itr itrReqChunkRemaining $ Just 0
256 writeItr itr itrReqChunkIsOver True
258 return $ acceptRequest input'
264 do remainingM <- readItr itr itrReqChunkRemaining id
266 let wanted = fromJust wantedM
267 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
268 (chunk, input') = B.splitAt bytesToRead input
270 (\ x -> x - (fromIntegral $ B.length chunk))
272 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
274 writeItr itr itrReqChunkRemaining newRemaining
275 writeItr itr itrReqChunkIsOver isOver
276 writeItr itr itrReqBodyWanted Nothing
277 writeItr itr itrReceivedBody chunk
280 return $ acceptRequest input'
282 return $ observeNonChunkedRequest itr input'
285 enqueue :: Interaction -> STM ()
286 enqueue itr = do queue <- readTVar tQueue
287 writeTVar tQueue (itr <| queue)