+class (Typeable a, Show a) => SysConfValue a where
+ confPath :: a -> FilePath
+ serialize :: a -> String
+ deserialize :: String -> Maybe a
+ defaultValue :: SystemConfig -> a
+
+
+mkSystemConfig :: LC.Config -> Repository -> IO SystemConfig
+mkSystemConfig lc repos
+ = do cache <- newTVarIO M.empty
+ return $ SystemConfig {
+ scLucuConf = lc
+ , scRepository = repos
+ , scCache = cache
+ }
+
+getSysConf :: forall m a. (MonadIO m, SysConfValue a) => SystemConfig -> m a
+getSysConf sc
+ = liftIO $
+ atomically $
+ do let path = confPath (undefined :: a)
+
+ cache <- readTVar (scCache sc)
+
+ case M.lookup path cache of
+ Just val -> return $ fromJust $ fromDynamic val
+ Nothing -> do val <- unsafeIOToSTM (getSysConf' sc)
+ writeTVar (scCache sc) (M.insert path (toDyn val) cache)
+ return val
+
+
+getSysConf' :: forall a. SysConfValue a => SystemConfig -> IO a
+getSysConf' sc
+ = do let path = fromConfPath $ confPath (undefined :: a)
+
+ fs <- getRepositoryFS (scRepository sc)
+ rev <- getYoungestRev fs
+ value <- withRevision fs rev
+ $ do exists <- isFile path
+ case exists of
+ True
+ -> do str <- getFileContentsLBS path
+ return $ Just $ chomp $ decode $ L.unpack str
+ False
+ -> return Nothing
+
+ case value of
+ Just str
+ -> case deserialize str of
+ Just val
+ -> do debugM logger ("Got a config value at `" ++ path ++ "': " ++ show val)
+ return val
+ Nothing
+ -> fail ("Got an invalid config value at `" ++ path ++ "': " ++ str)
+ Nothing
+ -> do let val = defaultValue sc
+ debugM logger ("Got no config value at `" ++ path ++ "'. Defaulting to " ++ show val)
+ return val
+
+
+getSysConfA :: (ArrowIO a, SysConfValue c) => SystemConfig -> a b c
+getSysConfA = arrIO0 . getSysConf
+
+
+fromConfPath :: FilePath -> FilePath
+fromConfPath = ("/config" </>)
+
+
+serializeStringPairs :: [(String, String)] -> String
+serializeStringPairs = joinWith "\n" . map serializePair'
+ where
+ serializePair' :: (String, String) -> String
+ serializePair' (a, b) = a ++ " " ++ b