Optimized as possible as I can.

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

diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs
index bb4ba2824e979582db1ca79fc841f2221328e2d2..a79e47b49c9f143d6d83638868d42be26cd0d901 100644 (file)
--- a/Network/HTTP/Lucu/DefaultPage.hs
+++ b/Network/HTTP/Lucu/DefaultPage.hs
@@ -15,13 +15,13 @@ import           Data.ByteString.Lazy.Char8 (ByteString)
 import           Data.Maybe
 import           Network
 import           Network.HTTP.Lucu.Config
+import           Network.HTTP.Lucu.Format
 import           Network.HTTP.Lucu.Headers
 import           Network.HTTP.Lucu.Interaction
 import           Network.HTTP.Lucu.Request
 import           Network.HTTP.Lucu.Response
 import           Network.URI
 import           System.IO.Unsafe
-import           Text.Printf
 import           Text.XML.HXT.Arrow.WriteDocument
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.Arrow.XmlIOStateArrow
@@ -31,7 +31,8 @@ import           Text.XML.HXT.DOM.XmlKeywords
 
 getDefaultPage :: Config -> Maybe Request -> Response -> String
 getDefaultPage conf req res
-    = let msgA = getMsg req res
+    = conf `seq` req `seq` res `seq`
+      let msgA = getMsg req res
       in
         unsafePerformIO $
         do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA
@@ -43,7 +44,8 @@ getDefaultPage conf req res
 
 writeDefaultPage :: Interaction -> STM ()
 writeDefaultPage itr
-    = do wroteHeader <- readTVar (itrWroteHeader itr)
+    = itr `seq`
+      do wroteHeader <- readTVar (itrWroteHeader itr)
 
          -- Content-Type が正しくなければ補完できない。
          res <- readItr itr itrResponse id
@@ -59,7 +61,8 @@ writeDefaultPage itr
 
 mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree
 mkDefaultPage conf status msgA
-    = let (sCode, sMsg) = statusCode status
+    = conf `seq` status `seq` msgA `seq`
+      let (sCode, sMsg) = statusCode status
           sig           = cnfServerSoftware conf
                           ++ " at "
                           ++ cnfServerHost conf
@@ -73,7 +76,7 @@ mkDefaultPage conf status msgA
                 += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                 += ( eelem "head"
                      += ( eelem "title"
-                          += txt (printf "%03d %s" sCode sMsg)
+                          += txt (fmtDec 3 sCode ++ " " ++ sMsg)
                         ))
                 += ( eelem "body"
                      += ( eelem "h1"
@@ -82,17 +85,18 @@ mkDefaultPage conf status msgA
                      += ( eelem "p" += msgA )
                      += eelem "hr"
                      += ( eelem "address" += txt sig ))))
-
+{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-}
 
 getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree
 getMsg req res
-    = case resStatus res of
+    = req `seq` res `seq`
+      case resStatus res of
         -- 1xx は body を持たない
         -- 2xx の body は補完しない
 
         -- 3xx
         MovedPermanently
-            -> txt (printf "The resource at %s has been moved to " path)
+            -> txt ("The resource at " ++ path ++ " has been moved to ")
                <+>
                eelem "a" += sattr "href" loc
                          += txt loc
@@ -100,7 +104,7 @@ getMsg req res
                txt " permanently."
 
         Found
-            -> txt (printf "The resource at %s is currently located at " path)
+            -> txt ("The resource at " ++ path ++ " is currently located at ")
                <+>
                eelem "a" += sattr "href" loc
                          += txt loc
@@ -108,7 +112,7 @@ getMsg req res
                txt ". This is not a permanent relocation."
 
         SeeOther
-            -> txt (printf "The resource at %s can be found at " path)
+            -> txt ("The resource at " ++ path ++ " can be found at ")
                <+>
                eelem "a" += sattr "href" loc
                          += txt loc
@@ -116,7 +120,7 @@ getMsg req res
                txt "."
 
         TemporaryRedirect
-            -> txt (printf "The resource at %s is temporarily located at " path)
+            -> txt ("The resource at " ++ path ++ " is temporarily located at ")
                <+>
                eelem "a" += sattr "href" loc
                          += txt loc
@@ -128,26 +132,26 @@ getMsg req res
             -> txt "The server could not understand the request you sent."
 
         Unauthorized
-            -> txt (printf "You need a valid authentication to access %s" path)
+            -> txt ("You need a valid authentication to access " ++ path)
 
         Forbidden
-            -> txt (printf "You don't have permission to access %s" path)
+            -> txt ("You don't have permission to access " ++ path)
 
         NotFound
-            -> txt (printf "The requested URL %s was not found on this server." path)
+            -> txt ("The requested URL " ++ path ++ " was not found on this server.")
 
         Gone
-            -> txt (printf "The resource at %s was here in past times, but has gone permanently." path)
+            -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.")
 
         RequestEntityTooLarge
-            -> txt (printf "The request entity you sent for %s was too big to accept." path)
+            -> txt ("The request entity you sent for " ++ path ++ " was too big to accept.")
 
         RequestURITooLarge
             -> txt "The request URI you sent was too big to accept."
 
         -- 5xx
         InternalServerError
-            -> txt (printf "An internal server error has occured during the process of your request to %s" path)
+            -> txt ("An internal server error has occured during the process of your request to " ++ path)
 
         ServiceUnavailable
             -> txt "The service is temporarily unavailable. Try later."
@@ -157,9 +161,11 @@ getMsg req res
                             
     where
       path :: String
-      path = let uri = reqURI $ fromJust req
+      path = let uri = reqURI $! fromJust req
              in
                uriPath uri
 
       loc :: String
-      loc = fromJust $ getHeader "Location" res
+      loc = fromJust $! getHeader "Location" res
+
+{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-}
\ No newline at end of file