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 Prelude hiding (catch)
31 import GHC.Conc (unsafeIOToSTM)
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
89 -> acceptRequestForExistentResource itr input 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 -> ResourceDef -> STM (IO ())
115 acceptRequestForExistentResource itr input rsrcDef
116 = do requestHasBody <- readItr itr itrRequestHasBody id
118 return $ do runResource rsrcDef itr
119 if requestHasBody then
120 observeRequest itr input
124 observeRequest :: Interaction -> ByteString -> IO ()
125 observeRequest itr input
126 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
128 observeChunkedRequest itr input
130 observeNonChunkedRequest itr input
132 observeChunkedRequest :: Interaction -> ByteString -> IO ()
133 observeChunkedRequest itr input
136 do isOver <- readItr itr itrReqChunkIsOver id
138 return $ acceptRequest input
140 do wantedM <- readItr itr itrReqBodyWanted id
141 if wantedM == Nothing then
142 do wasteAll <- readItr itr itrReqBodyWasteAll id
145 do remainingM <- readItr itr itrReqChunkRemaining id
146 if fmap (> 0) remainingM == Just True then
149 do let (_, input') = B.splitAt (fromIntegral
150 $ fromJust remainingM) input
151 (footerR, input'') = parse chunkFooterP input'
153 if footerR == Success () then
155 do writeItr itr itrReqChunkRemaining $ Just 0
157 return $ observeChunkedRequest itr input''
159 return $ chunkWasMalformed itr
162 seekNextChunk itr input
168 do remainingM <- readItr itr itrReqChunkRemaining id
169 if fmap (> 0) remainingM == Just True then
172 do let wanted = fromJust wantedM
173 remaining = fromJust remainingM
174 bytesToRead = fromIntegral $ min wanted remaining
175 (chunk, input') = B.splitAt bytesToRead input
176 actualReadBytes = fromIntegral $ B.length chunk
177 newWanted = case wanted - actualReadBytes of
180 newRemaining = Just $ remaining - actualReadBytes
182 = do writeItr itr itrReqChunkRemaining newRemaining
183 writeItr itr itrReqBodyWanted newWanted
184 updateItr itr itrReceivedBody $ flip B.append chunk
186 if newRemaining == Just 0 then
188 case parse chunkFooterP input' of
191 return $ observeChunkedRequest itr input''
192 _ -> return $ chunkWasMalformed itr
196 return $ observeChunkedRequest itr input'
199 seekNextChunk itr input
202 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
203 seekNextChunk itr input
204 = case parse chunkHeaderP input of
207 -> case parse chunkTrailerP input' of
209 -> do writeItr itr itrReqChunkLength $ Nothing
210 writeItr itr itrReqChunkRemaining $ Nothing
211 writeItr itr itrReqChunkIsOver True
213 return $ acceptRequest input''
214 _ -> return $ chunkWasMalformed itr
216 (Success len, input')
217 -> do writeItr itr itrReqChunkLength $ Just len
218 writeItr itr itrReqChunkRemaining $ Just len
220 return $ observeChunkedRequest itr input'
222 _ -> return $ chunkWasMalformed itr
224 chunkWasMalformed :: Interaction -> IO ()
225 chunkWasMalformed itr
226 = let res = Response {
227 resVersion = HttpVersion 1 1
228 , resStatus = BadRequest
232 atomically $ do writeItr itr itrResponse $ Just res
233 writeItr itr itrWillClose True
234 writeItr itr itrState Done
238 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
239 observeNonChunkedRequest itr input
242 do wantedM <- readItr itr itrReqBodyWanted id
243 if wantedM == Nothing then
244 do wasteAll <- readItr itr itrReqBodyWasteAll id
247 do remainingM <- readItr itr itrReqChunkRemaining id
249 let (_, input') = if remainingM == Nothing then
250 (B.takeWhile (\ _ -> True) input, B.empty)
252 B.splitAt (fromIntegral $ fromJust remainingM) input
254 writeItr itr itrReqChunkRemaining $ Just 0
255 writeItr itr itrReqChunkIsOver True
257 return $ acceptRequest input'
263 do remainingM <- readItr itr itrReqChunkRemaining id
265 let wanted = fromJust wantedM
266 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
267 (chunk, input') = B.splitAt bytesToRead input
269 (\ x -> x - (fromIntegral $ B.length chunk))
271 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
273 writeItr itr itrReqChunkRemaining newRemaining
274 writeItr itr itrReqChunkIsOver isOver
275 writeItr itr itrReqBodyWanted Nothing
276 writeItr itr itrReceivedBody chunk
279 return $ acceptRequest input'
281 return $ observeNonChunkedRequest itr input'
284 enqueue :: Interaction -> STM ()
285 enqueue itr = do queue <- readTVar tQueue
286 writeTVar tQueue (itr <| queue)