module Rakka.SystemConfig ( SystemConfig , SysConfValue(..) , mkSystemConfig -- private , 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.Map (Map) import qualified Data.Map as M import Data.Maybe import GHC.Conc (unsafeIOToSTM) import Network.BSD 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.IO.Unsafe import System.Log.Logger logger :: String logger = "Rakka.SystemConfig" data SystemConfig = SystemConfig { scLucuConf :: !LC.Config , scRepository :: !Repository , scCache :: !(TVar (Map FilePath Dynamic)) } class (Typeable a, Show a, Eq a) => SysConfValue a where confPath :: a -> FilePath serialize :: a -> String deserialize :: String -> Maybe a defaultValue :: SystemConfig -> a mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig mkSystemConfig lc repos = do cache <- newTVarIO M.empty return SystemConfig { scLucuConf = lc , scRepository = repos , scCache = cache } getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a getSysConf sc = liftIO $ atomically $ do let path = confPath (undefined :: a) cache <- readTVar (scCache sc) case M.lookup path cache of Just val -> return $ fromJust $ fromDynamic val Nothing -> do val <- unsafeIOToSTM (getSysConf' sc) writeTVar (scCache sc) (M.insert path (toDyn val) cache) return val getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a getSysConf' sc = do let path = fromConfPath $ confPath (undefined :: a) fs <- getRepositoryFS (scRepository sc) rev <- getYoungestRev fs value <- withRevision fs rev $ do exists <- isFile path case exists of True -> do str <- getFileContentsLBS path return $ Just $ chomp $ decode $ L.unpack str False -> return Nothing case value of Just str -> case deserialize str of Just val -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val) return val Nothing -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str) Nothing -> do let val = defaultValue sc debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show 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 setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode setSysConfA = (arrIO .) . setSysConf fromConfPath :: FilePath -> FilePath fromConfPath = ("/config" ) serializeStringPairs :: [(String, String)] -> String serializeStringPairs = joinWith "\n" . map serializePair' where serializePair' :: (String, String) -> String serializePair' (a, b) = a ++ " " ++ b deserializeStringPairs :: String -> Maybe [(String, String)] deserializeStringPairs = mapM deserializePair' . lines where deserializePair' :: String -> Maybe (String, String) deserializePair' s = case break (== ' ') s of (a, ' ':b) -> Just (a, b) _ -> Nothing {- config values -} newtype SiteName = SiteName String deriving (Show, Typeable, Eq) instance SysConfValue SiteName where confPath _ = "siteName" serialize (SiteName name) = name deserialize = Just . SiteName defaultValue _ = SiteName "Rakka" newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq) instance SysConfValue BaseURI where confPath _ = "baseURI" serialize (BaseURI uri) = uriToString id uri "" deserialize uri = fmap BaseURI $ do parsed <- parseURI uri when (uriPath parsed == "" ) (fail undefined) when (last (uriPath parsed) /= '/') (fail undefined) when (uriQuery parsed /= "" ) (fail undefined) when (uriFragment parsed /= "" ) (fail undefined) return parsed defaultValue sc = let conf = scLucuConf sc host = C8.unpack $ LC.cnfServerHost conf port = unsafePerformIO $ do ent <- getServiceByName (LC.cnfServerPort conf) "tcp" return (servicePort ent) -- FIXME: There should be a way to change configurations -- without web interface nor direct repository -- modification. defaultURI = "http://" ++ host ++ (if port == 80 then "" else ':' : show port) ++ "/" in BaseURI $ fromJust $ parseURI defaultURI newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq) instance SysConfValue DefaultPage where confPath _ = "defaultPage" serialize (DefaultPage name) = name deserialize = Just . DefaultPage defaultValue _ = DefaultPage "MainPage" newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq) instance SysConfValue StyleSheet where confPath _ = "styleSheet" serialize (StyleSheet name) = name deserialize = Just . StyleSheet defaultValue _ = StyleSheet "StyleSheet/Default" newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq) instance SysConfValue Languages where confPath _ = "languages" serialize (Languages langs) = serializeStringPairs (M.toList langs) deserialize = fmap (Languages . M.fromList) . deserializeStringPairs defaultValue _ = Languages $ M.fromList [ ("en", "English" ) , ("es", "Español" ) , ("de", "Deutsch" ) , ("fi", "Suomi" ) , ("fr", "Français" ) , ("ga", "Gaeilge" ) , ("gd", "Gàidhlig" ) , ("ja", "日本語" ) , ("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