From e2fd35989e9765281523fd4ce05dcd0199bdbbad Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 7 Nov 2007 16:28:10 +0900 Subject: [PATCH] Slightly improved something... darcs-hash:20071107072810-62b54-8e50ff093cb9ed5393bf107a226943cd390b0c4d.gz --- Main.hs | 4 +-- Rakka.cabal | 3 +- Rakka/Resource.hs | 56 +++++++++++++++++++++++++++++++ Rakka/Resource/PageEntity.hs | 7 ++-- Rakka/Storage/DefaultPage.hs | 2 +- Rakka/Validation.hs | 58 +++++++++++++++++++++++++++++++++ defaultPages/StyleSheet/Default | 25 ++++++++++++++ js/editPage.js | 23 +++++++++++-- js/screen.js | 19 +++++++++++ 9 files changed, 186 insertions(+), 11 deletions(-) create mode 100644 Rakka/Validation.hs diff --git a/Main.hs b/Main.hs index 5db2fcc..fd379f3 100644 --- a/Main.hs +++ b/Main.hs @@ -40,7 +40,7 @@ data CmdOpt defaultPort :: PortNumber -defaultPort = fromIntegral 8080 +defaultPort = toEnum 8080 defaultLocalStateDir :: FilePath defaultLocalStateDir = LOCALSTATEDIR -- replaced by CPP @@ -58,7 +58,7 @@ defaultLogLevel = NOTICE options :: [OptDescr CmdOpt] options = [ Option ['p'] ["port"] - (ReqArg (OptPortNum . fromIntegral . read) "NUM") + (ReqArg (OptPortNum . toEnum . read) "NUM") ("Port number to listen. (default: " ++ show defaultPort ++ ")") , Option ['d'] ["localstatedir"] diff --git a/Rakka.cabal b/Rakka.cabal index 2a23227..80c3cb2 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -59,6 +59,7 @@ Executable rakka Rakka.Storage.Impl Rakka.SystemConfig Rakka.Utils + Rakka.Validation Rakka.Wiki Rakka.Wiki.Interpreter Rakka.Wiki.Interpreter.Base @@ -72,7 +73,7 @@ Executable rakka Extensions: Arrows, ExistentialQuantification, ScopedTypeVariables GHC-Options: - -Wall -Werror -XDeriveDataTypeable + -Wall -XDeriveDataTypeable Executable RakkaUnitTest if flag(build-test-suite) diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs index a69a224..adbd706 100644 --- a/Rakka/Resource.hs +++ b/Rakka/Resource.hs @@ -1,5 +1,6 @@ module Rakka.Resource ( runIdempotentA + , runXmlA , outputXmlPage ) where @@ -11,6 +12,9 @@ import Control.Monad.Trans import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI hiding (path) +import Rakka.Environment +import Rakka.Validation +import Text.XML.HXT.Arrow.ReadDocument import Text.XML.HXT.Arrow.WriteDocument import Text.XML.HXT.Arrow.XmlIOStateArrow import Text.XML.HXT.DOM.TypeDefs @@ -52,6 +56,58 @@ runIdempotentA a rsrc +runXmlA :: Environment -> FilePath -> IOSArrow XmlTree (Resource c) -> Resource c +runXmlA env schemaPath a + = do inputA <- getInputXmlA env schemaPath + [rsrc] <- liftIO $ runX ( inputA + >>> + setErrorMsgHandler False fail + >>> + a + ) + rsrc + + +-- well-formed でない時は 400 Bad Request になり、valid でない時は 422 +-- Unprocessable Entity になる。入力の型が XML でない時は 415 +-- Unsupported Media Type を返す。 +getInputXmlA :: Environment -> FilePath -> Resource (IOSArrow b XmlTree) +getInputXmlA env schemaPath + = do reader <- getInputReader + validator <- getValidator env schemaPath + return ( setErrorMsgHandler False (abort BadRequest [] . Just) + >>> + reader + >>> + setErrorMsgHandler False (abort UnprocessableEntitiy [] . Just) + >>> + validator + ) + + +getInputReader :: Resource (IOSArrow b XmlTree) +getInputReader + = do mimeType <- getContentType + case mimeType of + Nothing + -> getFailingReader BadRequest [] (Just "Missing Content-Type") + Just (MIMEType "text" "xml" _) + -> getXmlReader + Just (MIMEType "application" "xml" _) + -> getXmlReader + Just t + -> getFailingReader UnsupportedMediaType [] (Just $ "Unsupported media type: " ++ show t) + where + getXmlReader + = do req <- input defaultLimit + return $ readString [ (a_validate , v_0) + , (a_check_namespaces , v_1) + , (a_remove_whitespace, v_0) + ] req + getFailingReader code headers msg + = return $ proc _ -> abortA -< (code, (headers, msg)) + + getEntityType :: Resource MIMEType getEntityType = do uri <- getRequestURI diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 19e9768..4515a4d 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -269,7 +269,6 @@ notFoundToXHTML env handlePut :: Environment -> PageName -> Resource () -handlePut _env _name - = do xml <- input defaultLimit - setContentType $ read "text/xml" - output xml +handlePut env name + = runXmlA env "rakka-page-1.0.rng" $ proc tree + -> returnA -< do setStatus Created diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 46fda3a..8e79a6d 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -56,7 +56,7 @@ loadDefaultPage :: PageName -> IO (Maybe Page) loadDefaultPage name -- ./defaultPages が存在するなら、./defaultPages/Foo を探す。無けれ -- ば Cabal で defaultPages/Foo を探す。 - = do let pagePath = "defaultPages/" ++ encodePageName name + = do let pagePath = "defaultPages" encodePageName name localDirExists <- doesLocalDirExist if localDirExists then diff --git a/Rakka/Validation.hs b/Rakka/Validation.hs new file mode 100644 index 0000000..73a83e7 --- /dev/null +++ b/Rakka/Validation.hs @@ -0,0 +1,58 @@ +module Rakka.Validation + ( getValidator + ) + where + +import Control.Arrow +import Control.Arrow.ArrowList +import Control.Arrow.ArrowTree +import Control.Monad.Reader +import Paths_Rakka -- Cabal が用意する。 +import Rakka.Environment +import System.Directory +import System.FilePath +import Text.XML.HXT.Arrow.XmlArrow +import Text.XML.HXT.Arrow.XmlIOStateArrow +import Text.XML.HXT.DOM.TypeDefs +import qualified Text.XML.HXT.RelaxNG.Schema as S +import Text.XML.HXT.RelaxNG.Validator + + +loadSchema :: FilePath -> IO (IOSArrow XmlTree XmlTree) +loadSchema fpath + = do [schema] <- runX ( setErrorMsgHandler False fail + >>> + readForRelax [] fpath + >>> + perform (validateWithRelaxAndHandleErrors S.relaxSchemaArrow) + >>> + createSimpleForm [] True True True + >>> + perform ( getErrors + >>> + getChildren >>> getAttrValue "desc" + >>> + arr ("Relax NG validation: " ++ ) + >>> + mkError c_err + >>> + filterErrorMsg + ) + ) + return $ validateDocumentWithRelax schema + + +doesLocalDirExist :: IO Bool +doesLocalDirExist = doesDirectoryExist "schemas" + + +getValidator :: MonadIO m => Environment -> FilePath -> m (IOSArrow XmlTree XmlTree) +getValidator _ fname + = liftIO $ + do let schemaPath = "schemas" fname + + localDirExists <- doesLocalDirExist + if localDirExists then + loadSchema schemaPath + else + getDataFileName ("schemas" fname) >>= loadSchema diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default index 5817106..2e9dd0e 100644 --- a/defaultPages/StyleSheet/Default +++ b/defaultPages/StyleSheet/Default @@ -411,5 +411,30 @@ img { .error:before { content: "Error: " } + +/* waiting message ************************************************************/ +.waitingMessageBoard { + position: fixed; + left: 0; + top: 0; + width: 100%; + height: 100%; + + background-color: white; + color: black; + opacity: 0.7; + + z-index: 1; +} + +.waitingMessageBoard p { + text-align: center; + vertical-align: middle; + font-size: 200%; + + position: fixed; + bottom: 1em; + right: 1em; +} diff --git a/js/editPage.js b/js/editPage.js index e14b383..0eb211e 100644 --- a/js/editPage.js +++ b/js/editPage.js @@ -1,11 +1,14 @@ Rakka.editPage = function (baseURI, pageName) { var $area = Rakka.switchScreen(); - $area.text("Loading... please wait."); + + Rakka.displayWaitingMessage("Loading... please wait."); // XML 版のページを取得する。 $.ajax({ url : baseURI + pageName + ".xml", success: function (pageXml) { + Rakka.hideWaitingMessage(); + var $page = $(pageXml).find("page"); var oldRevision = $page.attr("revision"); var defaultType @@ -18,6 +21,8 @@ Rakka.editPage = function (baseURI, pageName) { Rakka.displayPageEditor(baseURI, pageName, oldRevision, defaultType, source); }, error : function (req) { + Rakka.hideWaitingMessage(); + if (req.status == 404) { Rakka.displayPageEditor(baseURI, pageName, null, "rakka", null); } @@ -214,11 +219,23 @@ Rakka.submitTextPage = function (baseURI, pageName, oldRevision, givenPageName, page.appendChild(textData); } + Rakka.displayWaitingMessage("Submitting... please wait."); + + var url = baseURI + encodeURI(givenPageName); $.ajax({ type : "PUT", - url : baseURI + encodeURI(givenPageName), + url : url, contentType: "text/xml", data : doc, - processData: false + processData: false, + success : function () { + window.location.replace(url); + }, + error : function (req) { + Rakka.hideWaitingMessage(); + + var $area = Rakka.switchScreen(); + $area.text("Error: " + req.status + " " + req.statusText); + } }); }; diff --git a/js/screen.js b/js/screen.js index 35853b7..0ac558b 100644 --- a/js/screen.js +++ b/js/screen.js @@ -34,5 +34,24 @@ $("div.body").children().show(); return null; }; + + var waitingMessageBoard = null; + + Rakka.displayWaitingMessage = function (msg) { + Rakka.hideWaitingMessage(); + + waitingMessageBoard + = $.P({className: "waitingMessageBoard"}, + $.P({}, msg)); + + $("body").append(waitingMessageBoard); + }; + + Rakka.hideWaitingMessage = function () { + if (waitingMessageBoard != null) { + $(waitingMessageBoard).remove(); + waitingMessageBoard = null; + } + }; })(); -- 2.40.0