X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=be369cc1c88f77334593067705ecbc2e32fcfb86;hb=50e8fe7af585a8d33d93b3721be8f8f01905b891;hp=a31e754adc2d6c4e16050c478df42b26eda2766c;hpb=34b0ad7f2ffc5e7ca67fa3468d01c5551edc8a8b;p=Lucu.git diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index a31e754..be369cc 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,4 +1,3 @@ --- #hide, prune module Network.HTTP.Lucu.DefaultPage ( getDefaultPage , writeDefaultPage @@ -10,18 +9,18 @@ import Control.Arrow import Control.Arrow.ArrowList import Control.Concurrent.STM import Control.Monad -import qualified Data.ByteString.Lazy.Char8 as B -import Data.ByteString.Lazy.Char8 (ByteString) +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 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 +30,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,14 +43,16 @@ getDefaultPage conf req res writeDefaultPage :: Interaction -> STM () writeDefaultPage itr - = do wroteHeader <- readTVar (itrWroteHeader itr) + = itr `seq` + do wroteHeader <- readTVar (itrWroteHeader itr) -- Content-Type が正しくなければ補完できない。 - res <- readTVar (itrResponse itr) - when (getHeader "Content-Type" res == Just defaultPageContentType) - $ do let reqM = itrRequest itr - conf = itrConfig itr - page = B.pack $ getDefaultPage conf reqM res + 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 = L8.pack $ getDefaultPage conf reqM res writeTVar (itrBodyToSend itr) $ page @@ -58,40 +60,42 @@ writeDefaultPage itr mkDefaultPage :: (ArrowXml a) => Config -> StatusCode -> a b XmlTree -> a b XmlTree mkDefaultPage conf status msgA - = 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 - ) + = conf `seq` status `seq` msgA `seq` + 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 (printf "%03d %s" sCode sMsg) + += txt (fmtDec 3 sCode ++ " " ++ C8.unpack sMsg) )) += ( eelem "body" += ( eelem "h1" - += txt sMsg + += txt (C8.unpack sMsg) ) += ( 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 @@ -99,7 +103,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 @@ -107,7 +111,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 @@ -115,7 +119,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 @@ -127,26 +131,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." @@ -156,9 +160,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 = C8.unpack $! fromJust $! getHeader (C8.pack "Location") res + +{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file