X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=c6cdc0e54198eee6f5bc1aaf49d24a03c30fcdaf;hb=50e8fe7af585a8d33d93b3721be8f8f01905b891;hp=1cce2d659295a5386254bf42d9df1a96b77aa0df;hpb=858129cb755aa09da2b7bd758efb8519f2c89103;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 1cce2d6..c6cdc0e 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,4 +1,3 @@ --- #hide module Network.HTTP.Lucu.RequestReader ( requestReader ) @@ -9,31 +8,28 @@ import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy.Char8 as B import Data.ByteString.Lazy.Char8 (ByteString) -import Data.Map as M -import Data.Map (Map) import Data.Maybe import qualified Data.Sequence as S -import Data.Sequence (Seq, (<|), ViewR(..)) +import Data.Sequence ((<|)) +import GHC.Conc (unsafeIOToSTM) 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 import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess 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 -requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO () -requestReader cnf tree h addr tQueue - = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq` +requestReader :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO () +requestReader cnf tree fbs h addr tQueue + = cnf `seq` tree `seq` fbs `seq` h `seq` addr `seq` tQueue `seq` do catch (do input <- B.hGetContents h acceptRequest input) $ \ exc -> case exc of @@ -46,7 +42,8 @@ requestReader cnf tree h addr tQueue acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 - = do atomically $ do queue <- readTVar tQueue + = {-# SCC "acceptRequest" #-} + do atomically $ do queue <- readTVar tQueue when (S.length queue >= cnfMaxPipelineDepth cnf) retry @@ -54,13 +51,14 @@ requestReader cnf tree h addr tQueue -- Request 應答を設定し、それを出力してから切斷するやう -- に ResponseWriter に通知する。 case parse requestP input of - (Success req , input') -> acceptParsableRequest req input' - (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest - (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest + (# Success req , input' #) -> acceptParsableRequest req input' + (# IllegalInput, _ #) -> acceptNonparsableRequest BadRequest + (# ReachedEOF , _ #) -> acceptNonparsableRequest BadRequest acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status - = do itr <- newInteraction cnf addr Nothing + = {-# SCC "acceptNonparsableRequest" #-} + do itr <- newInteraction cnf addr Nothing atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = status @@ -73,7 +71,8 @@ requestReader cnf tree h addr tQueue acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req input - = do itr <- newInteraction cnf addr (Just req) + = {-# SCC "acceptParsableRequest" #-} + do itr <- newInteraction cnf addr (Just req) action <- atomically $ do preprocess itr @@ -81,17 +80,19 @@ requestReader cnf tree h addr tQueue if isErr then acceptSemanticallyInvalidRequest itr input else - case findResource tree $ reqURI req of - Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr input + do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req + case rsrcM of + Nothing -- Resource が無かった + -> acceptRequestForNonexistentResource itr input - Just (rsrcPath, rsrcDef) -- あった - -> acceptRequestForExistentResource itr input rsrcPath rsrcDef + Just (rsrcPath, rsrcDef) -- あった + -> acceptRequestForExistentResource itr input rsrcPath rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr input - = do writeItr itr itrState Done + = {-# SCC "acceptSemanticallyInvalidRequest" #-} + do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr @@ -99,7 +100,8 @@ requestReader cnf tree h addr tQueue acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr input - = do updateItr itr itrResponse + = {-# SCC "acceptRequestForNonexistentResource" #-} + do updateItr itr itrResponse $ \res -> res { resStatus = NotFound } @@ -111,7 +113,8 @@ requestReader cnf tree h addr tQueue acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ()) acceptRequestForExistentResource oldItr input rsrcPath rsrcDef - = do let itr = oldItr { itrResourcePath = Just rsrcPath } + = {-# SCC "acceptRequestForExistentResource" #-} + do let itr = oldItr { itrResourcePath = Just rsrcPath } requestHasBody <- readItr itr itrRequestHasBody id enqueue itr return $ do runResource rsrcDef itr @@ -122,7 +125,8 @@ requestReader cnf tree h addr tQueue observeRequest :: Interaction -> ByteString -> IO () observeRequest itr input - = do isChunked <- atomically $ readItr itr itrRequestIsChunked id + = {-# SCC "observeRequest" #-} + do isChunked <- atomically $ readItr itr itrRequestIsChunked id if isChunked then observeChunkedRequest itr input else @@ -130,7 +134,8 @@ requestReader cnf tree h addr tQueue observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr input - = do action + = {-# SCC "observeChunkedRequest" #-} + do action <- atomically $ do isOver <- readItr itr itrReqChunkIsOver id if isOver then @@ -147,7 +152,7 @@ requestReader cnf tree h addr tQueue -- 讀み終へてゐない do let (_, input') = B.splitAt (fromIntegral $ fromJust remainingM) input - (footerR, input'') = parse chunkFooterP input' + (# footerR, input'' #) = parse chunkFooterP input' if footerR == Success () then -- チャンクフッタを正常に讀めた @@ -185,10 +190,11 @@ requestReader cnf tree h addr tQueue if newRemaining == Just 0 then -- チャンクフッタを讀む case parse chunkFooterP input' of - (Success _, input'') + (# Success _, input'' #) -> do updateStates return $ observeChunkedRequest itr input'' - _ -> return $ chunkWasMalformed itr + (# _, _ #) + -> return $ chunkWasMalformed itr else -- まだチャンクの終はりに達してゐない do updateStates @@ -200,29 +206,33 @@ requestReader cnf tree h addr tQueue seekNextChunk :: Interaction -> ByteString -> STM (IO ()) seekNextChunk itr input - = case parse chunkHeaderP input of + = {-# SCC "seekNextChunk" #-} + case parse chunkHeaderP input of -- 最終チャンク (中身が空) - (Success 0, input') + (# Success 0, input' #) -> case parse chunkTrailerP input' of - (Success _, input'') + (# Success _, input'' #) -> do writeItr itr itrReqChunkLength $ Nothing writeItr itr itrReqChunkRemaining $ Nothing writeItr itr itrReqChunkIsOver True return $ acceptRequest input'' - _ -> return $ chunkWasMalformed itr + (# _, _ #) + -> return $ chunkWasMalformed itr -- 最終でないチャンク - (Success len, input') + (# Success len, input' #) -> do writeItr itr itrReqChunkLength $ Just len writeItr itr itrReqChunkRemaining $ Just len return $ observeChunkedRequest itr input' -- チャンクヘッダがをかしい - _ -> return $ chunkWasMalformed itr + (# _, _ #) + -> return $ chunkWasMalformed itr chunkWasMalformed :: Interaction -> IO () chunkWasMalformed itr - = atomically $ do updateItr itr itrResponse + = {-# SCC "chunkWasMalformed" #-} + atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = BadRequest } @@ -233,7 +243,8 @@ requestReader cnf tree h addr tQueue observeNonChunkedRequest :: Interaction -> ByteString -> IO () observeNonChunkedRequest itr input - = do action + = {-# SCC "observeNonChunkedRequest" #-} + do action <- atomically $ do wantedM <- readItr itr itrReqBodyWanted id if wantedM == Nothing then @@ -278,5 +289,6 @@ requestReader cnf tree h addr tQueue action enqueue :: Interaction -> STM () - enqueue itr = do queue <- readTVar tQueue + enqueue itr = {-# SCC "enqueue" #-} + do queue <- readTVar tQueue writeTVar tQueue (itr <| queue) \ No newline at end of file