/systemConfig now works

darcs-hash:20080731060207-62b54-4e434337eab109db5519ae2064d907579faf68a2.gz

diff --git a/Rakka/Resource/SystemConfig.hs b/Rakka/Resource/SystemConfig.hs
index 110ecc195143ceb3748d9831272c3252601830f9..beae8316994a2389baebba8d5236c9569a0fe589 100644 (file)
--- a/Rakka/Resource/SystemConfig.hs
+++ b/Rakka/Resource/SystemConfig.hs
@@ -3,17 +3,13 @@ module Rakka.Resource.SystemConfig
     )
     where
 
     )
     where
 

-import           Control.Arrow
-import           Control.Arrow.ArrowIO

 import           Control.Monad.Trans
 import           Control.Monad.Trans

+import           Data.Maybe

 import           Network.HTTP.Lucu
 import           Rakka.Environment
 import           Network.HTTP.Lucu
 import           Rakka.Environment

+import           Rakka.Resource

 import           Rakka.SystemConfig
 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
 
 
 resSystemConfig :: Environment -> ResourceDef


@@ -89,5 +85,34 @@ mkSystemConfigTree env
 
 
 handlePut :: Environment -> Resource ()
 
 
 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 ecf608df873232944880dbc0b518d6644cbebf46..91d9ca4178ed4f6f7b0a597d41662d0bc9e1e6ec 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -7,6 +7,9 @@ module Rakka.SystemConfig
     , getSysConf
     , getSysConfA
 
     , getSysConf
     , getSysConfA
 

+    , setSysConf
+    , setSysConfA
+

     , SiteName(..)
     , BaseURI(..)
     , DefaultPage(..)
     , 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
 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           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.Repository

+import           Subversion.Types

 import           System.FilePath.Posix
 import           System.Log.Logger
 
 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
     confPath     :: a -> FilePath
     serialize    :: a -> String
     deserialize  :: String -> Maybe a


@@ -116,10 +122,64 @@ getSysConf' sc
                      return 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
+
+    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
 
 
 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" </>)
 
 fromConfPath :: FilePath -> FilePath
 fromConfPath = ("/config" </>)
 


@@ -143,7 +203,7 @@ deserializeStringPairs = sequence . map deserializePair' . lines
 
 {- config values -}
 
 
 {- 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
 instance SysConfValue SiteName where
     confPath _                = "siteName"
     serialize (SiteName name) = name


@@ -151,7 +211,7 @@ instance SysConfValue SiteName where
     defaultValue _            = SiteName "Rakka"
 
 
     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 ""
 instance SysConfValue BaseURI where
     confPath _              = "baseURI"
     serialize (BaseURI uri) = uriToString id uri ""


@@ -177,7 +237,7 @@ instance SysConfValue BaseURI where
             BaseURI $ fromJust $ parseURI defaultURI
 
 
             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
 instance SysConfValue DefaultPage where
     confPath _                   = "defaultPage"
     serialize (DefaultPage name) = name


@@ -185,7 +245,7 @@ instance SysConfValue DefaultPage where
     defaultValue _               = DefaultPage "MainPage"
 
 
     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
 instance SysConfValue StyleSheet where
     confPath _                  = "styleSheet"
     serialize (StyleSheet name) = name


@@ -193,7 +253,7 @@ instance SysConfValue StyleSheet where
     defaultValue _              = StyleSheet "StyleSheet/Default"
 
 
     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)
 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)
 instance SysConfValue GlobalLock where
     confPath _      = "globalLock"
     serialize (GlobalLock isLocked)

diff --git a/js/systemConfig.js b/js/systemConfig.js
index 7cc4c9194f8324e0378cda5c8d492eb6d30ea395..5fc8303611cbb2df46c144bcbd9333228327759f 100644 (file)
--- a/js/systemConfig.js
+++ b/js/systemConfig.js
@@ -71,6 +71,10 @@
                  uri.anchor == "");
      };
 
                  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;
     Rakka.getSystemConfig = function () {
         if (cachedConf != null) {
             return cachedConf;


@@ -131,9 +135,64 @@
          var btnSave
              = $.INPUT({type: "button", value: "Save"});
 
          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"});
 
          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({},
          var configPanel
              = $.TABLE({className: "pageEditor"},
                        $.TBODY({},


@@ -185,6 +244,10 @@
                                     return false;
                                 }
 
                                     return false;
                                 }
 

+                               if (!isValidMap(fldLanguages.value)) {
+                                   return false;
+                               }
+

                                 return true;
                             })();
 
                                 return true;
                             })();
 

diff --git a/schemas/rakka-config-1.0.rng b/schemas/rakka-config-1.0.rng
new file mode 100644 (file)
index 0000000..f6a9287
--- /dev/null
+++ b/schemas/rakka-config-1.0.rng
@@ -0,0 +1,24 @@
+<?xml version="1.0" encoding="utf-8"?>
+<grammar ns="http://cielonegro.org/schema/Rakka/Config/1.0"
+         datatypeLibrary="http://www.w3.org/2001/XMLSchema-datatypes"
+         xmlns="http://relaxng.org/ns/structure/1.0">
+
+  <start>
+    <element name="systemConfig">
+      
+      <zeroOrMore>
+       <element name="value">
+
+         <attribute name="path">
+           <text />
+         </attribute>
+         
+         <text />
+
+       </element>
+      </zeroOrMore>
+
+    </element>
+  </start>
+
+</grammar>
\ No newline at end of file