1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
18 import Control.Arrow.ArrowIO
19 import Control.Concurrent.STM
20 import Control.Monad.Trans
21 import qualified Data.ByteString.Char8 as C8
24 import Data.Encoding.UTF8
26 import qualified Data.Map as M
28 import GHC.Conc (unsafeIOToSTM)
30 import qualified Network.HTTP.Lucu.Config as LC
31 import Network.HTTP.Lucu.Utils
35 import Subversion.FileSystem
36 import Subversion.FileSystem.Revision
37 import Subversion.FileSystem.Root
38 import Subversion.Repository
39 import System.FilePath.Posix
40 import System.Log.Logger
42 logger = "Rakka.SystemConfig"
45 data SystemConfig = SystemConfig {
46 scLucuConf :: !LC.Config
47 , scRepository :: !Repository
48 , scCache :: !(TVar (Map FilePath Dynamic))
52 class (Typeable a, Show a) => SysConfValue a where
53 confPath :: a -> FilePath
54 serialize :: a -> String
55 deserialize :: String -> Maybe a
56 defaultValue :: SystemConfig -> a
59 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
60 mkSystemConfig lc repos
61 = do cache <- newTVarIO M.empty
62 return $ SystemConfig {
64 , scRepository = repos
68 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
72 do let path = confPath (undefined :: a)
74 cache <- readTVar (scCache sc)
76 case M.lookup path cache of
77 Just val -> return $ fromJust $ fromDynamic val
78 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
79 writeTVar (scCache sc) (M.insert path (toDyn val) cache)
83 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
85 = do let path = fromConfPath $ confPath (undefined :: a)
87 fs <- getRepositoryFS (scRepository sc)
88 rev <- getYoungestRev fs
89 value <- withRevision fs rev
90 $ do exists <- isFile path
93 -> do str <- getFileContentsLBS path
94 return $ Just $ chomp $ decodeLazy UTF8 str
100 -> case deserialize str of
102 -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
105 -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
107 -> do let val = defaultValue sc
108 debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
112 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
113 getSysConfA = arrIO0 . getSysConf
116 fromConfPath :: FilePath -> FilePath
117 fromConfPath = combine "/config"
120 serializeStringPairs :: [(String, String)] -> String
121 serializeStringPairs = joinWith "\n" . map serializePair'
123 serializePair' :: (String, String) -> String
124 serializePair' (a, b) = a ++ " " ++ b
127 deserializeStringPairs :: String -> Maybe [(String, String)]
128 deserializeStringPairs = sequence . map deserializePair' . lines
130 deserializePair' :: String -> Maybe (String, String)
131 deserializePair' s = case break (/= ' ') s of
132 (a, ' ':b) -> Just (a, b)
139 newtype SiteName = SiteName String deriving (Show, Typeable)
140 instance SysConfValue SiteName where
141 confPath _ = "siteName"
142 serialize (SiteName name) = name
143 deserialize name = Just (SiteName name)
144 defaultValue _ = SiteName "Rakka"
147 newtype BaseURI = BaseURI URI deriving (Show, Typeable)
148 instance SysConfValue BaseURI where
149 confPath _ = "baseURI"
150 serialize (BaseURI uri) = uriToString id uri ""
151 deserialize uri = fmap BaseURI (parseURI uri)
153 = let conf = scLucuConf sc
154 host = C8.unpack $ LC.cnfServerHost conf
155 port = case LC.cnfServerPort conf of
156 PortNumber num -> fromIntegral num
159 = "http://" ++ host ++ -- FIXME: consider IPv6 address
162 else ':' : show port) ++ "/"
164 BaseURI $ fromJust $ parseURI defaultURI
167 newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
168 instance SysConfValue DefaultPage where
169 confPath _ = "defaultPage"
170 serialize (DefaultPage name) = name
171 deserialize name = Just (DefaultPage name)
172 defaultValue _ = DefaultPage "MainPage"
175 newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
176 instance SysConfValue StyleSheet where
177 confPath _ = "styleSheet"
178 serialize (StyleSheet name) = name
179 deserialize name = Just (StyleSheet name)
180 defaultValue _ = StyleSheet "StyleSheet/Default"
183 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
184 instance SysConfValue Languages where
185 confPath _ = "languages"
186 serialize (Languages langs) = serializeStringPairs (M.toList langs)
187 deserialize langs = fmap (Languages . M.fromList) (deserializeStringPairs langs)
189 = Languages $ M.fromList [ ("en", "English" )
193 , ("fr", "Français" )
195 , ("gd", "Gàidhlig" )
197 , ("pt", "Português")