Use base64-bytestring instead of dataenc

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 091a3a2f92e31735641e4bf46fc6dba7431deb39..d3b8daad721a88b8b28a700c28565a278101d20a 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -1,3 +1,8 @@
+{-# LANGUAGE
+    BangPatterns
+  , UnboxedTuples
+  , UnicodeSyntax
+  #-}
 module Network.HTTP.Lucu.RequestReader
     ( requestReader
     )
@@ -11,10 +16,12 @@ import           Data.ByteString.Lazy.Char8 (ByteString)
 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.HTTP.Lucu.HandleLike
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Parser
 import           Network.HTTP.Lucu.Postprocess
@@ -23,19 +30,18 @@ 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
@@ -50,14 +56,14 @@ requestReader cnf tree h addr tQueue
                -- 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" #-}
-            do itr <- newInteraction cnf addr Nothing
+            do itr <- newInteraction cnf port addr Nothing Nothing
                atomically $ do updateItr itr itrResponse
                                              $ \ res -> res {
                                                           resStatus = status
@@ -71,7 +77,8 @@ requestReader cnf tree h addr tQueue
       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
@@ -79,12 +86,13 @@ requestReader cnf tree h addr tQueue
                          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 ())
@@ -115,7 +123,7 @@ requestReader cnf tree h addr tQueue
             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
@@ -150,7 +158,7 @@ requestReader cnf tree h addr tQueue
                                                   -- 讀み終へてゐない
                                                   do let (_, input') = B.splitAt (fromIntegral
                                                                                   $ fromJust remainingM) input
-                                                         (footerR, input'') = parse chunkFooterP input'
+                                                         (# footerR, input'' #) = parse chunkFooterP input'
 
                                                      if footerR == Success () then
                                                          -- チャンクフッタを正常に讀めた
@@ -188,10 +196,11 @@ requestReader cnf tree h addr tQueue
                                               if newRemaining == Just 0 then
                                                   -- チャンクフッタを讀む
                                                   case parse chunkFooterP input' of
-                                                    (Success _, input'')
+                                                    (# Success _, input'' #)
                                                         -> do updateStates
                                                               return $ observeChunkedRequest itr input''
-                                                    _   -> return $ chunkWasMalformed itr
+                                                    (# _, _ #)
+                                                        -> return $ chunkWasMalformed itr
                                                 else
                                                   -- まだチャンクの終はりに達してゐない
                                                   do updateStates
@@ -206,23 +215,25 @@ requestReader cnf tree h addr tQueue
           = {-# SCC "seekNextChunk" #-}
             case parse chunkHeaderP input of
               -- 最終チャンク (中身が空)
-              (Success 0, input')
+              (# Success 0, input' #)
                   -> 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''
-                       _   -> 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'
               -- チャンクヘッダがをかしい
-              _   -> return $ chunkWasMalformed itr
+              (# _, _ #)
+                  -> return $ chunkWasMalformed itr
 
       chunkWasMalformed :: Interaction -> IO ()
       chunkWasMalformed itr