1 module Rakka.SystemConfig
5 , mkSystemConfig -- private
18 import Codec.Binary.UTF8.String
19 import Control.Arrow.ArrowIO
20 import Control.Concurrent.STM
22 import Control.Monad.Trans
23 import qualified Data.ByteString.Char8 as C8
24 import qualified Data.ByteString.Lazy as L
27 import qualified Data.Map as M
29 import GHC.Conc (unsafeIOToSTM)
31 import qualified Network.HTTP.Lucu.Config as LC
32 import Network.HTTP.Lucu.Utils
33 import Network.URI hiding (path)
36 import Subversion.FileSystem
37 import Subversion.FileSystem.Revision
38 import Subversion.FileSystem.Root
39 import Subversion.Repository
40 import System.FilePath.Posix
41 import System.Log.Logger
45 logger = "Rakka.SystemConfig"
48 data SystemConfig = SystemConfig {
49 scLucuConf :: !LC.Config
50 , scRepository :: !Repository
51 , scCache :: !(TVar (Map FilePath Dynamic))
55 class (Typeable a, Show a) => SysConfValue a where
56 confPath :: a -> FilePath
57 serialize :: a -> String
58 deserialize :: String -> Maybe a
59 defaultValue :: SystemConfig -> a
62 mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
63 mkSystemConfig lc repos
64 = do cache <- newTVarIO M.empty
65 return $ SystemConfig {
67 , scRepository = repos
71 getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
75 do let path = confPath (undefined :: a)
77 cache <- readTVar (scCache sc)
79 case M.lookup path cache of
80 Just val -> return $ fromJust $ fromDynamic val
81 Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
82 writeTVar (scCache sc) (M.insert path (toDyn val) cache)
86 getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
88 = do let path = fromConfPath $ confPath (undefined :: a)
90 fs <- getRepositoryFS (scRepository sc)
91 rev <- getYoungestRev fs
92 value <- withRevision fs rev
93 $ do exists <- isFile path
96 -> do str <- getFileContentsLBS path
97 return $ Just $ chomp $ decode $ L.unpack str
103 -> case deserialize str of
105 -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
108 -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
110 -> do let val = defaultValue sc
111 debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
115 getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
116 getSysConfA = arrIO0 . getSysConf
119 fromConfPath :: FilePath -> FilePath
120 fromConfPath = ("/config" </>)
123 serializeStringPairs :: [(String, String)] -> String
124 serializeStringPairs = joinWith "\n" . map serializePair'
126 serializePair' :: (String, String) -> String
127 serializePair' (a, b) = a ++ " " ++ b
130 deserializeStringPairs :: String -> Maybe [(String, String)]
131 deserializeStringPairs = sequence . map deserializePair' . lines
133 deserializePair' :: String -> Maybe (String, String)
134 deserializePair' s = case break (/= ' ') s of
135 (a, ' ':b) -> Just (a, b)
142 newtype SiteName = SiteName String deriving (Show, Typeable)
143 instance SysConfValue SiteName where
144 confPath _ = "siteName"
145 serialize (SiteName name) = name
146 deserialize name = Just (SiteName name)
147 defaultValue _ = SiteName "Rakka"
150 newtype BaseURI = BaseURI URI deriving (Show, Typeable)
151 instance SysConfValue BaseURI where
152 confPath _ = "baseURI"
153 serialize (BaseURI uri) = uriToString id uri ""
154 deserialize uri = fmap BaseURI
155 $ do parsed <- parseURI uri
156 when (uriPath parsed == "" ) (fail undefined)
157 when (last (uriPath parsed) /= '/') (fail undefined)
158 when (uriQuery parsed /= "" ) (fail undefined)
159 when (uriFragment parsed /= "" ) (fail undefined)
162 = let conf = scLucuConf sc
163 host = C8.unpack $ LC.cnfServerHost conf
164 port = case LC.cnfServerPort conf of
165 PortNumber num -> fromIntegral num :: Int
168 = "http://" ++ host ++ -- FIXME: consider IPv6 address
171 else ':' : show port) ++ "/"
173 BaseURI $ fromJust $ parseURI defaultURI
176 newtype DefaultPage = DefaultPage String deriving (Show, Typeable)
177 instance SysConfValue DefaultPage where
178 confPath _ = "defaultPage"
179 serialize (DefaultPage name) = name
180 deserialize name = Just (DefaultPage name)
181 defaultValue _ = DefaultPage "MainPage"
184 newtype StyleSheet = StyleSheet String deriving (Show, Typeable)
185 instance SysConfValue StyleSheet where
186 confPath _ = "styleSheet"
187 serialize (StyleSheet name) = name
188 deserialize name = Just (StyleSheet name)
189 defaultValue _ = StyleSheet "StyleSheet/Default"
192 newtype Languages = Languages (Map LanguageTag LanguageName) deriving (Show, Typeable)
193 instance SysConfValue Languages where
194 confPath _ = "languages"
195 serialize (Languages langs) = serializeStringPairs (M.toList langs)
196 deserialize langs = fmap (Languages . M.fromList) (deserializeStringPairs langs)
198 = Languages $ M.fromList [ ("en", "English" )
202 , ("fr", "Français" )
204 , ("gd", "Gàidhlig" )
206 , ("pt", "Português")