Record before an experiment

darcs-hash:20071024135214-62b54-5488f29fb5a58cbeaed020267a6eebf88c6f45ac.gz

diff --git a/Rakka/Page.hs b/Rakka/Page.hs
index 29f0964541d4228ea4c2a6b7e14a7f445c4e4a6e..380d4a5d2a3967eb08c875916a165be0945223da 100644 (file)
--- 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 307792d472452b643ccd2c24efa9ba589b8b33fb..e29c2a2e33ea071e7624ff1341666437c0ccfaef 100644 (file)
--- 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 698e789e7467c1ce86fc6b6a0f4c99686f9095c0..51d44fe50f047c37a037808dc47ade488ebc84e6 100644 (file)
--- 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 00fdf06dd9e8557f778d46e727a738823ef16d5e..30b5fcf5f1c918d963052b57cd8db293adcf7bb8 100644 (file)
--- 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 58de2bec0ca22afb68ce1534dc23691617136cd1..966ecf10d6c6ca1c2e4dc1af5a7d02279b9dfd9e 100644 (file)
--- 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 2b751d4a47db96bc49bc23e0ef02f0d54e2d2427..ba9151c1a43137f9ae267cd3e07874ee445e5027 100644 (file)
--- 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 1bf10ccc195ee495777aec363471bf06747a8d03..ad951f80a668beabf59cfea1f8f2d9796a763407 100644 (file)
--- 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 0070a837c376df6838bd2796d894cdaef62ccfa6..3d38c2c3c9dc2c34478e36de00175d73d1aa0784 100644 (file)
--- 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 41cbe04b60c60447a4ff7e5d9c7abb3307366d6f..ce9a0b2e6947a4379ff2f398ab0cd93d5b42838e 100644 (file)
--- a/defaultPages/Help/Syntax
+++ b/defaultPages/Help/Syntax
@@ -1,7 +1,8 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
       type="text/x-rakka"
-      isBoring="yes">
+      isBoring="yes"
+      lang="en">
   <textData><![CDATA[= Syntax Help =
 
 == Heading ==

diff --git a/defaultPages/MainPage b/defaultPages/MainPage
index 4c056fa76380bd967a98d214d4dbb14deea76fe2..cdfb7d6f720233ffc6552921603115e5402bc242 100644 (file)
--- a/defaultPages/MainPage
+++ b/defaultPages/MainPage
@@ -1,7 +1,13 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <page xmlns="http://cielonegro.org/schema/Rakka/Page/1.0"
       type="text/x-rakka"
-      isBoring="yes">
+      isBoring="yes"
+      lang="en">
+
+  <otherLang>
+    <link lang="ja" page="メインページ" />
+  </otherLang>
+
   <textData><![CDATA[
 = Main Page =
 This  is  the    main  page.

diff --git a/defaultPages/SideBar/Right b/defaultPages/SideBar/Right
index c3b03b101fe345da8ed0c9b406679ff0e84b296e..27c4eb330a191cc8d6f63564943b17a70fb56017 100644 (file)
--- a/defaultPages/SideBar/Right
+++ b/defaultPages/SideBar/Right
@@ -8,6 +8,7 @@
 = RSS feeds =
 
 = In other languages =
+<inOtherLanguages />
 
 = Recent updates =
 

diff --git a/schemas/rakka-page-1.0.rng b/schemas/rakka-page-1.0.rng
index 42b17336914528c3e5464a0a992fdbdce1261b18..3fefe6ca38bff6a5fa7971f4405bf07b4fbae2d1 100644 (file)
--- a/schemas/rakka-page-1.0.rng
+++ b/schemas/rakka-page-1.0.rng
@@ -18,6 +18,12 @@
         <text />
       </attribute>
 
+      <optional>
+        <attribute name="lang">
+          <text />
+        </attribute>
+      </optional>
+
       <optional>
         <!-- text/css でなければ無視される -->
         <attribute name="isTheme">