Slightly improved something...

darcs-hash:20071107072810-62b54-8e50ff093cb9ed5393bf107a226943cd390b0c4d.gz

diff --git a/Main.hs b/Main.hs
index 5db2fcceef8ee0ee0dfa1815dea1595cd3787ffa..fd379f3b4f0a228928edfd28a62e739cc3b4a7e2 100644 (file)
--- 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 2a232275155ca8d052b1b3e33195a0fe26c85cd7..80c3cb23eaf349995a8ff30fedb1d7a4b8e6bd3f 100644 (file)
--- 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 a69a2242215c2603ccd6f7c79826df8d21ed21b7..adbd706d6e9d07c6eb79a3f7bec776be9064b9d4 100644 (file)
--- 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 19e9768f7bd02e92039b85e6cf2ea4fc4438edec..4515a4d49e99eefd9b411b929cc20a21c4190d73 100644 (file)
--- 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 46fda3ac636b45032fc89a5419b09292427f238e..8e79a6dbc9470062677d8a2a1a64e2d8e9aa930c 100644 (file)
--- 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 (file)
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 5817106e6bbac83418ad9955ea3ebc5457325e43..2e9dd0ed2d586b9cee37e451625572241df5cdd7 100644 (file)
--- 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;
+}
 </textData>
 </page>

diff --git a/js/editPage.js b/js/editPage.js
index e14b383eebe13197ae5f591e5db4db336bbdeaeb..0eb211edaff0ee9a793f9ee0e3305e2b0fb96303 100644 (file)
--- 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 35853b7656ada17ffc2e88ab5d0faa23462a4083..0ac558b9f6da97e52bcf479f8f2c9e937f1a7efb 100644 (file)
--- 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;
+        }
+    };
     
 })();