Non-chunked input

[Lucu.git] / Network / HTTP / Lucu / RequestReader.hs

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 12cad2040039a95fd30426076ebfc45534a4c3b0..e3032ce583ea8afdae6c0802462ac283dcea2dbb 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -31,38 +31,38 @@ import GHC.Conc (unsafeIOToSTM)
 
 requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
 requestReader cnf tree h host tQueue
-    = do input <- B.hGetContents h
-         catch (acceptRequest input) $ \ exc ->
+    = do catch (do input <- B.hGetContents h
+                   acceptRequest input) $ \ exc ->
              case exc of
-               IOException _ -> return ()
-               _             -> print exc
+               IOException _               -> return ()
+               AsyncException ThreadKilled -> return ()
+               BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
+               _                           -> print exc
     where
       acceptRequest :: ByteString -> IO ()
       acceptRequest input
           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
           -- 時は、それが限度以下になるまで待つ。
-          = do action
-                   <- atomically $
-                      do queue    <- readTVar tQueue
-                         when (S.length queue >= cnfMaxPipelineDepth cnf)
-                              retry
-
-                         -- リクエストを讀む。パースできない場合は直ち
-                         -- に 400 Bad Request 應答を設定し、それを出力
-                         -- してから切斷するやうに ResponseWriter に通
-                         -- 知する。
-                         case parse requestP input of
-                           Nothing            -> return acceptNonparsableRequest
-                           Just (req, input') -> return $ acceptParsableRequest req input'
-               action
-      
-      acceptNonparsableRequest :: IO ()
-      acceptNonparsableRequest 
-          = do itr <- newInteraction host Nothing
+          = 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 host Nothing
                let res = Response {
                            resVersion = HttpVersion 1 1
-                         , resStatus  = BadRequest
+                         , resStatus  = status
                          , resHeaders = []
+
                          }
                atomically $ do writeItr itr itrResponse $ Just res
                                writeItr itr itrWillClose True
@@ -72,21 +72,21 @@ requestReader cnf tree h host tQueue
                                enqueue itr
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
-      acceptParsableRequest req input'
-          = do itr <- newInteraction host (Just req)
+      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 input'
+                             acceptSemanticallyInvalidRequest itr input
                            else
                              case findResource tree $ (reqURI . fromJust . itrRequest) itr of
                                Nothing -- Resource が無かった
-                                   -> acceptRequestForNonexistentResource itr input'
+                                   -> acceptRequestForNonexistentResource itr input
 
                                Just rsrcDef -- あった
-                                   -> acceptRequestForExistentResource itr input' rsrcDef
+                                   -> acceptRequestForExistentResource itr input rsrcDef
                action
 
       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
@@ -125,7 +125,64 @@ requestReader cnf tree h host tQueue
                                acceptRequest input
 
       observeRequest :: Interaction -> ByteString -> IO ()
-      observeRequest itr input = fail "FIXME: Not Implemented"
+      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
+          = fail "FIXME: not implemented"
+
+      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
+                                       writeItr itr itrReqBodyWanted Nothing
+                                       writeItr itr itrReceivedBody B.empty
+
+                                       return $ acceptRequest input'
+                                  else
+                                    -- 要求がまだ来ない
+                                    retry
+                           else
+                               -- 受信要求が來た
+                               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
 
       enqueue :: Interaction -> STM ()
       enqueue itr = do queue <- readTVar tQueue