X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=58183787a3942b81993e3ba00ca22e67b3b8fa90;hb=ca338174155913a969808d7b20193973394e474e;hp=9307c8dcba499b1a3adeeb920ba0fe6238c59b37;hpb=2bb7a0baa35dadb5d36d3f9fa98bd242baabc6d1;p=Lucu.git diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index 9307c8d..5818378 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,22 +1,22 @@ {-# LANGUAGE - BangPatterns - , UnboxedTuples + DoAndIfThenElse + , RecordWildCards + , ScopedTypeVariables , UnicodeSyntax #-} module Network.HTTP.Lucu.RequestReader ( requestReader ) where +import Control.Applicative 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 qualified Data.Attoparsec.Lazy as LP +import qualified Data.ByteString.Lazy as Lazy import Data.Maybe import qualified Data.Sequence as S -import Data.Sequence ((<|)) -import GHC.Conc (unsafeIOToSTM) -import Network.Socket +import Data.Sequence.Unicode import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Chunk import Network.HTTP.Lucu.DefaultPage @@ -27,273 +27,256 @@ 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) +import Network.Socket +import Network.URI +import Prelude.Unicode +import System.IO (hPutStrLn, stderr) -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 +data Context h + = Context { + cConfig ∷ !Config + , cResTree ∷ !ResTree + , cFallbacks ∷ ![FallbackHandler] + , cHandle ∷ !h + , cPort ∷ !PortNumber + , cAddr ∷ !SockAddr + , cQueue ∷ !InteractionQueue + } + +requestReader ∷ HandleLike h + ⇒ Config + → ResTree + → [FallbackHandler] + → h + → PortNumber + → SockAddr + → InteractionQueue + → IO () +requestReader cnf tree fbs h port addr tQueue + = do input ← hGetLBS h + acceptRequest (Context cnf tree fbs h port addr tQueue) input `catches` - [ Handler (( \ _ -> return () ) :: IOException -> IO ()) - , Handler ( \ ThreadKilled -> return () ) - , Handler ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" ) - , Handler (( \ e -> hPutStrLn stderr (show e) ) :: SomeException -> IO ()) + [ Handler $ \ (_ ∷ IOException) → return () + , Handler $ \ e → case e of + ThreadKilled → return () + _ → hPutStrLn stderr (show e) + , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely" + , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e) ] - 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 port 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 port 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 +acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO () +acceptRequest ctx@(Context {..}) input + -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、 + -- それが限度以下になるまで待つ。 + = do atomically $ + do queue ← readTVar cQueue + when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $ + retry + -- リクエストを讀む。パースできない場合は直ちに 400 Bad + -- Request 應答を設定し、それを出力してから切斷するやうに + -- ResponseWriter に通知する。 + case LP.parse requestP input of + LP.Done input' req → acceptParsableRequest req input' + LP.Fail _ _ _ → acceptNonparsableRequest ctx BadRequest - acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) - acceptSemanticallyInvalidRequest itr input - = {-# SCC "acceptSemanticallyInvalidRequest" #-} - do writeItr itr itrState Done - writeDefaultPage itr - postprocess itr - enqueue itr - return $ acceptRequest input +acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO () +acceptNonparsableRequest (Context {..}) status + = do itr ← newInteraction cConfig cPort cAddr Nothing Nothing + atomically $ + do setResponseStatus itr status + writeTVar (itrWillClose itr) True + writeTVar (itrState itr) Done + writeDefaultPage itr + postprocess itr + enqueue itr - 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 +acceptParsableRequest ∷ HandleLike h + ⇒ Context h + → Request + → Lazy.ByteString + → IO () +acceptParsableRequest (Context {..}) req input + = do cert ← hGetPeerCert cHandle + itr ← newInteraction cConfig cPort cAddr cert (Right req) + join $ atomically + $ do preprocess itr + isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr) + if isErr then + acceptSemanticallyInvalidRequest itr input + else + acceptSemanticallyValidRequest itr (reqURI req) 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 +acceptSemanticallyInvalidRequest ∷ Interaction → Lazy.ByteString → STM (IO ()) +acceptSemanticallyInvalidRequest itr input + = do writeTVar (itr itrState) Done + writeDefaultPage itr + postprocess itr + enqueue itr + return $ 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 +acceptSemanticallyValidRequest ∷ HandleLike h + ⇒ Context h + → Interaction + → URI + → Lazy.ByteString + → IO () +acceptSemanticallyValidRequest (Context {..}) itr uri input + = do rsrcM ← findResource cResTree cFallbacks uri + case rsrcM of + Nothing + → acceptRequestForNonexistentResource itr input + Just (rsrcPath, rsrcDef) + → acceptRequestForExistentResource itr input rsrcPath rsrcDef - 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' +acceptRequestForNonexistentResource ∷ Interaction → Lazy.ByteString → STM (IO ()) +acceptRequestForNonexistentResource itr input + = do setResponseStatus itr NotFound + writeTVar (itrState itr) Done + writeDefaultPage itr + postprocess itr + enqueue itr + return $ acceptRequest 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 - updateItr itrReceivedBodyLen (+ actualReadBytes) itr +acceptRequestForExistentResource ∷ Interaction → Lazy.ByteString → [String] → ResourceDef → STM (IO ()) +acceptRequestForExistentResource oldItr input rsrcPath rsrcDef + = do let itr = oldItr { itrResourcePath = Just rsrcPath } + enqueue itr + return $ do _ ← runResource rsrcDef itr + if reqHasBody $ fromJust $ itrRequest itr then + observeRequest itr input + else + acceptRequest input - 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 +observeRequest ∷ Interaction → Lazy.ByteString → IO () +observeRequest itr input + | itrReqBodyLength itr ≡ Just Chunked + = observeChunkedRequest itr input + | otherwise + = observeNonChunkedRequest itr input - 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 +observeChunkedRequest ∷ Interaction → Lazy.ByteString → IO () +observeChunkedRequest itr input + = join $ + atomically $ + do isOver ← readTVar $ itrReqChunkIsOver itr + if isOver then + return $ acceptRequest input + else + do wantedM ← readTVar $ itrReqBodyWanted itr + if isNothing wantedM then + do wasteAll ← readTVar $ itrReqBodyWasteAll itr + if wasteAll then + wasteCurrentChunk input + else + retry + else + readCurrentChunk (fromJust wantedM) - 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 +wasteCurrentChunk ∷ Interaction → Lazy.ByteString → Int → IO () +wasteCurrentChunk itr input len + | len > 0 + = let input' = Lazy.drop (fromIntegral len) input + in + case LP.parse chunkFooterP input' of + LP.Done input'' _ + → observeChunkedRequest itr input'' + LP.Fail _ _ _ + → chunkWasMalformed itr + | otherwise + = seekNextChunk itr input - 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 +readCurrentChunk ∷ Interaction → Lazy.ByteString → Int → Int → IO () +readCurrentChunk itr input wanted remaining + | remaining > 0 + = do let bytesToRead = fromIntegral $ min wanted remaining + (chunk, input') = Lazy.splitAt bytesToRead input + actualReadBytes = fromIntegral $ Lazy.length chunk + newWanted = case wanted - actualReadBytes of + 0 → Nothing + n → Just n + newRemaining = Just $ remaining - actualReadBytes + updateStates = do writeTVar (itrReqBodyWanted itr) newWanted + oldBody ← readTVar $ itrReceivedBody itr + oldBodyLen ← readTVar $ itrReceivedBodyLen itr + writeTVar (itrReceivedBody itr) $ oldBody ⊳ chunk + writeTVar (itrReceivedBodyLen itr) $ oldBodyLen + actualReadBytes + if newRemaining ≡ Just 0 then + case LP.parse chunkFooterP input' of + LP.Done input'' _ + → do updateStates + observeChunkedRequest itr input'' + LP.Fail _ _ _ + → chunkWasMalformed itr + else + do updateStates + observeChunkedRequest itr input' + | otherwise + = seekNextChunk itr input - writeItr itr itrReqChunkRemaining $ Just 0 - writeItr itr itrReqChunkIsOver True +seekNextChunk ∷ Interaction → Lazy.ByteString → IO () +seekNextChunk itr input + = case LP.parse chunkHeaderP input of + LP.Done input' len + | len ≡ 0 -- Final chunk + → case LP.parse chunkTrailerP input' of + LP.Done input'' _ + → do writeTVar (itrReqChunkIsOver itr) True + acceptRequest input'' + LP.Fail _ _ _ + → chunkWasMalformed itr + | otherwise -- Non-final chunk + → do observeChunkedRequest itr input' + LP.Fail _ _ _ + → chunkWasMalformed itr - return $ acceptRequest input' - else - -- 要求がまだ来ない - retry - else - -- 受信要求が來た - do remainingM <- readItr itr itrReqChunkRemaining id +chunkWasMalformed ∷ Interaction → IO () +chunkWasMalformed itr + = atomically $ + do setResponseStatus BadRequest + writeTVar (itrWillClose itr) True + writeTVar (itrState itr) Done + writeDefaultPage itr + postprocess itr - let wanted = fromJust wantedM - bytesToRead = fromIntegral $ maybe wanted (min wanted) remainingM - (chunk, input') = B.splitAt bytesToRead input - actualReadBytes = fromIntegral $ B.length chunk - newRemaining = (- actualReadBytes) <$> remainingM - isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0 +observeNonChunkedRequest ∷ Interaction → Lazy.ByteString → IO () +observeNonChunkedRequest itr input + = join $ + atomically $ + do wantedM ← readTVar $ itrReqBodyWanted itr + if isNothing wantedM then + do wasteAll ← readTVar itr itrReqBodyWasteAll id + if wasteAll then + wasteNonChunkedRequestBody itr input + else + retry + else + readNonChunkedRequestBody itr input - writeItr itr itrReqChunkRemaining newRemaining - writeItr itr itrReqChunkIsOver isOver - writeItr itr itrReqBodyWanted Nothing - writeItr itr itrReceivedBody chunk - writeItr itrReceivedBody actualReadBytes +wasteNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Maybe Int → IO () +wasteNonChunkedRequestBody itr input remaining + = do let input' = case remaining of + Just len → Lazy.drop len input + Nothing → (∅) + writeTVar (itrReqChunkIsOver itr) True + acceptRequest input' - if isOver then - return $ acceptRequest input' - else - return $ observeNonChunkedRequest itr input' - action +readNonChunkedRequestBody ∷ Interaction → Lazy.ByteString → Int → Maybe Int → IO () +readNonChunkedRequestBody itr input wanted remaining + = do let bytesToRead = fromIntegral $ maybe wanted (min wanted) remaining + (chunk, input') = Lazy.splitAt bytesToRead input + actualReadBytes = fromIntegral $ Lazy.length chunk + newRemaining = (- actualReadBytes) <$> remaining + isOver = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0 + writeTVar (itrReqChunkIsOver itr) isOver + writeTVar (itrReqBodyWanted itr) Nothing + writeTVar (itrReceivedBody itr) chunk + writeTVar (itrReceivedBodyLen itr) actualReadBytes + if isOver then + acceptRequest input' + else + observeNonChunkedRequest itr input' - enqueue :: Interaction -> STM () - enqueue itr = {-# SCC "enqueue" #-} - do queue <- readTVar tQueue - writeTVar tQueue (itr <| queue) \ No newline at end of file +enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM () +enqueue (Context {..}) itr + = do queue ← readTVar cQueue + writeTVar cQueue (itr ⊲ queue)