X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Network%2FHTTP%2FLucu%2FDefaultPage.hs;h=5b624181a0fa55f885df2ee360ee911e79130ac5;hb=db4b612;hp=8c30315e1d316a98f40642302453c7a4fbb07121;hpb=a9e9f50818285bf66cd64e5a248175eecb8e1fea;p=Lucu.git diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index 8c30315..5b62418 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -1,88 +1,162 @@ +{-# LANGUAGE + BangPatterns + , OverloadedStrings + , UnboxedTuples + , UnicodeSyntax + #-} module Network.HTTP.Lucu.DefaultPage - ( getDefaultPage -- Maybe Request -> Response -> String - , writeDefaultPage -- Interaction -> STM () + ( getDefaultPage + , writeDefaultPage + , mkDefaultPage ) where +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ListArrow +import Control.Arrow.Unicode +import Control.Concurrent.STM +import Control.Monad +import qualified Data.Ascii as A +import Data.Maybe +import qualified Data.Sequence as S +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding +import Network.HTTP.Lucu.Config +import Network.HTTP.Lucu.Headers +import Network.HTTP.Lucu.Interaction +import Network.HTTP.Lucu.Request +import Network.HTTP.Lucu.Response +import Network.URI hiding (path) +import Prelude.Unicode +import Text.XML.HXT.Arrow.WriteDocument +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlState +import Text.XML.HXT.DOM.TypeDefs -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 Data.Maybe -import Network.HTTP.Lucu.Headers -import Network.HTTP.Lucu.Interaction -import Network.HTTP.Lucu.Request -import Network.HTTP.Lucu.Response -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 -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 → Text +{-# INLINEABLE getDefaultPage #-} +getDefaultPage !conf !req !res + = let msgA = getMsg req res + [xmlStr] = runLA ( mkDefaultPage conf (resStatus res) msgA + ⋙ + writeDocumentToString [ withIndent True ] + ) () in - unsafePerformIO $ - do [xmlStr] <- runX ( mkDefaultPage (resStatus res) msgA - >>> - writeDocumentToString [ (a_indent, v_1) ] - ) - return xmlStr + T.pack xmlStr +writeDefaultPage ∷ Interaction → STM () +writeDefaultPage !itr + -- Content-Type が正しくなければ補完できない。 + = do res ← readItr itrResponse id itr + when (getHeader "Content-Type" res == Just defaultPageContentType) + $ do reqM ← readItr itrRequest id itr -writeDefaultPage :: Interaction -> STM () -writeDefaultPage itr - = do wroteHeader <- readTVar (itrWroteHeader itr) + let conf = itrConfig itr + page = getDefaultPage conf reqM res - -- ヘッダが出力濟だったら意味が無い。 - when wroteHeader - $ fail "writeDefaultPage: the header has already been written" + writeTVar (itrBodyToSend itr) + (S.singleton (encodeUtf8 page)) - resM <- readTVar (itrResponse itr) - - -- Response が不明ならばページ書込も不可 - when (resM == Nothing) - $ fail "writeDefaultPage: response was Nothing" - - 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 +{-# INLINEABLE mkDefaultPage #-} +mkDefaultPage !conf !status !msgA + = let sStr = A.toString $ printStatusCode status + sig = concat [ A.toString (cnfServerSoftware conf) + , " at " + , T.unpack (cnfServerHost conf) + ] in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" += ( eelem "head" += ( eelem "title" - += txt (printf "%03d %s" sCode sMsg) + += txt sStr )) += ( eelem "body" += ( eelem "h1" - += txt sMsg + += txt sStr ) - += ( msgA - >>> - eelem "p" += ( this - >>> - mkText - ))))) + += ( eelem "p" += msgA ) + += eelem "hr" + += ( eelem "address" += txt sig )))) + +getMsg ∷ (ArrowXml a) ⇒ Maybe Request → Response → a b XmlTree +{-# INLINEABLE getMsg #-} +getMsg !req !res + = 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 large to accept.") + + RequestURITooLarge + → txt "The request URI you sent was too large 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 -getMsg :: (ArrowList a) => Maybe Request -> Response -> a b String -getMsg req res - = constA "FIXME: NOT IMPL" + loc ∷ String + loc = A.toString $ fromJust $ getHeader "Location" res