1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
20 , serializeStringPairs
21 , deserializeStringPairs
25 import Codec.Binary.UTF8.String
26 import Control.Arrow.ArrowIO
27 import Control.Concurrent.STM
29 import Control.Monad.Trans
30 import qualified Data.ByteString.Char8 as C8
31 import qualified Data.ByteString.Lazy as L
34 import qualified Data.Map as M
36 import GHC.Conc (unsafeIOToSTM)
38 import qualified Network.HTTP.Lucu.Config as LC
39 import Network.HTTP.Lucu.Utils
40 import Network.HTTP.Lucu hiding (Config)
41 import Network.URI hiding (path)
44 import Subversion.FileSystem
45 import Subversion.FileSystem.Revision
46 import Subversion.FileSystem.Root
47 import Subversion.FileSystem.Transaction
48 import Subversion.Repository
49 import Subversion.Types
50 import System.FilePath.Posix
51 import System.Log.Logger
55 logger = "Rakka.SystemConfig"
58 data SystemConfig = SystemConfig {
59 scLucuConf :: !LC.Config
60 , scRepository :: !Repository
61 , scCache :: !(TVar (Map FilePath Dynamic))
65 class (Typeable a, Show a, Eq a) => SysConfValue a where
66 confPath :: a -> FilePath
67 serialize :: a -> String
68 deserialize :: String -> Maybe a
69 defaultValue :: SystemConfig -> a
72 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
73 mkSystemConfig lc repos
74 = do cache <- newTVarIO M.empty
77 , scRepository = repos
81 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
85 do let path = confPath (undefined :: a)
87 cache <- readTVar (scCache sc)
89 case M.lookup path cache of
90 Just val -> return $ fromJust $ fromDynamic val
91 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
92 writeTVar (scCache sc) (M.insert path (toDyn val) cache)
96 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
98 = do let path = fromConfPath $ confPath (undefined :: a)
100 fs <- getRepositoryFS (scRepository sc)
101 rev <- getYoungestRev fs
102 value <- withRevision fs rev
103 $ do exists <- isFile path
106 -> do str <- getFileContentsLBS path
107 return $ Just $ chomp $ decode $ L.unpack str
113 -> case deserialize str of
115 -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
118 -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
120 -> do let val = defaultValue sc
121 debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
125 setSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> String -> a -> m StatusCode
126 setSysConf sc userID value
128 do let path = confPath (undefined :: a)
130 current <- getSysConf sc
132 then return NotModified
133 else do atomically $ do cache <- readTVar (scCache sc)
134 writeTVar (scCache sc) (M.delete path cache)
135 setSysConf' sc userID value
138 setSysConf' :: forall a. SysConfValue a => SystemConfig -> String -> a -> IO StatusCode
139 setSysConf' sc userID value
140 = do let path = fromConfPath $ confPath (undefined :: a)
141 str = L.pack $ encode $ serialize value ++ "\n"
142 repos = scRepository sc
143 fs <- getRepositoryFS repos
144 rev <- getYoungestRev fs
149 (Just "Automatic commit by Rakka for systemConfig update")
150 $ do exists <- isFile path
152 $ createValueEntry path
153 applyTextLBS path Nothing str
155 Left _ -> return Conflict
156 Right _ -> do debugM logger ("Set a config value at `" ++ path ++ "': " ++ show value)
159 createValueEntry :: FilePath -> Txn ()
160 createValueEntry path
161 = do createParentDirectories path
164 createParentDirectories :: FilePath -> Txn ()
165 createParentDirectories path
166 = do let parentPath = takeDirectory path
167 kind <- checkPath parentPath
169 NoNode -> do createParentDirectories parentPath
170 makeDirectory parentPath
171 FileNode -> fail ("createParentDirectories: already exists a file: " ++ parentPath)
175 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
176 getSysConfA = arrIO0 . getSysConf
179 setSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> String -> a c StatusCode
180 setSysConfA = (arrIO .) . setSysConf
183 fromConfPath :: FilePath -> FilePath
184 fromConfPath = ("/config" </>)
187 serializeStringPairs :: [(String, String)] -> String
188 serializeStringPairs = joinWith "\n" . map serializePair'
190 serializePair' :: (String, String) -> String
191 serializePair' (a, b) = a ++ " " ++ b
194 deserializeStringPairs :: String -> Maybe [(String, String)]
195 deserializeStringPairs = mapM deserializePair' . lines
197 deserializePair' :: String -> Maybe (String, String)
198 deserializePair' s = case break (== ' ') s of
199 (a, ' ':b) -> Just (a, b)
206 newtype SiteName = SiteName String deriving (Show, Typeable, Eq)
207 instance SysConfValue SiteName where
208 confPath _ = "siteName"
209 serialize (SiteName name) = name
210 deserialize = Just . SiteName
211 defaultValue _ = SiteName "Rakka"
214 newtype BaseURI = BaseURI URI deriving (Show, Typeable, Eq)
215 instance SysConfValue BaseURI where
216 confPath _ = "baseURI"
217 serialize (BaseURI uri) = uriToString id uri ""
218 deserialize uri = fmap BaseURI
219 $ do parsed <- parseURI uri
220 when (uriPath parsed == "" ) (fail undefined)
221 when (last (uriPath parsed) /= '/') (fail undefined)
222 when (uriQuery parsed /= "" ) (fail undefined)
223 when (uriFragment parsed /= "" ) (fail undefined)
226 = let conf = scLucuConf sc
227 host = C8.unpack $ LC.cnfServerHost conf
228 port = case LC.cnfServerPort conf of
229 PortNumber num -> fromIntegral num :: Int
232 = "http://" ++ host ++ -- FIXME: consider IPv6 address
235 else ':' : show port) ++ "/"
237 BaseURI $ fromJust $ parseURI defaultURI
240 newtype DefaultPage = DefaultPage String deriving (Show, Typeable, Eq)
241 instance SysConfValue DefaultPage where
242 confPath _ = "defaultPage"
243 serialize (DefaultPage name) = name
244 deserialize = Just . DefaultPage
245 defaultValue _ = DefaultPage "MainPage"
248 newtype StyleSheet = StyleSheet String deriving (Show, Typeable, Eq)
249 instance SysConfValue StyleSheet where
250 confPath _ = "styleSheet"
251 serialize (StyleSheet name) = name
252 deserialize = Just . StyleSheet
253 defaultValue _ = StyleSheet "StyleSheet/Default"
256 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable, Eq)
257 instance SysConfValue Languages where
258 confPath _ = "languages"
259 serialize (Languages langs) = serializeStringPairs (M.toList langs)
260 deserialize = fmap (Languages . M.fromList) . deserializeStringPairs
262 = Languages $ M.fromList [ ("en", "English" )
266 , ("fr", "Français" )
268 , ("gd", "Gàidhlig" )
270 , ("pt", "Português")
275 newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable, Eq)
276 instance SysConfValue GlobalLock where
277 confPath _ = "globalLock"
278 serialize (GlobalLock isLocked)
281 deserialize "*" = Just (GlobalLock True)
282 deserialize "" = Just (GlobalLock False)
283 deserialize _ = Nothing
284 defaultValue _ = GlobalLock False