1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
20 , serializeStringPairs
21 , deserializeStringPairs
24 import Control.Arrow.ArrowIO
25 import Control.Concurrent.STM
27 import Control.Monad.Trans
28 import qualified Data.ByteString.Char8 as C8
29 import qualified Data.ByteString.Lazy as L
32 import qualified Data.Map as M
34 import GHC.Conc (unsafeIOToSTM)
36 import qualified Network.HTTP.Lucu.Config as LC
37 import Network.HTTP.Lucu.Utils
38 import Network.HTTP.Lucu hiding (Config)
39 import Network.URI hiding (path)
42 import Subversion.FileSystem
43 import Subversion.FileSystem.Revision
44 import Subversion.FileSystem.Root
45 import Subversion.FileSystem.Transaction
46 import Subversion.Repository
47 import Subversion.Types
48 import System.FilePath.Posix
49 import System.IO.Unsafe
50 import System.Log.Logger
54 logger = "Rakka.SystemConfig"
57 data SystemConfig = SystemConfig {
58 scLucuConf :: !LC.Config
59 , scRepository :: !Repository
60 , scCache :: !(TVar (Map FilePath Dynamic))
64 class (Typeable a, Show a, Eq a) => SysConfValue a where
65 confPath :: a -> FilePath
66 serialize :: a -> String
67 deserialize :: String -> Maybe a
68 defaultValue :: SystemConfig -> a
71 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
72 mkSystemConfig lc repos
73 = do cache <- newTVarIO M.empty
76 , scRepository = repos
80 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
84 do let path = confPath (undefined :: a)
86 cache <- readTVar (scCache sc)
88 case M.lookup path cache of
89 Just val -> return $ fromJust $ fromDynamic val
90 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
91 writeTVar (scCache sc) (M.insert path (toDyn val) cache)
95 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
97 = do let path = fromConfPath $ confPath (undefined :: a)
99 fs <- getRepositoryFS (scRepository sc)
100 rev <- getYoungestRev fs
101 value <- withRevision fs rev
102 $ do exists <- isFile path
105 -> do str <- getFileContentsLBS path
106 return $ Just $ chomp $ decode $ L.unpack str
112 -> case deserialize str of
114 -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
117 -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
119 -> do let val = defaultValue sc
120 debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
124 setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
125 setSysConf sc userID value
127 do let path = confPath (undefined :: a)
129 current <- getSysConf sc
131 then return NotModified
132 else do atomically $ do cache <- readTVar (scCache sc)
133 writeTVar (scCache sc) (M.delete path cache)
134 setSysConf' sc userID value
137 setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode
138 setSysConf' sc userID value
139 = do let path = fromConfPath $ confPath (undefined :: a)
140 str = L.pack $ encode $ serialize value ++ "\n"
141 repos = scRepository sc
142 fs <- getRepositoryFS repos
143 rev <- getYoungestRev fs
148 (Just "Automatic commit by Rakka for systemConfig update")
149 $ do exists <- isFile path
151 $ createValueEntry path
152 applyTextLBS path Nothing str
154 Left _ -> return Conflict
155 Right _ -> do debugM logger ("Set a config value at `" ++ path ++ "': " ++ show value)
158 createValueEntry :: FilePath -> Txn ()
159 createValueEntry path
160 = do createParentDirectories path
163 createParentDirectories :: FilePath -> Txn ()
164 createParentDirectories path
165 = do let parentPath = takeDirectory path
166 kind <- checkPath parentPath
168 NoNode -> do createParentDirectories parentPath
169 makeDirectory parentPath
170 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
174 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
175 getSysConfA = arrIO0 . getSysConf
178 setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode
179 setSysConfA = (arrIO .) . setSysConf
182 fromConfPath :: FilePath -> FilePath
183 fromConfPath = ("/config" </>)
186 serializeStringPairs :: [(String, String)] -> String
187 serializeStringPairs = joinWith "\n" . map serializePair'
189 serializePair' :: (String, String) -> String
190 serializePair' (a, b) = a ++ " " ++ b
193 deserializeStringPairs :: String -> Maybe [(String, String)]
194 deserializeStringPairs = mapM deserializePair' . lines
196 deserializePair' :: String -> Maybe (String, String)
197 deserializePair' s = case break (== ' ') s of
198 (a, ' ':b) -> Just (a, b)
205 newtype SiteName = SiteName String deriving (Show, Typeable, Eq)
206 instance SysConfValue SiteName where
207 confPath _ = "siteName"
208 serialize (SiteName name) = name
209 deserialize = Just . SiteName
210 defaultValue _ = SiteName "Rakka"
213 newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
214 instance SysConfValue BaseURI where
215 confPath _ = "baseURI"
216 serialize (BaseURI uri) = uriToString id uri ""
217 deserialize uri = fmap BaseURI
218 $ do parsed <- parseURI uri
219 when (uriPath parsed == "" ) (fail undefined)
220 when (last (uriPath parsed) /= '/') (fail undefined)
221 when (uriQuery parsed /= "" ) (fail undefined)
222 when (uriFragment parsed /= "" ) (fail undefined)
225 = let conf = scLucuConf sc
226 host = C8.unpack $ LC.cnfServerHost conf
227 port = unsafePerformIO $
228 do ent <- getServiceByName (LC.cnfServerPort conf) "tcp"
229 return (servicePort ent)
230 -- FIXME: There should be a way to change configurations
231 -- without web interface nor direct repository
234 = "http://" ++ host ++
237 else ':' : show port) ++ "/"
239 BaseURI $ fromJust $ parseURI defaultURI
242 newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq)
243 instance SysConfValue DefaultPage where
244 confPath _ = "defaultPage"
245 serialize (DefaultPage name) = name
246 deserialize = Just . DefaultPage
247 defaultValue _ = DefaultPage "MainPage"
250 newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq)
251 instance SysConfValue StyleSheet where
252 confPath _ = "styleSheet"
253 serialize (StyleSheet name) = name
254 deserialize = Just . StyleSheet
255 defaultValue _ = StyleSheet "StyleSheet/Default"
258 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
259 instance SysConfValue Languages where
260 confPath _ = "languages"
261 serialize (Languages langs) = serializeStringPairs (M.toList langs)
262 deserialize = fmap (Languages . M.fromList) . deserializeStringPairs
264 = Languages $ M.fromList [ ("en", "English" )
268 , ("fr", "Français" )
270 , ("gd", "Gàidhlig" )
272 , ("pt", "Português")
277 newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
278 instance SysConfValue GlobalLock where
279 confPath _ = "globalLock"
280 serialize (GlobalLock isLocked)
283 deserialize "*" = Just (GlobalLock True)
284 deserialize "" = Just (GlobalLock False)
285 deserialize _ = Nothing
286 defaultValue _ = GlobalLock False