From: pho Date: Tue, 1 Apr 2008 15:05:09 +0000 (+0900) Subject: Localization of sub page X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=cac96112c79075ff03dd38616a314dd293699170;p=Rakka.git Localization of sub page darcs-hash:20080401150509-62b54-d7821a0de03728c4cc3a8172d5d68f3e4869e210.gz --- diff --git a/Rakka/Resource/PageEntity.hs b/Rakka/Resource/PageEntity.hs index e354004..3ff0bba 100644 --- a/Rakka/Resource/PageEntity.hs +++ b/Rakka/Resource/PageEntity.hs @@ -9,6 +9,7 @@ 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 @@ -125,9 +126,9 @@ entityToXHTML env 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") + 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 "/" @@ -301,13 +302,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 +372,9 @@ 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") + 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" @@ -458,9 +484,9 @@ 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") + 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" diff --git a/Rakka/Resource/Search.hs b/Rakka/Resource/Search.hs index 6f72195..c46d401 100644 --- a/Rakka/Resource/Search.hs +++ b/Rakka/Resource/Search.hs @@ -148,9 +148,9 @@ searchResultToXHTML env let cssHref = [uriToString id (mkObjectURI baseURI styleSheet) ""] scriptSrc = [uriToString id (baseURI { uriPath = uriPath baseURI "js" }) ""] - pageTitle <- listA (readSubPage env) -< (Nothing, Nothing, "PageTitle") - leftSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Left") - rightSideBar <- listA (readSubPage env) -< (Nothing, Nothing, "SideBar/Right") + pageTitle <- listA (readSubPage env) -< "PageTitle" + leftSideBar <- listA (readSubPage env) -< "SideBar/Left" + rightSideBar <- listA (readSubPage env) -< "SideBar/Right" ( eelem "/" += ( eelem "html" @@ -382,12 +382,11 @@ searchResultToXHTML env uriToText = arr (\ uri -> uriToString id uri "") >>> mkText +-- FIXME: localize readSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a (Maybe PageName, Maybe XmlTree, PageName) XmlTree + Environment -> a PageName XmlTree readSubPage env - = proc (mainPageName, mainPage, subPageName) -> + = proc (subPageName) -> do subPage <- getPageA (envStorage env) >>> arr fromJust >>> xmlizePage -< (subPageName, Nothing) - subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) - -< (mainPageName, mainPage, subPage) + subXHTML <- makeSubXHTML (envStorage env) (envSysConf env) (envInterpTable env) -< (Nothing, Nothing, subPage) returnA -< subXHTML