Many changes...

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 1e5a7a6c6e51ebc422d72db62d024f56ac93df0a..5c6846bdc0dc94479ee4ba755e6864088117977c 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -1,6 +1,6 @@
 {-# LANGUAGE
-    BangPatterns
-  , OverloadedStrings
+    OverloadedStrings
+  , RecordWildCards
   , UnboxedTuples
   , UnicodeSyntax
   #-}
@@ -35,7 +35,7 @@ import Text.XML.HXT.DOM.TypeDefs
 
 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
                              ⋙ 
@@ -45,20 +45,17 @@ getDefaultPage !conf !req !res
         Lazy.pack xmlStr
 
 writeDefaultPage ∷ Interaction → STM ()
-writeDefaultPage !itr
+writeDefaultPage (Interaction {..})
     -- Content-Type が正しくなければ補完できない。
-    = do res ← readItr itrResponse itr
-         when (getHeader "Content-Type" res == Just defaultPageContentType)
-                  $ do reqM ← readItr itrRequest itr
-
-                       let conf = itrConfig itr
-                           page = getDefaultPage conf reqM res
-
-                       putTMVar (itrBodyToSend itr) (BB.fromLazyText page)
+    = do res ← readTVar itrResponse
+         when (getHeader "Content-Type" res ≡ Just defaultPageContentType)
+             $ do reqM ← readTVar itrRequest
+                  let page = getDefaultPage itrConfig reqM res
+                  putTMVar itrBodyToSend (BB.fromLazyText page)
 
 mkDefaultPage ∷ (ArrowXml a) ⇒ Config → StatusCode → a b XmlTree → a b XmlTree
 {-# INLINEABLE mkDefaultPage #-}
-mkDefaultPage !conf !status !msgA
+mkDefaultPage conf status msgA
     = let sStr = A.toString $ A.fromAsciiBuilder $ printStatusCode status
           sig  = concat [ A.toString (cnfServerSoftware conf)
                         , " at "
@@ -81,7 +78,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 は補完しない