-- #hide 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 Network.Socket import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.DefaultPage 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 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 where acceptRequest :: ByteString -> IO () acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 = 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 addr 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 = do itr <- newInteraction cnf addr (Just req) action <- atomically $ do preprocess itr isErr <- readItr itr itrResponse (isError . resStatus) if isErr then acceptSemanticallyInvalidRequest itr input else case findResource tree $ reqURI req of Nothing -- Resource が無かった -> acceptRequestForNonexistentResource itr input Just (rsrcPath, rsrcDef) -- あった -> acceptRequestForExistentResource itr input rsrcPath rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr input = do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest input acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr input = 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 = 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 = do isChunked <- atomically $ readItr itr itrRequestIsChunked id if isChunked then observeChunkedRequest itr input else observeNonChunkedRequest itr input observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr input = 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 = 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 = 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 <- 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 = do queue <- readTVar tQueue writeTVar tQueue (itr <| queue)