many changes...

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index cb0ce5c0cae7c17008cf5102e700aa674e6f9ca3..9307c8dcba499b1a3adeeb920ba0fe6238c59b37 100644 (file)
--- 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
 module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
     where

-

 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad


@@ -18,7 +22,6 @@ import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
 import           Network.HTTP.Lucu.HandleLike
 import           Network.HTTP.Lucu.Interaction
 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.Postprocess
 import           Network.HTTP.Lucu.Preprocess
 import           Network.HTTP.Lucu.Request


@@ -27,9 +30,8 @@ import           Network.HTTP.Lucu.Resource.Tree
 import           Prelude hiding (catch)
 import           System.IO (stderr)
 
 import           Prelude hiding (catch)
 import           System.IO (stderr)
 

-
-requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO ()
-requestReader !cnf !tree !fbs !h !addr !tQueue
+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`
     = do input <- hGetLBS h
          acceptRequest input
       `catches`


@@ -59,7 +61,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
           = {-# SCC "acceptNonparsableRequest" #-}
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
           = {-# SCC "acceptNonparsableRequest" #-}

-            do itr <- newInteraction cnf addr Nothing Nothing
+            do itr <- newInteraction cnf port addr Nothing Nothing

                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status
                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status


@@ -74,7 +76,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
       acceptParsableRequest req input
           = {-# SCC "acceptParsableRequest" #-}
             do cert <- hGetPeerCert h
       acceptParsableRequest req input
           = {-# SCC "acceptParsableRequest" #-}
             do cert <- hGetPeerCert h

-               itr  <- newInteraction cnf addr cert (Just req)
+               itr  <- newInteraction cnf port addr cert (Just req)

                action
                    <- atomically $
                       do preprocess itr
                action
                    <- atomically $
                       do preprocess itr


@@ -119,7 +121,7 @@ requestReader !cnf !tree !fbs !h !addr !tQueue
             do let itr = oldItr { itrResourcePath = Just rsrcPath }
                requestHasBody <- readItr itr itrRequestHasBody id
                enqueue itr
             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
                            if requestHasBody then
                                observeRequest itr input
                              else


@@ -188,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
                                                       = 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
                                                   -- チャンクフッタを讀む
 
                                               if newRemaining == Just 0 then
                                                   -- チャンクフッタを讀む


@@ -274,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
                                   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 itr itrReqChunkRemaining newRemaining
                                   writeItr itr itrReqChunkIsOver isOver
                                   writeItr itr itrReqBodyWanted Nothing
                                   writeItr itr itrReceivedBody chunk

+                                  writeItr itrReceivedBody actualReadBytes

 
                                   if isOver then
                                       return $ acceptRequest input'
 
                                   if isOver then
                                       return $ acceptRequest input'