Headers is now instances of collections-api's type classes.

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

diff --git a/Network/HTTP/Lucu/Abortion/Internal.hs b/Network/HTTP/Lucu/Abortion/Internal.hs
index f71e0454a51b9be04aa630df18bd268397574251..93fb8da44a70d87375d79bf47cb763385ba75450 100644 (file)
--- a/Network/HTTP/Lucu/Abortion/Internal.hs
+++ b/Network/HTTP/Lucu/Abortion/Internal.hs
@@ -12,6 +12,7 @@ import qualified Blaze.ByteString.Builder.Char.Utf8 as BB
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Control.Exception
+import Data.Collections
 import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Typeable
@@ -20,7 +21,6 @@ import Network.HTTP.Lucu.DefaultPage
 import Network.HTTP.Lucu.Headers
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
-import Prelude.Unicode
 import Text.XML.HXT.Arrow.WriteDocument
 import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
@@ -45,7 +45,7 @@ import Text.XML.HXT.Arrow.XmlState
 -- >         [("Location", "http://example.net/")]
 -- >         "It has been moved to example.net"
 data Abortion = Abortion {
-      aboStatus  ∷ !StatusCode
+      aboStatus  ∷ !SomeStatusCode
     , aboHeaders ∷ !Headers
     , aboMessage ∷ !(Maybe Text)
     } deriving (Eq, Show, Typeable)
@@ -67,8 +67,9 @@ abortPage conf reqM res abo
               in
                 BB.fromString html
         Nothing
-            → let res'  = res { resStatus = aboStatus abo }
-                  res'' = foldl (∘) id [setHeader name value
-                                            | (name, value) ← fromHeaders $ aboHeaders abo] res'
+            → let res' = res {
+                            resStatus  = aboStatus abo
+                          , resHeaders = insertMany (aboHeaders abo) (resHeaders res)
+                          }
                in
-                 getDefaultPage conf reqM res''
+                 getDefaultPage conf reqM res'