)
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
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
, getSysConf
, getSysConfA
+ , setSysConf
+ , setSysConfA
+
, SiteName(..)
, BaseURI(..)
, DefaultPage(..)
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
}
-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
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" </>)
{- 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
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 ""
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
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
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)
]
-newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable)
+newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
instance SysConfValue GlobalLock where
confPath _ = "globalLock"
serialize (GlobalLock isLocked)
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;
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({},
return false;
}
+ if (!isValidMap(fldLanguages.value)) {
+ return false;
+ }
+
return true;
})();
projects / Rakka.git / commitdiff