Slight speed improvement

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index d1505e80b8386e0f5e42e4b695a1fcf2e91e9a31..091a3a2f92e31735641e4bf46fc6dba7431deb39 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -41,7 +41,8 @@ requestReader cnf tree h addr tQueue
       acceptRequest input
           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
           -- 時は、それが限度以下になるまで待つ。
-          = do atomically $ do queue    <- readTVar tQueue
+          = {-# SCC "acceptRequest" #-}
+            do atomically $ do queue    <- readTVar tQueue
                                when (S.length queue >= cnfMaxPipelineDepth cnf)
                                     retry
 
@@ -55,7 +56,8 @@ requestReader cnf tree h addr tQueue
 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
-          = do itr <- newInteraction cnf addr Nothing
+          = {-# SCC "acceptNonparsableRequest" #-}
+            do itr <- newInteraction cnf addr Nothing
                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status
@@ -68,7 +70,8 @@ requestReader cnf tree h addr tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
-          = do itr <- newInteraction cnf addr (Just req)
+          = {-# SCC "acceptParsableRequest" #-}
+            do itr <- newInteraction cnf addr (Just req)
                action
                    <- atomically $
                       do preprocess itr
@@ -86,7 +89,8 @@ requestReader cnf tree h addr 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
@@ -94,7 +98,8 @@ requestReader cnf tree h addr tQueue
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input
-          = do updateItr itr itrResponse 
+          = {-# SCC "acceptRequestForNonexistentResource" #-}
+            do updateItr itr itrResponse 
                              $ \res -> res {
                                          resStatus = NotFound
                                        }
@@ -106,7 +111,8 @@ requestReader cnf tree h addr 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
@@ -117,7 +123,8 @@ requestReader cnf tree h addr 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
@@ -125,7 +132,8 @@ requestReader cnf tree h addr tQueue
 
       observeChunkedRequest :: Interaction -> ByteString -> IO ()
       observeChunkedRequest itr input
-          = do action
+          = {-# SCC "observeChunkedRequest" #-}
+            do action
                    <- atomically $
                       do isOver <- readItr itr itrReqChunkIsOver id
                          if isOver then
@@ -195,7 +203,8 @@ requestReader cnf tree h addr 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
@@ -217,7 +226,8 @@ requestReader cnf tree h addr tQueue
 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr
-          = atomically $ do updateItr itr itrResponse 
+          = {-# SCC "chunkWasMalformed" #-}
+            atomically $ do updateItr itr itrResponse 
                                           $ \ res -> res {
                                                        resStatus = BadRequest
                                                      }
@@ -228,7 +238,8 @@ requestReader cnf tree h addr 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
@@ -273,5 +284,6 @@ requestReader cnf tree h addr 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