implemented feed generator

darcs-hash:20080124024613-62b54-514299727598a8c166c319d58c1ff3a2c94bb946.gz

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index 62606b35af111daa344d37d738dfabd4aa273172..6d3dff0bdb927ff15c863fd165ed49197b10dc4d 100644 (file)
--- a/Rakka/Page.hs
+++ b/Rakka/Page.hs
@@ -20,6 +20,7 @@ module Rakka.Page
     , mkObjectURI
     , mkFragmentURI
     , mkAuxiliaryURI
+    , mkRDFURI
     , mkRakkaURI
 
     , xmlizePage
@@ -181,6 +182,13 @@ mkAuxiliaryURI baseURI basePath name
       }
 
 
+mkRDFURI :: URI -> PageName -> URI
+mkRDFURI baseURI name
+    = baseURI {
+        uriPath = foldl (</>) "/" [uriPath baseURI, encodePageName name ++ ".rdf"]
+      }
+
+
 mkRakkaURI :: PageName -> URI
 mkRakkaURI name = URI {
                     uriScheme    = "rakka:"

diff --git a/Rakka/Resource.hs b/Rakka/Resource.hs
index 26d73897e544cc1ec13d3553913bff5bf214da15..963101ff1f5220b0f562ce61a0c05b5268c62739 100644 (file)
--- a/Rakka/Resource.hs
+++ b/Rakka/Resource.hs
@@ -3,6 +3,7 @@ module Rakka.Resource
     , runXmlA
     , getEntityType
     , outputXmlPage
+    , outputXmlPage'
     , getUserID
     )
     where
@@ -127,18 +128,18 @@ getEntityType
     where
       extMap :: [(String, MIMEType)]
       extMap = [ ("html", read "application/xhtml+xml")
+               , ( "rdf", read "application/rdf+xml"  )
                , ( "xml", read "text/xml"             )
                ]
 
 
-outputXmlPage :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
-outputXmlPage tree toXHTML
+outputXmlPage :: XmlTree -> [(MIMEType, IOSArrow XmlTree XmlTree)] -> Resource ()
+outputXmlPage tree formatters
     = do mType <- getEntityType
          setContentType mType
-         let formatter = case mType of
-                           MIMEType "application" "xhtml+xml" _ -> toXHTML
-                           MIMEType "text"        "xml"       _ -> this
-                           _                                    -> undefined
+         let formatter = case lookup mType formatters of
+                           Just f  -> f
+                           Nothing -> this
          [resultStr] <- liftIO $ runX ( setErrorMsgHandler False fail
                                         >>>
                                         constA tree
@@ -150,6 +151,11 @@ outputXmlPage tree toXHTML
          output resultStr
 
 
+outputXmlPage' :: XmlTree -> IOSArrow XmlTree XmlTree -> Resource ()
+outputXmlPage' tree toXHTML
+    = outputXmlPage tree [(MIMEType "application" "xhtml+xml" [], toXHTML)]
+
+
 getUserID :: Environment -> Resource (Maybe String)
 getUserID env
     = do auth <- getAuthorization

diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs
index 0b5459447419ffab669650e8f08f5bd1c6abe381..efb92162f874808624972730ee430d5a7e867b71 100644 (file)
--- a/Rakka/Resource/PageEntity.hs
+++ b/Rakka/Resource/PageEntity.hs
@@ -10,6 +10,7 @@ import           Control.Arrow.ArrowList
 import           Control.Monad.Trans
 import           Data.Char
 import           Data.Maybe
+import           Data.Time
 import           Network.HTTP.Lucu
 import           Network.HTTP.Lucu.Utils
 import           Network.URI hiding (path)
@@ -19,6 +20,7 @@ import           Rakka.Resource
 import           Rakka.Storage
 import           Rakka.SystemConfig
 import           Rakka.Utils
+import           Rakka.W3CDateTime
 import           Rakka.Wiki.Engine
 import           System.FilePath
 import           Text.XML.HXT.Arrow.Namespace
@@ -76,14 +78,6 @@ handleRedirect env
     = proc redir
     -> 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
@@ -96,7 +90,12 @@ handleRedirect env
                                                               )
                                  output resultStr
 
-                       _   -> fail ("internal error: getEntityType returned " ++ show mType)
+                       _   -> do BaseURI baseURI <- getSysConf (envSysConf env)
+                                 let uri = mkPageFragmentURI
+                                           baseURI
+                                           (redirDest redir)
+                                           ("Redirect:" ++ redirName redir)
+                                 redirect Found uri
 
 
 handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ())
@@ -113,7 +112,9 @@ handleGetEntity env
                                    0   -> foundTimeStamp (entityLastMod page) -- 0 はデフォルトページ
                                    rev -> foundEntity (strongETag $ show rev) (entityLastMod page)
 
-                        outputXmlPage tree (entityToXHTML env)
+                        outputXmlPage tree [ (MIMEType "application" "xhtml+xml" [], entityToXHTML env)
+                                           , (MIMEType "application" "rdf+xml"   [], entityToRSS   env)
+                                           ]
 
 
 entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
@@ -207,6 +208,95 @@ entityToXHTML env
                ) ) -<< page
 
 
+entityToRSS :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
+entityToRSS env
+    = proc page
+    -> do SiteName   siteName   <- getSysConfA (envSysConf env) -< ()
+          BaseURI    baseURI    <- getSysConfA (envSysConf env) -< ()
+
+          name    <- (getXPathTreesInDoc "/page/@name/text()" >>> getText) -< page
+          summary <- maybeA (getXPathTreesInDoc "/page/summary/text()" >>> getText) -< page
+          pages   <- makePageLinkList (envStorage env) (envSysConf env) (envInterpTable env) -< page
+          
+          ( eelem "/"
+            += ( eelem "rdf:RDF"
+                 += sattr "xmlns"           "http://purl.org/rss/1.0/"
+                 += sattr "xmlns:rdf"       "http://www.w3.org/1999/02/22-rdf-syntax-ns#"
+                 += 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) "")
+                      += ( eelem "title"
+                           += txt siteName
+                           += txt " - "
+                           += getXPathTreesInDoc "/page/@name/text()"
+                         )
+                      += ( eelem "link"
+                           += txt (uriToString id baseURI "")
+                         )
+                      += ( eelem "description"
+                           += txt (case summary of
+                                     Nothing -> "RSS Feed for " ++ siteName
+                                     Just s  -> s)
+                         )
+                      += ( eelem "items"
+                           += ( eelem "rdf:Seq"
+                                += ( constL pages
+                                     >>>
+                                     eelem "rdf:li"
+                                     += attr "resource" (arr (mkPageURIStr baseURI) >>> mkText)
+                                   )
+                              )
+                         )
+                    )
+                 += ( constL pages
+                      >>>
+                      arr (\ n -> (n, Nothing))
+                      >>>
+                      getPageA (envStorage env)
+                      >>>
+                      arr fromJust
+                      >>>
+                      eelem "item"
+                      += attr "rdf:about" (arr (mkPageURIStr baseURI . entityName) >>> mkText)
+                      += ( eelem "title"
+                           += (arr entityName >>> mkText)
+                         )
+                      += ( eelem "link"
+                           += (arr (mkPageURIStr baseURI . entityName) >>> mkText)
+                         )
+                      += ( arrL (\ p -> case entitySummary p of
+                                          Nothing -> []
+                                          Just s  -> [s])
+                           >>>
+                           eelem "description"
+                           += mkText
+                         )
+                      += ( eelem "dc:date"
+                           += ( arrIO (utcToLocalZonedTime . entityLastMod)
+                                >>>
+                                arr formatW3CDateTime
+                                >>>
+                                mkText
+                              )
+                         )
+                      += ( eelem "trackback:ping"
+                           += attr "rdf:resource" (arr (mkTrackbackURIStr baseURI . entityName) >>> mkText)
+                         )
+                    )
+                 >>>
+                 uniqueNamespacesFromDeclAndQNames
+               ) ) -<< page
+    where
+      mkPageURIStr :: URI -> PageName -> String
+      mkPageURIStr baseURI name
+            = uriToString id (mkPageURI baseURI name) ""
+
+      mkTrackbackURIStr :: URI -> PageName -> String
+      mkTrackbackURIStr baseURI name
+            = uriToString id (mkAuxiliaryURI baseURI ["trackback"] name) ""
+
+
 readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
                Environment
             -> a (PageName, Maybe XmlTree, PageName) XmlTree
@@ -238,7 +328,7 @@ handleGetPageListing env
                             )
                        )
                   ) -< (dir, items)
-          returnA -< outputXmlPage tree (pageListingToXHTML env)
+          returnA -< outputXmlPage' tree (pageListingToXHTML env) -- FIXME: rss 對應
 
 
 pageListingToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree
@@ -350,7 +440,7 @@ handlePageNotFound env
                        )
                   ) -< name
           returnA -< do setStatus NotFound
-                        outputXmlPage tree (notFoundToXHTML env)
+                        outputXmlPage' tree (notFoundToXHTML env)
 
 
 notFoundToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree

diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs
index 910ef15f318a2f3222443074a84d9de313ee29ec..90ed666a25db4da0ca9134a4e73b64b154fcc2ef 100644 (file)
--- a/Rakka/Wiki/Engine.hs
+++ b/Rakka/Wiki/Engine.hs
@@ -2,8 +2,9 @@ module Rakka.Wiki.Engine
     ( InterpTable
     , makeMainXHTML
     , makeSubXHTML
-    , makeDraft
     , makePreviewXHTML
+    , makePageLinkList
+    , makeDraft
     )
     where
 
@@ -390,6 +391,48 @@ makeDraft interpTable
       addInlineCmdText doc (InlineCommand _ _ inlines) = mapM_ (addInlineText doc) inlines
 
 
+makePageLinkList :: (ArrowXml a, ArrowChoice a, ArrowIO a) =>
+                Storage
+             -> SystemConfig
+             -> InterpTable
+             -> a XmlTree [PageName]
+makePageLinkList sto sysConf interpTable
+    = proc tree
+    -> do wiki            <- wikifyPage interpTable -< tree
+          pName           <- getXPathTreesInDoc "/page/@name/text()" >>> getText -< tree
+          interpreted     <- interpretCommands sto sysConf interpTable
+                             -< (pName, Just tree, Just wiki, wiki)
+          returnA -< concatMap extractFromBlock interpreted
+    where
+      extractFromElem :: Element -> [PageName]
+      extractFromElem (Block  b) = extractFromBlock  b
+      extractFromElem (Inline i) = extractFromInline i
+
+      extractFromBlock :: BlockElement -> [PageName]
+      extractFromBlock (List _ items)         = concatMap extractFromListItem items
+      extractFromBlock (DefinitionList defs)  = concatMap extractFromDefinition defs
+      extractFromBlock (Preformatted inlines) = concatMap extractFromInline inlines
+      extractFromBlock (Paragraph inlines)    = concatMap extractFromInline inlines
+      extractFromBlock (Div _ elems)          = concatMap extractFromElem elems
+      extractFromBlock _                      = []
+
+      extractFromInline :: InlineElement -> [PageName]
+      extractFromInline (Italic inlines)           = concatMap extractFromInline inlines
+      extractFromInline (Bold inlines)             = concatMap extractFromInline inlines
+      extractFromInline (Span _ inlines)           = concatMap extractFromInline inlines
+      extractFromInline (PageLink (Just name) _ _) = [name]
+      extractFromInline _                          = []
+
+      extractFromListItem :: ListItem -> [PageName]
+      extractFromListItem = concatMap extractFromElem
+
+      extractFromDefinition :: Definition -> [PageName]
+      extractFromDefinition (Definition term desc)
+          = concatMap extractFromInline term
+            ++
+            concatMap extractFromInline desc
+
+
 wikifyParseError :: Arrow a => a ParseError WikiPage
 wikifyParseError = proc err
                  -> returnA -< [Div [("class", "error")]

diff --git a/defaultPages/Feed.xml b/defaultPages/Feed.xml
index 90a61a0c2752cf48832671700746d7362b8e7a14..f8285153f8332cef969c576e99a218da9e30a017 100644 (file)
--- a/defaultPages/Feed.xml
+++ b/defaultPages/Feed.xml
@@ -1,6 +1,7 @@
 <?xml version="1.0" encoding="utf-8"?>
 <page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
-      type="text/x-rakka">
+      type="text/x-rakka"
+      isFeed="yes">
 
   <textData><![CDATA[
 <recentUpdates items="30" showSummary="yes" onlyEntity="yes" onlySummarized="no" />