From f4a655a34bc6017db008c2e915053958ae13ee81 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 24 Oct 2007 22:52:14 +0900 Subject: [PATCH] Record before an experiment darcs-hash:20071024135214-62b54-5488f29fb5a58cbeaed020267a6eebf88c6f45ac.gz --- Rakka/Page.hs | 10 ++++++- Rakka/Resource/Object.hs | 2 +- Rakka/Resource/Render.hs | 29 +++++++++++++----- Rakka/Storage/DefaultPage.hs | 6 +++- Rakka/SystemConfig.hs | 54 +++++++++++++++++++++++++++++----- Rakka/Wiki/Engine.hs | 13 ++++---- Rakka/Wiki/Interpreter.hs | 1 + Rakka/Wiki/Interpreter/Base.hs | 29 ++++++++++++++++++ defaultPages/Help/Syntax | 3 +- defaultPages/MainPage | 8 ++++- defaultPages/SideBar/Right | 1 + schemas/rakka-page-1.0.rng | 6 ++++ 12 files changed, 135 insertions(+), 27 deletions(-) diff --git a/Rakka/Page.hs b/Rakka/Page.hs index 29f0964..380d4a5 100644 --- a/Rakka/Page.hs +++ b/Rakka/Page.hs @@ -1,6 +1,9 @@ module Rakka.Page ( PageName , Page(..) + , LanguageTag + , LanguageName + , encodePageName , decodePageName , mkPageURI @@ -14,6 +17,7 @@ import Data.ByteString.Base (LazyByteString) import qualified Data.ByteString.Char8 as C8 import Data.Encoding import Data.Encoding.UTF8 +import Data.Map (Map) import Network.HTTP.Lucu import Network.URI import Subversion.Types @@ -23,6 +27,9 @@ import System.Time type PageName = String +type LanguageTag = String -- See RFC 3066: http://www.ietf.org/rfc/rfc3066.txt +type LanguageName = String -- i.e. "日本語" + data Page = Redirection { @@ -34,6 +41,7 @@ data Page | Entity { pageName :: !PageName , pageType :: !MIMEType + , pageLanguage :: !(Maybe LanguageTag) , pageIsTheme :: !Bool -- text/css 以外では無意味 , pageIsFeed :: !Bool -- text/x-rakka 以外では無意味 , pageIsLocked :: !Bool @@ -42,7 +50,7 @@ data Page , pageRevision :: !(Maybe RevNum) , pageLastMod :: !CalendarTime , pageSummary :: !(Maybe String) - , pageOtherLang :: ![(String, PageName)] + , pageOtherLang :: !(Map LanguageTag PageName) , pageContent :: !LazyByteString } diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index 307792d..e29c2a2 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -38,7 +38,7 @@ handleGet env name Just redir@(Redirection _ _ _ _) -> handleRedirect env redir - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _) + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _) -> handleGetEntity env entity diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 698e789..51d44fe 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -5,8 +5,10 @@ module Rakka.Resource.Render import Control.Arrow import Control.Arrow.ArrowIO +import Control.Arrow.ArrowIf import Control.Arrow.ArrowList import Data.Char +import qualified Data.Map as M import Network.HTTP.Lucu import Network.HTTP.Lucu.Utils import Network.URI @@ -56,7 +58,7 @@ handleGet env name Just redir@(Redirection _ _ _ _) -> handleRedirect env -< redir - Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _) + Just entity@(Entity _ _ _ _ _ _ _ _ _ _ _ _ _) -> handleGetEntity env -< entity {- @@ -75,6 +77,7 @@ handleRedirect env styleSheet="http://example.org/object/StyleSheet/Default" name="Foo/Bar" type="text/x-rakka" + lang="ja" -- 存在しない場合もある isTheme="no" -- text/css の場合のみ存在 isFeed="no" -- text/x-rakka の場合のみ存在 isLocked="no" @@ -124,6 +127,10 @@ handleGetEntity env += sattr "styleSheet" (uriToString id (mkObjectURI baseURI cssName) "") += sattr "name" (pageName page) += sattr "type" (show $ pageType page) + += ( case pageLanguage page of + Just x -> sattr "lang" x + _ -> none + ) += ( case pageType page of MIMEType "text" "css" _ -> sattr "isTheme" (yesOrNo $ pageIsTheme page) @@ -146,13 +153,14 @@ handleGetEntity env Just s -> eelem "summary" += txt s ) - += ( case pageOtherLang page of - [] -> none - xs -> selem "otherLang" - [ eelem "link" - += sattr "lang" lang - += sattr "page" page - | (lang, page) <- xs ] + += ( if M.null (pageOtherLang page) then + none + else + selem "otherLang" + [ eelem "link" + += sattr "lang" lang + += sattr "page" page + | (lang, page) <- M.toList (pageOtherLang page) ] ) += ( eelem "pageTitle" += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle) @@ -205,6 +213,11 @@ entityToXHTML = eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" + += ( getXPathTreesInDoc "/page/@lang" + `guards` + qattr (QN "xml" "lang" "") + ( getXPathTreesInDoc "/page/@lang/text()" ) + ) += ( eelem "head" += ( eelem "title" += getXPathTreesInDoc "/page/@site/text()" diff --git a/Rakka/Storage/DefaultPage.hs b/Rakka/Storage/DefaultPage.hs index 00fdf06..30b5fcf 100644 --- a/Rakka/Storage/DefaultPage.hs +++ b/Rakka/Storage/DefaultPage.hs @@ -10,6 +10,7 @@ import Control.Arrow.ArrowList import qualified Data.ByteString.Lazy as L import Data.Encoding import Data.Encoding.UTF8 +import qualified Data.Map as M import Paths_Rakka -- Cabal が用意する。 import Rakka.Page import Rakka.Utils @@ -81,6 +82,8 @@ parseEntity -> do mimeType <- (getXPathTreesInDoc "/page/@type/text()" >>> getText >>> arr read) -< tree + lang <- maybeA (getXPathTreesInDoc "/page/@lang/text()" >>> getText) -< tree + isTheme <- (withDefault (getXPathTreesInDoc "/page/@isTheme/text()" >>> getText) "no" >>> parseYesOrNo) -< tree isFeed <- (withDefault (getXPathTreesInDoc "/page/@isFeed/text()" >>> getText) "no" @@ -111,6 +114,7 @@ parseEntity returnA -< Entity { pageName = name , pageType = mimeType + , pageLanguage = lang , pageIsTheme = isTheme , pageIsFeed = isFeed , pageIsLocked = isLocked @@ -119,6 +123,6 @@ parseEntity , pageRevision = Nothing , pageLastMod = lastMod , pageSummary = summary - , pageOtherLang = otherLang + , pageOtherLang = M.fromList otherLang , pageContent = content } \ No newline at end of file diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index 58de2be..966ecf1 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -21,7 +21,9 @@ import Data.Maybe import GHC.Conc (unsafeIOToSTM) import Network import qualified Network.HTTP.Lucu.Config as LC +import Network.HTTP.Lucu.Utils import Network.URI +import Rakka.Page import Rakka.Utils import Subversion.FileSystem import Subversion.FileSystem.Revision @@ -45,6 +47,7 @@ data SysConfValue | BaseURI URI | DefaultPage String | StyleSheet String + | Languages (Map LanguageTag LanguageName) deriving (Eq, Show) @@ -107,28 +110,47 @@ fromConfPath :: FilePath -> FilePath fromConfPath = combine "/config" +marshalStringPairs :: [(String, String)] -> String +marshalStringPairs = joinWith "\n" . map marshalPair' + where + marshalPair' :: (String, String) -> String + marshalPair' (a, b) = a ++ " " ++ b + + +unmarshalStringPairs :: String -> [(String, String)] +unmarshalStringPairs = catMaybes . map unmarshalPair' . lines + where + unmarshalPair' :: String -> Maybe (String, String) + unmarshalPair' s = case break (/= ' ') s of + (a, ' ':b) -> Just (a, b) + _ -> Nothing + + {- paths -} sysConfPath :: SysConfValue -> FilePath sysConfPath (SiteName _) = "siteName" sysConfPath (BaseURI _) = "baseURI" sysConfPath (DefaultPage _) = "defaultPage" sysConfPath (StyleSheet _) = "styleSheet" +sysConfPath (Languages _) = "languages" {- marshalling -} marshalSysConf :: SysConfValue -> String -marshalSysConf (SiteName name) = name -marshalSysConf (BaseURI uri ) = uriToString id uri "" -marshalSysConf (DefaultPage name) = name -marshalSysConf (StyleSheet name) = name +marshalSysConf (SiteName name ) = name +marshalSysConf (BaseURI uri ) = uriToString id uri "" +marshalSysConf (DefaultPage name ) = name +marshalSysConf (StyleSheet name ) = name +marshalSysConf (Languages langs) = marshalStringPairs (M.toList langs) {- unmarshalling -} unmarshalSysConf :: SysConfValue -> String -> SysConfValue -unmarshalSysConf (SiteName _) name = SiteName name -unmarshalSysConf (BaseURI _) uri = BaseURI $ fromJust $ parseURI uri -unmarshalSysConf (DefaultPage _) name = DefaultPage name -unmarshalSysConf (StyleSheet _) name = StyleSheet name +unmarshalSysConf (SiteName _) name = SiteName name +unmarshalSysConf (BaseURI _) uri = BaseURI $ fromJust $ parseURI uri +unmarshalSysConf (DefaultPage _) name = DefaultPage name +unmarshalSysConf (StyleSheet _) name = StyleSheet name +unmarshalSysConf (Languages _) langs = Languages $ M.fromList $ unmarshalStringPairs langs {- getting default value -} @@ -156,3 +178,19 @@ sysConfDefault _ (DefaultPage _) sysConfDefault _ (StyleSheet _) = return $ StyleSheet "StyleSheet/Default" + +sysConfDefault _ (Languages _) + = return + $ Languages + $ M.fromList [ ("en", "English" ) + , ("es", "Español" ) + , ("de", "Deutsch" ) + , ("fi", "Suomi" ) + , ("fr", "Français" ) + , ("ga", "Gaeilge" ) + , ("gd", "Gàidhlig" ) + , ("ja", "日本語" ) + , ("pt", "Português") + , ("sv", "Svenska" ) + ] + diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index 2b751d4..ba9151c 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -30,7 +30,7 @@ formatPage env = proc page -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () wiki <- wikifyPage env -< page - xs <- interpretCommandsA env -< (pageName page, (Just wiki, wiki)) + xs <- interpretCommandsA env -< (pageName page, (Just (page, wiki), wiki)) formatWikiBlocks -< (baseURI, xs) @@ -43,7 +43,7 @@ formatSubPage env mainWiki <- case mainPage of Just page -> do wiki <- wikifyPage env -< page - returnA -< Just wiki + returnA -< Just (page, wiki) Nothing -> returnA -< Nothing subWiki <- wikifyPage env -< subPage @@ -75,13 +75,13 @@ wikifyPage env interpretCommandsA :: ArrowIO a => Environment - -> a (PageName, (Maybe WikiPage, WikiPage)) WikiPage + -> a (PageName, (Maybe (Page, WikiPage), WikiPage)) WikiPage interpretCommandsA = arrIO3 . interpretCommands -interpretCommands :: Environment -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage +interpretCommands :: Environment -> PageName -> Maybe (Page, WikiPage) -> WikiPage -> IO WikiPage interpretCommands _ _ _ [] = return [] -interpretCommands env name mainTree targetTree +interpretCommands env name mainPageAndTree targetTree = everywhereM' (mkM interpBlockCmd) targetTree >>= everywhereM' (mkM interpInlineCmd) @@ -89,7 +89,8 @@ interpretCommands env name mainTree targetTree ctx :: InterpreterContext ctx = InterpreterContext { ctxPageName = name - , ctxMainTree = mainTree + , ctxMainPage = fmap fst mainPageAndTree + , ctxMainTree = fmap snd mainPageAndTree , ctxTargetTree = targetTree , ctxStorage = envStorage env , ctxSysConf = envSysConf env diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs index 1bf10cc..ad951f8 100644 --- a/Rakka/Wiki/Interpreter.hs +++ b/Rakka/Wiki/Interpreter.hs @@ -27,6 +27,7 @@ data Interpreter data InterpreterContext = InterpreterContext { ctxPageName :: !PageName + , ctxMainPage :: !(Maybe Page) , ctxMainTree :: !(Maybe WikiPage) , ctxTargetTree :: !WikiPage , ctxStorage :: !Storage diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index 0070a83..3d38c2c 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -3,6 +3,10 @@ module Rakka.Wiki.Interpreter.Base ) where +import Data.Map (Map) +import qualified Data.Map as M +import Rakka.Page +import Rakka.SystemConfig import Rakka.Wiki import Rakka.Wiki.Interpreter @@ -12,6 +16,7 @@ interpreters = [ lineBreakInterp , spanInterp , divInterp , pageNameInterp +-- , otherLangsInterp ] @@ -45,3 +50,27 @@ pageNameInterp = InlineCommandInterpreter { , iciInterpret = \ ctx _ -> return $ Text (ctxPageName ctx) } + +{- +otherLangsInterp :: Interpreter +otherLangsInterp + = BlockCommandInterpreter { + bciName = "inOtherLanguages" + , bciInterpret + = \ ctx _ -> + case fmap pageOtherLang (ctxMainPage ctx) of + Nothing + -> return EmptyBlock + + Just linkTable + -> do Languages langTable <- getSysConf (ctxSysConf ctx) (Languages undefined) + let merged = mergeTables langTable (M.toList linkTable) + -- FIXME + } + where + mergeTables :: Map LanguageTag LanguageName + -> [(LanguageTag, PageName)] + -> [(LanguageName, PageName)] + mergeTables _ [] = [] + mergeTables m (x:xs) = fromMaybe x (M.lookup x m) : mergeTables m xs +-} \ No newline at end of file diff --git a/defaultPages/Help/Syntax b/defaultPages/Help/Syntax index 41cbe04..ce9a0b2 100644 --- a/defaultPages/Help/Syntax +++ b/defaultPages/Help/Syntax @@ -1,7 +1,8 @@ + isBoring="yes" + lang="en"> + isBoring="yes" + lang="en"> + + + + + = Recent updates = diff --git a/schemas/rakka-page-1.0.rng b/schemas/rakka-page-1.0.rng index 42b1733..3fefe6c 100644 --- a/schemas/rakka-page-1.0.rng +++ b/schemas/rakka-page-1.0.rng @@ -18,6 +18,12 @@ + + + + + + -- 2.40.0