From: pho Date: Tue, 23 Oct 2007 04:46:06 +0000 (+0900) Subject: Implemented the outline command X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=3c5211253dc61c31196a47486c538b64c32d8c5e;p=Rakka.git Implemented the outline command darcs-hash:20071023044606-62b54-798c82617b3664c234c6abba6908bbc8f5b98642.gz --- diff --git a/.boring b/.boring index d545fc2..0a5b28a 100644 --- a/.boring +++ b/.boring @@ -54,3 +54,4 @@ ^Setup$ ^configure$ ^dist(/|$) +^repos(/|$) diff --git a/Main.hs b/Main.hs index 1b441ee..4485568 100644 --- a/Main.hs +++ b/Main.hs @@ -7,6 +7,7 @@ import Rakka.Environment import Rakka.Resource.Index import Rakka.Resource.Object import Rakka.Resource.Render +import Subversion import System.Console.GetOpt import System.Directory import System.Environment @@ -69,7 +70,8 @@ printUsage = do putStrLn "Usage:" main :: IO () -main = do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs +main = withSubversion $ + do (opts, nonOpts, errors) <- return . getOpt Permute options =<< getArgs when (not $ null errors) $ do mapM_ putStr errors diff --git a/Rakka.cabal b/Rakka.cabal index efc767a..844381b 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -26,7 +26,7 @@ GHC-Options: -fwarn-unused-imports -fglasgow-exts Build-Depends: Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hxt, mtl, - network, parsec, unix + network, parsec, stm, unix Exposed-Modules: Rakka.Page Rakka.Storage @@ -60,6 +60,7 @@ Other-Modules: Rakka.Resource.Render Rakka.Wiki.Interpreter.Base Rakka.Wiki.Interpreter.Base.Image + Rakka.Wiki.Interpreter.Base.Outline Rakka.Wiki.Engine Rakka.Wiki.Formatter Rakka.Wiki.Parser diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index d68892b..b554df8 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -7,8 +7,8 @@ module Rakka.Environment ) where +import Control.Concurrent.STM import Control.Arrow.ArrowIO -import Data.IORef import Data.Map (Map) import qualified Data.Map as M import Network @@ -17,14 +17,18 @@ import Rakka.Storage import Rakka.SystemConfig import Rakka.Wiki.Interpreter import Rakka.Wiki.Interpreter.Base +import Subversion.Repository +import System.Directory +import System.FilePath data Environment = Environment { envLocalStateDir :: !FilePath , envLucuConf :: !LC.Config + , envRepository :: !Repository , envStorage :: !Storage , envSysConf :: !SystemConfig - , envInterpTable :: !(IORef InterpTable) + , envInterpTable :: !(TVar InterpTable) } @@ -33,23 +37,32 @@ type InterpTable = Map String Interpreter setupEnv :: FilePath -> PortNumber -> IO Environment setupEnv lsdir portNum - = do let lucuConf = LC.defaultConfig { - LC.cnfServerPort = PortNumber portNum - } - storage = mkStorage - sysConf = mkSystemConfig lucuConf + = do let lucuConf = LC.defaultConfig { + LC.cnfServerPort = PortNumber portNum + } + reposPath = lsdir `combine` "repos" + storage = mkStorage + + reposExist <- doesDirectoryExist reposPath + repos <- if reposExist then + openRepository reposPath + else + createRepository reposPath [] [] + sysConf <- mkSystemConfig lucuConf repos interpTable <- mkInterpTable + return $ Environment { envLocalStateDir = lsdir , envLucuConf = lucuConf + , envRepository = repos , envStorage = storage , envSysConf = sysConf , envInterpTable = interpTable } -mkInterpTable :: IO (IORef InterpTable) -mkInterpTable = newIORef (listToTable baseInterpreters) +mkInterpTable :: IO (TVar InterpTable) +mkInterpTable = newTVarIO (listToTable baseInterpreters) where listToTable :: [Interpreter] -> InterpTable listToTable xs @@ -57,7 +70,7 @@ mkInterpTable = newIORef (listToTable baseInterpreters) getInterpTable :: Environment -> IO InterpTable -getInterpTable = readIORef . envInterpTable +getInterpTable = atomically . readTVar . envInterpTable getInterpTableA :: ArrowIO a => Environment -> a b InterpTable diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index df141b1..698e789 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -155,20 +155,20 @@ handleGetEntity env | (lang, page) <- xs ] ) += ( eelem "pageTitle" - += ( (constA (pageName page) &&& constA pageTitle) + += ( (constA (pageName page) &&& constA (Just page) &&& constA pageTitle) >>> formatSubPage env ) ) += ( eelem "sideBar" += ( eelem "left" - += ( (constA (pageName page) &&& constA leftSideBar) + += ( (constA (pageName page) &&& constA (Just page) &&& constA leftSideBar) >>> formatSubPage env ) ) += ( eelem "right" - += ( (constA (pageName page) &&& constA rightSideBar) + += ( (constA (pageName page) &&& constA (Just page) &&& constA rightSideBar) >>> formatSubPage env ) @@ -293,20 +293,20 @@ handlePageNotFound env += sattr "name" name += ( eelem "pageTitle" - += ( (constA name &&& constA pageTitle) + += ( (constA name &&& constA Nothing &&& constA pageTitle) >>> formatSubPage env ) ) += ( eelem "sideBar" += ( eelem "left" - += ( (constA name &&& constA leftSideBar) + += ( (constA name &&& constA Nothing &&& constA leftSideBar) >>> formatSubPage env ) ) += ( eelem "right" - += ( (constA name &&& constA rightSideBar) + += ( (constA name &&& constA Nothing &&& constA rightSideBar) >>> formatSubPage env ) diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index 423e6c5..8a6be02 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -10,16 +10,30 @@ module Rakka.SystemConfig where import Control.Arrow.ArrowIO +import Control.Concurrent.STM import Control.Monad.Trans import qualified Data.ByteString.Char8 as C8 +import Data.Encoding +import Data.Encoding.UTF8 +import Data.Map (Map) +import qualified Data.Map as M import Data.Maybe +import GHC.Conc (unsafeIOToSTM) import Network import qualified Network.HTTP.Lucu.Config as LC import Network.URI +import Rakka.Utils +import Subversion.FileSystem +import Subversion.FileSystem.Revision +import Subversion.FileSystem.Root +import Subversion.Repository +import System.FilePath.Posix data SystemConfig = SystemConfig { - scLucuConf :: !LC.Config + scLucuConf :: !LC.Config + , scRepository :: !Repository + , scCache :: !(TVar (Map FilePath SysConfValue)) } @@ -28,27 +42,66 @@ data SysConfValue | BaseURI URI | DefaultPage String | StyleSheet String + deriving (Eq, Show) -mkSystemConfig :: LC.Config -> SystemConfig -mkSystemConfig = SystemConfig +mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig +mkSystemConfig lc repos + = do cache <- newTVarIO M.empty + return $ SystemConfig { + scLucuConf = lc + , scRepository = repos + , scCache = cache + } getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue getSysConf sc key - = liftIO $ sysConfDefault sc key -- FIXME + = liftIO $ + atomically $ + do let path = sysConfPath key + + cache <- readTVar (scCache sc) + + case M.lookup path cache of + Just val -> return val + Nothing -> do val <- unsafeIOToSTM (getSysConf' sc key) + writeTVar (scCache sc) (M.insert path val cache) + return val + + +getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue +getSysConf' sc key + = do fs <- getRepositoryFS (scRepository sc) + rev <- getYoungestRev fs + value <- withRevision fs rev + $ do let path = fromConfPath (sysConfPath key) + exists <- isFile path + case exists of + True + -> do str <- getFileContentsLBS path + return $ Just $ chomp $ decodeLazy UTF8 str + False + -> return Nothing + case value of + Just str -> return $ unmarshalSysConf key str + Nothing -> sysConfDefault sc key getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue getSysConfA = (arrIO0 .) . getSysConf +fromConfPath :: FilePath -> FilePath +fromConfPath = combine "/config" + + {- paths -} sysConfPath :: SysConfValue -> FilePath -sysConfPath (SiteName _) = "/siteName" -sysConfPath (BaseURI _) = "/baseURI" -sysConfPath (DefaultPage _) = "/defaultPage" -sysConfPath (StyleSheet _) = "/styleSheet" +sysConfPath (SiteName _) = "siteName" +sysConfPath (BaseURI _) = "baseURI" +sysConfPath (DefaultPage _) = "defaultPage" +sysConfPath (StyleSheet _) = "styleSheet" {- marshalling -} diff --git a/Rakka/Utils.hs b/Rakka/Utils.hs index e411694..9f2873c 100644 --- a/Rakka/Utils.hs +++ b/Rakka/Utils.hs @@ -4,6 +4,7 @@ module Rakka.Utils , maybeA , deleteIfEmpty , formatW3CDateTime + , chomp ) where @@ -71,4 +72,8 @@ formatW3CDateTime time show2 :: Int -> String show2 n | n < 10 = '0':(show n) - | otherwise = show n \ No newline at end of file + | otherwise = show n + + +chomp :: String -> String +chomp = reverse . snd . break (/= '\n') . reverse diff --git a/Rakka/Wiki.hs b/Rakka/Wiki.hs index f8341ec..0fcf38a 100644 --- a/Rakka/Wiki.hs +++ b/Rakka/Wiki.hs @@ -35,6 +35,7 @@ data BlockElement | Preformatted ![InlineElement] | Paragraph ![InlineElement] | Div ![Attribute] ![BlockElement] + | EmptyBlock | BlockCmd !BlockCommand deriving (Eq, Show, Typeable, Data) @@ -56,6 +57,7 @@ data InlineElement | Span ![Attribute] ![InlineElement] | Image ![Attribute] | Anchor ![Attribute] ![InlineElement] + | EmptyInline | InlineCmd !InlineCommand deriving (Eq, Show, Typeable, Data) diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index aa897e8..ffaab2f 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -6,7 +6,6 @@ module Rakka.Wiki.Engine import Control.Arrow import Control.Arrow.ArrowIO -import Control.Arrow.ArrowTree import Data.Encoding import Data.Encoding.UTF8 import Data.Generics @@ -29,42 +28,47 @@ formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => -> a Page XmlTree formatPage env = proc page - -> do tree <- case pageType page of - MIMEType "text" "x-rakka" _ - -> do let source = decodeLazy UTF8 (pageContent page) - formatWikiPage env -< (pageName page, source) - attachXHtmlNs -< tree + -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () + interpTable <- getInterpTableA env -< () + wiki <- wikifyPage env -< (interpTable, page) + xs <- interpretCommandsA env -< (interpTable, (pageName page, (Just wiki, wiki))) + formatWikiBlocks -< (baseURI, xs) formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (PageName, Page) XmlTree + -> a (PageName, (Maybe Page, Page)) XmlTree formatSubPage env - = proc (mainPageName, subPage) - -> do tree <- case pageType subPage of - MIMEType "text" "x-rakka" _ - -> do let source = decodeLazy UTF8 (pageContent subPage) - formatWikiPage env -< (mainPageName, source) - attachXHtmlNs -< tree - - -formatWikiPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => - Environment - -> a (PageName, String) XmlTree -formatWikiPage env - = proc (name, source) + = proc (mainPageName, (mainPage, subPage)) -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () interpTable <- getInterpTableA env -< () - - let parser = wikiPage (tableToFunc interpTable) - - case parse parser "" source of - Left err - -> formatParseError -< err - - Right blocks - -> do xs <- interpretCommandsA env -< (interpTable, (name, blocks)) - formatWikiBlocks -< (baseURI, xs) + mainWiki <- case mainPage of + Just page + -> do wiki <- wikifyPage env -< (interpTable, page) + returnA -< Just wiki + Nothing + -> returnA -< Nothing + subWiki <- wikifyPage env -< (interpTable, subPage) + xs <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki))) + formatWikiBlocks -< (baseURI, xs) + + +wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => + Environment + -> a (InterpTable, Page) WikiPage +wikifyPage env + = proc (interpTable, page) + -> case pageType page of + MIMEType "text" "x-rakka" _ + -> do let source = decodeLazy UTF8 (pageContent page) + parser = wikiPage (tableToFunc interpTable) + + case parse parser "" source of + Left err + -> wikifyParseError -< err + + Right xs + -> returnA -< xs where tableToFunc :: InterpTable -> String -> Maybe CommandType tableToFunc table name @@ -73,22 +77,24 @@ formatWikiPage env interpretCommandsA :: ArrowIO a => Environment - -> a (InterpTable, (PageName, WikiPage)) WikiPage -interpretCommandsA = arrIO3 . interpretCommands + -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage +interpretCommandsA = arrIO4 . interpretCommands -interpretCommands :: Environment -> InterpTable -> PageName -> WikiPage -> IO WikiPage -interpretCommands _ _ _ [] = return [] -interpretCommands env table name blocks = everywhereM' (mkM interpBlockCmd) blocks - >>= - everywhereM' (mkM interpInlineCmd) +interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage +interpretCommands _ _ _ _ [] = return [] +interpretCommands env table name mainTree targetTree + = everywhereM' (mkM interpBlockCmd) targetTree + >>= + everywhereM' (mkM interpInlineCmd) where ctx :: InterpreterContext ctx = InterpreterContext { - ctxPageName = name - , ctxTree = blocks - , ctxStorage = envStorage env - , ctxSysConf = envSysConf env + ctxPageName = name + , ctxMainTree = mainTree + , ctxTargetTree = targetTree + , ctxStorage = envStorage env + , ctxSysConf = envSysConf env } interpBlockCmd :: BlockElement -> IO BlockElement @@ -124,16 +130,6 @@ everywhereM' :: Monad m => GenericM m -> GenericM m everywhereM' f x = f x >>= gmapM (everywhereM' f) -formatParseError :: ArrowXml a => a ParseError XmlTree -formatParseError - = proc err -> (eelem "pre" += txt (show err)) -<< () - - -attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree -attachXHtmlNs = processBottomUp (changeQName attach') - where - attach' :: QName -> QName - attach' qn = qn { - namePrefix = "xhtml" - , namespaceUri = "http://www.w3.org/1999/xhtml" - } +wikifyParseError :: ArrowXml a => a ParseError WikiPage +wikifyParseError + = proc err -> returnA -< [Preformatted [Text (show err)]] diff --git a/Rakka/Wiki/Formatter.hs b/Rakka/Wiki/Formatter.hs index a08fe30..b81c510 100644 --- a/Rakka/Wiki/Formatter.hs +++ b/Rakka/Wiki/Formatter.hs @@ -5,6 +5,7 @@ module Rakka.Wiki.Formatter import Control.Arrow import Control.Arrow.ArrowList +import Control.Arrow.ArrowTree import Data.Char import Data.List import Data.Maybe @@ -18,8 +19,9 @@ import Text.XML.HXT.DOM.TypeDefs formatWikiBlocks :: (ArrowXml a, ArrowChoice a) => a (URI, [BlockElement]) XmlTree formatWikiBlocks = proc (baseURI, blocks) - -> do block <- arrL id -< blocks - formatBlock -< (baseURI, block) + -> do block <- arrL id -< blocks + tree <- formatBlock -< (baseURI, block) + attachXHtmlNs -< tree formatBlock :: (ArrowXml a, ArrowChoice a) => a (URI, BlockElement) XmlTree @@ -46,6 +48,9 @@ formatBlock Div attrs contents -> formatElem "div" -< (baseURI, attrs, contents) + + EmptyBlock + -> none -< () where formatElem :: (ArrowXml a, ArrowChoice a) => String @@ -178,6 +183,9 @@ formatInline Anchor attrs contents -> formatElem "a" -< (baseURI, attrs, contents) + + EmptyInline + -> none -< () where formatElem :: (ArrowXml a, ArrowChoice a) => String @@ -229,3 +237,13 @@ formatExternalLink += attr "href" (arr fst >>> mkText) += (arr snd >>> mkText) ) -< (href, label) + + +attachXHtmlNs :: ArrowXml a => a XmlTree XmlTree +attachXHtmlNs = processBottomUp (changeQName attach') + where + attach' :: QName -> QName + attach' qn = qn { + namePrefix = "xhtml" + , namespaceUri = "http://www.w3.org/1999/xhtml" + } diff --git a/Rakka/Wiki/Interpreter.hs b/Rakka/Wiki/Interpreter.hs index 2a830b3..1bf10cc 100644 --- a/Rakka/Wiki/Interpreter.hs +++ b/Rakka/Wiki/Interpreter.hs @@ -26,10 +26,11 @@ data Interpreter data InterpreterContext = InterpreterContext { - ctxPageName :: !PageName - , ctxTree :: !WikiPage - , ctxStorage :: !Storage - , ctxSysConf :: !SystemConfig + ctxPageName :: !PageName + , ctxMainTree :: !(Maybe WikiPage) + , ctxTargetTree :: !WikiPage + , ctxStorage :: !Storage + , ctxSysConf :: !SystemConfig } diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index c749589..f2fd602 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -6,6 +6,7 @@ module Rakka.Wiki.Interpreter.Base import Rakka.Wiki import Rakka.Wiki.Interpreter import Rakka.Wiki.Interpreter.Base.Image +import Rakka.Wiki.Interpreter.Base.Outline baseInterpreters :: [Interpreter] @@ -16,6 +17,7 @@ baseInterpreters = [ lineBreakInterp , imgFrameInterp , pageNameInterp + , outlineInterp ] @@ -48,4 +50,4 @@ pageNameInterp = InlineCommandInterpreter { iciName = "pageName" , iciInterpret = \ ctx _ -> return $ Text (ctxPageName ctx) - } \ No newline at end of file + } diff --git a/Rakka/Wiki/Interpreter/Base/Outline.hs b/Rakka/Wiki/Interpreter/Base/Outline.hs new file mode 100644 index 0000000..d0e21ab --- /dev/null +++ b/Rakka/Wiki/Interpreter/Base/Outline.hs @@ -0,0 +1,76 @@ +module Rakka.Wiki.Interpreter.Base.Outline + ( outlineInterp + ) + where + +import Data.Generics +import Rakka.Wiki +import Rakka.Wiki.Interpreter + + +outlineInterp :: Interpreter +outlineInterp = BlockCommandInterpreter { + bciName = "outline" + , bciInterpret + = \ ctx _ -> + case ctxMainTree ctx of + Just tree -> return $ Div [("class", "outline")] [List $ mkOutline tree] + Nothing -> return EmptyBlock + } + + +mkOutline :: WikiPage -> ListElement +mkOutline tree + = let headings = listify query tree + in + fst (mkOutline' emptyOutline 1 headings) + + +query :: Typeable a => a -> Bool +query = mkQ False $ \ x -> case x of + Heading _ _ -> True + _ -> False + + +emptyOutline :: ListElement +emptyOutline = ListElement Bullet [] + + +mkOutline' :: ListElement -> Int -> [BlockElement] -> (ListElement, [BlockElement]) +mkOutline' soFar _ [] = (soFar, []) +mkOutline' soFar level (x:xs) + = case x of + Heading n text + | n == level + -- 同じレベルなので soFar に單獨の ListItem を追加して + -- 續行。 + -> let link = PageLink { + linkPage = Nothing + , linkFragment = Just text + , linkText = Just text + } + item = [Right link] + in + mkOutline' (soFar { listItems = listItems soFar ++ [item] }) n xs + + | n < level + -- 低いレベルなのでここで終了。 + -> (soFar, x:xs) + + | n > level + -- 高いレベルなので再帰して ListElement を作り、 + -- それを soFar の最後の ListItem に追加する。 + -> let (nested, ys) = mkOutline' emptyOutline (level + 1) (x:xs) + itemsSoFar = listItems soFar + + nonLastItems, lastItem :: [ListItem] + (nonLastItems, lastItem) = splitAt (length itemsSoFar - 1) itemsSoFar + + lastItem' :: ListItem + lastItem' = case lastItem of + [] -> [Left nested] + i:[] -> i ++ [Left nested] + + soFar' = soFar { listItems = nonLastItems ++ [lastItem'] } + in + mkOutline' soFar' level ys diff --git a/defaultPages/SideBar/Left b/defaultPages/SideBar/Left index 9b3a18d..d03ad83 100644 --- a/defaultPages/SideBar/Left +++ b/defaultPages/SideBar/Left @@ -4,6 +4,7 @@ isBoring="yes"> = Menu = diff --git a/defaultPages/StyleSheet/Default b/defaultPages/StyleSheet/Default index bd566ef..0c324b5 100644 --- a/defaultPages/StyleSheet/Default +++ b/defaultPages/StyleSheet/Default @@ -4,14 +4,13 @@ isBoring="yes" isTheme="yes"> -/* global configuration */ +/* global configuration ********************************************************/ * { padding: 0; margin: 0; } -/* layout */ - +/* layout **********************************************************************/ .center { position: absolute; @@ -58,7 +57,7 @@ overflow: auto; } -/* spacing */ +/* spacing *********************************************************************/ .title { padding: 5px 20px; } @@ -77,7 +76,7 @@ .body ul, .body ol { list-style-position: inside; - margin: 1em 0; + margin: 0 0 0.8em 0; } .body ul ul, .body ul ol, .body ol ul, .body ol ol { margin: 0; @@ -120,6 +119,7 @@ .sideBar ul, .sideBar ol { list-style-type: none; margin-top: 0.4em; + margin-bottom: 0.4em; } .sideBar li + li { @@ -130,7 +130,7 @@ margin-top: 1.2em; } -/* color and text */ +/* color and text **************************************************************/ * { font-family: sans-serif; } @@ -220,29 +220,35 @@ a { } .sideBar .outline li { - list-style-type: circle; + list-style-type: disc; margin-left: 1em; padding: 0; - background-color: black; + line-height: 1.0; } .sideBar .outline li li { - list-style-type: disc; + list-style-type: circle; } .sideBar .outline li li li { list-style-type: square; } +.sideBar .outline li li li li { + list-style-type: disc; +} +.sideBar .outline li li li li li { + list-style-type: circle; +} p { margin: 0 0 0.8em 0; } -/* float */ +/* float ***********************************************************************/ h1, h2, h3, h4, h5, h6 { clear: both; } -/* image */ +/* image ***********************************************************************/ img { border-width: 0; }