From: pho Date: Wed, 24 Oct 2007 15:05:41 +0000 (+0900) Subject: The experiment has succeeded X-Git-Url: https://git.cielonegro.org/gitweb.cgi?a=commitdiff_plain;h=605a843e408a7ef475fbb5a26f408271ab315cc8;p=Rakka.git The experiment has succeeded darcs-hash:20071024150541-62b54-68449e805e35c893cbf4daf7f65ecb5de8597914.gz --- diff --git a/Rakka.cabal b/Rakka.cabal index c250b7e..4fdf509 100644 --- a/Rakka.cabal +++ b/Rakka.cabal @@ -60,7 +60,7 @@ Other-Modules: Rakka.Wiki.Formatter Rakka.Wiki.Parser Extensions: - Arrows + Arrows, ExistentialQuantification GHC-Options: -fwarn-unused-imports -fglasgow-exts diff --git a/Rakka/Resource/Index.hs b/Rakka/Resource/Index.hs index 9db16eb..db8552d 100644 --- a/Rakka/Resource/Index.hs +++ b/Rakka/Resource/Index.hs @@ -15,8 +15,8 @@ resIndex env resUsesNativeThread = False , resIsGreedy = False , resGet - = Just $ do BaseURI baseURI <- getSysConf (envSysConf env) (BaseURI undefined) - DefaultPage name <- getSysConf (envSysConf env) (DefaultPage undefined) + = Just $ do BaseURI baseURI <- getSysConf (envSysConf env) + DefaultPage name <- getSysConf (envSysConf env) redirect Found (mkPageURI baseURI name) , resHead = Nothing , resPost = Nothing diff --git a/Rakka/Resource/Object.hs b/Rakka/Resource/Object.hs index e29c2a2..6f9bd1a 100644 --- a/Rakka/Resource/Object.hs +++ b/Rakka/Resource/Object.hs @@ -48,7 +48,7 @@ handleGet env name -} handleRedirect :: Environment -> Page -> Resource () handleRedirect env redir - = do BaseURI baseURI <- getSysConf (envSysConf env) (BaseURI undefined) + = do BaseURI baseURI <- getSysConf (envSysConf env) redirect Found (mkObjectURI baseURI $ redirName redir) diff --git a/Rakka/Resource/Render.hs b/Rakka/Resource/Render.hs index 51d44fe..599086b 100644 --- a/Rakka/Resource/Render.hs +++ b/Rakka/Resource/Render.hs @@ -68,7 +68,7 @@ handleGet env name handleRedirect :: (ArrowXml a, ArrowIO a) => Environment -> a Page (Resource ()) handleRedirect env = proc redir - -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () + -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< () returnA -< redirect Found (mkPageURI baseURI $ redirName redir) -- FIXME @@ -113,9 +113,9 @@ handleRedirect env handleGetEntity :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a Page (Resource ()) handleGetEntity env = proc page - -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< () - BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< () - StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< () + -> do SiteName siteName <- getSysConfA sysConf -< () + BaseURI baseURI <- getSysConfA sysConf -< () + StyleSheet cssName <- getSysConfA sysConf -< () Just pageTitle <- getPageA (envStorage env) -< "PageTitle" Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left" @@ -291,9 +291,9 @@ entityToXHTML handlePageNotFound :: (ArrowXml a, ArrowChoice a, ArrowIO a) => Environment -> a PageName (Resource ()) handlePageNotFound env = proc name - -> do SiteName siteName <- getSysConfA sysConf (SiteName undefined) -< () - BaseURI baseURI <- getSysConfA sysConf (BaseURI undefined) -< () - StyleSheet cssName <- getSysConfA sysConf (StyleSheet undefined) -< () + -> do SiteName siteName <- getSysConfA sysConf -< () + BaseURI baseURI <- getSysConfA sysConf -< () + StyleSheet cssName <- getSysConfA sysConf -< () Just pageTitle <- getPageA (envStorage env) -< "PageTitle" Just leftSideBar <- getPageA (envStorage env) -< "SideBar/Left" diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index 966ecf1..9e8be67 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -6,6 +6,12 @@ module Rakka.SystemConfig , getSysConf , getSysConfA + + , SiteName(..) + , BaseURI(..) + , DefaultPage(..) + , StyleSheet(..) + , Languages(..) ) where @@ -13,6 +19,7 @@ import Control.Arrow.ArrowIO import Control.Concurrent.STM import Control.Monad.Trans import qualified Data.ByteString.Char8 as C8 +import Data.Dynamic import Data.Encoding import Data.Encoding.UTF8 import Data.Map (Map) @@ -38,17 +45,15 @@ logger = "Rakka.SystemConfig" data SystemConfig = SystemConfig { scLucuConf :: !LC.Config , scRepository :: !Repository - , scCache :: !(TVar (Map FilePath SysConfValue)) + , scCache :: !(TVar (Map FilePath Dynamic)) } -data SysConfValue - = SiteName String - | BaseURI URI - | DefaultPage String - | StyleSheet String - | Languages (Map LanguageTag LanguageName) - deriving (Eq, Show) +class (Typeable a, Show a) => SysConfValue a where + confPath :: a -> FilePath + serialize :: a -> String + deserialize :: String -> Maybe a + defaultValue :: SystemConfig -> a mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig @@ -60,25 +65,24 @@ mkSystemConfig lc repos , scCache = cache } - -getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue -getSysConf sc key +getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a +getSysConf sc = liftIO $ atomically $ - do let path = sysConfPath key + do let path = confPath (undefined :: a) 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) + Just val -> return $ fromJust $ fromDynamic val + Nothing -> do val <- unsafeIOToSTM (getSysConf' sc) + writeTVar (scCache sc) (M.insert path (toDyn val) cache) return val -getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue -getSysConf' sc key - = do let path = fromConfPath (sysConfPath key) +getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a +getSysConf' sc + = do let path = fromConfPath $ confPath (undefined :: a) fs <- getRepositoryFS (scRepository sc) rev <- getYoungestRev fs @@ -93,104 +97,103 @@ getSysConf' sc key case value of Just str - -> do let val = unmarshalSysConf key str - debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val) - return val + -> case deserialize str of + Just val + -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val) + return val + Nothing + -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str) Nothing - -> do val <- sysConfDefault sc key + -> do let val = defaultValue sc debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val) return val -getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue -getSysConfA = (arrIO0 .) . getSysConf +getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c +getSysConfA = arrIO0 . getSysConf fromConfPath :: FilePath -> FilePath fromConfPath = combine "/config" -marshalStringPairs :: [(String, String)] -> String -marshalStringPairs = joinWith "\n" . map marshalPair' +serializeStringPairs :: [(String, String)] -> String +serializeStringPairs = joinWith "\n" . map serializePair' where - marshalPair' :: (String, String) -> String - marshalPair' (a, b) = a ++ " " ++ b + serializePair' :: (String, String) -> String + serializePair' (a, b) = a ++ " " ++ b -unmarshalStringPairs :: String -> [(String, String)] -unmarshalStringPairs = catMaybes . map unmarshalPair' . lines +deserializeStringPairs :: String -> Maybe [(String, String)] +deserializeStringPairs = sequence . map deserializePair' . 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 (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 (Languages _) langs = Languages $ M.fromList $ unmarshalStringPairs langs - - -{- getting default value -} -sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue - -sysConfDefault _ (SiteName _) - = return $ SiteName "Rakka" - -sysConfDefault sc (BaseURI _) - = do let conf = scLucuConf sc - host = C8.unpack $ LC.cnfServerHost conf - port = case LC.cnfServerPort conf of - PortNumber num -> fromIntegral num - - defaultURI + deserializePair' :: String -> Maybe (String, String) + deserializePair' s = case break (/= ' ') s of + (a, ' ':b) -> Just (a, b) + _ -> Nothing + + + +{- config values -} + +newtype SiteName = SiteName String deriving (Show, Typeable) +instance SysConfValue SiteName where + confPath _ = "siteName" + serialize (SiteName name) = name + deserialize name = Just (SiteName name) + defaultValue _ = SiteName "Rakka" + + +newtype BaseURI = BaseURI URI deriving (Show, Typeable) +instance SysConfValue BaseURI where + confPath _ = "baseURI" + serialize (BaseURI uri) = uriToString id uri "" + deserialize uri = fmap BaseURI (parseURI uri) + defaultValue sc + = let conf = scLucuConf sc + host = C8.unpack $ LC.cnfServerHost conf + port = case LC.cnfServerPort conf of + PortNumber num -> fromIntegral num + + defaultURI = "http://" ++ host ++ (if port == 80 then "" else ':' : show port) ++ "/" - - return $ BaseURI $ fromJust $ parseURI defaultURI - -sysConfDefault _ (DefaultPage _) - = return $ DefaultPage "MainPage" - -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" ) - ] - + in + BaseURI $ fromJust $ parseURI defaultURI + + +newtype DefaultPage = DefaultPage String deriving (Show, Typeable) +instance SysConfValue DefaultPage where + confPath _ = "defaultPage" + serialize (DefaultPage name) = name + deserialize name = Just (DefaultPage name) + defaultValue _ = DefaultPage "MainPage" + + +newtype StyleSheet = StyleSheet String deriving (Show, Typeable) +instance SysConfValue StyleSheet where + confPath _ = "styleSheet" + serialize (StyleSheet name) = name + deserialize name = Just (StyleSheet name) + defaultValue _ = StyleSheet "StyleSheet/Default" + + +newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable) +instance SysConfValue Languages where + confPath _ = "languages" + serialize (Languages langs) = serializeStringPairs (M.toList langs) + deserialize langs = fmap (Languages . M.fromList) (deserializeStringPairs langs) + defaultValue _ + = 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 ba9151c..b6969cc 100644 --- a/Rakka/Wiki/Engine.hs +++ b/Rakka/Wiki/Engine.hs @@ -28,7 +28,7 @@ formatPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => -> a Page XmlTree formatPage env = proc page - -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () + -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< () wiki <- wikifyPage env -< page xs <- interpretCommandsA env -< (pageName page, (Just (page, wiki), wiki)) formatWikiBlocks -< (baseURI, xs) @@ -39,7 +39,7 @@ formatSubPage :: (ArrowXml a, ArrowChoice a, ArrowIO a) => -> a (PageName, (Maybe Page, Page)) XmlTree formatSubPage env = proc (mainPageName, (mainPage, subPage)) - -> do BaseURI baseURI <- getSysConfA (envSysConf env) (BaseURI undefined) -< () + -> do BaseURI baseURI <- getSysConfA (envSysConf env) -< () mainWiki <- case mainPage of Just page -> do wiki <- wikifyPage env -< page diff --git a/Rakka/Wiki/Interpreter/Image.hs b/Rakka/Wiki/Interpreter/Image.hs index 7f64de0..f01c2de 100644 --- a/Rakka/Wiki/Interpreter/Image.hs +++ b/Rakka/Wiki/Interpreter/Image.hs @@ -27,7 +27,7 @@ imageInterp iciName = "img" , iciInterpret = \ ctx (InlineCommand _ attrs inside) -> - do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined) + do BaseURI baseURI <- getSysConf (ctxSysConf ctx) let pageName = lookup "src" attrs when (pageName == Nothing) @@ -67,7 +67,7 @@ imgFrameInterp bciName = "imgframe" , bciInterpret = \ ctx (BlockCommand _ attrs inside) -> - do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined) + do BaseURI baseURI <- getSysConf (ctxSysConf ctx) let pageName = lookup "src" attrs when (pageName == Nothing) diff --git a/Rakka/Wiki/Interpreter/Trackback.hs b/Rakka/Wiki/Interpreter/Trackback.hs index 984c4aa..44cf13c 100644 --- a/Rakka/Wiki/Interpreter/Trackback.hs +++ b/Rakka/Wiki/Interpreter/Trackback.hs @@ -20,7 +20,7 @@ trackbackURLInterp = InlineCommandInterpreter { iciName = "trackbackURL" , iciInterpret - = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) (BaseURI undefined) + = \ ctx _ -> do BaseURI baseURI <- getSysConf (ctxSysConf ctx) let uri = mkAuxiliaryURI baseURI ["trackback"] (ctxPageName ctx) return $ ExternalLink uri (Just "Trackback URL") }