, getSysConf
, getSysConfA
+ , setSysConf
+ , setSysConfA
+
, SiteName(..)
, BaseURI(..)
, DefaultPage(..)
, StyleSheet(..)
, Languages(..)
+ , GlobalLock(..)
+
+ , serializeStringPairs
+ , deserializeStringPairs
)
where
+import Codec.Binary.UTF8.String
import Control.Arrow.ArrowIO
import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as C8
+import qualified Data.ByteString.Lazy as L
import Data.Dynamic
-import Data.Encoding
-import Data.Encoding.UTF8
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Network
import qualified Network.HTTP.Lucu.Config as LC
import Network.HTTP.Lucu.Utils
-import Network.URI
+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
+
+logger :: String
logger = "Rakka.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
case exists of
True
-> do str <- getFileContentsLBS path
- return $ Just $ chomp $ decodeLazy UTF8 str
+ return $ Just $ chomp $ decode $ L.unpack str
False
-> return Nothing
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" </>)
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
{- 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
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 ""
= let conf = scLucuConf sc
host = C8.unpack $ LC.cnfServerHost conf
port = case LC.cnfServerPort conf of
- PortNumber num -> fromIntegral num
-
+ PortNumber num -> fromIntegral num :: Int
+ _ -> undefined
defaultURI
= "http://" ++ host ++ -- FIXME: consider IPv6 address
(if port == 80
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
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
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)
, ("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
projects / Rakka.git / blobdiff