Cosmetic changes suggested by hlint

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index 05acb60e5162711c840069aac3ab41a4aebd69de..cbbf674718e922957ce57389ae32aa8454b9b87a 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -9,7 +9,8 @@ import           Control.Arrow
 import           Control.Arrow.ArrowList
 import           Control.Concurrent.STM
 import           Control.Monad
-import qualified Data.ByteString.Lazy.Char8 as B
+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
@@ -18,7 +19,7 @@ import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
-import           Network.URI
+import           Network.URI hiding (path)
 import           System.IO.Unsafe
 import           Text.XML.HXT.Arrow.WriteDocument
 import           Text.XML.HXT.Arrow.XmlArrow
@@ -28,9 +29,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
@@ -41,44 +41,40 @@ getDefaultPage conf req res
 
 
 writeDefaultPage :: Interaction -> STM ()
-writeDefaultPage itr
-    = itr `seq`
-      do wroteHeader <- readTVar (itrWroteHeader itr)
-
-         -- Content-Type が正しくなければ補完できない。
-         res <- readItr itr itrResponse id
-         when (getHeader "Content-Type" res == Just defaultPageContentType)
+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
 
                        let conf = itrConfig itr
-                           page = B.pack $ getDefaultPage conf reqM res
+                           page = L8.pack $ getDefaultPage conf reqM res
 
                        writeTVar (itrBodyToSend itr)
                                      $ page
 
 
 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
-          sig           = cnfServerSoftware conf
-                          ++ " at "
-                          ++ cnfServerHost conf
-                          ++ ( case cnfServerPort conf of
-                                 Service    serv -> ", service " ++ serv
-                                 PortNumber num  -> ", port " ++ show num
-                                 UnixSocket path -> ", unix socket " ++ show path
-                             )
+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"
                 += ( eelem "head"
                      += ( eelem "title"
-                          += txt (fmtDec 3 sCode ++ " " ++ sMsg)
+                          += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg)
                         ))
                 += ( eelem "body"
                      += ( eelem "h1"
-                          += txt sMsg
+                          += txt (C8.unpack sMsg)
                         )
                      += ( eelem "p" += msgA )
                      += eelem "hr"
@@ -86,9 +82,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 は補完しない
 
@@ -164,6 +159,6 @@ getMsg req res
                uriPath uri
 
       loc :: String
-      loc = fromJust $! getHeader "Location" res
+      loc = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res
 
 {-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file