Applied HLint

[Rakka.git] / Rakka / SystemConfig.hs

diff --git a/Rakka/SystemConfig.hs b/Rakka/SystemConfig.hs
index eb526fbc45939a6863d2fc139fd2a45876f8138c..aa1e5798d24ee387bac9582797fc97d492d79a17 100644 (file)
--- a/Rakka/SystemConfig.hs
+++ b/Rakka/SystemConfig.hs
@@ -7,11 +7,15 @@ module Rakka.SystemConfig
     , getSysConf
     , getSysConfA
 
     , getSysConf
     , getSysConfA
 

+    , setSysConf
+    , setSysConfA
+

     , SiteName(..)
     , BaseURI(..)
     , DefaultPage(..)
     , StyleSheet(..)
     , Languages(..)
     , SiteName(..)
     , BaseURI(..)
     , DefaultPage(..)
     , StyleSheet(..)
     , Languages(..)

+    , GlobalLock(..)

 
     , serializeStringPairs
     , deserializeStringPairs
 
     , serializeStringPairs
     , deserializeStringPairs


@@ -33,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
 


@@ -55,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


@@ -65,7 +72,7 @@ class (Typeable a, Show a) => SysConfValue a where
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos
     = do cache <- newTVarIO M.empty
 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
 mkSystemConfig lc repos
     = do cache <- newTVarIO M.empty

-         return $ SystemConfig {
+         return SystemConfig {

                       scLucuConf   = lc
                     , scRepository = repos
                     , scCache      = cache
                       scLucuConf   = lc
                     , scRepository = repos
                     , scCache      = cache


@@ -115,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" </>)
 


@@ -131,10 +192,10 @@ serializeStringPairs = joinWith "\n" . map serializePair'
 
 
 deserializeStringPairs :: String -> Maybe [(String, String)]
 
 
 deserializeStringPairs :: String -> Maybe [(String, String)]

-deserializeStringPairs = sequence . map deserializePair' . lines
+deserializeStringPairs = mapM deserializePair' . lines

     where
       deserializePair' :: String -> Maybe (String, String)
     where
       deserializePair' :: String -> Maybe (String, String)

-      deserializePair' s = case break (/= ' ') s of
+      deserializePair' s = case break (== ' ') s of

                              (a, ' ':b) -> Just (a, b)
                              _          -> Nothing
 
                              (a, ' ':b) -> Just (a, b)
                              _          -> Nothing
 


@@ -142,15 +203,15 @@ 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

-    deserialize name          = Just (SiteName name)
+    deserialize               = Just . SiteName

     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 ""


@@ -176,27 +237,27 @@ 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

-    deserialize name             = Just (DefaultPage name)
+    deserialize                  = Just . DefaultPage

     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

-    deserialize name            = Just (StyleSheet name)
+    deserialize                 = Just . StyleSheet

     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)

-    deserialize langs           = fmap (Languages . M.fromList) (deserializeStringPairs langs)
+    deserialize                 = fmap (Languages . M.fromList) . deserializeStringPairs

     defaultValue _         
         = Languages $ M.fromList [ ("en", "English"  )
                                  , ("es", "Español"  )
     defaultValue _         
         = Languages $ M.fromList [ ("en", "English"  )
                                  , ("es", "Español"  )


@@ -209,3 +270,15 @@ instance SysConfValue Languages where
                                  , ("pt", "Português")
                                  , ("sv", "Svenska"  )
                                  ]
                                  , ("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