X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=9307c8dcba499b1a3adeeb920ba0fe6238c59b37;hb=3fe5ca3;hp=f6fa769cbadf04cc90d5eac6d3426f4de7835e51;hpb=1196f43ecedbb123515065f0440844864af906fb;p=Lucu.git

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index f6fa769..9307c8d 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,8 +1,12 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnboxedTuples
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
     where
-
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
@@ -16,25 +20,24 @@ import           Network.Socket
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
+import           Network.HTTP.Lucu.HandleLike
 import           Network.HTTP.Lucu.Interaction
-import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
 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
-
+import           System.IO (stderr)
 
-requestReader :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()
-requestReader !cnf !tree !fbs !h !addr !tQueue
-    = do input <- B.hGetContents h
+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
       `catches`
       [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
       , Handler  ( \ ThreadKilled        -> return () )
-      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" )
+      , Handler  ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" )
       , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
       ]
     where
@@ -58,7 +61,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
           = {-# SCC "acceptNonparsableRequest" #-}
-            do itr <- newInteraction cnf addr Nothing
+            do itr <- newInteraction cnf port addr Nothing Nothing
                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status
@@ -72,7 +75,8 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
           = {-# SCC "acceptParsableRequest" #-}
-            do itr <- newInteraction cnf addr (Just req)
+            do cert <- hGetPeerCert h
+               itr  <- newInteraction cnf port addr cert (Just req)
                action
                    <- atomically $
                       do preprocess itr
@@ -117,7 +121,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
             do let itr = oldItr { itrResourcePath = Just rsrcPath }
                requestHasBody <- readItr itr itrRequestHasBody id
                enqueue itr
-               return $ do runResource rsrcDef itr
+               return $ do _ <- runResource rsrcDef itr
                            if requestHasBody then
                                observeRequest itr input
                              else
@@ -186,6 +190,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
                                                       = do writeItr itr itrReqChunkRemaining newRemaining
                                                            writeItr itr itrReqBodyWanted newWanted
                                                            updateItr itr itrReceivedBody $ flip B.append chunk
+                                                           updateItr itrReceivedBodyLen (+ actualReadBytes) itr
 
                                               if newRemaining == Just 0 then
                                                   -- チャンクフッタを讀む
@@ -272,15 +277,15 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
                                   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
+                                      actualReadBytes = fromIntegral $ B.length chunk
+                                      newRemaining    = (- actualReadBytes) <$> remainingM
+                                      isOver          = actualReadBytes < bytesToRead ∨ newRemaining ≡ Just 0
 
                                   writeItr itr itrReqChunkRemaining newRemaining
                                   writeItr itr itrReqChunkIsOver isOver
                                   writeItr itr itrReqBodyWanted Nothing
                                   writeItr itr itrReceivedBody chunk
+                                  writeItr itrReceivedBody actualReadBytes
 
                                   if isOver then
                                       return $ acceptRequest input'