Changed type of abortA

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

diff --git a/Network/HTTP/Lucu/Abortion.hs b/Network/HTTP/Lucu/Abortion.hs
index 6c03e8b6732bf5332bbf14792edfda23631a03aa..953fc5973d527e74229fa27854042ef13e677edc 100644 (file)
--- a/Network/HTTP/Lucu/Abortion.hs
+++ b/Network/HTTP/Lucu/Abortion.hs
@@ -2,7 +2,7 @@ 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 => StatusCode -> [ (String, String) ] -> Maybe String -> a b c
+    , abortA     -- ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
     , abortPage  -- Config -> Maybe Request -> Maybe Response -> Abortion -> String
     )
     where
@@ -47,9 +47,9 @@ abortSTM status headers msg
     = unsafeIOToSTM $ abort status headers msg
 
 
-abortA :: ArrowIO a => StatusCode -> [ (String, String) ] -> Maybe String -> a b c
-abortA status headers msg
-    = arrIO0 $ abort status headers msg
+abortA :: ArrowIO a => a (StatusCode, ([ (String, String) ], Maybe String)) c
+abortA 
+    = arrIO3 abort
 
 
 -- aboMessage が Just なら單に mkDefaultPage に渡すだけで良いので樂だが、
@@ -58,24 +58,25 @@ abortA status headers msg
 -- がある。
 abortPage :: Config -> Maybe Request -> Maybe Response -> Abortion -> String
 abortPage conf reqM resM abo
-    = let msg    = case aboMessage abo of
-                     Just msg -> msg
-                     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'
-                                 in
-                                   getDefaultPage conf reqM res
-          [html] = unsafePerformIO 
-                   $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
-                            >>>
-                            writeDocumentToString [(a_indent, v_1)]
-                          )
-      in
-        html
+    = case aboMessage abo of
+        Just msg
+            -> let [html] = unsafePerformIO 
+                            $ runX ( mkDefaultPage conf (aboStatus abo) (txt msg)
+                                     >>>
+                                     writeDocumentToString [(a_indent, v_1)]
+                                   )
+               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'
+               in
+                 getDefaultPage conf reqM res