continue working on page search

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

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index efb92162f874808624972730ee430d5a7e867b71..1dd185f3b8d4e3269d401c412545c918897ed619 100644 (file)
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -23,6 +23,7 @@ import           Rakka.Utils
 import           Rakka.W3CDateTime
 import           Rakka.Wiki.Engine
 import           System.FilePath
+import           Text.HyperEstraier hiding (getText)
 import           Text.XML.HXT.Arrow.Namespace
 import           Text.XML.HXT.Arrow.WriteDocument
 import           Text.XML.HXT.Arrow.XmlArrow
@@ -102,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" "rdf+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
@@ -131,9 +122,11 @@ entityToXHTML env
           let cssHref   = [uriToString id (mkObjectURI baseURI styleSheet) ""]
               scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI </> "js" }) ""]
 
-          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")
+          feeds <- arrIO0 (findFeeds (envStorage env)) -< ()
+
+          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 "/"
@@ -157,6 +150,14 @@ entityToXHTML env
                            += sattr "type" "text/css"
                            += attr "href" (arr id >>> mkText)
                          )
+                      += ( constL feeds
+                           >>>
+                           eelem "link"
+                           += sattr "rel"   "alternate"
+                           += sattr "type"  "application/rss+xml"
+                           += attr  "title" (txt siteName <+> txt " - " <+> mkText)
+                           += attr  "href"  (arr (mkFeedURIStr baseURI) >>> mkText)
+                         )
                       += ( constL scriptSrc
                            >>>
                            eelem "script"
@@ -225,7 +226,7 @@ entityToRSS env
                  += sattr "xmlns:dc"        "http://purl.org/dc/elements/1.1/"
                  += sattr "xmlns:trackback" "http://madskills.com/public/xml/rss/module/trackback/"
                  += ( eelem "channel"
-                      += sattr "rdf:about" (uriToString id (mkRDFURI baseURI name) "")
+                      += sattr "rdf:about" (uriToString id (mkFeedURI baseURI name) "")
                       += ( eelem "title"
                            += txt siteName
                            += txt " - "
@@ -299,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)
@@ -344,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"
@@ -456,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"
@@ -540,3 +541,18 @@ handleDelete env name
     = do userID <- getUserID env
          status <- deletePage (envStorage env) userID name
          setStatus status
+
+
+findFeeds :: Storage -> IO [PageName]
+findFeeds sto
+    = do cond <- newCondition
+         setPhrase   cond "[UVSET]"
+         addAttrCond cond "rakka:isFeed STREQ yes"
+         setOrder    cond "@uri STRA"
+         result <- searchPages sto cond
+         return (map srPageName result)
+
+
+mkFeedURIStr :: URI -> PageName -> String
+mkFeedURIStr baseURI name
+    = uriToString id (mkFeedURI baseURI name) ""
\ No newline at end of file