From 7dc6971beb8a9c9fc36a7275d03abf1f1f7c25e5 Mon Sep 17 00:00:00 2001 From: pho Date: Thu, 24 Jan 2008 11:46:13 +0900 Subject: [PATCH] implemented feed generator darcs-hash:20080124024613-62b54-514299727598a8c166c319d58c1ff3a2c94bb946.gz --- Rakka/Page.hs | 8 +++ Rakka/Resource.hs | 18 ++++-- Rakka/Resource/PageEntity.hs | 114 +++++++++++++++++++++++++++++++---- Rakka/Wiki/Engine.hs | 45 +++++++++++++- defaultPages/Feed.xml | 3 +- 5 files changed, 168 insertions(+), 20 deletions(-) diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 62606b3..6d3dff0 100644 --- 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 26d7389..963101f 100644 --- 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 0b54594..efb9216 100644 --- 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 910ef15..90ed666 100644 --- 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 90a61a0..f828515 100644 --- a/defaultPages/Feed.xml +++ b/defaultPages/Feed.xml @@ -1,6 +1,7 @@ + type="text/x-rakka" + isFeed="yes"> -- 2.40.0