X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=19e9768f7bd02e92039b85e6cf2ea4fc4438edec;hb=7a4f13a3d483c950743e1ced001ade4406d239d3;hp=3c00612809ce2910e22abf421b3247d9c372fbe9;hpb=656fdb2772ab4de5cd083cbe9e7c1610cccef73b;p=Rakka.git

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 3c00612..19e9768 100644
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -11,7 +11,7 @@ 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,7 +19,6 @@ import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Wiki.Engine
 import           System.FilePath
-import           System.Time
 import           Text.XML.HXT.Arrow.XmlArrow
 import           Text.XML.HXT.Arrow.XmlNodeSet
 import           Text.XML.HXT.DOM.TypeDefs
@@ -37,7 +36,7 @@ fallbackPageEntity env path
           , resGet              = Just $ handleGet env (toPageName path)
           , resHead             = Nothing
           , resPost             = Nothing
-          , resPut              = Nothing
+          , resPut              = Just $ handlePut env (toPageName path)
           , resDelete           = Nothing
           }
     where
@@ -74,17 +73,15 @@ handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Pa
 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
                           MIMEType "text" "x-rakka" _
                               -> return ()
                           _   -> case pageRevision page of
-                                   0   -> foundTimeStamp lastMod -- 0 はデフォルトページ
-                                   rev -> foundEntity (strongETag $ show rev) lastMod
+                                   0   -> foundTimeStamp (pageLastMod page) -- 0 はデフォルトページ
+                                   rev -> foundEntity (strongETag $ show rev) (pageLastMod page)
 
                         outputXmlPage tree (entityToXHTML env)
 
@@ -96,14 +93,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 +200,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"
@@ -269,3 +266,10 @@ notFoundToXHTML env
                          )
                     )
                ) ) -<< pageNotFound
+
+
+handlePut :: Environment -> PageName -> Resource ()
+handlePut _env _name
+    = do xml <- input defaultLimit
+         setContentType $ read "text/xml"
+         output xml