"driftTo Done" was trying to change the response header, which is impossible.

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

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 953fc5973d527e74229fa27854042ef13e677edc..b9e4b116250cedee3692aedb9a082ece6d812420 100644 (file)
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -1,9 +1,9 @@
 module Network.HTTP.Lucu.Abortion
     ( Abortion(..)
-    , abort      -- MonadIO m => StatusCode -> [ (String, String) ] -> Maybe String -> m a
-    , abortSTM   -- StatusCode -> [ (String, String) ] -> Maybe String -> STM a
-    , abortA     -- ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
-    , abortPage  -- Config -> Maybe Request -> Maybe Response -> Abortion -> String
+    , abort
+    , abortSTM
+    , abortA
+    , abortPage
     )
     where
 
@@ -54,10 +54,9 @@ abortA
 
 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
 -- Nothing の場合は getDefaultPage を使ってデフォルトのメッセージを得な
--- ければならない。しかもその時は resM から Response を捏造までする必要
--- がある。
-abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String
-abortPage conf reqM resM abo
+-- ければならない。
+abortPage :: Config -> Maybe Request -> Response -> Abortion -> String
+abortPage conf reqM res abo
     = case aboMessage abo of
         Just msg
             -> let [html] = unsafePerformIO 
@@ -68,15 +67,9 @@ abortPage conf reqM resM abo
                in
                  html
         Nothing
-            -> let res' = case resM of
-                            Just res -> res { resStatus = aboStatus abo }
-                            Nothing  -> Response {
-                                          resVersion = HttpVersion 1 1
-                                        , resStatus  = aboStatus abo
-                                        , resHeaders = []
-                                        }
-                   res  = foldl (.) id [setHeader name value
-                                            | (name, value) <- aboHeaders abo]
-                          $ res'
+            -> let res'  = res { resStatus = aboStatus abo }
+                   res'' = foldl (.) id [setHeader name value
+                                             | (name, value) <- aboHeaders abo]
+                           $ res'
                in
-                 getDefaultPage conf reqM res
+                 getDefaultPage conf reqM res''