many changes...

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 639a37104262ad37a762c2881118977e002489b3..9307c8dcba499b1a3adeeb920ba0fe6238c59b37 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,9 +1,12 @@
--- #hide
+{-# 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


@@ -12,37 +15,38 @@ import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.Maybe
 import qualified Data.Sequence as S
 import           Data.Sequence ((<|))
 import           Data.Maybe
 import qualified Data.Sequence as S
 import           Data.Sequence ((<|))

+import           GHC.Conc (unsafeIOToSTM)

 import           Network.Socket
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage
 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.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           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 -> 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 ()
-               AsyncException ThreadKilled -> return ()
-               BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
-               _                           -> print exc
+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  ( \ BlockedIndefinitelyOnSTM -> hPutStrLn stderr "requestReader: blocked indefinitely" )
+      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+      ]

     where
       acceptRequest :: ByteString -> IO ()
       acceptRequest input
           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
           -- 時は、それが限度以下になるまで待つ。
     where
       acceptRequest :: ByteString -> IO ()
       acceptRequest input
           -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
           -- 時は、それが限度以下になるまで待つ。

-          = do atomically $ do queue    <- readTVar tQueue
+          = {-# SCC "acceptRequest" #-}
+            do atomically $ do queue    <- readTVar tQueue

                                when (S.length queue >= cnfMaxPipelineDepth cnf)
                                     retry
 
                                when (S.length queue >= cnfMaxPipelineDepth cnf)
                                     retry
 


@@ -50,13 +54,14 @@ requestReader cnf tree h addr tQueue
                -- Request 應答を設定し、それを出力してから切斷するやう
                -- に ResponseWriter に通知する。
                case parse requestP input of
                -- Request 應答を設定し、それを出力してから切斷するやう
                -- に ResponseWriter に通知する。
                case parse requestP input of

-                 (Success req , input') -> acceptParsableRequest req input'
-                 (IllegalInput, _     ) -> acceptNonparsableRequest BadRequest
-                 (ReachedEOF  , _     ) -> acceptNonparsableRequest BadRequest
+                 (# Success req , input' #) -> acceptParsableRequest req input'
+                 (# IllegalInput, _      #) -> acceptNonparsableRequest BadRequest
+                 (# ReachedEOF  , _      #) -> acceptNonparsableRequest BadRequest

 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status

-          = do itr <- newInteraction cnf addr Nothing
+          = {-# SCC "acceptNonparsableRequest" #-}
+            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


@@ -69,7 +74,9 @@ requestReader cnf tree h addr tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input

-          = do itr <- newInteraction cnf addr (Just req)
+          = {-# SCC "acceptParsableRequest" #-}
+            do cert <- hGetPeerCert h
+               itr  <- newInteraction cnf port addr cert (Just req)

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


@@ -77,17 +84,19 @@ requestReader cnf tree h addr tQueue
                          if isErr then
                              acceptSemanticallyInvalidRequest itr input
                            else
                          if isErr then
                              acceptSemanticallyInvalidRequest itr input
                            else

-                             case findResource tree $ reqURI req of
-                               Nothing -- Resource が無かった
-                                   -> acceptRequestForNonexistentResource itr input
+                             do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
+                                case rsrcM of
+                                  Nothing -- Resource が無かった
+                                      -> acceptRequestForNonexistentResource itr input

 
 

-                               Just (rsrcPath, rsrcDef) -- あった
-                                   -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
+                                  Just (rsrcPath, rsrcDef) -- あった
+                                      -> acceptRequestForExistentResource itr input rsrcPath rsrcDef

                action
 
       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
       acceptSemanticallyInvalidRequest itr input
                action
 
       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
                writeDefaultPage itr
                postprocess itr
                enqueue itr


@@ -95,7 +104,8 @@ requestReader cnf tree h addr tQueue
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input

-          = do updateItr itr itrResponse 
+          = {-# SCC "acceptRequestForNonexistentResource" #-}
+            do updateItr itr itrResponse 

                              $ \res -> res {
                                          resStatus = NotFound
                                        }
                              $ \res -> res {
                                          resStatus = NotFound
                                        }


@@ -107,10 +117,11 @@ requestReader cnf tree h addr tQueue
 
       acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
       acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
 
       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
                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


@@ -118,7 +129,8 @@ requestReader cnf tree h addr tQueue
 
       observeRequest :: Interaction -> ByteString -> IO ()
       observeRequest itr input
 
       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
                if isChunked then
                    observeChunkedRequest itr input
                  else


@@ -126,7 +138,8 @@ requestReader cnf tree h addr tQueue
 
       observeChunkedRequest :: Interaction -> ByteString -> IO ()
       observeChunkedRequest itr input
 
       observeChunkedRequest :: Interaction -> ByteString -> IO ()
       observeChunkedRequest itr input

-          = do action
+          = {-# SCC "observeChunkedRequest" #-}
+            do action

                    <- atomically $
                       do isOver <- readItr itr itrReqChunkIsOver id
                          if isOver then
                    <- atomically $
                       do isOver <- readItr itr itrReqChunkIsOver id
                          if isOver then


@@ -143,7 +156,7 @@ requestReader cnf tree h addr tQueue
                                                   -- 讀み終へてゐない
                                                   do let (_, input') = B.splitAt (fromIntegral
                                                                                   $ fromJust remainingM) input
                                                   -- 讀み終へてゐない
                                                   do let (_, input') = B.splitAt (fromIntegral
                                                                                   $ fromJust remainingM) input

-                                                         (footerR, input'') = parse chunkFooterP input'
+                                                         (# footerR, input'' #) = parse chunkFooterP input'

 
                                                      if footerR == Success () then
                                                          -- チャンクフッタを正常に讀めた
 
                                                      if footerR == Success () then
                                                          -- チャンクフッタを正常に讀めた


@@ -177,14 +190,16 @@ requestReader cnf tree 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
                                                   -- チャンクフッタを讀む
                                                   case parse chunkFooterP input' of
 
                                               if newRemaining == Just 0 then
                                                   -- チャンクフッタを讀む
                                                   case parse chunkFooterP input' of

-                                                    (Success _, input'')
+                                                    (# Success _, input'' #)

                                                         -> do updateStates
                                                               return $ observeChunkedRequest itr input''
                                                         -> do updateStates
                                                               return $ observeChunkedRequest itr input''

-                                                    _   -> return $ chunkWasMalformed itr
+                                                    (# _, _ #)
+                                                        -> return $ chunkWasMalformed itr

                                                 else
                                                   -- まだチャンクの終はりに達してゐない
                                                   do updateStates
                                                 else
                                                   -- まだチャンクの終はりに達してゐない
                                                   do updateStates


@@ -196,29 +211,33 @@ requestReader cnf tree h addr tQueue
 
       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
       seekNextChunk itr input
 
       seekNextChunk :: Interaction -> ByteString -> STM (IO ())
       seekNextChunk itr input

-          = case parse chunkHeaderP input of
+          = {-# SCC "seekNextChunk" #-}
+            case parse chunkHeaderP input of

               -- 最終チャンク (中身が空)
               -- 最終チャンク (中身が空)

-              (Success 0, input')
+              (# Success 0, input' #)

                   -> case parse chunkTrailerP input' of
                   -> case parse chunkTrailerP input' of

-                       (Success _, input'')
+                       (# Success _, input'' #)

                            -> do writeItr itr itrReqChunkLength $ Nothing
                                  writeItr itr itrReqChunkRemaining $ Nothing
                                  writeItr itr itrReqChunkIsOver True
                                  
                                  return $ acceptRequest input''
                            -> do writeItr itr itrReqChunkLength $ Nothing
                                  writeItr itr itrReqChunkRemaining $ Nothing
                                  writeItr itr itrReqChunkIsOver True
                                  
                                  return $ acceptRequest input''

-                       _   -> return $ chunkWasMalformed itr
+                       (# _, _ #)
+                           -> return $ chunkWasMalformed itr

               -- 最終でないチャンク
               -- 最終でないチャンク

-              (Success len, input')
+              (# Success len, input' #)

                   -> do writeItr itr itrReqChunkLength $ Just len
                         writeItr itr itrReqChunkRemaining $ Just len
                         
                         return $ observeChunkedRequest itr input'
               -- チャンクヘッダがをかしい
                   -> do writeItr itr itrReqChunkLength $ Just len
                         writeItr itr itrReqChunkRemaining $ Just len
                         
                         return $ observeChunkedRequest itr input'
               -- チャンクヘッダがをかしい

-              _   -> return $ chunkWasMalformed itr
+              (# _, _ #)
+                  -> return $ chunkWasMalformed itr

 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr
 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr

-          = atomically $ do updateItr itr itrResponse 
+          = {-# SCC "chunkWasMalformed" #-}
+            atomically $ do updateItr itr itrResponse 

                                           $ \ res -> res {
                                                        resStatus = BadRequest
                                                      }
                                           $ \ res -> res {
                                                        resStatus = BadRequest
                                                      }


@@ -229,7 +248,8 @@ requestReader cnf tree h addr tQueue
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input
 
       observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
       observeNonChunkedRequest itr input

-          = do action
+          = {-# SCC "observeNonChunkedRequest" #-}
+            do action

                    <- atomically $
                       do wantedM <- readItr itr itrReqBodyWanted id
                          if wantedM == Nothing then
                    <- atomically $
                       do wantedM <- readItr itr itrReqBodyWanted id
                          if wantedM == Nothing then


@@ -257,15 +277,15 @@ requestReader cnf tree 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'


@@ -274,5 +294,6 @@ requestReader cnf tree h addr tQueue
                action
 
       enqueue :: Interaction -> STM ()
                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
                        writeTVar tQueue (itr <| queue)
\ No newline at end of file