staticFile

[Lucu.git] / Network / HTTP / Lucu / Resource / Tree.hs

diff --git a/Network/HTTP/Lucu/Resource/Tree.hs b/Network/HTTP/Lucu/Resource/Tree.hs
index 062ffdca9217b5dd5462cf238fdb97e033b01ca7..28a94a4791d08235a1ff98abe2e8adf91a78c8eb 100644 (file)
--- a/Network/HTTP/Lucu/Resource/Tree.hs
+++ b/Network/HTTP/Lucu/Resource/Tree.hs
@@ -119,7 +119,7 @@ runResource def itr
                                 driftTo Done
                            ) itr
               )
-      $ \ exc -> processException (itrConfig itr) exc
+      $ \ exc -> processException exc
     where
       fork :: IO () -> IO ThreadId
       fork = if (resUsesNativeThread def)
@@ -153,21 +153,24 @@ runResource def itr
                        Just _  -> xs
                        Nothing -> []
 
-      processException :: Config -> Exception -> IO ()
-      processException conf exc
+      processException :: Exception -> IO ()
+      processException exc
           = do let abo = case exc of
-                           ErrorCall    msg  -> Abortion InternalServerError [] msg
-                           IOException  ioE  -> Abortion InternalServerError [] $ formatIOE ioE
+                           ErrorCall    msg  -> Abortion InternalServerError [] $ Just msg
+                           IOException  ioE  -> Abortion InternalServerError [] $ Just $ formatIOE ioE
                            DynException dynE -> case fromDynamic dynE of
                                                   Just (abo :: Abortion) -> abo
                                                   Nothing
                                                       -> Abortion InternalServerError []
-                                                         $ show exc
-                           _                 -> Abortion InternalServerError [] $ show exc
+                                                         $ Just $ show exc
+                           _                 -> Abortion InternalServerError [] $ Just $ show exc
+                   conf = itrConfig itr
+                   reqM = itrRequest itr
                -- まだ DecidingHeader 以前の状態だったら、この途中終了
                -- を應答に反映させる餘地がある。さうでなければ stderr
                -- にでも吐くしか無い。
                state <- atomically $ readItr itr itrState id
+               resM  <- atomically $ readItr itr itrResponse id
                if state <= DecidingHeader then
                    flip runReaderT itr
                       $ do setStatus $ aboStatus abo
@@ -175,7 +178,7 @@ runResource def itr
                            -- れではまずいと思ふ。
                            mapM_ (\ (name, value) -> setHeader name value) $ aboHeaders abo
                            setHeader "Content-Type" "application/xhtml+xml"
-                           output $ aboPage conf abo
+                           output $ abortPage conf reqM resM abo
                  else
                    hPutStrLn stderr $ show abo