1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
16 , serializeStringPairs
17 , deserializeStringPairs
21 import Codec.Binary.UTF8.String
22 import Control.Arrow.ArrowIO
23 import Control.Concurrent.STM
25 import Control.Monad.Trans
26 import qualified Data.ByteString.Char8 as C8
27 import qualified Data.ByteString.Lazy as L
30 import qualified Data.Map as M
32 import GHC.Conc (unsafeIOToSTM)
34 import qualified Network.HTTP.Lucu.Config as LC
35 import Network.HTTP.Lucu.Utils
36 import Network.URI hiding (path)
39 import Subversion.FileSystem
40 import Subversion.FileSystem.Revision
41 import Subversion.FileSystem.Root
42 import Subversion.Repository
43 import System.FilePath.Posix
44 import System.Log.Logger
48 logger = "Rakka.SystemConfig"
51 data SystemConfig = SystemConfig {
52 scLucuConf :: !LC.Config
53 , scRepository :: !Repository
54 , scCache :: !(TVar (Map FilePath Dynamic))
58 class (Typeable a, Show a) => SysConfValue a where
59 confPath :: a -> FilePath
60 serialize :: a -> String
61 deserialize :: String -> Maybe a
62 defaultValue :: SystemConfig -> a
65 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
66 mkSystemConfig lc repos
67 = do cache <- newTVarIO M.empty
68 return $ SystemConfig {
70 , scRepository = repos
74 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
78 do let path = confPath (undefined :: a)
80 cache <- readTVar (scCache sc)
82 case M.lookup path cache of
83 Just val -> return $ fromJust $ fromDynamic val
84 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
85 writeTVar (scCache sc) (M.insert path (toDyn val) cache)
89 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
91 = do let path = fromConfPath $ confPath (undefined :: a)
93 fs <- getRepositoryFS (scRepository sc)
94 rev <- getYoungestRev fs
95 value <- withRevision fs rev
96 $ do exists <- isFile path
99 -> do str <- getFileContentsLBS path
100 return $ Just $ chomp $ decode $ L.unpack str
106 -> case deserialize str of
108 -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
111 -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
113 -> do let val = defaultValue sc
114 debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
118 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
119 getSysConfA = arrIO0 . getSysConf
122 fromConfPath :: FilePath -> FilePath
123 fromConfPath = ("/config" </>)
126 serializeStringPairs :: [(String, String)] -> String
127 serializeStringPairs = joinWith "\n" . map serializePair'
129 serializePair' :: (String, String) -> String
130 serializePair' (a, b) = a ++ " " ++ b
133 deserializeStringPairs :: String -> Maybe [(String, String)]
134 deserializeStringPairs = sequence . map deserializePair' . lines
136 deserializePair' :: String -> Maybe (String, String)
137 deserializePair' s = case break (/= ' ') s of
138 (a, ' ':b) -> Just (a, b)
145 newtype SiteName = SiteName String deriving (Show, Typeable)
146 instance SysConfValue SiteName where
147 confPath _ = "siteName"
148 serialize (SiteName name) = name
149 deserialize name = Just (SiteName name)
150 defaultValue _ = SiteName "Rakka"
153 newtype BaseURI = BaseURI URI deriving (Show, Typeable)
154 instance SysConfValue BaseURI where
155 confPath _ = "baseURI"
156 serialize (BaseURI uri) = uriToString id uri ""
157 deserialize uri = fmap BaseURI
158 $ do parsed <- parseURI uri
159 when (uriPath parsed == "" ) (fail undefined)
160 when (last (uriPath parsed) /= '/') (fail undefined)
161 when (uriQuery parsed /= "" ) (fail undefined)
162 when (uriFragment parsed /= "" ) (fail undefined)
165 = let conf = scLucuConf sc
166 host = C8.unpack $ LC.cnfServerHost conf
167 port = case LC.cnfServerPort conf of
168 PortNumber num -> fromIntegral num :: Int
171 = "http://" ++ host ++ -- FIXME: consider IPv6 address
174 else ':' : show port) ++ "/"
176 BaseURI $ fromJust $ parseURI defaultURI
179 newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
180 instance SysConfValue DefaultPage where
181 confPath _ = "defaultPage"
182 serialize (DefaultPage name) = name
183 deserialize name = Just (DefaultPage name)
184 defaultValue _ = DefaultPage "MainPage"
187 newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
188 instance SysConfValue StyleSheet where
189 confPath _ = "styleSheet"
190 serialize (StyleSheet name) = name
191 deserialize name = Just (StyleSheet name)
192 defaultValue _ = StyleSheet "StyleSheet/Default"
195 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
196 instance SysConfValue Languages where
197 confPath _ = "languages"
198 serialize (Languages langs) = serializeStringPairs (M.toList langs)
199 deserialize langs = fmap (Languages . M.fromList) (deserializeStringPairs langs)
201 = Languages $ M.fromList [ ("en", "English" )
205 , ("fr", "Français" )
207 , ("gd", "Gàidhlig" )
209 , ("pt", "Português")