X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FResource%2FPageEntity.hs;h=8fd0ed4d4024b39cc851a6ec88b4441225ef8c8b;hb=b82b7cb90c3c3666ada1e2a2777c902850f831a2;hp=e354004728c746caa043200d2c1ef9b336e39ec4;hpb=ed0a2de09fc91fbd25c3ee82a722ef88793f2a8f;p=Rakka.git diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index e354004..8fd0ed4 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -3,12 +3,9 @@ module Rakka.Resource.PageEntity ) where -import Control.Arrow -import Control.Arrow.ArrowIO -import Control.Arrow.ArrowIf -import Control.Arrow.ArrowList import Control.Monad.Trans import Data.Char +import qualified Data.Map as M import Data.Maybe import Data.Time import Network.HTTP.Lucu @@ -24,11 +21,7 @@ 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 -import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.Arrow.XmlNodeSet +import Text.XML.HXT.Arrow import Text.XML.HXT.DOM.TypeDefs import Text.XML.HXT.DOM.XmlKeywords @@ -123,11 +116,12 @@ entityToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - feeds <- arrIO0 (findFeeds (envStorage env)) -< () + feeds <- arrIO0 (findFeeds (envStorage env)) -< () + javaScripts <- arrIO0 (findJavaScripts (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") + 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") pageBody <- listA (makeMainXHTML (envStorage env) (envSysConf env) (envInterpTable env)) -< page ( eelem "/" @@ -171,6 +165,12 @@ entityToXHTML env += txt ("Rakka.isLocked=" ++ trueOrFalse isLocked ++ ";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += ( constL javaScripts + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText) + ) ) += ( eelem "body" += ( eelem "div" @@ -301,13 +301,38 @@ entityToRSS env readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree + -> a (PageName, Maybe XmlTree, PageName) XmlTree readSubPage env = proc (mainPageName, mainPage, subPageName) -> - do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) - subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) - -< (mainPageName, mainPage, subPage) + do langM <- case mainPage of + Nothing + -> returnA -< Nothing + Just p + -> maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< p + subPage <- getPageA (envStorage env) >>> arr fromJust -< (subPageName, Nothing) + localSubPage <- case langM of + Nothing + -> returnA -< subPage + Just l + -> localize (envStorage env) -< (l, subPage) + subPageXml <- xmlizePage -< localSubPage + subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) + -< (Just mainPageName, mainPage, subPageXml) returnA -< subXHTML + where + localize :: (ArrowChoice a, ArrowIO a) => Storage -> a (LanguageTag, Page) Page + localize sto + = proc (lang, origPage) + -> do let otherLang = entityOtherLang origPage + localName = M.lookup lang otherLang + case localName of + Nothing + -> returnA -< origPage + Just ln + -> do localPage <- getPageA sto -< (ln, Nothing) + returnA -< case localPage of + Nothing -> origPage + Just p -> p {- @@ -346,9 +371,12 @@ pageListingToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - 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") + feeds <- arrIO0 (findFeeds (envStorage env)) -< () + javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< () + + pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") ( eelem "/" += ( eelem "html" @@ -366,6 +394,14 @@ pageListingToXHTML 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" @@ -377,6 +413,12 @@ pageListingToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += ( constL javaScripts + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText) + ) ) += ( eelem "body" += ( eelem "div" @@ -458,9 +500,12 @@ notFoundToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - 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") + feeds <- arrIO0 (findFeeds (envStorage env)) -< () + javaScripts <- arrIO0 (findJavaScripts (envStorage env)) -< () + + pageTitle <- listA (readSubPage env) -< (name, Nothing, "PageTitle") + leftSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Left") + rightSideBar <- listA (readSubPage env) -< (name, Nothing, "SideBar/Right") ( eelem "/" += ( eelem "html" @@ -478,6 +523,14 @@ notFoundToXHTML 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" @@ -489,6 +542,12 @@ notFoundToXHTML env += txt ("Rakka.baseURI = \"" ++ uriToString id baseURI "" ++ "\";") += txt ("Rakka.isGlobalLocked=" ++ trueOrFalse isGLocked ++ ";") ) + += ( constL javaScripts + >>> + eelem "script" + += sattr "type" "text/javascript" + += attr "src" (arr (mkObjectURIStr baseURI) >>> mkText) + ) ) += ( eelem "body" += ( eelem "div" @@ -554,6 +613,22 @@ findFeeds sto return (map hpPageName $ srPages result) +findJavaScripts :: Storage -> IO [PageName] +findJavaScripts sto + = do cond <- newCondition + setPhrase cond "[UVSET]" + addAttrCond cond "@title STRBW Global/" + addAttrCond cond "@type STRBW text/javascript" + setOrder cond "@uri STRA" + result <- searchPages sto cond + return (map hpPageName $ srPages result) + + mkFeedURIStr :: URI -> PageName -> String mkFeedURIStr baseURI name - = uriToString id (mkFeedURI baseURI name) "" \ No newline at end of file + = uriToString id (mkFeedURI baseURI name) "" + + +mkObjectURIStr :: URI -> PageName -> String +mkObjectURIStr baseURI name + = uriToString id (mkObjectURI baseURI name) ""