X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FSystemConfig.hs;h=c151427263a45e65c966ba8deb66f969098f522f;hb=88747f2;hp=8a6be0283914eb5e78b35fee2ec88aec5244986e;hpb=3c5211253dc61c31196a47486c538b64c32d8c5e;p=Rakka.git diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index 8a6be02..c151427 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -6,142 +6,281 @@ module Rakka.SystemConfig , getSysConf , getSysConfA + + , setSysConf + , setSysConfA + + , SiteName(..) + , BaseURI(..) + , DefaultPage(..) + , StyleSheet(..) + , Languages(..) + , GlobalLock(..) + + , serializeStringPairs + , deserializeStringPairs ) where - import Control.Arrow.ArrowIO import Control.Concurrent.STM +import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as C8 -import Data.Encoding -import Data.Encoding.UTF8 +import qualified Data.ByteString.Lazy as L +import Data.Dynamic import Data.Map (Map) import qualified Data.Map as M import Data.Maybe import GHC.Conc (unsafeIOToSTM) -import Network +import Network.BSD import qualified Network.HTTP.Lucu.Config as LC -import Network.URI +import Network.HTTP.Lucu.Utils +import Network.HTTP.Lucu hiding (Config) +import Network.URI hiding (path) +import Rakka.Page import Rakka.Utils import Subversion.FileSystem import Subversion.FileSystem.Revision import Subversion.FileSystem.Root +import Subversion.FileSystem.Transaction import Subversion.Repository +import Subversion.Types import System.FilePath.Posix +import System.IO.Unsafe +import System.Log.Logger + + +logger :: String +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 - deriving (Eq, Show) +class (Typeable a, Show a, Eq a) => SysConfValue a where + confPath :: a -> FilePath + serialize :: a -> String + deserialize :: String -> Maybe a + defaultValue :: SystemConfig -> a mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig mkSystemConfig lc repos = do cache <- newTVarIO M.empty - return $ SystemConfig { + return SystemConfig { scLucuConf = lc , scRepository = 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 fs <- getRepositoryFS (scRepository sc) +getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a +getSysConf' sc + = do let path = fromConfPath $ confPath (undefined :: a) + + fs <- getRepositoryFS (scRepository sc) rev <- getYoungestRev fs value <- withRevision fs rev - $ do let path = fromConfPath (sysConfPath key) - exists <- isFile path + $ do exists <- isFile path case exists of True -> do str <- getFileContentsLBS path - return $ Just $ chomp $ decodeLazy UTF8 str + return $ Just $ chomp $ decode $ L.unpack 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 + case value of + Just str + -> 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 let val = defaultValue sc + debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val) + return val + + +setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode +setSysConf sc userID value + = liftIO $ + do let path = confPath (undefined :: a) + + current <- getSysConf sc + if current == value + then return NotModified + else do atomically $ do cache <- readTVar (scCache sc) + writeTVar (scCache sc) (M.delete path cache) + setSysConf' sc userID value + + +setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode +setSysConf' sc userID value + = do let path = fromConfPath $ confPath (undefined :: a) + str = L.pack $ encode $ serialize value ++ "\n" + repos = scRepository sc + fs <- getRepositoryFS repos + rev <- getYoungestRev fs + ret <- doReposTxn + repos + rev + userID + (Just "Automatic commit by Rakka for systemConfig update") + $ do exists <- isFile path + unless exists + $ createValueEntry path + applyTextLBS path Nothing str + case ret of + Left _ -> return Conflict + Right _ -> do debugM logger ("Set a config value at `" ++ path ++ "': " ++ show value) + return Created + where + createValueEntry :: FilePath -> Txn () + createValueEntry path + = do createParentDirectories path + makeFile path -fromConfPath :: FilePath -> FilePath -fromConfPath = combine "/config" + createParentDirectories :: FilePath -> Txn () + createParentDirectories path + = do let parentPath = takeDirectory path + kind <- checkPath parentPath + case kind of + NoNode -> do createParentDirectories parentPath + makeDirectory parentPath + FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath) + DirNode -> return () -{- paths -} -sysConfPath :: SysConfValue -> FilePath -sysConfPath (SiteName _) = "siteName" -sysConfPath (BaseURI _) = "baseURI" -sysConfPath (DefaultPage _) = "defaultPage" -sysConfPath (StyleSheet _) = "styleSheet" +getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c +getSysConfA = arrIO0 . getSysConf -{- marshalling -} -marshalSysConf :: SysConfValue -> String -marshalSysConf (SiteName name) = name -marshalSysConf (BaseURI uri ) = uriToString id uri "" -marshalSysConf (DefaultPage name) = name -marshalSysConf (StyleSheet name) = name +setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode +setSysConfA = (arrIO .) . setSysConf -{- 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 +fromConfPath :: FilePath -> FilePath +fromConfPath = ("/config" ) -{- getting default value -} -sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue +serializeStringPairs :: [(String, String)] -> String +serializeStringPairs = joinWith "\n" . map serializePair' + where + serializePair' :: (String, String) -> String + serializePair' (a, b) = a ++ " " ++ b -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 - = "http://" ++ host ++ +deserializeStringPairs :: String -> Maybe [(String, String)] +deserializeStringPairs = mapM deserializePair' . lines + where + 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, Eq) +instance SysConfValue SiteName where + confPath _ = "siteName" + serialize (SiteName name) = name + deserialize = Just . SiteName + defaultValue _ = SiteName "Rakka" + + +newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq) +instance SysConfValue BaseURI where + confPath _ = "baseURI" + serialize (BaseURI uri) = uriToString id uri "" + deserialize uri = fmap BaseURI + $ do parsed <- parseURI uri + when (uriPath parsed == "" ) (fail undefined) + when (last (uriPath parsed) /= '/') (fail undefined) + when (uriQuery parsed /= "" ) (fail undefined) + when (uriFragment parsed /= "" ) (fail undefined) + return parsed + defaultValue sc + = let conf = scLucuConf sc + host = C8.unpack $ LC.cnfServerHost conf + port = unsafePerformIO $ + do ent <- getServiceByName (LC.cnfServerPort conf) "tcp" + return (servicePort ent) + -- FIXME: There should be a way to change configurations + -- without web interface nor direct repository + -- modification. + 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" + in + BaseURI $ fromJust $ parseURI defaultURI + + +newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq) +instance SysConfValue DefaultPage where + confPath _ = "defaultPage" + serialize (DefaultPage name) = name + deserialize = Just . DefaultPage + defaultValue _ = DefaultPage "MainPage" + + +newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq) +instance SysConfValue StyleSheet where + confPath _ = "styleSheet" + serialize (StyleSheet name) = name + deserialize = Just . StyleSheet + defaultValue _ = StyleSheet "StyleSheet/Default" + + +newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq) +instance SysConfValue Languages where + confPath _ = "languages" + serialize (Languages langs) = serializeStringPairs (M.toList langs) + deserialize = fmap (Languages . M.fromList) . deserializeStringPairs + 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" ) + ] + + +newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq) +instance SysConfValue GlobalLock where + confPath _ = "globalLock" + serialize (GlobalLock isLocked) + | isLocked = "*" + | otherwise = "" + deserialize "*" = Just (GlobalLock True) + deserialize "" = Just (GlobalLock False) + deserialize _ = Nothing + defaultValue _ = GlobalLock False