module B9.B9Config
( B9Config(..)
, runB9ConfigReader
, B9ConfigReader
, getB9Config
, getExecEnvType
, getConfig
, getLogVerbosity
, getProjectRoot
, getRemoteRepos
, isInteractive
, B9ConfigWriter
, verbosity
, logFile
, projectRoot
, keepTempDirs
, execEnvType
, uniqueBuildDirs
, repositoryCache
, repository
, interactive
, libVirtLXCConfigs
, remoteRepos
, maxLocalSharedImageRevisions
, B9ConfigOverride(..)
, noB9ConfigOverride
, B9ConfigAction()
, runB9ConfigActionWithOverrides
, runB9ConfigAction
, localB9Config
, modifyPermanentConfig
, customB9Config
, customB9ConfigPath
, customLibVirtNetwork
, customEnvironment
, overrideB9ConfigPath
, overrideB9Config
, overrideWorkingDirectory
, overrideVerbosity
, overrideKeepBuildDirs
, defaultB9ConfigFile
, defaultRepositoryCache
, defaultB9Config
, openOrCreateB9Config
, writeB9CPDocument
, readB9Config
, parseB9Config
, modifyCPDocument
, b9ConfigToCPDocument
, LogLevel(..)
, ExecEnvType(..)
, Environment
, module X
)
where
import B9.B9Config.LibVirtLXC as X
import B9.B9Config.Repository as X
import Control.Eff
import Control.Eff.Reader.Lazy
import Control.Eff.Writer.Lazy
import Control.Exception
import Control.Lens as Lens
( (&)
, (.~)
, (?~)
, (^.)
, _Just
, makeLenses
, over
, set
)
import Control.Monad ( (>=>)
, filterM
)
import Control.Monad.IO.Class
import Data.ConfigFile.B9Extras ( CPDocument
, CPError
, CPGet
, CPOptionSpec
, CPReadException(..)
, addSectionCP
, emptyCP
, mergeCP
, readCP
, readCPDocument
, setShowCP
, toStringCP
)
import Data.Function ( on )
import Data.List ( inits )
import Data.Maybe ( fromMaybe
, listToMaybe
, maybeToList
)
import Data.Monoid
import Data.Semigroup as Semigroup
hiding ( Last(..) )
import Data.Version
import System.Directory
import System.FilePath ( (<.>) )
import System.IO.B9Extras ( SystemPath(..)
, ensureDir
, resolve
)
import Text.Printf ( printf )
import B9.Environment
import Text.ParserCombinators.ReadP
import qualified Paths_b9 as My
data ExecEnvType =
LibVirtLXC
deriving (Eq, Show, Ord, Read)
data LogLevel
= LogTrace
| LogDebug
| LogInfo
| LogError
| LogNothing
deriving (Eq, Show, Ord, Read)
data B9Config = B9Config
{ _verbosity :: Maybe LogLevel
, _logFile :: Maybe FilePath
, _projectRoot :: Maybe FilePath
, _keepTempDirs :: Bool
, _execEnvType :: ExecEnvType
, _uniqueBuildDirs :: Bool
, _repositoryCache :: Maybe SystemPath
, _repository :: Maybe String
, _interactive :: Bool
, _maxLocalSharedImageRevisions :: Maybe Int
, _libVirtLXCConfigs :: Maybe LibVirtLXCConfig
, _remoteRepos :: [RemoteRepo]
} deriving (Show, Eq)
instance Semigroup B9Config where
c <> c' = B9Config
{ _verbosity = getLast $ on mappend (Last . _verbosity) c c'
, _logFile = getLast $ on mappend (Last . _logFile) c c'
, _projectRoot = getLast $ on mappend (Last . _projectRoot) c c'
, _keepTempDirs = getAny $ on mappend (Any . _keepTempDirs) c c'
, _execEnvType = LibVirtLXC
, _uniqueBuildDirs = getAll ((mappend `on` (All . _uniqueBuildDirs)) c c')
, _repositoryCache = getLast $ on mappend (Last . _repositoryCache) c c'
, _repository = getLast ((mappend `on` (Last . _repository)) c c')
, _interactive = getAny ((mappend `on` (Any . _interactive)) c c')
, _maxLocalSharedImageRevisions =
getLast ((mappend `on` (Last . _maxLocalSharedImageRevisions)) c c')
, _libVirtLXCConfigs = getLast
((mappend `on` (Last . _libVirtLXCConfigs)) c c')
, _remoteRepos = (mappend `on` _remoteRepos) c c'
}
instance Monoid B9Config where
mappend = (<>)
mempty = B9Config Nothing
Nothing
Nothing
False
LibVirtLXC
True
Nothing
Nothing
False
Nothing
Nothing
[]
type B9ConfigReader = Reader B9Config
runB9ConfigReader :: B9Config -> Eff (B9ConfigReader ': e) a -> Eff e a
runB9ConfigReader = runReader
getB9Config :: Member B9ConfigReader e => Eff e B9Config
getB9Config = ask
localB9Config
:: Member B9ConfigReader e => (B9Config -> B9Config) -> Eff e a -> Eff e a
localB9Config = local
getConfig :: Member B9ConfigReader e => Eff e B9Config
getConfig = getB9Config
isInteractive :: Member B9ConfigReader e => Eff e Bool
isInteractive = _interactive <$> getB9Config
getExecEnvType :: Member B9ConfigReader e => Eff e ExecEnvType
getExecEnvType = _execEnvType <$> getB9Config
getRemoteRepos :: Member B9ConfigReader e => Eff e [RemoteRepo]
getRemoteRepos = _remoteRepos <$> getB9Config
getLogVerbosity :: Member B9ConfigReader e => Eff e (Maybe LogLevel)
getLogVerbosity = _verbosity <$> getB9Config
getProjectRoot :: Member B9ConfigReader e => Eff e FilePath
getProjectRoot = fromMaybe "." . _projectRoot <$> ask
data B9ConfigOverride = B9ConfigOverride
{ _customB9ConfigPath :: Maybe SystemPath
, _customB9Config :: B9Config
, _customLibVirtNetwork :: Maybe (Maybe String)
, _customEnvironment :: Environment
} deriving (Show)
noB9ConfigOverride :: B9ConfigOverride
noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty mempty
makeLenses ''B9Config
makeLenses ''B9ConfigOverride
overrideB9ConfigPath :: SystemPath -> B9ConfigOverride -> B9ConfigOverride
overrideB9ConfigPath p = customB9ConfigPath ?~ p
overrideB9Config
:: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride
overrideB9Config = over customB9Config
overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride
overrideWorkingDirectory p = customB9Config . projectRoot ?~ p
overrideVerbosity :: LogLevel -> B9ConfigOverride -> B9ConfigOverride
overrideVerbosity = overrideB9Config . Lens.set verbosity . Just
overrideKeepBuildDirs :: Bool -> B9ConfigOverride -> B9ConfigOverride
overrideKeepBuildDirs = overrideB9Config . Lens.set keepTempDirs
type B9ConfigAction a
= Eff '[B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a
type B9ConfigWriter = Writer (Semigroup.Endo B9Config)
modifyPermanentConfig :: Member B9ConfigWriter e => Endo B9Config -> Eff e ()
modifyPermanentConfig = tell
runB9ConfigActionWithOverrides :: B9ConfigAction a -> B9ConfigOverride -> IO a
runB9ConfigActionWithOverrides act cfg = do
configuredCfgPath <- traverse resolve (cfg ^. customB9ConfigPath)
fallbackCfgPath <- resolve defaultB9ConfigFile
let
cfgPathCandidates = case My.version of
Version v _ ->
(concatMap
(\c ->
(\v' -> c <.> showVersion (makeVersion v')) <$> reverse (inits v)
)
(maybeToList configuredCfgPath)
)
++ ( (\v' -> fallbackCfgPath <.> showVersion (makeVersion v'))
<$> reverse (inits v)
)
pathToCreate = fromMaybe fallbackCfgPath configuredCfgPath
existingCfgPaths <- filterM
(\candidate -> putStrLn ("Trying to load config file: " ++ candidate)
>> doesFileExist candidate
)
cfgPathCandidates
let cfgPath = fromMaybe pathToCreate (listToMaybe existingCfgPaths)
cp <- openOrCreateB9Config cfgPath
case parseB9Config cp of
Left e -> fail
(printf "Internal configuration load error, please report this: %s\n"
(show e)
)
Right permanentConfigIn -> do
let runtimeCfg =
let rc = permanentConfigIn <> (cfg ^. customB9Config)
in case cfg ^. customLibVirtNetwork of
Just overridenNetwork ->
rc
& libVirtLXCConfigs
. _Just
. networkId
.~ overridenNetwork
Nothing -> rc
(res, permanentB9ConfigUpdates) <- runLift
(runEnvironmentReader (cfg ^. customEnvironment)
(runReader runtimeCfg (runMonoidWriter act))
)
let cpExtErr = modifyCPDocument cp <$> permanentB9ConfigUpdateMaybe
permanentB9ConfigUpdateMaybe =
if appEndo permanentB9ConfigUpdates permanentConfigIn
== permanentConfigIn
then
Nothing
else
Just permanentB9ConfigUpdates
cpExt <- maybe
(return Nothing)
(either
( fail
. printf
"Internal configuration update error! Please report this: %s\n"
. show
)
(return . Just)
)
cpExtErr
mapM_ (writeB9CPDocument (cfg ^. customB9ConfigPath)) cpExt
return res
runB9ConfigAction :: B9ConfigAction a -> IO a
runB9ConfigAction = flip runB9ConfigActionWithOverrides noB9ConfigOverride
openOrCreateB9Config :: MonadIO m => FilePath -> m CPDocument
openOrCreateB9Config cfgFile = do
ensureDir cfgFile
liftIO $ do
exists <- doesFileExist cfgFile
if exists
then readCPDocument (Path cfgFile)
else
let res = b9ConfigToCPDocument defaultB9Config
in case res of
Left e -> throwIO (CPReadException cfgFile e)
Right cp -> writeFile cfgFile (toStringCP cp) >> return cp
writeB9CPDocument :: MonadIO m => Maybe SystemPath -> CPDocument -> m ()
writeB9CPDocument cfgFileIn cp = do
cfgFile <- resolve (fromMaybe defaultB9ConfigFile cfgFileIn)
ensureDir cfgFile
liftIO (writeFile cfgFile (toStringCP cp))
defaultB9Config :: B9Config
defaultB9Config = B9Config { _verbosity = Just LogInfo
, _logFile = Nothing
, _projectRoot = Nothing
, _keepTempDirs = False
, _execEnvType = LibVirtLXC
, _uniqueBuildDirs = True
, _repository = Nothing
, _repositoryCache = Just defaultRepositoryCache
, _interactive = False
, _maxLocalSharedImageRevisions = Just 2
, _libVirtLXCConfigs = Just defaultLibVirtLXCConfig
, _remoteRepos = []
}
defaultRepositoryCache :: SystemPath
defaultRepositoryCache = InB9UserDir "repo-cache"
defaultB9ConfigFile :: SystemPath
defaultB9ConfigFile = InB9UserDir "b9.conf"
verbosityK :: String
verbosityK = "verbosity"
logFileK :: String
logFileK = "log_file"
projectRootK :: String
projectRootK = "build_dir_root"
keepTempDirsK :: String
keepTempDirsK = "keep_temp_dirs"
execEnvTypeK :: String
execEnvTypeK = "exec_env"
uniqueBuildDirsK :: String
uniqueBuildDirsK = "unique_build_dirs"
repositoryCacheK :: String
repositoryCacheK = "repository_cache"
maxLocalSharedImageRevisionsK :: String
maxLocalSharedImageRevisionsK = "max_cached_shared_images"
repositoryK :: String
repositoryK = "repository"
cfgFileSection :: String
cfgFileSection = "global"
modifyCPDocument :: CPDocument -> Endo B9Config -> Either CPError CPDocument
modifyCPDocument cp f = do
cfg <- parseB9Config cp
cp2 <- b9ConfigToCPDocument (appEndo f cfg)
return (mergeCP cp cp2)
b9ConfigToCPDocument :: B9Config -> Either CPError CPDocument
b9ConfigToCPDocument c = do
cp1 <- addSectionCP emptyCP cfgFileSection
cp2 <- setShowCP cp1 cfgFileSection verbosityK (_verbosity c)
cp3 <- setShowCP cp2 cfgFileSection logFileK (_logFile c)
cp4 <- setShowCP cp3 cfgFileSection projectRootK (_projectRoot c)
cp5 <- setShowCP cp4 cfgFileSection keepTempDirsK (_keepTempDirs c)
cp6 <- setShowCP cp5 cfgFileSection execEnvTypeK (_execEnvType c)
cp7 <- setShowCP cp6 cfgFileSection uniqueBuildDirsK (_uniqueBuildDirs c)
cp8 <- setShowCP cp7
cfgFileSection
maxLocalSharedImageRevisionsK
(_maxLocalSharedImageRevisions c)
cp9 <- setShowCP cp8 cfgFileSection repositoryCacheK (_repositoryCache c)
cpA <- foldr (>=>)
return
(libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c)
cp9
cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpA
setShowCP cpFinal cfgFileSection repositoryK (_repository c)
readB9Config :: MonadIO m => Maybe SystemPath -> m CPDocument
readB9Config cfgFile = readCPDocument (fromMaybe defaultB9ConfigFile cfgFile)
parseB9Config :: CPDocument -> Either CPError B9Config
parseB9Config cp =
let
getr :: (CPGet a) => CPOptionSpec -> Either CPError a
getr = readCP cp cfgFileSection
in
B9Config
<$> getr verbosityK
<*> getr logFileK
<*> getr projectRootK
<*> getr keepTempDirsK
<*> getr execEnvTypeK
<*> getr uniqueBuildDirsK
<*> getr repositoryCacheK
<*> getr repositoryK
<*> pure False
<*> pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK))
<*> pure (either (const Nothing) Just (parseLibVirtLXCConfig cp))
<*> parseRemoteRepos cp