X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=8f4bd9caced4f263c09be86f1f02d6bfbcaf953c;hb=8c0fd38bb52a7b7cc69431df81c7736ddbb0faa6;hp=208b0b5946d07c8b45ded213f1c09b1ba742c464;hpb=f57c5c5ae6c95e68b11400718e7ce5de4ea1317a;p=Rakka.git

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 208b0b5..8f4bd9c 100644
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -103,19 +103,9 @@ handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Pa
 handleGetEntity env
     = proc page
     -> do tree <- xmlizePage -< page
-          returnA -< do -- text/x-rakka の場合は、内容が動的に生成され
-                        -- てゐる可能性があるので、ETag も
-                        -- Last-Modified も返す事が出來ない。
-                        case entityType page of
-                          MIMEType "text" "x-rakka" _
-                              -> return ()
-                          _   -> case entityRevision page of
-                                   0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
-                                   rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
-
-                        outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
-                                           , (MIMEType "application" "rss+xml"   [], entityToRSS   env)
-                                           ]
+          returnA -< outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
+                                        , (MIMEType "application" "rss+xml"   [], entityToRSS   env)
+                                        ]
 
 
 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
@@ -134,9 +124,9 @@ entityToXHTML env
 
           feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
 
-          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")
+          pageTitle    <- listA (readSubPage env) -< (Just name, Just page, "PageTitle")
+          leftSideBar  <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Left")
+          rightSideBar <- listA (readSubPage env) -< (Just name, Just page, "SideBar/Right")
           pageBody     <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page
 
           ( eelem "/"
@@ -144,7 +134,7 @@ entityToXHTML env
                  += sattr "xmlns" "http://www.w3.org/1999/xhtml"
                  += ( getXPathTreesInDoc "/page/@lang"
                       `guards`
-                      qattr (QN "xml" "lang" "")
+                      qattr (mkQName "xml" "lang" "")
                                 ( getXPathTreesInDoc "/page/@lang/text()" )
                     )
                  += ( eelem "head"
@@ -310,7 +300,7 @@ entityToRSS env
 
 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                Environment
-            -> a (PageName, Maybe XmlTree, PageName) XmlTree
+            -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree
 readSubPage env
     = proc (mainPageName, mainPage, subPageName) ->
       do subPage  <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing)
@@ -355,9 +345,9 @@ pageListingToXHTML env
           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 
-          pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
+          pageTitle    <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
+          leftSideBar  <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
+          rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
 
           ( eelem "/"
             += ( eelem "html"
@@ -467,9 +457,9 @@ notFoundToXHTML env
           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 
-          pageTitle    <- listA (readSubPage env) -< (name, Nothing, "PageTitle")
-          leftSideBar  <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left")
-          rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right")
+          pageTitle    <- listA (readSubPage env) -< (Just name, Nothing, "PageTitle")
+          leftSideBar  <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Left")
+          rightSideBar <- listA (readSubPage env) -< (Just name, Nothing, "SideBar/Right")
 
           ( eelem "/"
             += ( eelem "html"
@@ -560,7 +550,7 @@ findFeeds sto
          addAttrCond cond "rakka:isFeed STREQ yes"
          setOrder    cond "@uri STRA"
          result <- searchPages sto cond
-         return (map fst result)
+         return (map hpPageName $ srPages result)
 
 
 mkFeedURIStr :: URI -> PageName -> String