/systemConfig now works

[Rakka.git] / Rakka / SystemConfig.hs

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index 10b39b354fa5ba1ae986befc19f2f22ca02bfa3d..91d9ca4178ed4f6f7b0a597d41662d0bc9e1e6ec 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -7,11 +7,18 @@ module Rakka.SystemConfig
     , getSysConf
     , getSysConfA
 
+    , setSysConf
+    , setSysConfA
+
     , SiteName(..)
     , BaseURI(..)
     , DefaultPage(..)
     , StyleSheet(..)
     , Languages(..)
+    , GlobalLock(..)
+
+    , serializeStringPairs
+    , deserializeStringPairs
     )
     where
 
@@ -30,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
 
@@ -52,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
@@ -112,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" </>)
 
@@ -131,7 +195,7 @@ deserializeStringPairs :: String -> Maybe [(String, String)]
 deserializeStringPairs = sequence . map deserializePair' . lines
     where
       deserializePair' :: String -> Maybe (String, String)
-      deserializePair' s = case break (/= ' ') s of
+      deserializePair' s = case break (== ' ') s of
                              (a, ' ':b) -> Just (a, b)
                              _          -> Nothing
 
@@ -139,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
@@ -147,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 ""
@@ -173,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
@@ -181,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
@@ -189,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)
@@ -206,3 +270,15 @@ instance SysConfValue Languages where
                                  , ("pt", "Português")
                                  , ("sv", "Svenska"  )
                                  ]
+
+
+newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
+instance SysConfValue GlobalLock where
+    confPath _      = "globalLock"
+    serialize (GlobalLock isLocked)
+        | isLocked  = "*"
+        | otherwise = ""
+    deserialize "*" = Just (GlobalLock True)
+    deserialize ""  = Just (GlobalLock False)
+    deserialize _   = Nothing
+    defaultValue _  = GlobalLock False