Many improvements

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 567b98b6961c75206994a8eb94c4e036e71c9a94..b0c22be45d93ab9e36612f7d635b4b10df955492 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -55,20 +55,19 @@ requestReader cnf tree h host tQueue
                let input = B.append soFar chunk
                case parse requestP input of
                  (Success req , input') -> acceptParsableRequest req input'
-                 (IllegalInput, _     ) -> acceptNonparsableRequest
+                 (IllegalInput, _     ) -> acceptNonparsableRequest BadRequest
                  (ReachedEOF  , _     ) -> if B.length input >= 1024 * 1024 then
                                                -- ヘッダ長過ぎ
-                                               acceptNonparsableRequest
+                                               acceptNonparsableRequest RequestEntityTooLarge
                                            else
                                                acceptRequest input
 
-      
-      acceptNonparsableRequest :: IO ()
-      acceptNonparsableRequest 
-          = do itr <- newInteraction host Nothing
+      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
@@ -80,7 +79,7 @@ requestReader cnf tree h host tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req soFar
-          = do itr <- newInteraction host (Just req)
+          = do itr <- newInteraction cnf host (Just req)
                action
                    <- atomically $
                       do preprocess itr
@@ -132,7 +131,86 @@ requestReader cnf tree h host tQueue
                                acceptRequest soFar
 
       observeRequest :: Interaction -> ByteString -> IO ()
-      observeRequest itr soFar = fail "FIXME: Not Implemented"
+      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