From 52bafd675e7ac9d3fc9d3bf2d72e66a22efb6db9 Mon Sep 17 00:00:00 2001 From: pho Date: Thu, 31 Jul 2008 15:02:07 +0900 Subject: [PATCH] /systemConfig now works darcs-hash:20080731060207-62b54-4e434337eab109db5519ae2064d907579faf68a2.gz --- Rakka/Resource/SystemConfig.hs | 43 +++++++++++++++----- Rakka/SystemConfig.hs | 74 ++++++++++++++++++++++++++++++---- js/systemConfig.js | 63 +++++++++++++++++++++++++++++ schemas/rakka-config-1.0.rng | 24 +++++++++++ 4 files changed, 188 insertions(+), 16 deletions(-) create mode 100644 schemas/rakka-config-1.0.rng diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs index 110ecc1..beae831 100644 --- a/Rakka/Resource/SystemConfig.hs +++ b/Rakka/Resource/SystemConfig.hs @@ -3,17 +3,13 @@ module Rakka.Resource.SystemConfig ) where -import Control.Arrow -import Control.Arrow.ArrowIO import Control.Monad.Trans +import Data.Maybe import Network.HTTP.Lucu import Rakka.Environment +import Rakka.Resource import Rakka.SystemConfig -import Text.XML.HXT.Arrow.WriteDocument -import Text.XML.HXT.Arrow.XmlArrow -import Text.XML.HXT.Arrow.XmlIOStateArrow -import Text.XML.HXT.DOM.TypeDefs -import Text.XML.HXT.DOM.XmlKeywords +import Text.XML.HXT.Arrow resSystemConfig :: Environment -> ResourceDef @@ -89,5 +85,34 @@ mkSystemConfigTree env handlePut :: Environment -> Resource () -handlePut _ - = fail "NOT IMPL" +handlePut env + = do let sc = envSysConf env + + userID <- getUserID env + case userID of + Nothing + -> setStatus Forbidden + Just uid + -> runXmlA env "rakka-config-1.0.rng" $ proc tree + -> do listA ( getXPathTreesInDoc "/systemConfig/value" + >>> + choiceA [ branch (undefined :: SiteName ) + , branch (undefined :: BaseURI ) + , branch (undefined :: DefaultPage) + , branch (undefined :: StyleSheet ) + , branch (undefined :: Languages ) + , branch (undefined :: GlobalLock ) + ] + ) -< tree + returnA -< setStatus Ok + where + branch :: forall a c. (ArrowXml a, ArrowIO a, SysConfValue c) => + c + -> IfThen (a XmlTree XmlTree) (a XmlTree StatusCode) + branch c + = hasAttrValue "path" (== confPath c) + :-> + ( getChildren + >>> getText + >>> arr (fromJust . (deserialize :: String -> Maybe c)) + >>> setSysConfA sc uid ) \ No newline at end of file diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs index ecf608d..91d9ca4 100644 --- a/Rakka/SystemConfig.hs +++ b/Rakka/SystemConfig.hs @@ -7,6 +7,9 @@ module Rakka.SystemConfig , getSysConf , getSysConfA + , setSysConf + , setSysConfA + , SiteName(..) , BaseURI(..) , DefaultPage(..) @@ -34,13 +37,16 @@ import GHC.Conc (unsafeIOToSTM) import Network import qualified Network.HTTP.Lucu.Config as LC 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.Log.Logger @@ -56,7 +62,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 @@ -116,10 +122,64 @@ 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 = ("/config" ) @@ -143,7 +203,7 @@ 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 @@ -151,7 +211,7 @@ instance SysConfValue SiteName where 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 "" @@ -177,7 +237,7 @@ 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 @@ -185,7 +245,7 @@ instance SysConfValue DefaultPage where 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 @@ -193,7 +253,7 @@ instance SysConfValue StyleSheet where 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) @@ -212,7 +272,7 @@ instance SysConfValue Languages where ] -newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable) +newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq) instance SysConfValue GlobalLock where confPath _ = "globalLock" serialize (GlobalLock isLocked) diff --git a/js/systemConfig.js b/js/systemConfig.js index 7cc4c91..5fc8303 100644 --- a/js/systemConfig.js +++ b/js/systemConfig.js @@ -71,6 +71,10 @@ uri.anchor == ""); }; + var isValidMap = function (src) { + return src.match(/^\S+\s+\S+(?:\n\S+\s+\S+)*\n?$/) != null; + }; + Rakka.getSystemConfig = function () { if (cachedConf != null) { return cachedConf; @@ -131,9 +135,64 @@ var btnSave = $.INPUT({type: "button", value: "Save"}); + $(btnSave).click(function () { + var NS = "http://cielonegro.org/schema/Rakka/Config/1.0"; + var doc = document.implementation.createDocument(NS, "systemConfig", null); + var sc = doc.documentElement; + + var mkValue = function (path, value) { + var elem = doc.createElementNS(NS, "value"); + elem.setAttribute("path", path); + elem.appendChild(doc.createTextNode(value)); + return elem; + }; + + sc.appendChild(mkValue("siteName" , fldSiteName.value)); + sc.appendChild(mkValue("baseURI" , fldBaseURI.value)); + sc.appendChild(mkValue("defaultPage", fldDefaultPage.value)); + sc.appendChild(mkValue("styleSheet" , fldStyleSheet.value)); + sc.appendChild(mkValue("languages" , fldLanguages.value)); + sc.appendChild(mkValue("globalLock" , encoder_of["globalLock"](chkGlobalLock.checked))); + + Rakka.displayWaitingMessage("Submitting... please wait."); + + var url = Rakka.baseURI + "systemConfig"; + $.ajax({ type : "PUT", + url : url, + contentType: "text/xml", + data : doc, + processData: false, + beforeSend : function (req) { + Rakka.setAuthorization(req); + }, + success : function () { + cachedConf = null; + Rakka.hideWaitingMessage(); + Rakka.restoreScreen(); + }, + error : function (req) { + Rakka.hideWaitingMessage(); + + var $area = Rakka.switchScreen(); + $area.text("Error: " + req.status + " " + req.statusText); + } + }); + }); + var btnCancel = $.INPUT({type: "button", value: "Cancel"}); + $(btnCancel).click(function () { + if (isDirty) { + if (window.confirm("Do you really want to discard changes?")) { + Rakka.restoreScreen(); + } + } + else { + Rakka.restoreScreen(); + } + }); + var configPanel = $.TABLE({className: "pageEditor"}, $.TBODY({}, @@ -185,6 +244,10 @@ return false; } + if (!isValidMap(fldLanguages.value)) { + return false; + } + return true; })(); diff --git a/schemas/rakka-config-1.0.rng b/schemas/rakka-config-1.0.rng new file mode 100644 index 0000000..f6a9287 --- /dev/null +++ b/schemas/rakka-config-1.0.rng @@ -0,0 +1,24 @@ + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file -- 2.40.0