From: pho <pho@cielonegro.org>
Date: Thu, 27 Dec 2007 04:31:10 +0000 (+0900)
Subject: redirection
X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=d6f5dd9adfa8bccc7799396554dfaf80d9522a38;p=Rakka.git

redirection

darcs-hash:20071227043110-62b54-97de9113f75a87b77da2288e1e17ae735f0cebe0.gz
---

diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs
index adbd706..21acb4b 100644
--- a/Rakka/Resource.hs
+++ b/Rakka/Resource.hs
@@ -1,6 +1,7 @@
 module Rakka.Resource
     ( runIdempotentA
     , runXmlA
+    , getEntityType
     , outputXmlPage
     )
     where
diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 1a8eb03..d84ddc7 100644
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -7,6 +7,7 @@ import           Control.Arrow
 import           Control.Arrow.ArrowIO
 import           Control.Arrow.ArrowIf
 import           Control.Arrow.ArrowList
+import           Control.Monad.Trans
 import           Data.Char
 import           Data.Maybe
 import           Network.HTTP.Lucu
@@ -19,9 +20,12 @@ import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Wiki.Engine
 import           System.FilePath
+import           Text.XML.HXT.Arrow.WriteDocument
 import           Text.XML.HXT.Arrow.XmlArrow
+import           Text.XML.HXT.Arrow.XmlIOStateArrow
 import           Text.XML.HXT.Arrow.XmlNodeSet
 import           Text.XML.HXT.DOM.TypeDefs
+import           Text.XML.HXT.DOM.XmlKeywords
 
 
 fallbackPageEntity :: Environment -> [String] -> IO (Maybe ResourceDef)
@@ -60,13 +64,34 @@ handleGet env name
 
 {-
   HTTP/1.1 302 Found
-  Location: http://example.org/Destination#Redirect:Source
+  Location: http://example.org/Destination.html#Redirect:Source
 -}
 handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ())
 handleRedirect env
     = proc redir
-    -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< ()
-          returnA -< redirect Found (mkPageURI baseURI $ redirDest redir) -- FIXME
+    -> returnA -< do mType <- getEntityType
+                     case mType of
+                       MIMEType "application" "xhtml+xml" _
+                           -> do BaseURI baseURI <- getSysConf (envSysConf env)
+                                 let uri = mkPageFragmentURI
+                                           baseURI
+                                           (redirDest redir)
+                                           ("Redirect:" ++ redirName redir)
+                                 redirect Found uri
+
+                       MIMEType "text" "xml" _
+                           -> do setContentType mType
+                                 [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
+                                                                >>>
+                                                                constA redir
+                                                                >>>
+                                                                xmlizePage
+                                                                >>>
+                                                                writeDocumentToString [ (a_indent, v_1) ]
+                                                              )
+                                 output resultStr
+
+                       _   -> fail ("internal error: getEntityType returned " ++ show mType)
 
 
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
diff --git a/defaultPages/StyleSheet/Default.xml b/defaultPages/StyleSheet/Default.xml
index 2e9dd0e..757e5f9 100644
--- a/defaultPages/StyleSheet/Default.xml
+++ b/defaultPages/StyleSheet/Default.xml
@@ -436,5 +436,32 @@ img {
     bottom: 1em;
     right: 1em;
 }
+
+/* redirection message ********************************************************/
+.redirection {
+    margin: 5px;
+    padding: 2px;
+
+    font-size: 80%;
+
+    background-color: #fafafa;
+    color: #888888;
+
+    border-color: #eeeeee;
+    border-width: 1px;
+    border-style: dotted
+}
+
+.redirection input[type="button"] {
+    background-color: inherit;
+
+    color: #008800;
+    
+    border-width: 0;
+}
+
+.redirection input[type="button"]:hover {
+    color: #880000;
+}
 </textData>
 </page>
diff --git a/js/Makefile b/js/Makefile
index 689deee..effc48b 100644
--- a/js/Makefile
+++ b/js/Makefile
@@ -6,6 +6,7 @@ SOURCES = \
 	jquery-dom.js \
 	base.js \
 	editPage.js \
+	redirection.js \
 	screen.js \
 	$(NULL)
 
diff --git a/js/redirection.js b/js/redirection.js
new file mode 100644
index 0000000..b379437
--- /dev/null
+++ b/js/redirection.js
@@ -0,0 +1,30 @@
+$(document).ready(function () {
+    var fragment;
+    
+    if ($.browser.mozilla) {
+        fragment = window.location.hash; // 何故か勝手に URI デコードされる
+    }
+    else {
+        fragment = decodeURIComponent(window.location.hash);
+    }
+
+    var m = fragment.match(/^#Redirect:(.*)$/);
+    if (m) {
+        var from = m[1];
+
+        var editButton
+            = $.INPUT({className: "editButton",
+                       type:      "button",
+                       value:     from,
+                       title:     "Edit the page"});
+        $(editButton).click(function () {
+            alert("not implemented");
+        });
+
+        var box
+            = $.P({className: "redirection"},
+                  "This page is redirected from ", editButton, ".");
+
+        $("div.title").after(box);
+    }
+});
\ No newline at end of file