X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=2220c7fca408d5b416ec324103dbe0ed646b4e02;hb=0214f070b80791323430e21b53bcbe8a77b71b23;hp=6a980104d3dfe6a1f6d9b66202b9898aaa0ae1fd;hpb=3d017dd65ddede9a11c5b7a34a91e04340e67bc4;p=Lucu.git

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 6a98010..2220c7f 100644
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -12,7 +12,6 @@ import           Control.Monad
 import qualified Data.ByteString.Char8 as C8
 import qualified Data.ByteString.Lazy.Char8 as L8
 import           Data.Maybe
-import           Network
 import           Network.HTTP.Lucu.Config
 import           Network.HTTP.Lucu.Format
 import           Network.HTTP.Lucu.Headers
@@ -29,9 +28,8 @@ import           Text.XML.HXT.DOM.XmlKeywords
 
 
 getDefaultPage :: Config -> Maybe Request -> Response -> String
-getDefaultPage conf req res
-    = conf `seq` req `seq` res `seq`
-      let msgA = getMsg req res
+getDefaultPage !conf !req !res
+    = let msgA = getMsg req res
       in
         unsafePerformIO $
         do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
@@ -42,10 +40,9 @@ getDefaultPage conf req res
 
 
 writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
-    = itr `seq`
-      -- Content-Type が正しくなければ補完できない。
-      do res <- readItr itr itrResponse id
+writeDefaultPage !itr
+    -- Content-Type が正しくなければ補完できない。
+    = do res <- readItr itr itrResponse id
          when (getHeader (C8.pack "Content-Type") res == Just defaultPageContentType)
                   $ do reqM <- readItr itr itrRequest id
 
@@ -57,17 +54,11 @@ writeDefaultPage itr
 
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
-mkDefaultPage conf status msgA
-    = conf `seq` status `seq` msgA `seq`
-      let (# sCode, sMsg #) = statusCode status
+mkDefaultPage !conf !status !msgA
+    = let (# sCode, sMsg #) = statusCode status
           sig               = C8.unpack (cnfServerSoftware conf)
                               ++ " at "
                               ++ C8.unpack (cnfServerHost conf)
-                              ++ ( case cnfServerPort conf of
-                                     Service    serv -> ", service " ++ serv
-                                     PortNumber num  -> ", port " ++ show num
-                                     UnixSocket path -> ", unix socket " ++ show path
-                                 )
       in ( eelem "/"
            += ( eelem "html"
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
@@ -85,9 +76,8 @@ mkDefaultPage conf status msgA
 {-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
 
 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
-getMsg req res
-    = req `seq` res `seq`
-      case resStatus res of
+getMsg !req !res
+    = case resStatus res of
         -- 1xx は body を持たない
         -- 2xx の body は補完しない