redirection

[Rakka.git] / Rakka / Resource / PageEntity.hs

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 32a4a6155698b4a62152eb19e459eee7f41620db..d84ddc7b6af0024b9792aafff1d1c835fb29ead6 100644 (file)
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -7,11 +7,12 @@ 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
 import           Network.HTTP.Lucu.Utils
-import           Network.URI
+import           Network.URI hiding (path)
 import           Rakka.Environment
 import           Rakka.Page
 import           Rakka.Resource
@@ -19,10 +20,12 @@ import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Wiki.Engine
 import           System.FilePath
-import           System.Time
+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)
@@ -53,38 +56,57 @@ handleGet env name
             Nothing
                 -> handlePageNotFound env -< name
 
-            Just redir@(Redirection _ _ _ _)
+            Just redir@(Redirection _ _ _ _ _)
                 -> handleRedirect env -< redir
 
-            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _)
+            Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _ _ _)
                 -> handleGetEntity env -< entity
 
 {-
   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 ())
 handleGetEntity env
     = proc page
     -> do tree <- xmlizePage -< page
-          returnA -< do let lastMod = toClockTime $ pageLastMod page
-                              
-                        -- text/x-rakka の場合は、内容が動的に生成され
+          returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
                         -- てゐる可能性があるので、ETag も
                         -- Last-Modified も返す事が出來ない。
-                        case pageType page of
+                        case entityType page of
                           MIMEType "text" "x-rakka" _
                               -> return ()
-                          _   -> case pageRevision page of
-                                   0   -> foundTimeStamp lastMod -- 0 はデフォルトページ
-                                   rev -> foundEntity (strongETag $ show rev) lastMod
+                          _   -> case entityRevision page of
+                                   0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
+                                   rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
 
                         outputXmlPage tree (entityToXHTML env)
 
@@ -96,14 +118,14 @@ entityToXHTML env
           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 
-          pageName <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
+          name <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
 
           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 
-          pageTitle    <- listA (readSubPage env) -< (pageName, Just page, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (pageName, Just page, "SideBar/Right")
+          pageTitle    <- listA (readSubPage env) -< (name, Just page, "PageTitle")
+          leftSideBar  <- listA (readSubPage env) -< (name, Just page, "SideBar/Left")
+          rightSideBar <- listA (readSubPage env) -< (name, Just page, "SideBar/Right")
           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 
           ( eelem "/"
@@ -203,14 +225,14 @@ notFoundToXHTML env
           BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
           StyleSheet styleSheet <- getSysConfA (envSysConf env) -< ()
 
-          pageName <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
+          name <- (getXPathTreesInDoc "/pageNotFound/@name/text()" >>> getText) -< pageNotFound
 
           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 
-          pageTitle    <- listA (readSubPage env) -< (pageName, Nothing, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (pageName, Nothing, "SideBar/Right")
+          pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
+          leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
+          rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
 
           ( eelem "/"
             += ( eelem "html"
@@ -273,6 +295,7 @@ notFoundToXHTML env
 
 handlePut :: Environment -> PageName -> Resource ()
 handlePut env name
-    = do xml <- input defaultLimit
-         setContentType $ read "text/xml"
-         output xml
+    = runXmlA env "rakka-page-1.0.rng" $ proc tree
+    -> do page   <- parseXmlizedPage -< (name, tree)
+          status <- putPageA (envStorage env) -< page
+          returnA  -< setStatus status