/systemConfig now works

[Rakka.git] / Rakka / SystemConfig.hs

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
 
+    , 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)