diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,19 @@ # Changelog for B9 +## 0.5.68.1 + +* Fix positional argument enumeration in the `Enviromnent`; CLI arguments + are passed via the keys `arg_1 .. arg_N` in the `Environment`. + They are currently passed in reverse order and start from `arg_0` + instead of `arg_1`. See github issues #6 and #9. + +* Fix #7 shared image meta info download and + generalize and simplify `B9ConfigOverrid` while at it. + +* Remove `Trying to load config file` messages + +* Fix #8 - resurrect the environment variable `buildDirRoot`. + ## 0.5.68 * Allow version specific config file resolution diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: b9 -version: 0.5.68 +version: 0.5.68.1 synopsis: A tool and library for building virtual machine images. @@ -198,6 +198,7 @@ , B9.Content.YamlObjectSpec , B9.ArtifactGeneratorImplSpec , B9.DiskImagesSpec + , B9.EnvironmentSpec , Paths_b9 build-depends: b9 , binary >= 0.8 && < 0.9 diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -1,16 +1,11 @@ module Main ( main - ) -where + ) where import B9 -import Control.Lens ( (&) - , (.~) - , (^.) - ) -import Options.Applicative hiding ( action ) -import Options.Applicative.Help.Pretty - hiding ( () ) +import Control.Lens (set, (&), (.~), _Just) +import Options.Applicative hiding (action) +import Options.Applicative.Help.Pretty hiding (()) main :: IO () main = do @@ -29,259 +24,146 @@ applyB9RunParameters :: B9RunParameters -> IO () applyB9RunParameters (B9RunParameters overrides act vars) = - let cfg = - noB9ConfigOverride - & customLibVirtNetwork - .~ (overrides ^. customLibVirtNetwork) - & maybe id overrideB9ConfigPath (overrides ^. customB9ConfigPath) - & customEnvironment - .~ vars - in runB9ConfigActionWithOverrides act cfg + let cfg = overrides & customEnvironment .~ vars + in runB9ConfigActionWithOverrides act cfg parseCommandLine :: IO B9RunParameters -parseCommandLine = execParser - (info - (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars)) - ( fullDesc - <> progDesc - "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${projectRoot} if not otherwise specified in the config file, or via the '-b' option." - <> headerDoc (Just b9HelpHeader) - ) - ) - where - b9HelpHeader = linebreak - <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString) +parseCommandLine = + execParser + (info + (helper <*> (B9RunParameters <$> globals <*> cmds <*> buildVars)) + (fullDesc <> + progDesc + "Build and run VM-Images inside LXC containers. Custom arguments follow after '--' and are accessable in many strings in build files trough shell like variable references, i.e. '${arg_N}' referes to positional argument $N.\n\nRepository names passed to the command line are looked up in the B9 configuration file, which is per default located in: '~/.b9/b9.conf'. The current working directory is used as ${projectRoot} if not otherwise specified in the config file, or via the '-b' option." <> + headerDoc (Just b9HelpHeader))) + where + b9HelpHeader = linebreak <> text ("B9 - a benign VM-Image build tool v. " ++ b9VersionString) globals :: Parser B9ConfigOverride globals = - toGlobalOpts - <$> optional - (strOption - ( help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" - <> short 'c' - <> long "configuration-file" - <> metavar "FILENAME" - ) - ) - <*> switch - (help "Log everything that happens to stdout" <> short 'v' <> long - "verbose" - ) - <*> switch (help "Suppress non-error output" <> short 'q' <> long "quiet") - <*> optional - (strOption - (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar - "FILENAME" - ) - ) - <*> optional - (strOption - ( help - "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${projectRoot}." - <> short 'b' - <> long "build-root-dir" - <> metavar "DIRECTORY" - ) - ) - <*> switch - (help "Keep build directories after exit" <> short 'k' <> long - "keep-build-dir" - ) - <*> switch - (help "Predictable build directory names" <> short 'u' <> long - "predictable-build-dir" - ) - <*> optional - (strOption - ( help - "Cache directory for shared images, default: '~/.b9/repo-cache'" - <> long "repo-cache" - <> metavar "DIRECTORY" - ) - ) - <*> optional - (strOption - ( help "Remote repository to share image to" - <> short 'r' - <> long "repo" - <> metavar "REPOSITORY_ID" - ) - ) - <*> optional - (strOption - ( help - ("Override the libvirt-lxc network setting.\nThe special value '" - ++ hostNetworkMagicValue - ++ "' disables restricted container networking." - ) - <> long "network" - <> metavar "NETWORK_ID" - ) - ) - where - toGlobalOpts - :: Maybe FilePath - -> Bool - -> Bool - -> Maybe FilePath - -> Maybe FilePath - -> Bool - -> Bool - -> Maybe FilePath - -> Maybe String - -> Maybe String - -> B9ConfigOverride - toGlobalOpts cfg verbose quiet logF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet - = let - minLogLevel | verbose = Just LogTrace - | quiet = Just LogError - | otherwise = Nothing - b9cfg = - mempty - & verbosity - .~ minLogLevel - & logFile - .~ logF - & projectRoot - .~ buildRoot - & keepTempDirs - .~ keep - & uniqueBuildDirs - .~ not predictableBuildDir - & repository - .~ repo - & repositoryCache - .~ (Path <$> mRepoCache) - in - B9ConfigOverride - { _customB9ConfigPath = Path <$> cfg - , _customB9Config = b9cfg - , _customLibVirtNetwork = - (\n -> if n == hostNetworkMagicValue then Nothing else Just n) - <$> libvirtNet - , _customEnvironment = mempty - } + toGlobalOpts <$> + optional + (strOption + (help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file" <> + metavar "FILENAME")) <*> + switch (help "Log everything that happens to stdout" <> short 'v' <> long "verbose") <*> + switch (help "Suppress non-error output" <> short 'q' <> long "quiet") <*> + optional (strOption (help "Path to a logfile" <> short 'l' <> long "log-file" <> metavar "FILENAME")) <*> + optional + (strOption + (help + "Root directory for build directories. If not specified '.'. The path will be canonicalized and stored in ${projectRoot}." <> + short 'b' <> + long "build-root-dir" <> + metavar "DIRECTORY")) <*> + switch (help "Keep build directories after exit" <> short 'k' <> long "keep-build-dir") <*> + switch (help "Predictable build directory names" <> short 'u' <> long "predictable-build-dir") <*> + optional + (strOption + (help "Cache directory for shared images, default: '~/.b9/repo-cache'" <> long "repo-cache" <> + metavar "DIRECTORY")) <*> + optional + (strOption (help "Remote repository to share image to" <> short 'r' <> long "repo" <> metavar "REPOSITORY_ID")) <*> + optional + (strOption + (help + ("Override the libvirt-lxc network setting.\nThe special value '" ++ + hostNetworkMagicValue ++ "' disables restricted container networking.") <> + long "network" <> + metavar "NETWORK_ID")) + where + toGlobalOpts :: + Maybe FilePath + -> Bool + -> Bool + -> Maybe FilePath + -> Maybe FilePath + -> Bool + -> Bool + -> Maybe FilePath + -> Maybe String + -> Maybe String + -> B9ConfigOverride + toGlobalOpts cfg verbose quiet logF buildRoot keep predictableBuildDir mRepoCache repo libvirtNet = + let minLogLevel + | verbose = Just LogTrace + | quiet = Just LogError + | otherwise = Nothing + b9cfg = + Endo (verbosity .~ minLogLevel) <> Endo (logFile .~ logF) <> Endo (projectRoot .~ buildRoot) <> + Endo (keepTempDirs .~ keep) <> + Endo (uniqueBuildDirs .~ not predictableBuildDir) <> + Endo (repository .~ repo) <> + Endo (repositoryCache .~ (Path <$> mRepoCache)) <> + case libvirtNet of + Just n + | n /= hostNetworkMagicValue -> Endo (set (libVirtLXCConfigs . _Just . networkId) (Just n)) + _ -> mempty + in B9ConfigOverride {_customB9ConfigPath = Path <$> cfg, _customB9Config = b9cfg, _customEnvironment = mempty} cmds :: Parser (B9ConfigAction ()) -cmds = subparser - ( command - "version" - (info (pure runShowVersion) (progDesc "Show program version and exit.")) - <> command +cmds = + subparser + (command "version" (info (pure runShowVersion) (progDesc "Show program version and exit.")) <> + command "build" - (info (void . runBuildArtifacts <$> buildFileParser) - (progDesc "Merge all build file and generate all artifacts.") - ) - <> command + (info + (void . runBuildArtifacts <$> buildFileParser) + (progDesc "Merge all build file and generate all artifacts.")) <> + command "run" (info - ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many - (strArgument idm) - ) - (progDesc - "Run a command on the lastest version of the specified shared image." - ) - ) - <> command + ((\x y -> void (runRun x y)) <$> sharedImageNameParser <*> many (strArgument idm)) + (progDesc "Run a command on the lastest version of the specified shared image.")) <> + command "push" (info - (runPush <$> sharedImageNameParser) - (progDesc - "Push the lastest shared image from cache to the selected remote repository." - ) - ) - <> command + (runPush <$> sharedImageNameParser) + (progDesc "Push the lastest shared image from cache to the selected remote repository.")) <> + command "pull" (info - (runPull <$> optional sharedImageNameParser) - (progDesc - "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version." - ) - ) - <> command + (runPull <$> optional sharedImageNameParser) + (progDesc + "Either pull shared image meta data from all repositories, or only from just a selected one. If additionally the name of a shared images was specified, pull the newest version from either the selected repo, or from the repo with the most recent version.")) <> + command "clean-local" - (info - (pure runGcLocalRepoCache) - (progDesc - "Remove old versions of shared images from the local cache." - ) - ) - <> command + (info (pure runGcLocalRepoCache) (progDesc "Remove old versions of shared images from the local cache.")) <> + command "clean-remote" (info - (pure runGcRemoteRepoCache) - (progDesc - "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories." - ) - ) - <> command - "list" - (info (pure (void runListSharedImages)) - (progDesc "List shared images.") - ) - <> command - "add-repo" - (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.") - ) - <> command - "reformat" - (info (runFormatBuildFiles <$> buildFileParser) - (progDesc "Re-Format all build files.") - ) - ) + (pure runGcRemoteRepoCache) + (progDesc + "Remove cached meta-data of a remote repository. If no '-r' is given, clean the meta data of ALL remote repositories.")) <> + command "list" (info (pure (void runListSharedImages)) (progDesc "List shared images.")) <> + command "add-repo" (info (runAddRepo <$> remoteRepoParser) (progDesc "Add a remote repo.")) <> + command "reformat" (info (runFormatBuildFiles <$> buildFileParser) (progDesc "Re-Format all build files."))) buildFileParser :: Parser [FilePath] -buildFileParser = helper <*> some - (strOption - ( help - "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." - <> short 'f' - <> long "project-file" - <> metavar "FILENAME" - <> noArgError (ErrorMsg "No build file specified!") - ) - ) +buildFileParser = + helper <*> + some + (strOption + (help "Build file to load, specify multiple build files (each witch '-f') to build them all in a single run." <> + short 'f' <> + long "project-file" <> + metavar "FILENAME" <> + noArgError (ErrorMsg "No build file specified!"))) buildVars :: Parser Environment buildVars = flip addPositionalArguments mempty <$> many (strArgument idm) remoteRepoParser :: Parser RemoteRepo remoteRepoParser = - helper - <*> ( RemoteRepo - <$> strArgument - (help "The name of the remmote repository." <> metavar "NAME") - <*> strArgument - ( help "The (remote) repository root path." - <> metavar "REMOTE_DIRECTORY" - ) - <*> (SshPrivKey <$> strArgument - ( help - "Path to the SSH private key file used for authorization." - <> metavar "SSH_PRIV_KEY_FILE" - ) - ) - <*> ( SshRemoteHost - <$> ( (,) - <$> strArgument - (help "Repo hostname or IP" <> metavar "HOST") - <*> argument - auto - ( help "SSH-Port number" - <> value 22 - <> showDefault - <> metavar "PORT" - ) - ) - ) - <*> ( SshRemoteUser - <$> strArgument (help "SSH-User to login" <> metavar "USER") - ) - ) + helper <*> + (RemoteRepo <$> strArgument (help "The name of the remmote repository." <> metavar "NAME") <*> + strArgument (help "The (remote) repository root path." <> metavar "REMOTE_DIRECTORY") <*> + (SshPrivKey <$> + strArgument (help "Path to the SSH private key file used for authorization." <> metavar "SSH_PRIV_KEY_FILE")) <*> + (SshRemoteHost <$> + ((,) <$> strArgument (help "Repo hostname or IP" <> metavar "HOST") <*> + argument auto (help "SSH-Port number" <> value 22 <> showDefault <> metavar "PORT"))) <*> + (SshRemoteUser <$> strArgument (help "SSH-User to login" <> metavar "USER"))) sharedImageNameParser :: Parser SharedImageName -sharedImageNameParser = - helper - <*> ( SharedImageName - <$> strArgument (help "Shared image name" <> metavar "NAME") - ) +sharedImageNameParser = helper <*> (SharedImageName <$> strArgument (help "Shared image name" <> metavar "NAME")) diff --git a/src/lib/B9.hs b/src/lib/B9.hs --- a/src/lib/B9.hs +++ b/src/lib/B9.hs @@ -1,8 +1,10 @@ -{-| B9 is a library and build tool with primitive operations to rmrun a - build script inside a virtual machine and to create and convert - virtual machine image files as well as related ISO and VFAT disk images - for e.g. cloud-init configuration sources. +{-| B9 is a library and build tool with which one can create/convert different types + of VM images. Additionally installation steps - like installing software - + can be done in a LXC container, running on the disk images. + B9 allows to create and convert virtual machine image files as well as + related ISO and VFAT disk images for e.g. cloud-init configuration sources. + This module re-exports the modules needed to build a tool around the library, e.g. see @src\/cli\/Main.hs@ as an example. @@ -228,6 +230,7 @@ (runB9 (do MkSelectedRemoteRepo remoteRepo <- getSelectedRemoteRepo + let repoPred = maybe (== Cache) ((==) . toRemoteRepository) remoteRepo allRepos <- getRemoteRepos if isNothing remoteRepo diff --git a/src/lib/B9/B9Config.hs b/src/lib/B9/B9Config.hs --- a/src/lib/B9/B9Config.hs +++ b/src/lib/B9/B9Config.hs @@ -35,7 +35,6 @@ , modifyPermanentConfig , customB9Config , customB9ConfigPath - , customLibVirtNetwork , customEnvironment , overrideB9ConfigPath , overrideB9Config @@ -55,62 +54,43 @@ , ExecEnvType(..) , Environment , module X - ) -where + ) 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 +import B9.B9Config.LibVirtLXC as X +import B9.B9Config.Repository as X +import B9.Environment +import Control.Eff +import Control.Eff.Reader.Lazy +import Control.Eff.Writer.Lazy +import Control.Exception +import Control.Lens as Lens ((?~), (^.), makeLenses, 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 qualified Paths_b9 as My +import System.Directory +import System.FilePath ((<.>)) +import System.IO.B9Extras (SystemPath(..), ensureDir, resolve) +import Text.Printf (printf) data ExecEnvType = LibVirtLXC @@ -140,37 +120,25 @@ } 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' - } + 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 - [] + mempty = B9Config Nothing Nothing Nothing False LibVirtLXC True Nothing Nothing False Nothing Nothing [] -- | Reader for 'B9Config'. See 'getB9Config' and 'localB9Config'. -- @@ -194,8 +162,7 @@ -- | Run an action with an updated runtime configuration. -- -- @since 0.5.65 -localB9Config - :: Member B9ConfigReader e => (B9Config -> B9Config) -> Eff e a -> Eff e a +localB9Config :: Member B9ConfigReader e => (B9Config -> B9Config) -> Eff e a -> Eff e a localB9Config = local -- | An alias for 'getB9Config'. @@ -241,15 +208,22 @@ -- This is useful, i.e. when dealing with command line parameters. data B9ConfigOverride = B9ConfigOverride { _customB9ConfigPath :: Maybe SystemPath - , _customB9Config :: B9Config - , _customLibVirtNetwork :: Maybe (Maybe String) + , _customB9Config :: Endo B9Config , _customEnvironment :: Environment - } deriving (Show) + } +instance Show B9ConfigOverride where + show x = + unlines + [ "config file path: " ++ show (_customB9ConfigPath x) + , "config modification: " ++ show (appEndo (_customB9Config x) mempty) + , "environment: " ++ show (_customEnvironment x) + ] + -- | An empty default 'B9ConfigOverride' value, that will neither apply any -- additional 'B9Config' nor change the path of the configuration file. noB9ConfigOverride :: B9ConfigOverride -noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty mempty +noB9ConfigOverride = B9ConfigOverride Nothing mempty mempty makeLenses ''B9Config @@ -260,13 +234,12 @@ overrideB9ConfigPath p = customB9ConfigPath ?~ p -- | Modify the runtime configuration. -overrideB9Config - :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride -overrideB9Config = over customB9Config +overrideB9Config :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride +overrideB9Config e = customB9Config <>~ Endo e -- | Define the current working directory to be used when building. overrideWorkingDirectory :: FilePath -> B9ConfigOverride -> B9ConfigOverride -overrideWorkingDirectory p = customB9Config . projectRoot ?~ p +overrideWorkingDirectory p = overrideB9Config (projectRoot ?~ p) -- | Overwrite the 'verbosity' settings in the configuration with those given. overrideVerbosity :: LogLevel -> B9ConfigOverride -> B9ConfigOverride @@ -283,8 +256,7 @@ -- 'B9ConfigReader' and 'IO'. -- -- @since 0.5.65 -type B9ConfigAction a - = Eff '[B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a +type B9ConfigAction a = Eff '[ B9ConfigWriter, B9ConfigReader, EnvironmentReader, Lift IO] a -- | Accumulate 'B9Config' changes that go back to the config file. See -- 'B9ConfigAction' and 'modifyPermanentConfig'. @@ -313,67 +285,34 @@ 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 + 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 doesFileExist 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) - ) + 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 runtimeCfg = appEndo (cfg ^. customB9Config) permanentConfigIn + (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 + 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 @@ -394,11 +333,10 @@ 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 + else let res = b9ConfigToCPDocument defaultB9Config + in case res of + Left e -> throwIO (CPReadException cfgFile e) + Right cp -> writeFile cfgFile (toStringCP cp) >> return cp -- | Write the configuration in the 'CPDocument' to either the user supplied -- configuration file path or to 'defaultB9ConfigFile'. @@ -410,19 +348,21 @@ 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 = [] - } +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" @@ -477,15 +417,9 @@ 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) + cp8 <- setShowCP cp7 cfgFileSection maxLocalSharedImageRevisionsK (_maxLocalSharedImageRevisions c) cp9 <- setShowCP cp8 cfgFileSection repositoryCacheK (_repositoryCache c) - cpA <- foldr (>=>) - return - (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) - cp9 + cpA <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cp9 cpFinal <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpA setShowCP cpFinal cfgFileSection repositoryK (_repository c) @@ -494,20 +428,13 @@ 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 + 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 diff --git a/src/lib/B9/BuildInfo.hs b/src/lib/B9/BuildInfo.hs --- a/src/lib/B9/BuildInfo.hs +++ b/src/lib/B9/BuildInfo.hs @@ -113,7 +113,7 @@ traceL (printf "Project Root Directory: %s" rootD) buildD <- getBuildDir traceL (printf "Build Directory: %s" buildD) - r <- action + r <- addLocalStringBinding ("buildDirRoot", buildD) action tsAfter <- liftIO getCurrentTime let duration = show (tsAfter `diffUTCTime` startTime) infoL (printf "DURATION: %s" duration) diff --git a/src/lib/B9/Environment.hs b/src/lib/B9/Environment.hs --- a/src/lib/B9/Environment.hs +++ b/src/lib/B9/Environment.hs @@ -34,6 +34,7 @@ import Control.Eff.Reader.Lazy as Eff import Control.Parallel.Strategies import Data.Data +import Data.Foldable import Data.HashMap.Strict ( HashMap ) import qualified Data.HashMap.Strict as HashMap import Data.Maybe ( maybe @@ -54,9 +55,9 @@ instance Semigroup Environment where e1 <> e2 = MkEnvironment { nextPosition = case (nextPosition e1, nextPosition e2) of - (0 , 0 ) -> 0 - (0 , p2) -> p2 - (p1, 0 ) -> p1 + (1 , 1 ) -> 1 + (1 , p2) -> p2 + (p1, 1 ) -> p1 _ -> error ( "Overlapping positional arguments (<>): (" ++ show e1 @@ -86,7 +87,7 @@ } instance Monoid Environment where - mempty = MkEnvironment 0 HashMap.empty + mempty = MkEnvironment 1 HashMap.empty -- | If environment variables @arg_1 .. arg_n@ are bound -- and a list of @k@ additional values are passed to this function, @@ -97,8 +98,8 @@ -- @since 0.5.62 addPositionalArguments :: [Text] -> Environment -> Environment addPositionalArguments = flip - (foldr - (\arg (MkEnvironment i e) -> MkEnvironment + (foldl' + (\(MkEnvironment i e) arg -> MkEnvironment (i + 1) (HashMap.insert (unsafeRenderToText ("arg_" ++ show i)) arg e) ) @@ -217,7 +218,7 @@ { duplicateKey :: Text , duplicateKeyOldValue :: Text , duplicateKeyNewValue :: Text - } deriving (Typeable, Show) + } deriving (Typeable, Show, Eq) instance Exception DuplicateKey @@ -227,7 +228,7 @@ data KeyNotFound = MkKeyNotFound Text Environment - deriving (Typeable) + deriving (Typeable, Eq) instance Exception KeyNotFound diff --git a/src/tests/B9/EnvironmentSpec.hs b/src/tests/B9/EnvironmentSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/EnvironmentSpec.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} +module B9.EnvironmentSpec (spec) where + +import Test.Hspec +import Data.Text +import B9.Environment +import Control.Eff + +spec :: Spec +spec = + describe "Environment" $ + describe "addLocalPositionalArguments" $ do + let k = 13 :: Integer + j = 7 :: Integer + n = 13 :: Integer + args = [pack (show i) | i <- [1 .. n]] + + k_key = pack ("arg_" ++ show k) + j_key = pack ("arg_" ++ show j) + + k_value = pack (show k) + j_value = pack (show j) + + testEnv = addPositionalArguments args mempty + inEnv = run . runEnvironmentReader testEnv + + it "generates keys prefixed with arg_ followed by an ascending numeric index, starting with 1" $ + let res = inEnv $ do + ej_value <- lookupEither j_key + ek_value <- lookupEither k_key + e_arg_0 <- lookupEither "arg_0" + return (ej_value, ek_value, e_arg_0) + in res `shouldBe` (Right j_value, Right k_value, Left (MkKeyNotFound "arg_0" testEnv)) + +-- run . runEnvironmentReader testEnv $ do + diff --git a/stack.yaml b/stack.yaml --- a/stack.yaml +++ b/stack.yaml @@ -6,5 +6,5 @@ - template-0.2.0.10 - extensible-effects-5.0.0.1 -resolver: lts-13.9 +resolver: lts-13.13 require-stack-version: ">=1.6.5"