X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=1cce2d659295a5386254bf42d9df1a96b77aa0df;hb=858129cb755aa09da2b7bd758efb8519f2c89103;hp=e3032ce583ea8afdae6c0802462ac283dcea2dbb;hpb=2d25d34513dc4f6bf62e53e2af2f4a4ef39cc6dc;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index e3032ce..1cce2d6 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,5 +1,6 @@ +-- #hide module Network.HTTP.Lucu.RequestReader - ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () + ( requestReader ) where @@ -13,8 +14,9 @@ import Data.Map (Map) import Data.Maybe import qualified Data.Sequence as S import Data.Sequence (Seq, (<|), ViewR(..)) -import Network +import Network.Socket import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction @@ -24,14 +26,15 @@ import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource +import Network.HTTP.Lucu.Resource.Tree import Prelude hiding (catch) import System.IO -import GHC.Conc (unsafeIOToSTM) -requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () -requestReader cnf tree h host tQueue - = do catch (do input <- B.hGetContents h +requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO () +requestReader cnf tree h addr tQueue + = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq` + do catch (do input <- B.hGetContents h acceptRequest input) $ \ exc -> case exc of IOException _ -> return () @@ -57,14 +60,11 @@ requestReader cnf tree h host tQueue acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status - = do itr <- newInteraction cnf host Nothing - let res = Response { - resVersion = HttpVersion 1 1 - , resStatus = status - , resHeaders = [] - - } - atomically $ do writeItr itr itrResponse $ Just res + = do itr <- newInteraction cnf addr Nothing + atomically $ do updateItr itr itrResponse + $ \ res -> res { + resStatus = status + } writeItr itr itrWillClose True writeItr itr itrState Done writeDefaultPage itr @@ -73,20 +73,20 @@ requestReader cnf tree h host tQueue acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req input - = do itr <- newInteraction cnf host (Just req) + = do itr <- newInteraction cnf addr (Just req) action <- atomically $ do preprocess itr - isErr <- readItrF itr itrResponse (isError . resStatus) - if isErr == Just True then + isErr <- readItr itr itrResponse (isError . resStatus) + if isErr then acceptSemanticallyInvalidRequest itr input else - case findResource tree $ (reqURI . fromJust . itrRequest) itr of + case findResource tree $ reqURI req of Nothing -- Resource が無かった -> acceptRequestForNonexistentResource itr input - Just rsrcDef -- あった - -> acceptRequestForExistentResource itr input rsrcDef + Just (rsrcPath, rsrcDef) -- あった + -> acceptRequestForExistentResource itr input rsrcPath rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) @@ -99,24 +99,20 @@ requestReader cnf tree h host tQueue acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr input - = do let res = Response { - resVersion = HttpVersion 1 1 - , resStatus = NotFound - , resHeaders = [] - } - writeItr itr itrResponse $ Just res + = do updateItr itr itrResponse + $ \res -> res { + resStatus = NotFound + } writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input - acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) - acceptRequestForExistentResource itr input rsrcDef - = do requestHasBody <- readItr itr itrRequestHasBody id - writeItr itr itrState (if requestHasBody - then ExaminingHeader - else DecidingHeader) + acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ()) + acceptRequestForExistentResource oldItr input rsrcPath rsrcDef + = do let itr = oldItr { itrResourcePath = Just rsrcPath } + requestHasBody <- readItr itr itrRequestHasBody id enqueue itr return $ do runResource rsrcDef itr if requestHasBody then @@ -134,7 +130,106 @@ requestReader cnf tree h host tQueue observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr input - = fail "FIXME: not implemented" + = do action + <- atomically $ + do isOver <- readItr itr itrReqChunkIsOver id + if isOver then + return $ acceptRequest input + else + do wantedM <- readItr itr itrReqBodyWanted id + if wantedM == Nothing then + do wasteAll <- readItr itr itrReqBodyWasteAll id + if wasteAll then + -- 破棄要求が來た + do remainingM <- readItr itr itrReqChunkRemaining id + if fmap (> 0) remainingM == Just True then + -- 現在のチャンクをまだ + -- 讀み終へてゐない + do let (_, input') = B.splitAt (fromIntegral + $ fromJust remainingM) input + (footerR, input'') = parse chunkFooterP input' + + if footerR == Success () then + -- チャンクフッタを正常に讀めた + do writeItr itr itrReqChunkRemaining $ Just 0 + + return $ observeChunkedRequest itr input'' + else + return $ chunkWasMalformed itr + else + -- 次のチャンクを讀み始める + seekNextChunk itr input + else + -- 要求がまだ來ない + retry + else + -- 受信要求が來た + do remainingM <- readItr itr itrReqChunkRemaining id + if fmap (> 0) remainingM == Just True then + -- 現在のチャンクをまだ讀み + -- 終へてゐない + do let wanted = fromJust wantedM + remaining = fromJust remainingM + bytesToRead = fromIntegral $ min wanted remaining + (chunk, input') = B.splitAt bytesToRead input + actualReadBytes = fromIntegral $ B.length chunk + newWanted = case wanted - actualReadBytes of + 0 -> Nothing + n -> Just n + newRemaining = Just $ remaining - actualReadBytes + updateStates + = do writeItr itr itrReqChunkRemaining newRemaining + writeItr itr itrReqBodyWanted newWanted + updateItr itr itrReceivedBody $ flip B.append chunk + + if newRemaining == Just 0 then + -- チャンクフッタを讀む + case parse chunkFooterP input' of + (Success _, input'') + -> do updateStates + return $ observeChunkedRequest itr input'' + _ -> return $ chunkWasMalformed itr + else + -- まだチャンクの終はりに達してゐない + do updateStates + return $ observeChunkedRequest itr input' + else + -- 次のチャンクを讀み始める + seekNextChunk itr input + action + + seekNextChunk :: Interaction -> ByteString -> STM (IO ()) + seekNextChunk itr input + = case parse chunkHeaderP input of + -- 最終チャンク (中身が空) + (Success 0, input') + -> case parse chunkTrailerP input' of + (Success _, input'') + -> do writeItr itr itrReqChunkLength $ Nothing + writeItr itr itrReqChunkRemaining $ Nothing + writeItr itr itrReqChunkIsOver True + + return $ acceptRequest input'' + _ -> return $ chunkWasMalformed itr + -- 最終でないチャンク + (Success len, input') + -> do writeItr itr itrReqChunkLength $ Just len + writeItr itr itrReqChunkRemaining $ Just len + + return $ observeChunkedRequest itr input' + -- チャンクヘッダがをかしい + _ -> return $ chunkWasMalformed itr + + chunkWasMalformed :: Interaction -> IO () + chunkWasMalformed itr + = atomically $ do updateItr itr itrResponse + $ \ res -> res { + resStatus = BadRequest + } + writeItr itr itrWillClose True + writeItr itr itrState Done + writeDefaultPage itr + postprocess itr observeNonChunkedRequest :: Interaction -> ByteString -> IO () observeNonChunkedRequest itr input @@ -154,8 +249,6 @@ requestReader cnf tree h host tQueue writeItr itr itrReqChunkRemaining $ Just 0 writeItr itr itrReqChunkIsOver True - writeItr itr itrReqBodyWanted Nothing - writeItr itr itrReceivedBody B.empty return $ acceptRequest input' else @@ -165,13 +258,13 @@ requestReader cnf tree h host tQueue -- 受信要求が來た do remainingM <- readItr itr itrReqChunkRemaining id - let wanted = fromJust wantedM - expectedChunkLen = fromIntegral $ maybe wanted (min wanted) remainingM - (chunk, input') = B.splitAt expectedChunkLen input - newRemaining = fmap - (\ x -> x - (fromIntegral $ B.length chunk)) - remainingM - isOver = B.length chunk < expectedChunkLen + let wanted = fromJust wantedM + bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM + (chunk, input') = B.splitAt bytesToRead input + newRemaining = fmap + (\ x -> x - (fromIntegral $ B.length chunk)) + remainingM + isOver = B.length chunk < bytesToRead || newRemaining == Just 0 writeItr itr itrReqChunkRemaining newRemaining writeItr itr itrReqChunkIsOver isOver