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.HandleLike
20 import Network.HTTP.Lucu.Interaction
21 import Network.HTTP.Lucu.Parser
22 import Network.HTTP.Lucu.Postprocess
23 import Network.HTTP.Lucu.Preprocess
24 import Network.HTTP.Lucu.Request
25 import Network.HTTP.Lucu.Response
26 import Network.HTTP.Lucu.Resource.Tree
27 import Prelude hiding (catch)
28 import System.IO (stderr)
31 requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO ()
32 requestReader !cnf !tree !fbs !h !addr !tQueue
33 = do input <- hGetLBS h
36 [ Handler (( \ _ -> return () ) :: IOException -> IO ())
37 , Handler ( \ ThreadKilled -> return () )
38 , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" )
39 , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
42 acceptRequest :: ByteString -> IO ()
44 -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
46 = {-# SCC "acceptRequest" #-}
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 = {-# SCC "acceptNonparsableRequest" #-}
62 do itr <- newInteraction cnf addr Nothing Nothing
63 atomically $ do updateItr itr itrResponse
67 writeItr itr itrWillClose True
68 writeItr itr itrState Done
73 acceptParsableRequest :: Request -> ByteString -> IO ()
74 acceptParsableRequest req input
75 = {-# SCC "acceptParsableRequest" #-}
76 do cert <- hGetPeerCert h
77 itr <- newInteraction cnf addr cert (Just req)
81 isErr <- readItr itr itrResponse (isError . resStatus)
83 acceptSemanticallyInvalidRequest itr input
85 do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
87 Nothing -- Resource が無かった
88 -> acceptRequestForNonexistentResource itr input
90 Just (rsrcPath, rsrcDef) -- あった
91 -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
94 acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
95 acceptSemanticallyInvalidRequest itr input
96 = {-# SCC "acceptSemanticallyInvalidRequest" #-}
97 do writeItr itr itrState Done
101 return $ acceptRequest input
103 acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
104 acceptRequestForNonexistentResource itr input
105 = {-# SCC "acceptRequestForNonexistentResource" #-}
106 do updateItr itr itrResponse
110 writeItr itr itrState Done
114 return $ acceptRequest input
116 acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
117 acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
118 = {-# SCC "acceptRequestForExistentResource" #-}
119 do let itr = oldItr { itrResourcePath = Just rsrcPath }
120 requestHasBody <- readItr itr itrRequestHasBody id
122 return $ do runResource rsrcDef itr
123 if requestHasBody then
124 observeRequest itr input
128 observeRequest :: Interaction -> ByteString -> IO ()
129 observeRequest itr input
130 = {-# SCC "observeRequest" #-}
131 do isChunked <- atomically $ readItr itr itrRequestIsChunked id
133 observeChunkedRequest itr input
135 observeNonChunkedRequest itr input
137 observeChunkedRequest :: Interaction -> ByteString -> IO ()
138 observeChunkedRequest itr input
139 = {-# SCC "observeChunkedRequest" #-}
142 do isOver <- readItr itr itrReqChunkIsOver id
144 return $ acceptRequest input
146 do wantedM <- readItr itr itrReqBodyWanted id
147 if wantedM == Nothing then
148 do wasteAll <- readItr itr itrReqBodyWasteAll id
151 do remainingM <- readItr itr itrReqChunkRemaining id
152 if fmap (> 0) remainingM == Just True then
155 do let (_, input') = B.splitAt (fromIntegral
156 $ fromJust remainingM) input
157 (# footerR, input'' #) = parse chunkFooterP input'
159 if footerR == Success () then
161 do writeItr itr itrReqChunkRemaining $ Just 0
163 return $ observeChunkedRequest itr input''
165 return $ chunkWasMalformed itr
168 seekNextChunk itr input
174 do remainingM <- readItr itr itrReqChunkRemaining id
175 if fmap (> 0) remainingM == Just True then
178 do let wanted = fromJust wantedM
179 remaining = fromJust remainingM
180 bytesToRead = fromIntegral $ min wanted remaining
181 (chunk, input') = B.splitAt bytesToRead input
182 actualReadBytes = fromIntegral $ B.length chunk
183 newWanted = case wanted - actualReadBytes of
186 newRemaining = Just $ remaining - actualReadBytes
188 = do writeItr itr itrReqChunkRemaining newRemaining
189 writeItr itr itrReqBodyWanted newWanted
190 updateItr itr itrReceivedBody $ flip B.append chunk
192 if newRemaining == Just 0 then
194 case parse chunkFooterP input' of
195 (# Success _, input'' #)
197 return $ observeChunkedRequest itr input''
199 -> return $ chunkWasMalformed itr
203 return $ observeChunkedRequest itr input'
206 seekNextChunk itr input
209 seekNextChunk :: Interaction -> ByteString -> STM (IO ())
210 seekNextChunk itr input
211 = {-# SCC "seekNextChunk" #-}
212 case parse chunkHeaderP input of
214 (# Success 0, input' #)
215 -> case parse chunkTrailerP input' of
216 (# Success _, input'' #)
217 -> do writeItr itr itrReqChunkLength $ Nothing
218 writeItr itr itrReqChunkRemaining $ Nothing
219 writeItr itr itrReqChunkIsOver True
221 return $ acceptRequest input''
223 -> return $ chunkWasMalformed itr
225 (# Success len, input' #)
226 -> do writeItr itr itrReqChunkLength $ Just len
227 writeItr itr itrReqChunkRemaining $ Just len
229 return $ observeChunkedRequest itr input'
232 -> return $ chunkWasMalformed itr
234 chunkWasMalformed :: Interaction -> IO ()
235 chunkWasMalformed itr
236 = {-# SCC "chunkWasMalformed" #-}
237 atomically $ do updateItr itr itrResponse
239 resStatus = BadRequest
241 writeItr itr itrWillClose True
242 writeItr itr itrState Done
246 observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
247 observeNonChunkedRequest itr input
248 = {-# SCC "observeNonChunkedRequest" #-}
251 do wantedM <- readItr itr itrReqBodyWanted id
252 if wantedM == Nothing then
253 do wasteAll <- readItr itr itrReqBodyWasteAll id
256 do remainingM <- readItr itr itrReqChunkRemaining id
258 let (_, input') = if remainingM == Nothing then
259 (B.takeWhile (\ _ -> True) input, B.empty)
261 B.splitAt (fromIntegral $ fromJust remainingM) input
263 writeItr itr itrReqChunkRemaining $ Just 0
264 writeItr itr itrReqChunkIsOver True
266 return $ acceptRequest input'
272 do remainingM <- readItr itr itrReqChunkRemaining id
274 let wanted = fromJust wantedM
275 bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM
276 (chunk, input') = B.splitAt bytesToRead input
278 (\ x -> x - (fromIntegral $ B.length chunk))
280 isOver = B.length chunk < bytesToRead || newRemaining == Just 0
282 writeItr itr itrReqChunkRemaining newRemaining
283 writeItr itr itrReqChunkIsOver isOver
284 writeItr itr itrReqBodyWanted Nothing
285 writeItr itr itrReceivedBody chunk
288 return $ acceptRequest input'
290 return $ observeNonChunkedRequest itr input'
293 enqueue :: Interaction -> STM ()
294 enqueue itr = {-# SCC "enqueue" #-}
295 do queue <- readTVar tQueue
296 writeTVar tQueue (itr <| queue)