X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=b4413ce96b1a7017399bc65a9893b1a2b3954da6;hb=0dc3d31312a12f2b085242841b29eb0d96e9c4ac;hp=8c30315e1d316a98f40642302453c7a4fbb07121;hpb=a9e9f50818285bf66cd64e5a248175eecb8e1fea;p=Lucu.git diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 8c30315..b4413ce 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,6 +1,7 @@ module Network.HTTP.Lucu.DefaultPage - ( getDefaultPage -- Maybe Request -> Response -> String - , writeDefaultPage -- Interaction -> STM () + ( getDefaultPage + , writeDefaultPage + , mkDefaultPage ) where @@ -9,14 +10,16 @@ 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 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 @@ -24,12 +27,13 @@ import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords -getDefaultPage :: Maybe Request -> Response -> String -getDefaultPage req res - = let msgA = getMsg req res +getDefaultPage :: Config -> Maybe Request -> Response -> String +getDefaultPage conf req res + = conf `seq` req `seq` res `seq` + let msgA = getMsg req res in unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA + do [xmlStr] <- runX ( mkDefaultPage conf (resStatus res) msgA >>> writeDocumentToString [ (a_indent, v_1) ] ) @@ -38,51 +42,128 @@ getDefaultPage req res writeDefaultPage :: Interaction -> STM () writeDefaultPage itr - = do wroteHeader <- readTVar (itrWroteHeader itr) + = itr `seq` + do wroteHeader <- readTVar (itrWroteHeader itr) - -- ヘッダが出力濟だったら意味が無い。 - when wroteHeader - $ fail "writeDefaultPage: the header has already been written" + -- Content-Type が正しくなければ補完できない。 + res <- readItr itr itrResponse id + when (getHeader "Content-Type" res == Just defaultPageContentType) + $ do reqM <- readItr itr itrRequest id - resM <- readTVar (itrResponse itr) + let conf = itrConfig itr + page = B.pack $ getDefaultPage conf reqM res - -- Response が不明ならばページ書込も不可 - when (resM == Nothing) - $ fail "writeDefaultPage: response was Nothing" + writeTVar (itrBodyToSend itr) + $ page - let reqM = itrRequest itr - res = fromJust resM - page = B.pack $ getDefaultPage reqM res - writeTVar (itrResponse itr) - $ Just $ setHeader "Content-Type" "application/xhtml+xml" res - - writeTVar (itrBodyToSend itr) - $ page - - -mkDefaultPage :: (ArrowXml a) => StatusCode -> a b String -> a b XmlTree -mkDefaultPage status msgA - = let (sCode, sMsg) = statusCode status +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 + ) 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 ++ " " ++ sMsg) )) += ( eelem "body" += ( eelem "h1" += txt sMsg ) - += ( msgA - >>> - eelem "p" += ( this - >>> - mkText - ))))) + += ( eelem "p" += msgA ) + += eelem "hr" + += ( eelem "address" += txt sig )))) +{-# SPECIALIZE mkDefaultPage :: Config -> StatusCode -> IOSArrow b XmlTree -> IOSArrow b XmlTree #-} - -getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String +getMsg :: (ArrowXml a) => Maybe Request -> Response -> a b XmlTree getMsg req res - = constA "FIXME: NOT IMPL" + = req `seq` res `seq` + case resStatus res of + -- 1xx は body を持たない + -- 2xx の body は補完しない + + -- 3xx + MovedPermanently + -> txt ("The resource at " ++ path ++ " has been moved to ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt " permanently." + + Found + -> txt ("The resource at " ++ path ++ " is currently located at ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt ". This is not a permanent relocation." + + SeeOther + -> txt ("The resource at " ++ path ++ " can be found at ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt "." + + TemporaryRedirect + -> txt ("The resource at " ++ path ++ " is temporarily located at ") + <+> + eelem "a" += sattr "href" loc + += txt loc + <+> + txt "." + + -- 4xx + BadRequest + -> txt "The server could not understand the request you sent." + + Unauthorized + -> txt ("You need a valid authentication to access " ++ path) + + Forbidden + -> txt ("You don't have permission to access " ++ path) + + NotFound + -> txt ("The requested URL " ++ path ++ " was not found on this server.") + + Gone + -> txt ("The resource at " ++ path ++ " was here in past times, but has gone permanently.") + + RequestEntityTooLarge + -> 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 ("An internal server error has occured during the process of your request to " ++ path) + + ServiceUnavailable + -> txt "The service is temporarily unavailable. Try later." + + _ -> none + + + where + path :: String + path = let uri = reqURI $! fromJust req + in + uriPath uri + + loc :: String + loc = fromJust $! getHeader "Location" res + +{-# SPECIALIZE getMsg :: Maybe Request -> Response -> IOSArrow b XmlTree #-} \ No newline at end of file