X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Rakka%2FSystemConfig.hs;h=4978b46d131bc853271438120e860b5ac17f5fdc;hb=223d4df57fa1371945075d4d2714e5f36c1fc5dd;hp=de33f911119eb07aac46ab6dc04cd52cb163bb0a;hpb=8d43862784caf5fc187c948c89e7ef58551f5642;p=Rakka.git diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index de33f91..4978b46 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -7,38 +7,52 @@ module Rakka.SystemConfig , getSysConf , getSysConfA + , setSysConf + , setSysConfA + , SiteName(..) , BaseURI(..) , DefaultPage(..) , StyleSheet(..) , Languages(..) + , GlobalLock(..) + + , serializeStringPairs + , deserializeStringPairs ) where +import Codec.Binary.UTF8.String import Control.Arrow.ArrowIO import Control.Concurrent.STM +import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as L import Data.Dynamic -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 Network.BSD import qualified Network.HTTP.Lucu.Config as LC import Network.HTTP.Lucu.Utils -import Network.URI +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" @@ -49,7 +63,7 @@ data SystemConfig = SystemConfig { } -class (Typeable a, Show a) => SysConfValue a where +class (Typeable a, Show a, Eq a) => SysConfValue a where confPath :: a -> FilePath serialize :: a -> String deserialize :: String -> Maybe a @@ -59,7 +73,7 @@ class (Typeable a, Show a) => SysConfValue a where mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig mkSystemConfig lc repos = do cache <- newTVarIO M.empty - return $ SystemConfig { + return SystemConfig { scLucuConf = lc , scRepository = repos , scCache = cache @@ -91,7 +105,7 @@ getSysConf' sc case exists of True -> do str <- getFileContentsLBS path - return $ Just $ chomp $ decodeLazy UTF8 str + return $ Just $ chomp $ decode $ L.unpack str False -> return Nothing @@ -109,12 +123,66 @@ getSysConf' sc 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 + + 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 () + + getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c getSysConfA = arrIO0 . getSysConf +setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode +setSysConfA = (arrIO .) . setSysConf + + fromConfPath :: FilePath -> FilePath -fromConfPath = combine "/config" +fromConfPath = ("/config" ) serializeStringPairs :: [(String, String)] -> String @@ -125,10 +193,10 @@ serializeStringPairs = joinWith "\n" . map serializePair' deserializeStringPairs :: String -> Maybe [(String, String)] -deserializeStringPairs = sequence . map deserializePair' . lines +deserializeStringPairs = mapM deserializePair' . lines where deserializePair' :: String -> Maybe (String, String) - deserializePair' s = case break (/= ' ') s of + deserializePair' s = case break (== ' ') s of (a, ' ':b) -> Just (a, b) _ -> Nothing @@ -136,27 +204,36 @@ deserializeStringPairs = sequence . map deserializePair' . lines {- config values -} -newtype SiteName = SiteName String deriving (Show, Typeable) +newtype SiteName = SiteName String deriving (Show, Typeable, Eq) instance SysConfValue SiteName where confPath _ = "siteName" serialize (SiteName name) = name - deserialize name = Just (SiteName name) + deserialize = Just . SiteName defaultValue _ = SiteName "Rakka" -newtype BaseURI = BaseURI URI deriving (Show, Typeable) +newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq) instance SysConfValue BaseURI where confPath _ = "baseURI" serialize (BaseURI uri) = uriToString id uri "" - deserialize uri = fmap BaseURI (parseURI 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 = case LC.cnfServerPort conf of - PortNumber num -> fromIntegral num - + 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 ++ -- FIXME: consider IPv6 address + = "http://" ++ host ++ (if port == 80 then "" else ':' : show port) ++ "/" @@ -164,27 +241,27 @@ instance SysConfValue BaseURI where BaseURI $ fromJust $ parseURI defaultURI -newtype DefaultPage = DefaultPage String deriving (Show, Typeable) +newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq) instance SysConfValue DefaultPage where confPath _ = "defaultPage" serialize (DefaultPage name) = name - deserialize name = Just (DefaultPage name) + deserialize = Just . DefaultPage defaultValue _ = DefaultPage "MainPage" -newtype StyleSheet = StyleSheet String deriving (Show, Typeable) +newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq) instance SysConfValue StyleSheet where confPath _ = "styleSheet" serialize (StyleSheet name) = name - deserialize name = Just (StyleSheet name) + deserialize = Just . StyleSheet defaultValue _ = StyleSheet "StyleSheet/Default" -newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable) +newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq) instance SysConfValue Languages where confPath _ = "languages" serialize (Languages langs) = serializeStringPairs (M.toList langs) - deserialize langs = fmap (Languages . M.fromList) (deserializeStringPairs langs) + deserialize = fmap (Languages . M.fromList) . deserializeStringPairs defaultValue _ = Languages $ M.fromList [ ("en", "English" ) , ("es", "Español" ) @@ -197,3 +274,15 @@ instance SysConfValue Languages where , ("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