X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=59753d7d5fd223ceaeab59453d15fa8dc87fdd29;hb=71f2db55513679098869de2122b5d5989dbc2be2;hp=37c2aa8a85b9e8e914f5d388d4f923aa3d14122a;hpb=b4a3d2cf3854b10d923cb4c546bf1fe32b021a68;p=Rakka.git

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 37c2aa8..59753d7 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,13 @@ import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Wiki.Engine
 import           System.FilePath
+import           Text.XML.HXT.Arrow.Namespace
+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 +65,34 @@ handleGet env name
 
 {-
   HTTP/1.1 302 Found
-  Location: http://example.org/Destination?from=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 $ redirName 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 ())
@@ -130,6 +156,10 @@ entityToXHTML env
                            += sattr "type" "text/javascript"
                            += attr "src" (arr id >>> mkText)
                          )
+                      += ( eelem "script"
+                           += sattr "type" "text/javascript"
+                           += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+                         )
                     )
                  += ( eelem "body"
                       += ( eelem "div"
@@ -164,6 +194,8 @@ entityToXHTML env
                               )
                          )
                     )
+                 >>>
+                 uniqueNamespacesFromDeclAndQNames
                ) ) -<< page
 
 
@@ -231,6 +263,10 @@ notFoundToXHTML env
                            += sattr "type" "text/javascript"
                            += attr "src" (arr id >>> mkText)
                          )
+                      += ( eelem "script"
+                           += sattr "type" "text/javascript"
+                           += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";")
+                         )
                     )
                  += ( eelem "body"
                       += ( eelem "div"
@@ -265,6 +301,8 @@ notFoundToXHTML env
                               )
                          )
                     )
+                 >>>
+                 uniqueNamespacesFromDeclAndQNames
                ) ) -<< pageNotFound