many changes...

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

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


@@ -11,31 +15,31 @@ 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


@@ -50,14 +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
           = {-# SCC "acceptNonparsableRequest" #-}
 
       acceptNonparsableRequest :: StatusCode -> IO ()
       acceptNonparsableRequest status
           = {-# SCC "acceptNonparsableRequest" #-}

-            do itr <- newInteraction cnf addr Nothing
+            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


@@ -71,7 +75,8 @@ requestReader cnf tree h addr tQueue
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
           = {-# SCC "acceptParsableRequest" #-}
       acceptParsableRequest :: Request -> ByteString -> IO ()
       acceptParsableRequest req input
           = {-# SCC "acceptParsableRequest" #-}

-            do itr <- newInteraction cnf addr (Just req)
+            do cert <- hGetPeerCert h
+               itr  <- newInteraction cnf port addr cert (Just req)

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


@@ -79,12 +84,13 @@ 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 ())
                action
 
       acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())


@@ -115,7 +121,7 @@ requestReader cnf tree h addr tQueue
             do let itr = oldItr { itrResourcePath = Just rsrcPath }
                requestHasBody <- readItr itr itrRequestHasBody id
                enqueue itr
             do let itr = oldItr { itrResourcePath = Just rsrcPath }
                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


@@ -150,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
                                                          -- チャンクフッタを正常に讀めた


@@ -184,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


@@ -206,23 +214,25 @@ requestReader cnf tree h addr tQueue
           = {-# SCC "seekNextChunk" #-}
             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


@@ -267,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'