X-Git-Url: http://git.cielonegro.org/gitweb.cgi?p=Rakka.git;a=blobdiff_plain;f=Rakka%2FSystemConfig.hs;h=91d9ca4178ed4f6f7b0a597d41662d0bc9e1e6ec;hp=ecf608df873232944880dbc0b518d6644cbebf46;hb=52bafd675e7ac9d3fc9d3bf2d72e66a22efb6db9;hpb=c80a6d8660e2ed0168329b5a959c84923da177c7

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)