Fixed breakage on GHC 6.10.1

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 8760cb80f45212bd041a9d0b454745fd1030ccd8..f6fa769cbadf04cc90d5eac6d3426f4de7835e51 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -11,6 +11,7 @@ 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
@@ -26,16 +27,16 @@ import           Prelude hiding (catch)
 import           System.IO
 
 
-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 :: Config -> ResTree -> [FallbackHandler] -> Handle -> SockAddr -> InteractionQueue -> IO ()
+requestReader !cnf !tree !fbs !h !addr !tQueue
+    = do input <- B.hGetContents h
+         acceptRequest input
+      `catches`
+      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
+      , Handler  ( \ ThreadKilled        -> return () )
+      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" )
+      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
+      ]
     where
       acceptRequest :: ByteString -> IO ()
       acceptRequest input
@@ -79,12 +80,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 ())