module Network.HTTP.Lucu.RequestReader ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () ) 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.Map as M import Data.Map (Map) import Data.Maybe 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 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 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 (acceptRequest B.empty) $ \ exc -> case exc of IOException _ -> return () AsyncException ThreadKilled -> return () BlockedIndefinitely -> putStrLn "requestReader: blocked indefinitely" _ -> print exc where acceptRequest :: ByteString -> IO () acceptRequest soFar -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 = do atomically $ do queue <- readTVar tQueue when (S.length queue >= cnfMaxPipelineDepth cnf) retry -- リクエストを讀む。パースできない場合は直ちに 400 Bad -- Request 應答を設定し、それを出力してから切斷するやう -- に ResponseWriter に通知する。 hWaitForInput h (-1) chunk <- B.hGetNonBlocking h 1024 let input = B.append soFar chunk case parse requestP input of (Success req , input') -> acceptParsableRequest req input' (IllegalInput, _ ) -> acceptNonparsableRequest BadRequest (ReachedEOF , _ ) -> if B.length input >= 1024 * 1024 then -- ヘッダ長過ぎ acceptNonparsableRequest RequestEntityTooLarge else acceptRequest input 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 writeItr itr itrWillClose True writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () acceptParsableRequest req soFar = do itr <- newInteraction cnf host (Just req) action <- atomically $ do preprocess itr isErr <- readItrF itr itrResponse (isError . resStatus) if isErr == Just True then acceptSemanticallyInvalidRequest itr soFar else case findResource tree $ (reqURI . fromJust . itrRequest) itr of Nothing -- Resource が無かった -> acceptRequestForNonexistentResource itr soFar Just rsrcDef -- あった -> acceptRequestForExistentResource itr soFar rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) acceptSemanticallyInvalidRequest itr soFar = do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest soFar acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) acceptRequestForNonexistentResource itr soFar = do let res = Response { resVersion = HttpVersion 1 1 , resStatus = NotFound , resHeaders = [] } writeItr itr itrResponse $ Just res writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr return $ acceptRequest soFar acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) acceptRequestForExistentResource itr soFar rsrcDef = 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 observeRequest itr soFar else acceptRequest soFar observeRequest :: Interaction -> ByteString -> IO () observeRequest itr soFar = do isChunked <- atomically $ readItr itr itrRequestIsChunked id if isChunked then observeChunkedRequest itr soFar else observeNonChunkedRequest itr soFar observeChunkedRequest :: Interaction -> ByteString -> IO () observeChunkedRequest itr soFar = fail "FIXME: not implemented" observeNonChunkedRequest :: Interaction -> ByteString -> IO () observeNonChunkedRequest itr soFar = fail "FIXME: not implemented" {- = do action <- atomically $ do wantedM <- readItr itr itrReqBodyWanted id if wantedM == Nothing then do wasteAll <- readItr itr itrReqBodyWasteAll id if wasteAll then return $ wasteAllReqBody itr soFar else retry else -- 受信要求が來た。 if B.empty soFar then return $ receiveNonChunkedReqBody itr else do remaining <- readItr itr itrReqChunkRemaining fromJust let wanted = fromJust wanted (chunk, input') = B.splitAt (min wanted remaining) soFar newRemaining = remaining - B.length chunk isOver = newRemaining == 0 writeItr itr itrReqChunkRemaining newRemaining writeItr itr itrReqChunkIsOver isOver writeItr itr itrReqBodyWanted (if isOver then Nothing else Just wanted) writeItr itr itrReceivedBody chunk if isOver then return $ acceptRequest input' else return $ observeNonChunkedRequest itr input' action receiveNonChunkedReqBody :: Interaction -> IO () receiveNonChunkedReqBody itr = do wanted <- atomically $ readItr itr itrReqBodyWanted fromJust remaining <- atomically $ readItr itr itrReqChunkRemaining fromJust hWaitForInput h (-1) chunk <- B.hGetNonBlocking h (min wanted remaining) let newRemaining = remaining - B.length chunk isOver = newRemaining == 0 atomically $ do writeItr itr itrReqChunkRemaining newRemaining writeItr itr itrReqChunkIsOver isOver writeItr itr itrReqBodyWanted (if isOver then Nothing else Just wanted) writeItr itr itrReceivedBody chunk if isOver then return $ acceptRequest B.empty else return $ observeNonChunkedRequest itr B.empty wasteAllReqBody :: Interaction -> ByteString -> IO () wasteAllReqBody itr soFar = -} enqueue :: Interaction -> STM () enqueue itr = do queue <- readTVar tQueue writeTVar tQueue (itr <| queue)