many changes...

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 42eda0e7cb8efcec541eed78f19ba4f1d557b241..9307c8dcba499b1a3adeeb920ba0fe6238c59b37 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,50 +1,52 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnboxedTuples
+  , UnicodeSyntax
+  #-}

 module Network.HTTP.Lucu.RequestReader
 module Network.HTTP.Lucu.RequestReader

-    ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
+    ( requestReader

     )
     where
     )
     where

-

 import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
 import qualified Data.ByteString.Lazy.Char8 as B
 import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Control.Concurrent.STM
 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.Maybe
 import qualified Data.Sequence as S

-import           Data.Sequence (Seq, (<|), ViewR(..))
-import           Network
+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.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Chunk
 import           Network.HTTP.Lucu.DefaultPage

-import           Network.HTTP.Lucu.HttpVersion
+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.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           Prelude hiding (catch)

-import           System.IO
-
-import GHC.Conc (unsafeIOToSTM)
+import           System.IO (stderr)

 
 

-requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
-requestReader cnf tree h host tQueue
-    = 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
 


@@ -52,19 +54,18 @@ requestReader cnf tree h host 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 host Nothing
-               let res = Response {
-                           resVersion = HttpVersion 1 1
-                         , resStatus  = status
-                         , resHeaders = []
-                         }
-               atomically $ do writeItr itr itrResponse $ Just res
+          = {-# SCC "acceptNonparsableRequest" #-}
+            do itr <- newInteraction cnf port addr Nothing Nothing
+               atomically $ do updateItr itr itrResponse
+                                             $ \ res -> res {
+                                                          resStatus = status
+                                                        }

                                writeItr itr itrWillClose True
                                writeItr itr itrState     Done
                                writeDefaultPage itr
                                writeItr itr itrWillClose True
                                writeItr itr itrState     Done
                                writeDefaultPage itr


@@ -73,25 +74,29 @@ requestReader cnf tree h host tQueue
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
 
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input

-          = do itr <- newInteraction cnf host (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

-                         isErr <- readItrF itr itrResponse (isError . resStatus)
-                         if isErr == Just True then
+                         isErr <- readItr itr itrResponse (isError . resStatus)
+                         if isErr then

                              acceptSemanticallyInvalidRequest itr input
                            else
                              acceptSemanticallyInvalidRequest itr input
                            else

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

 
 

-                               Just rsrcDef -- あった
-                                   -> acceptRequestForExistentResource itr input 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


@@ -99,23 +104,24 @@ requestReader cnf tree h host tQueue
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input
 
       acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
       acceptRequestForNonexistentResource itr input

-          = do let res = Response {
-                           resVersion = HttpVersion 1 1
-                         , resStatus  = NotFound
-                         , resHeaders = []
-                         }
-               writeItr itr itrResponse $ Just res
+          = {-# SCC "acceptRequestForNonexistentResource" #-}
+            do updateItr itr itrResponse 
+                             $ \res -> res {
+                                         resStatus = NotFound
+                                       }

                writeItr itr itrState Done
                writeDefaultPage itr
                postprocess itr
                enqueue itr
                return $ acceptRequest input
 
                writeItr itr itrState Done
                writeDefaultPage itr
                postprocess itr
                enqueue itr
                return $ acceptRequest input
 

-      acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
-      acceptRequestForExistentResource itr input rsrcDef
-          = do requestHasBody <- readItr itr itrRequestHasBody id
+      acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
+      acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
+          = {-# SCC "acceptRequestForExistentResource" #-}
+            do let itr = oldItr { itrResourcePath = Just rsrcPath }
+               requestHasBody <- readItr itr itrRequestHasBody id

                enqueue itr
                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


@@ -123,7 +129,8 @@ requestReader cnf tree h host 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


@@ -131,7 +138,8 @@ requestReader cnf tree h host 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


@@ -148,7 +156,7 @@ requestReader cnf tree h host 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
                                                          -- チャンクフッタを正常に讀めた


@@ -182,14 +190,16 @@ requestReader cnf tree h host 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


@@ -201,43 +211,45 @@ requestReader cnf tree h host 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

-          = let res = Response {
-                        resVersion = HttpVersion 1 1
-                      , resStatus  = BadRequest
-                      , resHeaders = []
-                      }
-            in
-              atomically $ do writeItr itr itrResponse $ Just res
-                              writeItr itr itrWillClose True
-                              writeItr itr itrState Done
-                              writeDefaultPage itr
-                              postprocess itr
+          = {-# SCC "chunkWasMalformed" #-}
+            atomically $ do updateItr itr itrResponse 
+                                          $ \ res -> res {
+                                                       resStatus = BadRequest
+                                                     }
+                            writeItr itr itrWillClose True
+                            writeItr itr itrState Done
+                            writeDefaultPage itr
+                            postprocess itr

 
       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


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


@@ -282,5 +294,6 @@ requestReader cnf tree h host 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