From 8f77b5949ccd5f2272a02c852d51bfa2ecfa84c8 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 24 Oct 2007 00:32:43 +0900 Subject: [PATCH] Farewell the dream of plug-in system... It's way too hard to implement nicely. Many problems arose during the implementation. darcs-hash:20071023153243-62b54-c6bcb14fd0d8be2231448cbfafec9b2b086184d2.gz --- Makefile | 4 +- Rakka.cabal | 26 +++++-------- Rakka/Environment.hs | 39 +++++++++----------- Rakka/Wiki/Engine.hs | 38 +++++++++---------- Rakka/Wiki/Interpreter/Base.hs | 20 ++++------ Rakka/Wiki/Interpreter/{Base => }/Image.hs | 11 ++++-- Rakka/Wiki/Interpreter/{Base => }/Outline.hs | 8 +++- 7 files changed, 68 insertions(+), 78 deletions(-) rename Rakka/Wiki/Interpreter/{Base => }/Image.hs (95%) rename Rakka/Wiki/Interpreter/{Base => }/Outline.hs (95%) diff --git a/Makefile b/Makefile index b64ac45..624dbea 100644 --- a/Makefile +++ b/Makefile @@ -1,11 +1,11 @@ CABAL_FILE = Rakka.cabal GHC = ghc -EXECUTABLE = sudo rakka -p 8989 -l DEBUG +EXECUTABLE = sudo ./dist/build/rakka/rakka -p 8989 -l DEBUG build: .setup-config Setup ./Setup build -run: install +run: build $(EXECUTABLE) .setup-config: $(CABAL_FILE) configure Setup Rakka.buildinfo.in diff --git a/Rakka.cabal b/Rakka.cabal index 4d72b21..7df3dc4 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -20,23 +20,9 @@ Category: Web Tested-With: GHC == 6.6.1 -Extensions: - Arrows -GHC-Options: - -fwarn-unused-imports -fglasgow-exts Build-Depends: Crypto, HUnit, HsSVN, Lucu, base, encoding, filepath, hslogger, hxt, mtl, network, parsec, stm, unix -Exposed-Modules: - Rakka.Page - Rakka.Plugin - Rakka.Storage - Rakka.SystemConfig - Rakka.Utils - Rakka.Wiki - Rakka.Wiki.Interpreter -Other-Modules: - Rakka.Storage.DefaultPage Data-Files: defaultpages/Help/SampleImage/Large defaultpages/Help/SampleImage/Small @@ -55,13 +41,21 @@ Main-Is: Main.hs Other-Modules: Rakka.Environment + Rakka.Page + Rakka.Plugin Rakka.Resource Rakka.Resource.Index Rakka.Resource.Object Rakka.Resource.Render + Rakka.Storage + Rakka.Storage.DefaultPage + Rakka.SystemConfig + Rakka.Utils + Rakka.Wiki + Rakka.Wiki.Interpreter Rakka.Wiki.Interpreter.Base - Rakka.Wiki.Interpreter.Base.Image - Rakka.Wiki.Interpreter.Base.Outline + Rakka.Wiki.Interpreter.Image + Rakka.Wiki.Interpreter.Outline Rakka.Wiki.Engine Rakka.Wiki.Formatter Rakka.Wiki.Parser diff --git a/Rakka/Environment.hs b/Rakka/Environment.hs index 6ae6f11..48105b4 100644 --- a/Rakka/Environment.hs +++ b/Rakka/Environment.hs @@ -2,13 +2,9 @@ module Rakka.Environment ( Environment(..) , InterpTable , setupEnv - , getInterpTable - , getInterpTableA ) where -import Control.Concurrent.STM -import Control.Arrow.ArrowIO import Data.Map (Map) import qualified Data.Map as M import Network @@ -16,7 +12,9 @@ import qualified Network.HTTP.Lucu.Config as LC import Rakka.Storage import Rakka.SystemConfig import Rakka.Wiki.Interpreter -import Rakka.Wiki.Interpreter.Base +import qualified Rakka.Wiki.Interpreter.Base as Base +import qualified Rakka.Wiki.Interpreter.Image as Image +import qualified Rakka.Wiki.Interpreter.Outline as Outline import Subversion.Repository import System.Directory import System.FilePath @@ -31,7 +29,7 @@ data Environment = Environment { , envRepository :: !Repository , envStorage :: !Storage , envSysConf :: !SystemConfig - , envInterpTable :: !(TVar InterpTable) + , envInterpTable :: !InterpTable } @@ -40,11 +38,12 @@ type InterpTable = Map String Interpreter setupEnv :: FilePath -> PortNumber -> IO Environment setupEnv lsdir portNum - = do let lucuConf = LC.defaultConfig { - LC.cnfServerPort = PortNumber portNum - } - reposPath = lsdir `combine` "repos" - storage = mkStorage + = do let lucuConf = LC.defaultConfig { + LC.cnfServerPort = PortNumber portNum + } + reposPath = lsdir `combine` "repos" + storage = mkStorage + interpTable = mkInterpTable reposExist <- doesDirectoryExist reposPath repos <- if reposExist then @@ -54,7 +53,7 @@ setupEnv lsdir portNum do noticeM logger ("Creating a subversion repository on " ++ reposPath) createRepository reposPath [] [] sysConf <- mkSystemConfig lucuConf repos - interpTable <- mkInterpTable + return $ Environment { envLocalStateDir = lsdir @@ -66,17 +65,13 @@ setupEnv lsdir portNum } -mkInterpTable :: IO (TVar InterpTable) -mkInterpTable = newTVarIO (listToTable baseInterpreters) +mkInterpTable :: InterpTable +mkInterpTable = listToTable $ + foldl (++) [] [ Base.interpreters + , Image.interpreters + , Outline.interpreters + ] where listToTable :: [Interpreter] -> InterpTable listToTable xs = M.fromList [ (commandName x, x) | x <- xs ] - - -getInterpTable :: Environment -> IO InterpTable -getInterpTable = atomically . readTVar . envInterpTable - - -getInterpTableA :: ArrowIO a => Environment -> a b InterpTable -getInterpTableA = arrIO0 . getInterpTable diff --git a/Rakka/Wiki/Engine.hs b/Rakka/Wiki/Engine.hs index eb986ea..2b751d4 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -29,9 +29,8 @@ formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => formatPage env = proc page -> 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))) + wiki <- wikifyPage env -< page + xs <- interpretCommandsA env -< (pageName page, (Just wiki, wiki)) formatWikiBlocks -< (baseURI, xs) @@ -41,27 +40,26 @@ formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => formatSubPage env = proc (mainPageName, (mainPage, subPage)) -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () - interpTable <- getInterpTableA env -< () mainWiki <- case mainPage of Just page - -> do wiki <- wikifyPage env -< (interpTable, page) + -> do wiki <- wikifyPage env -< page returnA -< Just wiki Nothing -> returnA -< Nothing - subWiki <- wikifyPage env -< (interpTable, subPage) - xs <- interpretCommandsA env -< (interpTable, (mainPageName, (mainWiki, subWiki))) + subWiki <- wikifyPage env -< subPage + xs <- interpretCommandsA env -< (mainPageName, (mainWiki, subWiki)) formatWikiBlocks -< (baseURI, xs) wikifyPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment - -> a (InterpTable, Page) WikiPage + -> a Page WikiPage wikifyPage env - = proc (interpTable, page) + = proc page -> case pageType page of MIMEType "text" "x-rakka" _ -> do let source = decodeLazy UTF8 (pageContent page) - parser = wikiPage (tableToFunc interpTable) + parser = wikiPage tableToFunc case parse parser "" source of Left err @@ -70,20 +68,20 @@ wikifyPage env Right xs -> returnA -< xs where - tableToFunc :: InterpTable -> String -> Maybe CommandType - tableToFunc table name - = fmap commandType (M.lookup name table) + tableToFunc :: String -> Maybe CommandType + tableToFunc name + = fmap commandType (M.lookup name (envInterpTable env)) interpretCommandsA :: ArrowIO a => Environment - -> a (InterpTable, (PageName, (Maybe WikiPage, WikiPage))) WikiPage -interpretCommandsA = arrIO4 . interpretCommands + -> a (PageName, (Maybe WikiPage, WikiPage)) WikiPage +interpretCommandsA = arrIO3 . interpretCommands -interpretCommands :: Environment -> InterpTable -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage -interpretCommands _ _ _ _ [] = return [] -interpretCommands env table name mainTree targetTree +interpretCommands :: Environment -> PageName -> Maybe WikiPage -> WikiPage -> IO WikiPage +interpretCommands _ _ _ [] = return [] +interpretCommands env name mainTree targetTree = everywhereM' (mkM interpBlockCmd) targetTree >>= everywhereM' (mkM interpInlineCmd) @@ -103,7 +101,7 @@ interpretCommands env table name mainTree targetTree interpBlockCmd' :: BlockCommand -> IO BlockElement interpBlockCmd' cmd - = case M.lookup (bCmdName cmd) table of + = case M.lookup (bCmdName cmd) (envInterpTable env) of Nothing -> fail ("no such interpreter: " ++ bCmdName cmd) @@ -117,7 +115,7 @@ interpretCommands env table name mainTree targetTree interpInlineCmd' :: InlineCommand -> IO InlineElement interpInlineCmd' cmd - = case M.lookup (iCmdName cmd) table of + = case M.lookup (iCmdName cmd) (envInterpTable env) of Nothing -> fail ("no such interpreter: " ++ iCmdName cmd) diff --git a/Rakka/Wiki/Interpreter/Base.hs b/Rakka/Wiki/Interpreter/Base.hs index f2fd602..0070a83 100644 --- a/Rakka/Wiki/Interpreter/Base.hs +++ b/Rakka/Wiki/Interpreter/Base.hs @@ -1,24 +1,18 @@ module Rakka.Wiki.Interpreter.Base - ( baseInterpreters + ( interpreters ) where import Rakka.Wiki import Rakka.Wiki.Interpreter -import Rakka.Wiki.Interpreter.Base.Image -import Rakka.Wiki.Interpreter.Base.Outline -baseInterpreters :: [Interpreter] -baseInterpreters = [ lineBreakInterp - , spanInterp - , divInterp - , imageInterp - , imgFrameInterp - - , pageNameInterp - , outlineInterp - ] +interpreters :: [Interpreter] +interpreters = [ lineBreakInterp + , spanInterp + , divInterp + , pageNameInterp + ] lineBreakInterp :: Interpreter diff --git a/Rakka/Wiki/Interpreter/Base/Image.hs b/Rakka/Wiki/Interpreter/Image.hs similarity index 95% rename from Rakka/Wiki/Interpreter/Base/Image.hs rename to Rakka/Wiki/Interpreter/Image.hs index f73b205..7f64de0 100644 --- a/Rakka/Wiki/Interpreter/Base/Image.hs +++ b/Rakka/Wiki/Interpreter/Image.hs @@ -1,6 +1,5 @@ -module Rakka.Wiki.Interpreter.Base.Image - ( imageInterp - , imgFrameInterp +module Rakka.Wiki.Interpreter.Image + ( interpreters ) where @@ -13,6 +12,12 @@ import Rakka.Wiki.Interpreter import Rakka.Wiki +interpreters :: [Interpreter] +interpreters = [ imageInterp + , imgFrameInterp + ] + + -- -- ... -- diff --git a/Rakka/Wiki/Interpreter/Base/Outline.hs b/Rakka/Wiki/Interpreter/Outline.hs similarity index 95% rename from Rakka/Wiki/Interpreter/Base/Outline.hs rename to Rakka/Wiki/Interpreter/Outline.hs index d0e21ab..04554a6 100644 --- a/Rakka/Wiki/Interpreter/Base/Outline.hs +++ b/Rakka/Wiki/Interpreter/Outline.hs @@ -1,5 +1,5 @@ -module Rakka.Wiki.Interpreter.Base.Outline - ( outlineInterp +module Rakka.Wiki.Interpreter.Outline + ( interpreters ) where @@ -8,6 +8,10 @@ import Rakka.Wiki import Rakka.Wiki.Interpreter +interpreters :: [Interpreter] +interpreters = [ outlineInterp ] + + outlineInterp :: Interpreter outlineInterp = BlockCommandInterpreter { bciName = "outline" -- 2.40.0