Abortion

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 1cc46387f0c112c017df9e54704be70774e8e7b1..b5a934118e68cf513b3fe72a4c357b212bd847eb 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -12,6 +12,7 @@ module Network.HTTP.Lucu.DefaultPage
     where
 import Control.Arrow
 import Control.Arrow.ArrowList
+import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
 import Control.Concurrent.STM
 import Control.Monad
@@ -19,6 +20,7 @@ import qualified Data.Ascii as A
 import qualified Data.ByteString.Char8 as C8
 import Data.Maybe
 import qualified Data.Sequence as S
+import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Text.Encoding
 import Network.HTTP.Lucu.Config
@@ -28,23 +30,22 @@ import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.URI hiding (path)
-import System.IO.Unsafe
 import Prelude.Unicode
 import Text.XML.HXT.Arrow.WriteDocument
 import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.DOM.TypeDefs
 
-getDefaultPage ∷ Config → Maybe Request → Response → String
+getDefaultPage ∷ Config → Maybe Request → Response → Text
+{-# INLINEABLE getDefaultPage #-}
 getDefaultPage !conf !req !res
-    = let msgA = getMsg req res
-      in
-        unsafePerformIO $
-        do [xmlStr] ← runX ( mkDefaultPage conf (resStatus res) msgA
+    = let msgA     = getMsg req res
+          [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
                              ⋙ 
                              writeDocumentToString [ withIndent True ]
-                           )
-           return xmlStr
+                           ) ()
+      in
+        T.pack xmlStr
 
 writeDefaultPage ∷ Interaction → STM ()
 writeDefaultPage !itr
@@ -54,7 +55,7 @@ writeDefaultPage !itr
                   $ do reqM ← readItr itr itrRequest id
 
                        let conf = itrConfig itr
-                           page = T.pack $ getDefaultPage conf reqM res
+                           page = getDefaultPage conf reqM res
 
                        writeTVar (itrBodyToSend itr)
                                  (S.singleton (encodeUtf8 page))