X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FResource%2FTree.hs;h=06fed17dd13c7d52af6d49e7f65ca3adcc164fb8;hb=f62b6f07bbf1eefcf552163d8f7daa6e0862ed5d;hp=51c30b6908ac67e02bf178d02640f25b6489ad81;hpb=5fc2e72c153ade03b16071c66a08a316295bb42a;p=Lucu.git

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 51c30b6..06fed17 100644
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -1,4 +1,4 @@
--- #prune
+{-# OPTIONS_HADDOCK prune #-}
 
 -- | Repository of the resources in httpd.
 module Network.HTTP.Lucu.Resource.Tree
@@ -18,7 +18,6 @@ import           Control.Concurrent.STM
 import           Control.Exception
 import           Control.Monad
 import qualified Data.ByteString.Char8 as C8
-import           Data.Dynamic
 import           Data.List
 import qualified Data.Map as M
 import           Data.Map (Map)
@@ -33,7 +32,6 @@ import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Utils
 import           Network.URI hiding (path)
 import           System.IO
-import           System.IO.Error hiding (catch)
 import           Prelude hiding (catch)
 
 
@@ -166,6 +164,9 @@ findResource (ResTree (ResNode rootDefM subtree)) fbs uri
     where
       walkTree :: ResSubtree -> [String] -> [String] -> Maybe ([String], ResourceDef)
 
+      walkTree _ [] _
+          = error "Internal error: should not reach here."
+
       walkTree tree (name:[]) soFar
           = case M.lookup name tree of
               Nothing               -> Nothing
@@ -198,10 +199,10 @@ runResource def itr
                              driftTo Done
                         ) itr
                )
-             $ \ exc -> processException exc
+               processException
     where
       fork :: IO () -> IO ThreadId
-      fork = if (resUsesNativeThread def)
+      fork = if resUsesNativeThread def
              then forkOS
              else forkIO
       
@@ -222,30 +223,26 @@ runResource def itr
                       setHeader (C8.pack "Allow") (C8.pack $ joinWith ", " allowedMethods)
 
       allowedMethods :: [String]
-      allowedMethods = nub $ foldr (++) [] [ methods resGet    ["GET"]
-                                           , methods resHead   ["GET", "HEAD"]
-                                           , methods resPost   ["POST"]
-                                           , methods resPut    ["PUT"]
-                                           , methods resDelete ["DELETE"]
-                                           ]
+      allowedMethods = nub $ concat [ methods resGet    ["GET"]
+                                    , methods resHead   ["GET", "HEAD"]
+                                    , methods resPost   ["POST"]
+                                    , methods resPut    ["PUT"]
+                                    , methods resDelete ["DELETE"]
+                                    ]
 
       methods :: (ResourceDef -> Maybe a) -> [String] -> [String]
       methods f xs = case f def of
                        Just _  -> xs
                        Nothing -> []
 
-      processException :: Exception -> IO ()
+      toAbortion :: SomeException -> Abortion
+      toAbortion e = case fromException e of
+                       Just abortion -> abortion
+                       Nothing       -> Abortion InternalServerError emptyHeaders (Just (show e))
+
+      processException :: SomeException -> IO ()
       processException exc
-          = do let abo = case exc of
-                           ErrorCall    msg  -> Abortion InternalServerError emptyHeaders $ Just msg
-                           IOException  ioE  -> Abortion InternalServerError emptyHeaders $ Just $ formatIOE ioE
-                           DynException dynE -> case fromDynamic dynE of
-                                                  Just a
-                                                      -> a :: Abortion
-                                                  Nothing
-                                                      -> Abortion InternalServerError emptyHeaders
-                                                         $ Just $ show exc
-                           _                 -> Abortion InternalServerError emptyHeaders $ Just $ show exc
+          = do let abo = toAbortion exc
                    conf = itrConfig itr
                -- まだ DecidingHeader 以前の状態だったら、この途中終了
                -- を應答に反映させる餘地がある。さうでなければ stderr
@@ -256,16 +253,10 @@ runResource def itr
                if state <= DecidingHeader then
                    flip runRes itr
                       $ do setStatus $ aboStatus abo
-                           mapM_ (\ (name, value) -> setHeader name value) $ fromHeaders $ aboHeaders abo
+                           mapM_ (uncurry setHeader) $ fromHeaders $ aboHeaders abo
                            output $ abortPage conf reqM res abo
                  else
                    when (cnfDumpTooLateAbortionToStderr $ itrConfig itr)
                             $ hPutStrLn stderr $ show abo
 
                flip runRes itr $ driftTo Done
-
-      formatIOE :: IOError -> String
-      formatIOE ioE = if isUserError ioE then
-                          ioeGetErrorString ioE
-                      else
-                          show ioE