Say good bye to the ugliness of "text" </> "plain".

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 800484cd0674a98d93dc214cb2c7ad94654cae36..091a3a2f92e31735641e4bf46fc6dba7431deb39 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
@@ -9,31 +8,28 @@ import           Control.Exception
 import           Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
-import           Data.Map as M
-import           Data.Map (Map)
 import           Data.Maybe
 import qualified Data.Sequence as S
-import           Data.Sequence (Seq, (<|), ViewR(..))
-import           Network
+import           Data.Sequence ((<|))
+import           Network.Socket
 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
 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
 import           Network.HTTP.Lucu.Resource.Tree
 import           Prelude hiding (catch)
 import           System.IO
 
 
-requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
-requestReader cnf tree h host tQueue
-    = do catch (do input <- B.hGetContents h
+requestReader :: Config -> ResTree -> Handle -> SockAddr -> InteractionQueue -> IO ()
+requestReader cnf tree h addr tQueue
+    = cnf `seq` tree `seq` h `seq` addr `seq` tQueue `seq`
+      do catch (do input <- B.hGetContents h
                    acceptRequest input) $ \ exc ->
              case exc of
                IOException _               -> return ()
@@ -45,7 +41,8 @@ requestReader cnf tree h host tQueue
       acceptRequest input
           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
           -- 時は、それが限度以下になるまで待つ。
-          = do atomically $ do queue    <- readTVar tQueue
+          = {-# SCC "acceptRequest" #-}
+            do atomically $ do queue    <- readTVar tQueue
                                when (S.length queue >= cnfMaxPipelineDepth cnf)
                                     retry
 
@@ -59,7 +56,8 @@ requestReader cnf tree h host tQueue
 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
-          = do itr <- newInteraction cnf host Nothing
+          = {-# SCC "acceptNonparsableRequest" #-}
+            do itr <- newInteraction cnf addr Nothing
                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status
@@ -72,7 +70,8 @@ requestReader cnf tree h host tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
-          = do itr <- newInteraction cnf host (Just req)
+          = {-# SCC "acceptParsableRequest" #-}
+            do itr <- newInteraction cnf addr (Just req)
                action
                    <- atomically $
                       do preprocess itr
@@ -90,7 +89,8 @@ requestReader cnf tree h host tQueue
 
       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
       acceptSemanticallyInvalidRequest itr input
-          = do writeItr itr itrState Done
+          = {-# SCC "acceptSemanticallyInvalidRequest" #-}
+            do writeItr itr itrState Done
                writeDefaultPage itr
                postprocess itr
                enqueue itr
@@ -98,7 +98,8 @@ requestReader cnf tree h host tQueue
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input
-          = do updateItr itr itrResponse 
+          = {-# SCC "acceptRequestForNonexistentResource" #-}
+            do updateItr itr itrResponse 
                              $ \res -> res {
                                          resStatus = NotFound
                                        }
@@ -110,7 +111,8 @@ requestReader cnf tree h host tQueue
 
       acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
       acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
-          = do let itr = oldItr { itrResourcePath = Just rsrcPath }
+          = {-# SCC "acceptRequestForExistentResource" #-}
+            do let itr = oldItr { itrResourcePath = Just rsrcPath }
                requestHasBody <- readItr itr itrRequestHasBody id
                enqueue itr
                return $ do runResource rsrcDef itr
@@ -121,7 +123,8 @@ requestReader cnf tree h host tQueue
 
       observeRequest :: Interaction -> ByteString -> IO ()
       observeRequest itr input
-          = do isChunked <- atomically $ readItr itr itrRequestIsChunked id
+          = {-# SCC "observeRequest" #-}
+            do isChunked <- atomically $ readItr itr itrRequestIsChunked id
                if isChunked then
                    observeChunkedRequest itr input
                  else
@@ -129,7 +132,8 @@ requestReader cnf tree h host tQueue
 
       observeChunkedRequest :: Interaction -> ByteString -> IO ()
       observeChunkedRequest itr input
-          = do action
+          = {-# SCC "observeChunkedRequest" #-}
+            do action
                    <- atomically $
                       do isOver <- readItr itr itrReqChunkIsOver id
                          if isOver then
@@ -199,7 +203,8 @@ requestReader cnf tree h host tQueue
 
       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
       seekNextChunk itr input
-          = case parse chunkHeaderP input of
+          = {-# SCC "seekNextChunk" #-}
+            case parse chunkHeaderP input of
               -- 最終チャンク (中身が空)
               (Success 0, input')
                   -> case parse chunkTrailerP input' of
@@ -221,7 +226,8 @@ requestReader cnf tree h host tQueue
 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr
-          = atomically $ do updateItr itr itrResponse 
+          = {-# SCC "chunkWasMalformed" #-}
+            atomically $ do updateItr itr itrResponse 
                                           $ \ res -> res {
                                                        resStatus = BadRequest
                                                      }
@@ -232,7 +238,8 @@ requestReader cnf tree h host tQueue
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input
-          = do action
+          = {-# SCC "observeNonChunkedRequest" #-}
+            do action
                    <- atomically $
                       do wantedM <- readItr itr itrReqBodyWanted id
                          if wantedM == Nothing then
@@ -277,5 +284,6 @@ requestReader cnf tree h host tQueue
                action
 
       enqueue :: Interaction -> STM ()
-      enqueue itr = do queue <- readTVar tQueue
+      enqueue itr = {-# SCC "enqueue" #-}
+                    do queue <- readTVar tQueue
                        writeTVar tQueue (itr <| queue)
\ No newline at end of file