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