module Network.HTTP.Lucu.RequestReader ( requestReader ) where import Control.Concurrent.STM import Control.Exception import Control.Monad import qualified Data.ByteString.Lazy.Char8 as B 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 import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.HTTP.Lucu.Resource.Tree import Prelude hiding (catch) import System.IO (stderr) requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO () requestReader !cnf !tree !fbs !h !addr !tQueue = do input <- hGetLBS h acceptRequest input `catches` [ Handler (( \ _ -> return () ) :: IOException -> IO ()) , Handler ( \ ThreadKilled -> return () ) , Handler ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" ) , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) ] where acceptRequest :: ByteString -> IO () acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 = {-# SCC "acceptRequest" #-} 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 = {-# SCC "acceptNonparsableRequest" #-} do itr <- newInteraction cnf addr Nothing Nothing atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = status } writeItr itr itrWillClose True writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req input = {-# SCC "acceptParsableRequest" #-} do cert <- hGetPeerCert h itr <- newInteraction cnf addr cert (Just req) action <- atomically $ do preprocess itr isErr <- readItr itr itrResponse (isError . resStatus) if isErr then acceptSemanticallyInvalidRequest itr input else do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req case rsrcM of Nothing -- Resource が無かった -> acceptRequestForNonexistentResource itr input Just (rsrcPath, rsrcDef) -- あった -> acceptRequestForExistentResource itr input rsrcPath rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr input = {-# SCC "acceptSemanticallyInvalidRequest" #-} do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr input = {-# 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 -> [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 observeRequest itr input else acceptRequest input observeRequest :: Interaction -> ByteString -> IO () observeRequest itr input = {-# SCC "observeRequest" #-} do isChunked <- atomically $ readItr itr itrRequestIsChunked id if isChunked then observeChunkedRequest itr input else observeNonChunkedRequest itr input observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr input = {-# SCC "observeChunkedRequest" #-} 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 = {-# SCC "seekNextChunk" #-} 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 = {-# 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 = {-# SCC "observeNonChunkedRequest" #-} 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 return $ acceptRequest input' else -- 要求がまだ来ない retry else -- 受信要求が來た do remainingM <- readItr itr itrReqChunkRemaining id 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 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 = {-# SCC "enqueue" #-} do queue <- readTVar tQueue writeTVar tQueue (itr <| queue)