X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=d3b8daad721a88b8b28a700c28565a278101d20a;hb=70bf5bd248aa426ca4e410b3fb9a0529354aedaf;hp=091a3a2f92e31735641e4bf46fc6dba7431deb39;hpb=47206637d664f163316dc9bb20983440ae4b138f;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 091a3a2..d3b8daa 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,3 +1,8 @@ +{-# LANGUAGE + BangPatterns + , UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.RequestReader ( requestReader ) @@ -11,10 +16,12 @@ import Data.ByteString.Lazy.Char8 (ByteString) import Data.Maybe import qualified Data.Sequence as S 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.HandleLike import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Parser import Network.HTTP.Lucu.Postprocess @@ -23,19 +30,18 @@ import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource.Tree import Prelude hiding (catch) -import System.IO +import System.IO (stderr) - -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 () - AsyncException ThreadKilled -> return () - BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely" - _ -> print exc +requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO () +requestReader !cnf !tree !fbs !h !port !addr !tQueue + = do input <- hGetLBS h + acceptRequest input + `catches` + [ Handler (( \ _ -> return () ) :: IOException -> IO ()) + , Handler ( \ ThreadKilled -> return () ) + , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" ) + , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + ] where acceptRequest :: ByteString -> IO () acceptRequest input @@ -50,14 +56,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 = {-# SCC "acceptNonparsableRequest" #-} - do itr <- newInteraction cnf addr Nothing + do itr <- newInteraction cnf port addr Nothing Nothing atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = status @@ -71,7 +77,8 @@ requestReader cnf tree h addr tQueue acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req input = {-# SCC "acceptParsableRequest" #-} - do itr <- newInteraction cnf addr (Just req) + do cert <- hGetPeerCert h + itr <- newInteraction cnf port addr cert (Just req) action <- atomically $ do preprocess itr @@ -79,12 +86,13 @@ 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 ()) @@ -115,7 +123,7 @@ requestReader cnf tree h addr tQueue do let itr = oldItr { itrResourcePath = Just rsrcPath } requestHasBody <- readItr itr itrRequestHasBody id enqueue itr - return $ do runResource rsrcDef itr + return $ do _ <- runResource rsrcDef itr if requestHasBody then observeRequest itr input else @@ -150,7 +158,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 -- チャンクフッタを正常に讀めた @@ -188,10 +196,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 @@ -206,23 +215,25 @@ requestReader cnf tree h addr tQueue = {-# 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