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 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 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 = sequence . map 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 name = Just (SiteName name) 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 = case LC.cnfServerPort conf of PortNumber num -> fromIntegral num :: Int _ -> undefined defaultURI = "http://" ++ host ++ -- FIXME: consider IPv6 address (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 name = Just (DefaultPage name) defaultValue _ = DefaultPage "MainPage" newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq) instance SysConfValue StyleSheet where confPath _ = "styleSheet" serialize (StyleSheet name) = name deserialize name = Just (StyleSheet name) 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 langs = fmap (Languages . M.fromList) (deserializeStringPairs langs) 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