1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
17 , serializeStringPairs
18 , deserializeStringPairs
22 import Codec.Binary.UTF8.String
23 import Control.Arrow.ArrowIO
24 import Control.Concurrent.STM
26 import Control.Monad.Trans
27 import qualified Data.ByteString.Char8 as C8
28 import qualified Data.ByteString.Lazy as L
31 import qualified Data.Map as M
33 import GHC.Conc (unsafeIOToSTM)
35 import qualified Network.HTTP.Lucu.Config as LC
36 import Network.HTTP.Lucu.Utils
37 import Network.URI hiding (path)
40 import Subversion.FileSystem
41 import Subversion.FileSystem.Revision
42 import Subversion.FileSystem.Root
43 import Subversion.Repository
44 import System.FilePath.Posix
45 import System.Log.Logger
49 logger = "Rakka.SystemConfig"
52 data SystemConfig = SystemConfig {
53 scLucuConf :: !LC.Config
54 , scRepository :: !Repository
55 , scCache :: !(TVar (Map FilePath Dynamic))
59 class (Typeable a, Show a) => SysConfValue a where
60 confPath :: a -> FilePath
61 serialize :: a -> String
62 deserialize :: String -> Maybe a
63 defaultValue :: SystemConfig -> a
66 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
67 mkSystemConfig lc repos
68 = do cache <- newTVarIO M.empty
69 return $ SystemConfig {
71 , scRepository = repos
75 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
79 do let path = confPath (undefined :: a)
81 cache <- readTVar (scCache sc)
83 case M.lookup path cache of
84 Just val -> return $ fromJust $ fromDynamic val
85 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
86 writeTVar (scCache sc) (M.insert path (toDyn val) cache)
90 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
92 = do let path = fromConfPath $ confPath (undefined :: a)
94 fs <- getRepositoryFS (scRepository sc)
95 rev <- getYoungestRev fs
96 value <- withRevision fs rev
97 $ do exists <- isFile path
100 -> do str <- getFileContentsLBS path
101 return $ Just $ chomp $ decode $ L.unpack str
107 -> case deserialize str of
109 -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
112 -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
114 -> do let val = defaultValue sc
115 debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
119 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
120 getSysConfA = arrIO0 . getSysConf
123 fromConfPath :: FilePath -> FilePath
124 fromConfPath = ("/config" </>)
127 serializeStringPairs :: [(String, String)] -> String
128 serializeStringPairs = joinWith "\n" . map serializePair'
130 serializePair' :: (String, String) -> String
131 serializePair' (a, b) = a ++ " " ++ b
134 deserializeStringPairs :: String -> Maybe [(String, String)]
135 deserializeStringPairs = sequence . map deserializePair' . lines
137 deserializePair' :: String -> Maybe (String, String)
138 deserializePair' s = case break (/= ' ') s of
139 (a, ' ':b) -> Just (a, b)
146 newtype SiteName = SiteName String deriving (Show, Typeable)
147 instance SysConfValue SiteName where
148 confPath _ = "siteName"
149 serialize (SiteName name) = name
150 deserialize name = Just (SiteName name)
151 defaultValue _ = SiteName "Rakka"
154 newtype BaseURI = BaseURI URI deriving (Show, Typeable)
155 instance SysConfValue BaseURI where
156 confPath _ = "baseURI"
157 serialize (BaseURI uri) = uriToString id uri ""
158 deserialize uri = fmap BaseURI
159 $ do parsed <- parseURI uri
160 when (uriPath parsed == "" ) (fail undefined)
161 when (last (uriPath parsed) /= '/') (fail undefined)
162 when (uriQuery parsed /= "" ) (fail undefined)
163 when (uriFragment parsed /= "" ) (fail undefined)
166 = let conf = scLucuConf sc
167 host = C8.unpack $ LC.cnfServerHost conf
168 port = case LC.cnfServerPort conf of
169 PortNumber num -> fromIntegral num :: Int
172 = "http://" ++ host ++ -- FIXME: consider IPv6 address
175 else ':' : show port) ++ "/"
177 BaseURI $ fromJust $ parseURI defaultURI
180 newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
181 instance SysConfValue DefaultPage where
182 confPath _ = "defaultPage"
183 serialize (DefaultPage name) = name
184 deserialize name = Just (DefaultPage name)
185 defaultValue _ = DefaultPage "MainPage"
188 newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
189 instance SysConfValue StyleSheet where
190 confPath _ = "styleSheet"
191 serialize (StyleSheet name) = name
192 deserialize name = Just (StyleSheet name)
193 defaultValue _ = StyleSheet "StyleSheet/Default"
196 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
197 instance SysConfValue Languages where
198 confPath _ = "languages"
199 serialize (Languages langs) = serializeStringPairs (M.toList langs)
200 deserialize langs = fmap (Languages . M.fromList) (deserializeStringPairs langs)
202 = Languages $ M.fromList [ ("en", "English" )
206 , ("fr", "Français" )
208 , ("gd", "Gàidhlig" )
210 , ("pt", "Português")
215 newtype GlobalLock = GlobalLock Bool deriving (Show, Typeable)
216 instance SysConfValue GlobalLock where
217 confPath _ = "globalLock"
218 serialize (GlobalLock isLocked)
221 deserialize "*" = Just (GlobalLock True)
222 deserialize "" = Just (GlobalLock False)
223 deserialize _ = Nothing
224 defaultValue _ = GlobalLock False