X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=208b0b5946d07c8b45ded213f1c09b1ba742c464;hb=f57c5c5ae6c95e68b11400718e7ce5de4ea1317a;hp=0b5459447419ffab669650e8f08f5bd1c6abe381;hpb=b101c0a9aad609704eaa9157fe809be80d2aacf7;p=Rakka.git diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index 0b54594..208b0b5 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,8 +20,10 @@ import Rakka.Resource import Rakka.Storage import Rakka.SystemConfig 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 @@ -76,14 +79,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 +91,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 +113,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" "rss+xml" [], entityToRSS env) + ] entityToXHTML :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a XmlTree XmlTree @@ -130,6 +132,8 @@ entityToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] + 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") @@ -156,6 +160,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" @@ -207,6 +219,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 (mkFeedURI 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 +339,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 +451,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 @@ -450,3 +551,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 fst result) + + +mkFeedURIStr :: URI -> PageName -> String +mkFeedURIStr baseURI name + = uriToString id (mkFeedURI baseURI name) "" \ No newline at end of file