From 2d25d34513dc4f6bf62e53e2af2f4a4ef39cc6dc Mon Sep 17 00:00:00 2001 From: pho Date: Sun, 1 Apr 2007 23:14:14 +0900 Subject: [PATCH] Non-chunked input darcs-hash:20070401141414-62b54-621e5852b33796d5c6f7e2d94bf511ba1187885b.gz --- Network/HTTP/Lucu/Preprocess.hs | 14 +-- Network/HTTP/Lucu/RequestReader.hs | 140 ++++++++++++----------------- Network/HTTP/Lucu/Resource.hs | 5 ++ examples/HelloWorld.hs | 7 +- 4 files changed, 69 insertions(+), 97 deletions(-) diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs index d951f6a..1c11f89 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -70,22 +70,12 @@ preprocess itr case reqMethod req of GET -> return () HEAD -> writeItr itr itrWillDiscardBody True - POST -> ensureHavingBody itr - PUT -> ensureHavingBody itr + POST -> writeItr itr itrRequestHasBody True + PUT -> writeItr itr itrRequestHasBody True _ -> setStatus itr NotImplemented mapM_ (preprocessHeader itr) (reqHeaders req) where - ensureHavingBody itr - = let req = fromJust $ itrRequest itr - in - if getHeader "Content-Length" req == Nothing && - getHeader "Transfer-Encoding" req == Nothing then - - setStatus itr LengthRequired - else - writeItr itr itrRequestHasBody True - setStatus itr status = writeItr itr itrResponse $ Just (Response { resVersion = HttpVersion 1 1 diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index b0c22be..e3032ce 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -31,7 +31,8 @@ import GHC.Conc (unsafeIOToSTM) requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO () requestReader cnf tree h host tQueue - = do catch (acceptRequest B.empty) $ \ exc -> + = do catch (do input <- B.hGetContents h + acceptRequest input) $ \ exc -> case exc of IOException _ -> return () AsyncException ThreadKilled -> return () @@ -39,7 +40,7 @@ requestReader cnf tree h host tQueue _ -> print exc where acceptRequest :: ByteString -> IO () - acceptRequest soFar + acceptRequest input -- キューに最大パイプライン深度以上のリクエストが溜まってゐる -- 時は、それが限度以下になるまで待つ。 = do atomically $ do queue <- readTVar tQueue @@ -49,18 +50,10 @@ requestReader cnf tree h host tQueue -- リクエストを讀む。パースできない場合は直ちに 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 + (ReachedEOF , _ ) -> acceptNonparsableRequest BadRequest acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status @@ -69,6 +62,7 @@ requestReader cnf tree h host tQueue resVersion = HttpVersion 1 1 , resStatus = status , resHeaders = [] + } atomically $ do writeItr itr itrResponse $ Just res writeItr itr itrWillClose True @@ -78,33 +72,33 @@ requestReader cnf tree h host tQueue enqueue itr acceptParsableRequest :: Request -> ByteString -> IO () - acceptParsableRequest req soFar + acceptParsableRequest req input = 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 + acceptSemanticallyInvalidRequest itr input else case findResource tree $ (reqURI . fromJust . itrRequest) itr of Nothing -- Resource が無かった - -> acceptRequestForNonexistentResource itr soFar + -> acceptRequestForNonexistentResource itr input Just rsrcDef -- あった - -> acceptRequestForExistentResource itr soFar rsrcDef + -> acceptRequestForExistentResource itr input rsrcDef action acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ()) - acceptSemanticallyInvalidRequest itr soFar + acceptSemanticallyInvalidRequest itr input = do writeItr itr itrState Done writeDefaultPage itr postprocess itr enqueue itr - return $ acceptRequest soFar + return $ acceptRequest input acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ()) - acceptRequestForNonexistentResource itr soFar + acceptRequestForNonexistentResource itr input = do let res = Response { resVersion = HttpVersion 1 1 , resStatus = NotFound @@ -115,10 +109,10 @@ requestReader cnf tree h host tQueue writeDefaultPage itr postprocess itr enqueue itr - return $ acceptRequest soFar + return $ acceptRequest input acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ()) - acceptRequestForExistentResource itr soFar rsrcDef + acceptRequestForExistentResource itr input rsrcDef = do requestHasBody <- readItr itr itrRequestHasBody id writeItr itr itrState (if requestHasBody then ExaminingHeader @@ -126,92 +120,70 @@ requestReader cnf tree h host tQueue enqueue itr return $ do runResource rsrcDef itr if requestHasBody then - observeRequest itr soFar + observeRequest itr input else - acceptRequest soFar + acceptRequest input observeRequest :: Interaction -> ByteString -> IO () - observeRequest itr soFar + observeRequest itr input = do isChunked <- atomically $ readItr itr itrRequestIsChunked id if isChunked then - observeChunkedRequest itr soFar + observeChunkedRequest itr input else - observeNonChunkedRequest itr soFar + observeNonChunkedRequest itr input observeChunkedRequest :: Interaction -> ByteString -> IO () - observeChunkedRequest itr soFar + observeChunkedRequest itr input = fail "FIXME: not implemented" observeNonChunkedRequest :: Interaction -> ByteString -> IO () - observeNonChunkedRequest itr soFar - = fail "FIXME: not implemented" -{- + 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 - return $ wasteAllReqBody itr soFar + -- 破棄要求が來た + 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 + writeItr itr itrReqBodyWanted Nothing + writeItr itr itrReceivedBody B.empty + + return $ acceptRequest input' 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' + -- 受信要求が來た + do remainingM <- readItr itr itrReqChunkRemaining id + + let wanted = fromJust wantedM + expectedChunkLen = fromIntegral $ maybe wanted (min wanted) remainingM + (chunk, input') = B.splitAt expectedChunkLen input + newRemaining = fmap + (\ x -> x - (fromIntegral $ B.length chunk)) + remainingM + isOver = B.length chunk < expectedChunkLen + + 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 - 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) \ No newline at end of file diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index 7405975..24ae4b2 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -10,6 +10,7 @@ module Network.HTTP.Lucu.Resource , inputChunk -- Int -> Resource String , inputBS -- Int -> Resource ByteString , inputChunkBS -- Int -> Resource ByteString + , defaultLimit -- Int , setStatus -- StatusCode -> Resource () , setHeader -- String -> String -> Resource () @@ -305,6 +306,10 @@ inputChunkBS limit return chunk +defaultLimit :: Int +defaultLimit = (-1) + + setStatus :: StatusCode -> Resource () setStatus code = do driftTo DecidingHeader diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 69d7a05..1d0e6aa 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -25,7 +25,12 @@ helloWorld outputChunk "Hello, " outputChunk "World!\n" , resHead = Nothing - , resPost = Nothing + , resPost + = Just $ do --str1 <- inputChunk 3 + --str2 <- inputChunk 3 + --str3 <- inputChunk 3 + setHeader "Content-Type" "text/plain" + --output ("[" ++ str1 ++ " - " ++ str2 ++ "#" ++ str3 ++ "]") , resPut = Nothing , resDelete = Nothing } \ No newline at end of file -- 2.40.0