6 module Network.HTTP.Lucu.RequestReader
10 import Control.Concurrent.STM
11 import Control.Exception
13 import qualified Data.ByteString.Lazy.Char8 as B
14 import Data.ByteString.Lazy.Char8 (ByteString)
16 import qualified Data.Sequence as S
17 import Data.Sequence ((<|))
18 import GHC.Conc (unsafeIOToSTM)
20 import Network.HTTP.Lucu.Config
21 import Network.HTTP.Lucu.Chunk
22 import Network.HTTP.Lucu.DefaultPage
23 import Network.HTTP.Lucu.HandleLike
24 import Network.HTTP.Lucu.Interaction
25 import Network.HTTP.Lucu.Postprocess
26 import Network.HTTP.Lucu.Preprocess
27 import Network.HTTP.Lucu.Request
28 import Network.HTTP.Lucu.Response
29 import Network.HTTP.Lucu.Resource.Tree
30 import Prelude hiding (catch)
31 import System.IO (stderr)
33 requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO ()
34 requestReader !cnf !tree !fbs !h !port !addr !tQueue
35 = do input <- hGetLBS h
38 [ Handler (( \ _ -> return () ) :: IOException -> IO ())
39 , Handler ( \ ThreadKilled -> return () )
40 , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" )
41 , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
44 acceptRequest :: ByteString -> IO ()
46 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
48 = {-# SCC "acceptRequest" #-}
49 do atomically $ do queue <- readTVar tQueue
50 when (S.length queue >= cnfMaxPipelineDepth cnf)
53 -- リクエストを讀む。パースできない場合は直ちに 400 Bad
54 -- Request 應答を設定し、それを出力してから切斷するやう
55 -- に ResponseWriter に通知する。
56 case parse requestP input of
57 (# Success req , input' #) -> acceptParsableRequest req input'
58 (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest
59 (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest
61 acceptNonparsableRequest :: StatusCode -> IO ()
62 acceptNonparsableRequest status
63 = {-# SCC "acceptNonparsableRequest" #-}
64 do itr <- newInteraction cnf port addr Nothing Nothing
65 atomically $ do updateItr itr itrResponse
69 writeItr itr itrWillClose True
70 writeItr itr itrState Done
75 acceptParsableRequest :: Request -> ByteString -> IO ()
76 acceptParsableRequest req input
77 = {-# SCC "acceptParsableRequest" #-}
78 do cert <- hGetPeerCert h
79 itr <- newInteraction cnf port addr cert (Just req)
83 isErr <- readItr itr itrResponse (isError . resStatus)
85 acceptSemanticallyInvalidRequest itr input
87 do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
89 Nothing -- Resource が無かった
90 -> acceptRequestForNonexistentResource itr input
92 Just (rsrcPath, rsrcDef) -- あった
93 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
96 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
97 acceptSemanticallyInvalidRequest itr input
98 = {-# SCC "acceptSemanticallyInvalidRequest" #-}
99 do writeItr itr itrState Done
103 return $ acceptRequest input
105 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
106 acceptRequestForNonexistentResource itr input
107 = {-# SCC "acceptRequestForNonexistentResource" #-}
108 do updateItr itr itrResponse
112 writeItr itr itrState Done
116 return $ acceptRequest input
118 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
119 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
120 = {-# SCC "acceptRequestForExistentResource" #-}
121 do let itr = oldItr { itrResourcePath = Just rsrcPath }
122 requestHasBody <- readItr itr itrRequestHasBody id
124 return $ do _ <- runResource rsrcDef itr
125 if requestHasBody then
126 observeRequest itr input
130 observeRequest :: Interaction -> ByteString -> IO ()
131 observeRequest itr input
132 = {-# SCC "observeRequest" #-}
133 do isChunked <- atomically $ readItr itr itrRequestIsChunked id
135 observeChunkedRequest itr input
137 observeNonChunkedRequest itr input
139 observeChunkedRequest :: Interaction -> ByteString -> IO ()
140 observeChunkedRequest itr input
141 = {-# SCC "observeChunkedRequest" #-}
144 do isOver <- readItr itr itrReqChunkIsOver id
146 return $ acceptRequest input
148 do wantedM <- readItr itr itrReqBodyWanted id
149 if wantedM == Nothing then
150 do wasteAll <- readItr itr itrReqBodyWasteAll id
153 do remainingM <- readItr itr itrReqChunkRemaining id
154 if fmap (> 0) remainingM == Just True then
157 do let (_, input') = B.splitAt (fromIntegral
158 $ fromJust remainingM) input
159 (# footerR, input'' #) = parse chunkFooterP input'
161 if footerR == Success () then
163 do writeItr itr itrReqChunkRemaining $ Just 0
165 return $ observeChunkedRequest itr input''
167 return $ chunkWasMalformed itr
170 seekNextChunk itr input
176 do remainingM <- readItr itr itrReqChunkRemaining id
177 if fmap (> 0) remainingM == Just True then
180 do let wanted = fromJust wantedM
181 remaining = fromJust remainingM
182 bytesToRead = fromIntegral $ min wanted remaining
183 (chunk, input') = B.splitAt bytesToRead input
184 actualReadBytes = fromIntegral $ B.length chunk
185 newWanted = case wanted - actualReadBytes of
188 newRemaining = Just $ remaining - actualReadBytes
190 = do writeItr itr itrReqChunkRemaining newRemaining
191 writeItr itr itrReqBodyWanted newWanted
192 updateItr itr itrReceivedBody $ flip B.append chunk
193 updateItr itrReceivedBodyLen (+ actualReadBytes) itr
195 if newRemaining == Just 0 then
197 case parse chunkFooterP input' of
198 (# Success _, input'' #)
200 return $ observeChunkedRequest itr input''
202 -> return $ chunkWasMalformed itr
206 return $ observeChunkedRequest itr input'
209 seekNextChunk itr input
212 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
213 seekNextChunk itr input
214 = {-# SCC "seekNextChunk" #-}
215 case parse chunkHeaderP input of
217 (# Success 0, input' #)
218 -> case parse chunkTrailerP input' of
219 (# Success _, input'' #)
220 -> do writeItr itr itrReqChunkLength $ Nothing
221 writeItr itr itrReqChunkRemaining $ Nothing
222 writeItr itr itrReqChunkIsOver True
224 return $ acceptRequest input''
226 -> return $ chunkWasMalformed itr
228 (# Success len, input' #)
229 -> do writeItr itr itrReqChunkLength $ Just len
230 writeItr itr itrReqChunkRemaining $ Just len
232 return $ observeChunkedRequest itr input'
235 -> return $ chunkWasMalformed itr
237 chunkWasMalformed :: Interaction -> IO ()
238 chunkWasMalformed itr
239 = {-# SCC "chunkWasMalformed" #-}
240 atomically $ do updateItr itr itrResponse
242 resStatus = BadRequest
244 writeItr itr itrWillClose True
245 writeItr itr itrState Done
249 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
250 observeNonChunkedRequest itr input
251 = {-# SCC "observeNonChunkedRequest" #-}
254 do wantedM <- readItr itr itrReqBodyWanted id
255 if wantedM == Nothing then
256 do wasteAll <- readItr itr itrReqBodyWasteAll id
259 do remainingM <- readItr itr itrReqChunkRemaining id
261 let (_, input') = if remainingM == Nothing then
262 (B.takeWhile (\ _ -> True) input, B.empty)
264 B.splitAt (fromIntegral $ fromJust remainingM) input
266 writeItr itr itrReqChunkRemaining $ Just 0
267 writeItr itr itrReqChunkIsOver True
269 return $ acceptRequest input'
275 do remainingM <- readItr itr itrReqChunkRemaining id
277 let wanted = fromJust wantedM
278 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
279 (chunk, input') = B.splitAt bytesToRead input
280 actualReadBytes = fromIntegral $ B.length chunk
281 newRemaining = (- actualReadBytes) <$> remainingM
282 isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
284 writeItr itr itrReqChunkRemaining newRemaining
285 writeItr itr itrReqChunkIsOver isOver
286 writeItr itr itrReqBodyWanted Nothing
287 writeItr itr itrReceivedBody chunk
288 writeItr itrReceivedBody actualReadBytes
291 return $ acceptRequest input'
293 return $ observeNonChunkedRequest itr input'
296 enqueue :: Interaction -> STM ()
297 enqueue itr = {-# SCC "enqueue" #-}
298 do queue <- readTVar tQueue
299 writeTVar tQueue (itr <| queue)