X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=091a3a2f92e31735641e4bf46fc6dba7431deb39;hb=47206637d664f163316dc9bb20983440ae4b138f;hp=f2f3976f3a5c9adcb8345500018f9ef44447282a;hpb=cd1b58b84ff354e3fc2a7d2c8fd548a7b59fe138;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index f2f3976..091a3a2 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,5 +1,5 @@ module Network.HTTP.Lucu.RequestReader - ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () + ( requestReader ) where @@ -8,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 Network +import Data.Sequence ((<|)) +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 -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 () @@ -44,7 +41,8 @@ requestReader cnf tree h host tQueue acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 - = do atomically $ do queue <- readTVar tQueue + = {-# SCC "acceptRequest" #-} + do atomically $ do queue <- readTVar tQueue when (S.length queue >= cnfMaxPipelineDepth cnf) retry @@ -58,13 +56,12 @@ 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 + = {-# SCC "acceptNonparsableRequest" #-} + 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,25 +70,27 @@ requestReader cnf tree h host tQueue acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req input - = do itr <- newInteraction cnf host (Just req) + = {-# SCC "acceptParsableRequest" #-} + 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 ()) acceptSemanticallyInvalidRequest itr input - = do writeItr itr itrState Done + = {-# SCC "acceptSemanticallyInvalidRequest" #-} + do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr @@ -99,24 +98,22 @@ 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 + = {-# SCC "acceptRequestForNonexistentResource" #-} + 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 + = {-# SCC "acceptRequestForExistentResource" #-} + do let itr = oldItr { itrResourcePath = Just rsrcPath } + requestHasBody <- readItr itr itrRequestHasBody id enqueue itr return $ do runResource rsrcDef itr if requestHasBody then @@ -126,7 +123,8 @@ requestReader cnf tree h host 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 @@ -134,7 +132,8 @@ requestReader cnf tree h host tQueue observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr input - = do action + = {-# SCC "observeChunkedRequest" #-} + do action <- atomically $ do isOver <- readItr itr itrReqChunkIsOver id if isOver then @@ -204,7 +203,8 @@ requestReader cnf tree h host tQueue seekNextChunk :: Interaction -> ByteString -> STM (IO ()) seekNextChunk itr input - = case parse chunkHeaderP input of + = {-# SCC "seekNextChunk" #-} + case parse chunkHeaderP input of -- 最終チャンク (中身が空) (Success 0, input') -> case parse chunkTrailerP input' of @@ -226,21 +226,20 @@ requestReader cnf tree h host tQueue chunkWasMalformed :: Interaction -> IO () chunkWasMalformed itr - = let res = Response { - resVersion = HttpVersion 1 1 - , resStatus = BadRequest - , resHeaders = [] - } - in - atomically $ do writeItr itr itrResponse $ Just res - writeItr itr itrWillClose True - writeItr itr itrState Done - writeDefaultPage itr - postprocess itr + = {-# SCC "chunkWasMalformed" #-} + 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 - = do action + = {-# SCC "observeNonChunkedRequest" #-} + do action <- atomically $ do wantedM <- readItr itr itrReqBodyWanted id if wantedM == Nothing then @@ -285,5 +284,6 @@ requestReader cnf tree h host 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