1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
12 import Control.Arrow.ArrowIO
13 import Control.Concurrent.STM
14 import Control.Monad.Trans
15 import qualified Data.ByteString.Char8 as C8
17 import Data.Encoding.UTF8
19 import qualified Data.Map as M
21 import GHC.Conc (unsafeIOToSTM)
23 import qualified Network.HTTP.Lucu.Config as LC
26 import Subversion.FileSystem
27 import Subversion.FileSystem.Revision
28 import Subversion.FileSystem.Root
29 import Subversion.Repository
30 import System.FilePath.Posix
33 data SystemConfig = SystemConfig {
34 scLucuConf :: !LC.Config
35 , scRepository :: !Repository
36 , scCache :: !(TVar (Map FilePath SysConfValue))
48 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
49 mkSystemConfig lc repos
50 = do cache <- newTVarIO M.empty
51 return $ SystemConfig {
53 , scRepository = repos
58 getSysConf :: MonadIO m => SystemConfig -> SysConfValue -> m SysConfValue
62 do let path = sysConfPath key
64 cache <- readTVar (scCache sc)
66 case M.lookup path cache of
67 Just val -> return val
68 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc key)
69 writeTVar (scCache sc) (M.insert path val cache)
73 getSysConf' :: SystemConfig -> SysConfValue -> IO SysConfValue
75 = do fs <- getRepositoryFS (scRepository sc)
76 rev <- getYoungestRev fs
77 value <- withRevision fs rev
78 $ do let path = fromConfPath (sysConfPath key)
82 -> do str <- getFileContentsLBS path
83 return $ Just $ chomp $ decodeLazy UTF8 str
87 Just str -> return $ unmarshalSysConf key str
88 Nothing -> sysConfDefault sc key
91 getSysConfA :: ArrowIO a => SystemConfig -> SysConfValue -> a b SysConfValue
92 getSysConfA = (arrIO0 .) . getSysConf
95 fromConfPath :: FilePath -> FilePath
96 fromConfPath = combine "/config"
100 sysConfPath :: SysConfValue -> FilePath
101 sysConfPath (SiteName _) = "siteName"
102 sysConfPath (BaseURI _) = "baseURI"
103 sysConfPath (DefaultPage _) = "defaultPage"
104 sysConfPath (StyleSheet _) = "styleSheet"
108 marshalSysConf :: SysConfValue -> String
109 marshalSysConf (SiteName name) = name
110 marshalSysConf (BaseURI uri ) = uriToString id uri ""
111 marshalSysConf (DefaultPage name) = name
112 marshalSysConf (StyleSheet name) = name
116 unmarshalSysConf :: SysConfValue -> String -> SysConfValue
117 unmarshalSysConf (SiteName _) name = SiteName name
118 unmarshalSysConf (BaseURI _) uri = BaseURI $ fromJust $ parseURI uri
119 unmarshalSysConf (DefaultPage _) name = DefaultPage name
120 unmarshalSysConf (StyleSheet _) name = StyleSheet name
123 {- getting default value -}
124 sysConfDefault :: SystemConfig -> SysConfValue -> IO SysConfValue
126 sysConfDefault _ (SiteName _)
127 = return $ SiteName "Rakka"
129 sysConfDefault sc (BaseURI _)
130 = do let conf = scLucuConf sc
131 host = C8.unpack $ LC.cnfServerHost conf
132 port = case LC.cnfServerPort conf of
133 PortNumber num -> fromIntegral num
136 = "http://" ++ host ++
139 else ':' : show port) ++ "/"
141 return $ BaseURI $ fromJust $ parseURI defaultURI
143 sysConfDefault _ (DefaultPage _)
144 = return $ DefaultPage "MainPage"
146 sysConfDefault _ (StyleSheet _)
147 = return $ StyleSheet "StyleSheet/Default"