X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FRequestReader.hs;h=091a3a2f92e31735641e4bf46fc6dba7431deb39;hb=47206637d664f163316dc9bb20983440ae4b138f;hp=639a37104262ad37a762c2881118977e002489b3;hpb=8e78bc83bfe67a376293c346ae0b30f1a684c787;p=Lucu.git

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 639a371..091a3a2 100644
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,4 +1,3 @@
--- #hide
 module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
@@ -42,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
 
@@ -56,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
@@ -69,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
@@ -87,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
@@ -95,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
                                        }
@@ -107,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
@@ -118,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
@@ -126,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
@@ -196,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
@@ -218,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
                                                      }
@@ -229,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
@@ -274,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