Resource paths should not be assumed to be encoded in UTF-8. HTTP/1.1 says nothing...

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

diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs
index 554fa39e52c228463f13fd05a736465a20ced5f0..ecaaadb1d28a7f9ad479443c7b27e5dcc22493d1 100644 (file)
--- a/Network/HTTP/Lucu/RequestReader.hs
+++ b/Network/HTTP/Lucu/RequestReader.hs
@@ -26,6 +26,7 @@ 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.Internal
 import Network.HTTP.Lucu.Resource.Tree
 import Network.Socket
 import Network.URI
@@ -56,13 +57,25 @@ requestReader cnf tree fbs h port addr tQueue
     = do input ← hGetLBS h
          acceptRequest (Context cnf tree fbs h port addr tQueue) input
       `catches`
-      [ Handler $ \ (_ ∷ IOException)        → return ()
-      , Handler $ \ e → case e of
-                           ThreadKilled      → return ()
-                           _                 → hPutStrLn stderr (show e)
-      , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely"
-      , Handler $ \ (e ∷ SomeException)      → hPutStrLn stderr (show e)
+      [ Handler handleAsyncE
+      , Handler handleBIOS
+      , Handler handleOthers
       ]
+    where
+      handleAsyncE ∷ AsyncException → IO ()
+      handleAsyncE ThreadKilled = return ()
+      handleAsyncE e            = dump e
+
+      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
+      handleBIOS = dump
+
+      handleOthers ∷ SomeException → IO ()
+      handleOthers = dump
+
+      dump ∷ Exception e ⇒ e → IO ()
+      dump e
+          = do hPutStrLn stderr "requestReader caught an exception:"
+               hPutStrLn stderr (show $ toException e)
 
 acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
 acceptRequest ctx@(Context {..}) input
@@ -150,7 +163,7 @@ acceptRequestForExistentResource ∷ HandleLike h
 acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
     = do let itr = oldItr { itrResourcePath = Just rsrcPath }
          atomically $ enqueue ctx itr
-         do _ ← runResource rsrcDef itr
+         do _ ← spawnResource rsrcDef itr
             if reqMustHaveBody $ fromJust $ itrRequest itr then
                 observeRequest ctx itr input
             else