X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=70d4a6a278b29c6aa6f3e70ba31b3d2920565e1f;hb=1789cee5ee66d2f7f2b26280be2f13eac4df7980;hp=dbc3835d6bbd8e5e7362426c900c81d736771278;hpb=e34910f85f459f049b9e6e6b79db9ef95dfccc13;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index dbc3835..70d4a6a 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,12 +1,10 @@
 {-# LANGUAGE
-    BangPatterns
-  , OverloadedStrings
-  , UnboxedTuples
+    OverloadedStrings
   , UnicodeSyntax
   #-}
 module Network.HTTP.Lucu.DefaultPage
     ( getDefaultPage
-    , writeDefaultPage
+    , defaultPageContentType
     , mkDefaultPage
     )
     where
@@ -14,17 +12,13 @@ import Control.Arrow
 import Control.Arrow.ArrowList
 import Control.Arrow.ListArrow
 import Control.Arrow.Unicode
-import Control.Concurrent.STM
-import Control.Monad
+import Data.Ascii (Ascii)
 import qualified Data.Ascii as A
 import Data.Maybe
-import qualified Data.Sequence as S
-import Data.Text (Text)
 import qualified Data.Text as T
-import Data.Text.Encoding
+import qualified Data.Text.Lazy as Lazy
 import Network.HTTP.Lucu.Config
 import Network.HTTP.Lucu.Headers
-import Network.HTTP.Lucu.Interaction
 import Network.HTTP.Lucu.Request
 import Network.HTTP.Lucu.Response
 import Network.URI hiding (path)
@@ -34,34 +28,25 @@ import Text.XML.HXT.Arrow.XmlArrow
 import Text.XML.HXT.Arrow.XmlState
 import Text.XML.HXT.DOM.TypeDefs
 
-getDefaultPage ∷ Config → Maybe Request → Response → Text
+getDefaultPage ∷ Config → Maybe Request → Response → Lazy.Text
 {-# INLINEABLE getDefaultPage #-}
-getDefaultPage !conf !req !res
+getDefaultPage conf req res
     = let msgA     = getMsg req res
           [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA
                              ⋙ 
                              writeDocumentToString [ withIndent True ]
                            ) ()
       in
-        T.pack xmlStr
+        Lazy.pack xmlStr
 
-writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage !itr
-    -- Content-Type が正しくなければ補完できない。
-    = do res ← readItr itr itrResponse id
-         when (getHeader "Content-Type" res == Just defaultPageContentType)
-                  $ do reqM ← readItr itr itrRequest id
-
-                       let conf = itrConfig itr
-                           page = getDefaultPage conf reqM res
-
-                       writeTVar (itrBodyToSend itr)
-                                 (S.singleton (encodeUtf8 page))
+defaultPageContentType ∷ Ascii
+{-# INLINE defaultPageContentType #-}
+defaultPageContentType = "application/xhtml+xml"
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}
-mkDefaultPage !conf !status !msgA
-    = let sStr = A.toString $ printStatusCode status
+mkDefaultPage conf status msgA
+    = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "
                         , T.unpack (cnfServerHost conf)
@@ -83,7 +68,7 @@ mkDefaultPage !conf !status !msgA
 
 getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree
 {-# INLINEABLE getMsg #-}
-getMsg !req !res
+getMsg req res
     = case resStatus res of
         -- 1xx は body を持たない
         -- 2xx の body は補完しない