, 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.URI
+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
+ scLucuConf :: !LC.Config
+ , scRepository :: !Repository
+ , scCache :: !(TVar (Map FilePath Dynamic))
}
-data SysConfValue
- = SiteName String
- | BaseURI URI
- | DefaultPage String
- | StyleSheet String
+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
-mkSystemConfig :: LC.Config -> SystemConfig
-mkSystemConfig = SystemConfig
+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
-getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
-getSysConf sc key
- = liftIO $ sysConfDefault sc key -- FIXME
+
+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
-getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
-getSysConfA = (arrIO0 .) . getSysConf
+fromConfPath :: FilePath -> FilePath
+fromConfPath = ("/config" </>)
-{- paths -}
-sysConfPath :: SysConfValue -> FilePath
-sysConfPath (SiteName _) = "/siteName"
-sysConfPath (BaseURI _) = "/baseURI"
-sysConfPath (DefaultPage _) = "/defaultPage"
-sysConfPath (StyleSheet _) = "/styleSheet"
+serializeStringPairs :: [(String, String)] -> String
+serializeStringPairs = joinWith "\n" . map serializePair'
+ where
+ serializePair' :: (String, String) -> String
+ serializePair' (a, b) = a ++ " " ++ b
-{- marshalling -}
-marshalSysConf :: SysConfValue -> String
-marshalSysConf (SiteName name) = name
-marshalSysConf (BaseURI uri ) = uriToString id uri ""
-marshalSysConf (DefaultPage name) = name
-marshalSysConf (StyleSheet name) = name
+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
-{- unmarshalling -}
-unmarshalSysConf :: SysConfValue -> String -> SysConfValue
-unmarshalSysConf (SiteName _) name = SiteName name
-unmarshalSysConf (BaseURI _) uri = BaseURI $ fromJust $ parseURI uri
-unmarshalSysConf (DefaultPage _) name = DefaultPage name
-unmarshalSysConf (StyleSheet _) name = StyleSheet name
+{- config values -}
-{- getting default value -}
-sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
+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"
-sysConfDefault _ (SiteName _)
- = return $ SiteName "Rakka"
-sysConfDefault sc (BaseURI _)
- = do let conf = scLucuConf sc
- host = C8.unpack $ LC.cnfServerHost conf
- port = case LC.cnfServerPort conf of
- PortNumber num -> fromIntegral num
-
- defaultURI
- = "http://" ++ host ++
+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"
+
- return $ BaseURI $ fromJust $ parseURI defaultURI
+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" )
+ ]
-sysConfDefault _ (DefaultPage _)
- = return $ DefaultPage "MainPage"
-sysConfDefault _ (StyleSheet _)
- = return $ StyleSheet "StyleSheet/Default"
+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