Chunked input now works!

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index e3032ce583ea8afdae6c0802462ac283dcea2dbb..f2f3976f3a5c9adcb8345500018f9ef44447282a 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -15,6 +15,7 @@ import qualified Data.Sequence as S
 import           Data.Sequence (Seq, (<|), ViewR(..))
 import           Network
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.HttpVersion
 import           Network.HTTP.Lucu.Interaction
@@ -62,7 +63,6 @@ requestReader cnf tree h host tQueue
                            resVersion = HttpVersion 1 1
                          , resStatus  = status
                          , resHeaders = []
-
                          }
                atomically $ do writeItr itr itrResponse $ Just res
                                writeItr itr itrWillClose True
@@ -134,7 +134,109 @@ requestReader cnf tree h host tQueue
 
       observeChunkedRequest :: Interaction -> ByteString -> IO ()
       observeChunkedRequest itr input
-          = fail "FIXME: not implemented"
+          = 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'
+
+                                                     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
+
+                                              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
+
+      seekNextChunk :: Interaction -> ByteString -> STM (IO ())
+      seekNextChunk itr input
+          = 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
+
+      chunkWasMalformed :: Interaction -> IO ()
+      chunkWasMalformed itr
+          = let res = Response {
+                        resVersion = HttpVersion 1 1
+                      , resStatus  = BadRequest
+                      , resHeaders = []
+                      }
+            in
+              atomically $ do writeItr itr itrResponse $ Just res
+                              writeItr itr itrWillClose True
+                              writeItr itr itrState Done
+                              writeDefaultPage itr
+                              postprocess itr
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input
@@ -154,8 +256,6 @@ requestReader cnf tree h host tQueue
 
                                        writeItr itr itrReqChunkRemaining $ Just 0
                                        writeItr itr itrReqChunkIsOver True
-                                       writeItr itr itrReqBodyWanted Nothing
-                                       writeItr itr itrReceivedBody B.empty
 
                                        return $ acceptRequest input'
                                   else
@@ -165,13 +265,13 @@ requestReader cnf tree h host tQueue
                                -- 受信要求が來た
                                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
+                                  let wanted          = fromJust wantedM
+                                      bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
+                                      (chunk, input') = B.splitAt bytesToRead input
+                                      newRemaining    = fmap
+                                                        (\ x -> x - (fromIntegral $ B.length chunk))
+                                                        remainingM
+                                      isOver          = B.length chunk < bytesToRead || newRemaining == Just 0
 
                                   writeItr itr itrReqChunkRemaining newRemaining
                                   writeItr itr itrReqChunkIsOver isOver