X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=e3032ce583ea8afdae6c0802462ac283dcea2dbb;hb=2d25d34513dc4f6bf62e53e2af2f4a4ef39cc6dc;hp=4f63f28bb2a7293e907e08df9f1fc2a845b5f419;hpb=3c7a58ab749a55a30466a033b170536bcdf18b98;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 4f63f28..e3032ce 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -15,6 +15,7 @@ import qualified Data.Sequence as S import Data.Sequence (Seq, (<|), ViewR(..)) import Network import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.DefaultPage import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser @@ -30,66 +31,68 @@ import GHC.Conc (unsafeIOToSTM) requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () requestReader cnf tree h host tQueue - = do input <- B.hGetContents h - catch (acceptRequest input) $ \ exc -> + = do catch (do input <- B.hGetContents h + acceptRequest input) $ \ exc -> case exc of - IOException _ -> return () - _ -> print exc + IOException _ -> return () + AsyncException ThreadKilled -> return () + BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely" + _ -> print exc where acceptRequest :: ByteString -> IO () acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 - = do action - <- atomically $ - do queue <- readTVar tQueue - when (S.length queue >= cnfMaxPipelineDepth cnf) - retry - - -- リクエストを讀む。パースできない場合は直ち - -- に 400 Bad Request 應答を設定し、それを出力 - -- してから切斷するやうに ResponseWriter に通 - -- 知する。 - case parse requestP input of - Nothing -> return acceptNonparsableRequest - Just (req, input') -> return $ acceptParsableRequest req input' - action - - acceptNonparsableRequest :: IO () - acceptNonparsableRequest - = do itr <- newInteraction host Nothing + = do atomically $ do queue <- readTVar tQueue + when (S.length queue >= cnfMaxPipelineDepth cnf) + retry + + -- リクエストを讀む。パースできない場合は直ちに 400 Bad + -- Request 應答を設定し、それを出力してから切斷するやう + -- に ResponseWriter に通知する。 + case parse requestP input of + (Success req , input') -> acceptParsableRequest req input' + (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest + (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest + + acceptNonparsableRequest :: StatusCode -> IO () + acceptNonparsableRequest status + = do itr <- newInteraction cnf host Nothing let res = Response { resVersion = HttpVersion 1 1 - , resStatus = BadRequest + , resStatus = status , resHeaders = [] + } - atomically $ do writeTVar (itrResponse itr) $ Just res - writeTVar (itrWillClose itr) True - writeTVar (itrState itr) Done + atomically $ do writeItr itr itrResponse $ Just res + writeItr itr itrWillClose True + writeItr itr itrState Done + writeDefaultPage itr postprocess itr enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () - acceptParsableRequest req input' - = do itr <- newInteraction host (Just req) + acceptParsableRequest req input + = do itr <- newInteraction cnf host (Just req) action <- atomically $ do preprocess itr - res <- readTVar (itrResponse itr) - if fmap isError (fmap resStatus res) == Just True then - acceptSemanticallyInvalidRequest itr input' + isErr <- readItrF itr itrResponse (isError . resStatus) + if isErr == Just True then + acceptSemanticallyInvalidRequest itr input else case findResource tree $ (reqURI . fromJust . itrRequest) itr of Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr input' + -> acceptRequestForNonexistentResource itr input Just rsrcDef -- あった - -> acceptRequestForExistentResource itr input' rsrcDef + -> acceptRequestForExistentResource itr input rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr input - = do writeTVar (itrState itr) Done + = do writeItr itr itrState Done + writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input @@ -101,18 +104,19 @@ requestReader cnf tree h host tQueue , resStatus = NotFound , resHeaders = [] } - writeTVar (itrResponse itr) $ Just res - writeTVar (itrState itr) Done + writeItr itr itrResponse $ Just res + 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 <- readTVar (itrRequestHasBody itr) - writeTVar (itrState itr) (if requestHasBody - then ExaminingHeader - else DecidingHeader) + = do requestHasBody <- readItr itr itrRequestHasBody id + writeItr itr itrState (if requestHasBody + then ExaminingHeader + else DecidingHeader) enqueue itr return $ do runResource rsrcDef itr if requestHasBody then @@ -121,7 +125,64 @@ requestReader cnf tree h host tQueue acceptRequest input observeRequest :: Interaction -> ByteString -> IO () - observeRequest itr input = fail "FIXME: Not Implemented" + observeRequest itr input + = do isChunked <- atomically $ readItr itr itrRequestIsChunked id + if isChunked then + observeChunkedRequest itr input + else + observeNonChunkedRequest itr input + + observeChunkedRequest :: Interaction -> ByteString -> IO () + observeChunkedRequest itr input + = fail "FIXME: not implemented" + + observeNonChunkedRequest :: Interaction -> ByteString -> IO () + observeNonChunkedRequest itr input + = do action + <- atomically $ + 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 + + let (_, input') = if remainingM == Nothing then + (B.takeWhile (\ _ -> True) input, B.empty) + else + B.splitAt (fromIntegral $ fromJust remainingM) input + + writeItr itr itrReqChunkRemaining $ Just 0 + writeItr itr itrReqChunkIsOver True + writeItr itr itrReqBodyWanted Nothing + writeItr itr itrReceivedBody B.empty + + return $ acceptRequest input' + else + -- 要求がまだ来ない + retry + else + -- 受信要求が來た + 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 + + writeItr itr itrReqChunkRemaining newRemaining + writeItr itr itrReqChunkIsOver isOver + writeItr itr itrReqBodyWanted Nothing + writeItr itr itrReceivedBody chunk + + if isOver then + return $ acceptRequest input' + else + return $ observeNonChunkedRequest itr input' + action enqueue :: Interaction -> STM () enqueue itr = do queue <- readTVar tQueue