diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,25 @@ # Changelog for B9 +## 2.0.0 + +### Breaking Changes + +* Specify upper version bounds for all project dependencies +* Move the `interactive` flag from the `B9Config` to the `BuildInfo` + * `isInteractive` now requires the `BuildInfoReader` effect + * Add the `runB9Interactive` function, that can by used to + make the `bsIsInteractive` field in `BuildInfo` `True` + * Add the `cmdInteractive` function, that executes a command + with inherited stdin/stdout if `runB9Interactive` was called. + * Remove the interactivity functionality from the `cmd` function + +### Minor Changes + +* Fix bug in the parsing of `console` key in the `systemd-nspawn` + configuration section: When a user specifies `console: pipe` + this effects will be the same as if `console: read-only` was specified. +* Fix bug where the timeout factor configuration option given in a + configuration file is ignored. ## 1.1.1 diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: b9 -version: 1.1.1 +version: 2.0.0 synopsis: A tool and library for building virtual machine images. @@ -57,15 +57,25 @@ , CHANGELOG.md common b9Deps - build-depends: base >= 4.12 && < 5 - , bytestring >= 0.10.8 - , directory >= 1.3 - , extensible-effects >= 5 && < 6 - , hspec - , hspec-expectations - , lens >= 4 + build-depends: QuickCheck >= 2.5 && < 3 + , aeson == 1.4.* + , base >= 4.12 && < 5 + , binary == 0.8.* + , bytestring >= 0.10.8 && < 1 + , containers >= 0.6 && < 1 + , directory >= 1.3 && < 2 + , extensible-effects == 5.* + , filepath == 1.4.* + , hspec == 2.7.* + , hspec-expectations == 0.8.* + , lens == 4.* + , neat-interpolation >= 0.3 && < 1 + , optparse-applicative >= 0.13 && < 1 , shake >= 0.17.6 && < 0.19 - , text >= 1.2 + , text == 1.2.* + , unordered-containers >= 0.2 && < 1 + , vector >= 0.11 && < 1 + , yaml >= 0.8 && < 1 common b9Extensions other-extensions: OverloadedStrings @@ -150,39 +160,29 @@ , System.IO.B9Extras other-modules: Paths_b9 autogen-modules: Paths_b9 - build-depends: ConfigFile >= 1.1.4 - , QuickCheck >= 2.5 - , aeson >= 1.0 - , async >= 2.1 - , base64-bytestring - , bifunctors >= 5.4 - , binary >= 0.8.3 - , boxes >= 0.1.4 - , conduit >= 1.2 - , conduit-extra >= 1.1 - -- , dhall >= 1 TODO - , containers - , exceptions >= 0.10 - , filepath >= 1.4 - , free >= 4.12 - , hashable >= 1.2 - , monad-control >= 1.0 && < 1.1 - , mtl >= 2.2 - , optparse-applicative >= 0.14 - , parallel >= 3.2 - , parsec >= 3.1 - , pretty >= 1.1 - , pretty-show >= 1.6 - , process >= 1.4 - , random >= 1.1 - , syb >= 0.6 + build-depends: ConfigFile >= 1.1.4 && < 1.2 + , async == 2.* + , base64-bytestring == 1.* + , bifunctors == 5.* + , boxes == 0.1.* + , conduit == 1.* + , conduit-extra == 1.* + , exceptions == 0.10.* + , free >= 4.12 && < 6 + , hashable == 1.2.* + , monad-control == 1.* + , mtl == 2.* + , parallel >= 3.2 && < 4 + , parsec >= 3.1 && < 4 + , pretty >= 1.1 && < 2 + , pretty-show >= 1.6 && < 2 + , process >= 1.4 && < 2 + , random >= 1.1 && < 2 + , syb >= 0.6 && < 1 , tagged >= 0.8 && < 0.9 - , template >= 0.2 - , time >= 1.6 - , transformers >= 0.5 - , unordered-containers >= 0.2.8 - , vector >= 0.11 - , yaml >= 0.8 + , template >= 0.2 && < 1 + , time >= 1.6 && < 2 + , transformers >= 0.5 && < 1 executable b9c import: b9Extensions, b9Deps @@ -190,8 +190,6 @@ other-modules: Paths_b9 autogen-modules: Paths_b9 build-depends: b9 - , extensible-effects >= 5 && < 6 - , optparse-applicative >= 0.13 hs-source-dirs: src/cli ghc-options: -Wall -fwarn-unused-binds -fno-warn-unused-do-bind -threaded @@ -204,6 +202,7 @@ main-is: Spec.hs autogen-modules: Paths_b9 other-modules: B9.ArtifactGeneratorImplSpec + , B9.B9ConfigSpec , B9.B9ExecSpec , B9.Content.ErlTermsSpec , B9.Content.ErlangPropListSpec @@ -214,14 +213,4 @@ , B9.RepositorySpec , B9.Shake.SharedImageRulesSpec , Paths_b9 - build-depends: QuickCheck >= 2.5 - , b9 - , aeson >= 1.0 - , binary >= 0.8 && < 0.9 - , containers - , filepath - , hspec - , hspec-expectations - , unordered-containers >= 0.2 - , vector >= 0.11 - , yaml >= 0.8 + build-depends: b9 diff --git a/src/lib/B9.hs b/src/lib/B9.hs --- a/src/lib/B9.hs +++ b/src/lib/B9.hs @@ -75,6 +75,7 @@ import Data.Maybe as X import Data.Monoid as X import Data.Set (Set) +import qualified Data.Set as Set import Data.Version as X import Paths_b9 (version) import System.Exit as X @@ -160,8 +161,8 @@ runRun :: SharedImageName -> [String] -> B9ConfigAction String runRun (SharedImageName name) cmdAndArgs = localB9Config - ((keepTempDirs .~ False) . (interactive .~ True)) - (runB9 (buildArtifacts runCmdAndArgs)) + ((keepTempDirs .~ False) . (verbosity .~ Just LogTrace)) + (runB9Interactive (buildArtifacts runCmdAndArgs)) where runCmdAndArgs = Artifact @@ -245,8 +246,8 @@ modifyPermanentConfig ( Endo ( remoteRepos - %~ ( mappend [repo'] - . filter ((== remoteRepoRepoId repo') . remoteRepoRepoId) + %~ ( mappend (Set.singleton repo') + . Set.filter ((== remoteRepoRepoId repo') . remoteRepoRepoId) ) ) ) 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 @@ -13,7 +13,6 @@ getLogVerbosity, getProjectRoot, getRemoteRepos, - isInteractive, B9ConfigWriter, verbosity, logFile, @@ -22,7 +21,6 @@ uniqueBuildDirs, repositoryCache, repository, - interactive, defaultTimeout, libVirtLXCConfigs, dockerConfigs, @@ -73,6 +71,7 @@ import B9.B9Config.Repository as X import B9.B9Config.SystemdNspawn as X import B9.Environment +import B9.QCUtil (smaller) import Control.Eff import Control.Eff.Reader.Lazy import Control.Eff.Writer.Lazy @@ -99,6 +98,8 @@ import Data.Maybe (fromMaybe) import Data.Monoid import Data.Semigroup as Semigroup hiding (Last (..)) +import Data.Set (Set) +import qualified Data.Set as Set import Data.Version import GHC.Stack import qualified Paths_b9 as My @@ -106,6 +107,8 @@ import System.FilePath ((<.>)) import System.IO.B9Extras (SystemPath (..), ensureDir, resolve) import Text.Printf (printf) +import Test.QuickCheck (Arbitrary(arbitrary)) +import qualified Test.QuickCheck as QuickCheck -- | A way to specify a time intervall for example for the timeouts -- of system commands. @@ -114,6 +117,11 @@ newtype Timeout = TimeoutMicros Int deriving (Show, Eq, Ord, Read) +instance Arbitrary Timeout where + arbitrary = do + QuickCheck.Positive t <- arbitrary + pure (TimeoutMicros (t * 1_000_000)) + data LogLevel = LogTrace | LogDebug @@ -122,6 +130,9 @@ | LogNothing deriving (Eq, Show, Ord, Read) +instance Arbitrary LogLevel where + arbitrary = QuickCheck.elements [LogTrace, LogDebug, LogInfo, LogError, LogNothing] + data B9Config = B9Config { _verbosity :: Maybe LogLevel, @@ -131,18 +142,36 @@ _uniqueBuildDirs :: Bool, _repositoryCache :: Maybe SystemPath, _repository :: Maybe String, - _interactive :: Bool, _maxLocalSharedImageRevisions :: Maybe Int, _systemdNspawnConfigs :: Maybe SystemdNspawnConfig, _podmanConfigs :: Maybe PodmanConfig, _dockerConfigs :: Maybe DockerConfig, _libVirtLXCConfigs :: Maybe LibVirtLXCConfig, - _remoteRepos :: [RemoteRepo], + _remoteRepos :: Set RemoteRepo, _defaultTimeout :: Maybe Timeout, _timeoutFactor :: Maybe Int } deriving (Show, Eq) +instance Arbitrary B9Config where + arbitrary = + B9Config + <$> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> (QuickCheck.elements [Nothing, Just (InTempDir "xxx")]) + <*> smaller arbitrary + <*> smaller (fmap QuickCheck.getPositive <$> arbitrary) + <*> smaller arbitrary + <*> pure Nothing + <*> pure Nothing + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> (fmap QuickCheck.getPositive <$> smaller arbitrary) + instance Semigroup B9Config where c <> c' = B9Config @@ -153,7 +182,6 @@ _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'), _systemdNspawnConfigs = getLast ((mappend `on` (Last . _systemdNspawnConfigs)) c c'), _podmanConfigs = getLast ((mappend `on` (Last . _podmanConfigs)) c c'), @@ -166,7 +194,7 @@ instance Monoid B9Config where mappend = (<>) - mempty = B9Config Nothing Nothing Nothing False True Nothing Nothing False Nothing Nothing Nothing Nothing Nothing [] (Just (TimeoutMicros (60 * 60 * 1_000_000))) Nothing + mempty = B9Config Nothing Nothing Nothing False True Nothing Nothing Nothing Nothing Nothing Nothing Nothing mempty (Just (TimeoutMicros (60 * 60 * 1_000_000))) Nothing -- | Reader for 'B9Config'. See 'getB9Config' and 'localB9Config'. -- @@ -201,17 +229,10 @@ getConfig :: Member B9ConfigReader e => Eff e B9Config getConfig = getB9Config --- | Ask whether @stdin@ of the @B9@ process should be redirected to the --- external commands executed during the build. --- --- @since 0.5.65 -isInteractive :: Member B9ConfigReader e => Eff e Bool -isInteractive = _interactive <$> getB9Config - -- | Ask for the 'RemoteRepo's. -- -- @since 0.5.65 -getRemoteRepos :: Member B9ConfigReader e => Eff e [RemoteRepo] +getRemoteRepos :: Member B9ConfigReader e => Eff e (Set RemoteRepo) getRemoteRepos = _remoteRepos <$> getB9Config -- | Ask for the 'LogLevel'. @@ -413,13 +434,12 @@ _uniqueBuildDirs = True, _repository = Nothing, _repositoryCache = Just defaultRepositoryCache, - _interactive = False, _maxLocalSharedImageRevisions = Just 2, _systemdNspawnConfigs = Just defaultSystemdNspawnConfig, _podmanConfigs = Just defaultPodmanConfig, _libVirtLXCConfigs = Just defaultLibVirtLXCConfig, _dockerConfigs = Just defaultDockerConfig, - _remoteRepos = [], + _remoteRepos = mempty, _defaultTimeout = Just (TimeoutMicros (3_600_000_000)), _timeoutFactor = Nothing } @@ -485,10 +505,15 @@ cpB <- foldr (>=>) return (podmanConfigToCPDocument <$> _podmanConfigs c) cpA cpC <- foldr (>=>) return (dockerConfigToCPDocument <$> _dockerConfigs c) cpB cpD <- foldr (>=>) return (libVirtLXCConfigToCPDocument <$> _libVirtLXCConfigs c) cpC - cpE <- foldr (>=>) return (remoteRepoToCPDocument <$> _remoteRepos c) cpD - cpF <- setShowCP cpE cfgFileSection repositoryK (_repository c) - cpFinal <- setShowCP cpF cfgFileSection defaultTimeoutK (_defaultTimeout c) - setShowCP cpFinal cfgFileSection timeoutFactorK (_timeoutFactor c) + cpE <- foldr (>=>) return ( remoteRepoToCPDocument <$> Set.toList (_remoteRepos c)) cpD + cpF <- setShowCP cpE cfgFileSection repositoryK (_repository c) + cpFinal <- maybe (pure cpF) (setShowCP cpF cfgFileSection defaultTimeoutK) + ( case _defaultTimeout c of + Just (TimeoutMicros t) -> + Just (t `div` 1_000_000) + Nothing -> Nothing + ) + maybe (pure cpFinal) (setShowCP cpFinal cfgFileSection timeoutFactorK) (_timeoutFactor c) readB9Config :: (HasCallStack, MonadIO m) => Maybe SystemPath -> m CPDocument readB9Config cfgFile = readCPDocument (fromMaybe defaultB9ConfigFile cfgFile) @@ -497,17 +522,20 @@ parseB9Config cp = let getr :: (CPGet a) => CPOptionSpec -> Either CPError a getr = readCP cp cfgFileSection - in B9Config <$> getr verbosityK <*> getr logFileK <*> getr projectRootK <*> getr keepTempDirsK + in B9Config + <$> getr verbosityK + <*> getr logFileK + <*> getr projectRootK + <*> getr keepTempDirsK <*> getr uniqueBuildDirsK <*> getr repositoryCacheK <*> getr repositoryK - <*> pure False <*> pure (either (const Nothing) id (getr maxLocalSharedImageRevisionsK)) <*> pure (either (const Nothing) Just (parseSystemdNspawnConfig cp)) <*> pure (either (const Nothing) Just (parsePodmanConfig cp)) <*> pure (either (const Nothing) Just (parseDockerConfig cp)) <*> pure (either (const Nothing) Just (parseLibVirtLXCConfig cp)) - <*> parseRemoteRepos cp + <*> (Set.fromList <$> parseRemoteRepos cp) <*> pure (either (const Nothing) Just (parseDefaultTimeoutConfig cp)) <*> pure (either (const Nothing) Just (getr timeoutFactorK)) diff --git a/src/lib/B9/B9Config/Container.hs b/src/lib/B9/B9Config/Container.hs --- a/src/lib/B9/B9Config/Container.hs +++ b/src/lib/B9/B9Config/Container.hs @@ -6,6 +6,8 @@ where import Data.ConfigFile.B9Extras +import Test.QuickCheck (Arbitrary(arbitrary)) +import qualified Test.QuickCheck as QuickCheck -- | Available capabilities for Linux containers. This maps directly to the -- capabilities defined in 'man 7 capabilities'. @@ -48,7 +50,12 @@ | CAP_SYS_TTY_CONFIG | CAP_SYSLOG | CAP_WAKE_ALARM - deriving (Read, Show, Eq) + deriving (Read, Show, Eq, Enum, Bounded) + +instance Arbitrary ContainerCapability where + arbitrary = + QuickCheck.elements + (enumFromTo minBound maxBound :: [ContainerCapability]) containerCapabilitiesK :: String containerCapabilitiesK = "guest_capabilities" diff --git a/src/lib/B9/B9Config/LibVirtLXC.hs b/src/lib/B9/B9Config/LibVirtLXC.hs --- a/src/lib/B9/B9Config/LibVirtLXC.hs +++ b/src/lib/B9/B9Config/LibVirtLXC.hs @@ -16,6 +16,8 @@ import Data.ConfigFile.B9Extras import Data.Maybe (fromMaybe) import System.Environment.Blank as SysIO +import Test.QuickCheck (Arbitrary(arbitrary),oneof,listOf1) +import B9.QCUtil (smaller, arbitraryFilePath, arbitraryLetter) data LibVirtLXCConfig = LibVirtLXCConfig @@ -27,6 +29,16 @@ guestRamSize :: RamSize } deriving (Read, Show, Eq) + +instance Arbitrary LibVirtLXCConfig where + arbitrary = + LibVirtLXCConfig <$> + smaller arbitrary <*> + smaller (oneof [pure Nothing, Just <$> arbitraryFilePath]) <*> + smaller arbitraryFilePath <*> + smaller (oneof [pure Nothing, Just <$> listOf1 arbitraryLetter]) <*> + smaller arbitrary <*> + pure (RamSize 4 GB) makeLenses ''LibVirtLXCConfig diff --git a/src/lib/B9/B9Config/Repository.hs b/src/lib/B9/B9Config/Repository.hs --- a/src/lib/B9/B9Config/Repository.hs +++ b/src/lib/B9/B9Config/Repository.hs @@ -12,7 +12,9 @@ import Data.ConfigFile.B9Extras import Data.Data -import Data.List (isSuffixOf) +import Data.List (isSuffixOf, sort) +import Test.QuickCheck (Positive(..), Arbitrary(arbitrary), listOf1) +import B9.QCUtil (smaller, arbitraryFilePath, arbitraryLetter) newtype RepoCache = RepoCache FilePath deriving (Read, Show, Typeable, Data) @@ -24,20 +26,41 @@ SshPrivKey SshRemoteHost SshRemoteUser - deriving (Read, Show, Typeable, Data, Eq) + deriving (Read, Show, Typeable, Data, Eq, Ord) +instance Arbitrary RemoteRepo where + arbitrary = RemoteRepo <$> + smaller (listOf1 arbitraryLetter) <*> + smaller arbitraryFilePath <*> + smaller arbitrary <*> + smaller arbitrary <*> + smaller arbitrary + + remoteRepoRepoId :: RemoteRepo -> String remoteRepoRepoId (RemoteRepo repoId _ _ _ _) = repoId newtype SshPrivKey = SshPrivKey FilePath - deriving (Read, Show, Typeable, Data, Eq) + deriving (Read, Show, Typeable, Data, Eq, Ord) +instance Arbitrary SshPrivKey where + arbitrary = SshPrivKey <$> arbitraryFilePath + newtype SshRemoteHost = SshRemoteHost (String, Int) - deriving (Read, Show, Typeable, Data, Eq) + deriving (Read, Show, Typeable, Data, Eq, Ord) +instance Arbitrary SshRemoteHost where + arbitrary = do + h <- smaller (listOf1 arbitraryLetter) + Positive p <- arbitrary + pure (SshRemoteHost (h,p)) + newtype SshRemoteUser = SshRemoteUser String - deriving (Read, Show, Typeable, Data, Eq) + deriving (Read, Show, Typeable, Data, Eq, Ord) +instance Arbitrary SshRemoteUser where + arbitrary = SshRemoteUser <$> smaller (listOf1 arbitraryLetter) + -- | Persist a repo to a configuration file. remoteRepoToCPDocument :: RemoteRepo -> CPDocument -> Either CPError CPDocument remoteRepoToCPDocument repo cpIn = cpWithRepo @@ -56,7 +79,7 @@ -- | Load a repository from a configuration file that has been written by -- 'writeRepositoryToB9Config'. parseRemoteRepos :: CPDocument -> Either CPError [RemoteRepo] -parseRemoteRepos cp = traverse parseRepoSection repoSections +parseRemoteRepos cp = sort <$> traverse parseRepoSection repoSections where repoSections = filter (repoSectionSuffix `isSuffixOf`) (sectionsCP cp) parseRepoSection section = parseResult diff --git a/src/lib/B9/B9Config/SystemdNspawn.hs b/src/lib/B9/B9Config/SystemdNspawn.hs --- a/src/lib/B9/B9Config/SystemdNspawn.hs +++ b/src/lib/B9/B9Config/SystemdNspawn.hs @@ -19,6 +19,9 @@ import qualified Text.ParserCombinators.ReadP as ReadP import qualified Text.ParserCombinators.ReadPrec as ReadPrec import Text.Read +import Test.QuickCheck (Arbitrary(arbitrary)) +import qualified Test.QuickCheck as QuickCheck +import B9.QCUtil (smaller, arbitraryFilePath) -- TODO document b9 config file data SystemdNspawnConfig @@ -32,6 +35,16 @@ } deriving (Read, Show, Eq) +instance Arbitrary SystemdNspawnConfig where + arbitrary = + SystemdNspawnConfig + <$> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller arbitrary + <*> smaller (QuickCheck.oneof [pure Nothing, Just <$> arbitraryFilePath]) + <*> smaller arbitrary + data SystemdNspawnConsole = SystemdNspawnInteractive | SystemdNspawnReadOnly @@ -39,6 +52,15 @@ | SystemdNspawnPipe deriving (Eq) +instance Arbitrary SystemdNspawnConsole where + arbitrary = + QuickCheck.elements + [ SystemdNspawnInteractive + , SystemdNspawnReadOnly + , SystemdNspawnPassive + , SystemdNspawnPipe + ] + instance Show SystemdNspawnConsole where show x = case x of SystemdNspawnInteractive -> "interactive" @@ -62,7 +84,7 @@ return SystemdNspawnPassive +++ do Ident "pipe" <- lexP - return SystemdNspawnReadOnly + return SystemdNspawnPipe makeLenses ''SystemdNspawnConfig diff --git a/src/lib/B9/B9Exec.hs b/src/lib/B9/B9Exec.hs --- a/src/lib/B9/B9Exec.hs +++ b/src/lib/B9/B9Exec.hs @@ -3,6 +3,7 @@ -- @since 0.5.65 module B9.B9Exec ( cmd, + cmdInteractive, hostCmdEither, hostCmd, hostCmdStdIn, @@ -14,8 +15,7 @@ import B9.B9Config import B9.B9Error import B9.B9Logging --- import qualified Data.ByteString.Lazy as Lazy - +import B9.BuildInfo (BuildInfoReader, isInteractive) import qualified Conduit as CL import Control.Concurrent import Control.Concurrent.Async (Concurrently (..), race) @@ -51,18 +51,40 @@ -- If the command exists with non-zero exit code, the current process exists with the same -- exit code. -- --- @since 0.5.65 -cmd :: - (HasCallStack, Member ExcB9 e, CommandIO e) => +-- @since 2.0.0 +cmdInteractive :: + (HasCallStack, Member ExcB9 e, Member BuildInfoReader e, CommandIO e) => String -> Eff e () -cmd str = do +cmdInteractive str = do t <- view defaultTimeout <$> getB9Config inheritStdIn <- isInteractive ok <- if inheritStdIn then hostCmdEither HostCommandInheritStdin str t else hostCmdEither HostCommandNoStdin str t + case ok of + Right _ -> + return () + Left e -> + errorExitL ("SYSTEM COMMAND FAILED: " ++ show e) + +-- | Execute the given shell command. +-- +-- The command and the output is either logged to the logfile with 'traceL' or 'errorL' or +-- written to stdout. +-- +-- If the command exists with non-zero exit code, the current process exists with the same +-- exit code. +-- +-- @since 0.5.65 +cmd :: + (HasCallStack, Member ExcB9 e, CommandIO e) => + String -> + Eff e () +cmd str = do + t <- view defaultTimeout <$> getB9Config + ok <- hostCmdEither HostCommandNoStdin str t case ok of Right _ -> return () diff --git a/src/lib/B9/B9Monad.hs b/src/lib/B9/B9Monad.hs --- a/src/lib/B9/B9Monad.hs +++ b/src/lib/B9/B9Monad.hs @@ -1,5 +1,6 @@ module B9.B9Monad ( runB9, + runB9Interactive, B9, B9Eff, IsB9, @@ -53,7 +54,21 @@ -- -- @since 0.5.65 runB9 :: HasCallStack => B9 a -> B9ConfigAction a -runB9 action = do +runB9 = runB9Full False + +-- | Execute a 'B9' effect like 'runB9' but run +-- external commands, such as `systemd-nspawn`, +-- /interactively/. +-- +-- When run /interactively/, the stdin/stdout of +-- certain commands is inherited from the main process. +-- +-- @since 2.0.0 +runB9Interactive :: HasCallStack => B9 a -> B9ConfigAction a +runB9Interactive = runB9Full True + +runB9Full :: HasCallStack => Bool -> B9 a -> B9ConfigAction a +runB9Full interactive action = do cfg <- getB9Config env <- askEnvironment lift @@ -62,8 +77,11 @@ . runEnvironmentReader env . runB9ConfigReader cfg . withLogger - . withBuildInfo + . withBuildInfo interactive . withRemoteRepos . withSelectedRemoteRepo $ action ) + + + 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 @@ -10,6 +10,7 @@ getBuildDir, withBuildInfo, BuildInfoReader, + isInteractive, ) where @@ -45,7 +46,8 @@ { bsBuildId :: String, bsBuildDate :: String, bsBuildDir :: FilePath, - bsStartTime :: UTCTime + bsStartTime :: UTCTime, + bsIsInteractive :: Bool } deriving (Eq, Show) @@ -74,9 +76,10 @@ Member LoggerReader e, HasCallStack ) => + Bool -> Eff (BuildInfoReader ': e) a -> Eff e a -withBuildInfo action = withRootDir $ do +withBuildInfo interactive action = withRootDir $ do now <- lift getCurrentTime let buildDate = formatTime undefined "%F-%T" now -- TODO make configurable how the build date is formatted buildId <- generateBuildId @@ -117,7 +120,7 @@ when (_uniqueBuildDirs cfg && not (_keepTempDirs cfg)) $ removeDirectoryRecursive buildDir runImpl buildId buildDate startTime buildDir = - let ctx = BuildInfo buildId buildDate buildDir startTime + let ctx = BuildInfo buildId buildDate buildDir startTime interactive in runReader ctx wrappedAction where wrappedAction = do @@ -140,3 +143,10 @@ getBuildDir :: Member BuildInfoReader e => Eff e FilePath getBuildDir = bsBuildDir <$> ask + +-- | Ask whether @stdin@ of the @B9@ process should be redirected to the +-- external commands executed during the build. +-- +-- @since 2.0.0 +isInteractive :: Member BuildInfoReader e => Eff e Bool +isInteractive = bsIsInteractive <$> ask diff --git a/src/lib/B9/LibVirtLXC.hs b/src/lib/B9/LibVirtLXC.hs --- a/src/lib/B9/LibVirtLXC.hs +++ b/src/lib/B9/LibVirtLXC.hs @@ -78,9 +78,9 @@ successMarkerFile :: [Char] successMarkerFile = "SUCCESS" -execute :: (Member ExcB9 e, CommandIO e, Member B9ConfigReader e) => Context -> Eff e Bool +execute :: (Member ExcB9 e, CommandIO e, Member BuildInfoReader e, Member B9ConfigReader e) => Context -> Eff e Bool execute (Context scriptDirHost _uuid domainFile cfg) = do - cmd $ printf "%s create '%s' --console --autodestroy" virshCommand domainFile + cmdInteractive $ printf "%s create '%s' --console --autodestroy" virshCommand domainFile -- cmd $ printf "%s console %U" virsh uuid liftIO (doesFileExist $ scriptDirHost successMarkerFile) where diff --git a/src/lib/B9/Repository.hs b/src/lib/B9/Repository.hs --- a/src/lib/B9/Repository.hs +++ b/src/lib/B9/Repository.hs @@ -148,10 +148,11 @@ localRepoDir (RepoCache cacheDir) = cacheDir "local-repo" -- | Select the first 'RemoteRepo' with a given @repoId@. -lookupRemoteRepo :: [RemoteRepo] -> String -> Maybe RemoteRepo -lookupRemoteRepo repos repoId = lookup repoId repoIdRepoPairs +lookupRemoteRepo :: Set RemoteRepo -> String -> Maybe RemoteRepo +lookupRemoteRepo repos repoId = Map.lookup repoId repoIdRepoPairs where - repoIdRepoPairs = map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) repos + repoIdRepoPairs = + Map.fromList (map (\r@(RemoteRepo rid _ _ _ _) -> (rid, r)) (toList repos)) -- | A 'Map' that maps 'Repository's to the 'SharedImage's they hold. -- diff --git a/src/lib/B9/RepositoryIO.hs b/src/lib/B9/RepositoryIO.hs --- a/src/lib/B9/RepositoryIO.hs +++ b/src/lib/B9/RepositoryIO.hs @@ -64,7 +64,7 @@ repoCache <- lift (initRepoCache (fromMaybe defaultRepositoryCache (_repositoryCache cfg))) - remoteRepos' <- mapM (initRemoteRepo repoCache) (_remoteRepos cfg) + remoteRepos' <- Set.fromList <$> mapM (initRemoteRepo repoCache) (toList (_remoteRepos cfg)) let setRemoteRepos = remoteRepos .~ remoteRepos' localB9Config setRemoteRepos (runReader repoCache f) @@ -123,7 +123,7 @@ repoSearch subDir glob = (:) <$> localMatches <*> remoteRepoMatches where remoteRepoMatches = - getRemoteRepos >>= mapM remoteRepoSearch + getRemoteRepos >>= mapM remoteRepoSearch . toList localMatches :: Eff e (Repository, [FilePath]) localMatches = do cache <- getRepoCache @@ -295,8 +295,8 @@ pullLatestImage name@(SharedImageName dbgName) = do repos <- getSelectedRepos let repoPredicate Cache = False - repoPredicate (Remote repoId) = repoId `elem` repoIds - repoIds = map remoteRepoRepoId repos + repoPredicate (Remote repoId) = repoId `Set.member` repoIds + repoIds = Set.map remoteRepoRepoId repos hasName sharedImage = name == sharedImageName sharedImage candidates <- filterRepoImagesMap repoPredicate hasName <$> getSharedImages @@ -434,11 +434,11 @@ pushToRepo (fromJust r) cachedInfoFile repoInfoFile -- | Return either all remote repos or just the single selected repo. -getSelectedRepos :: '[B9ConfigReader, SelectedRemoteRepoReader] <:: e => Eff e [RemoteRepo] +getSelectedRepos :: '[B9ConfigReader, SelectedRemoteRepoReader] <:: e => Eff e (Set RemoteRepo) getSelectedRepos = do allRepos <- getRemoteRepos MkSelectedRemoteRepo selectedRepo <- getSelectedRemoteRepo - let repos = maybe allRepos return selectedRepo -- 'Maybe' a repo + let repos = maybe allRepos Set.singleton selectedRepo -- 'Maybe' a repo return repos -- | Return the path to the sub directory in the cache that contains files of diff --git a/src/lib/B9/SystemdNspawn.hs b/src/lib/B9/SystemdNspawn.hs --- a/src/lib/B9/SystemdNspawn.hs +++ b/src/lib/B9/SystemdNspawn.hs @@ -163,7 +163,7 @@ deriving (Show) execBuild :: - (Member ExcB9 e, CommandIO e) => + (Member ExcB9 e, Member BuildInfoReader e, CommandIO e) => SudoPrepender -> ContainerMounts -> [SharedDirectory] -> @@ -214,10 +214,18 @@ execOptions = ["/bin/sh", bootScriptContainerCommand bootScript] timeout = (TimeoutMicros . (* 1000000)) <$> _systemdNspawnMaxLifetimeSeconds dCfg traceL ("executing systemd-nspawn container build") - case _systemdNspawnConsole dCfg of - SystemdNspawnInteractive -> + interactiveAction <- isInteractive + let + runInteractively = + case _systemdNspawnConsole dCfg of + SystemdNspawnInteractive -> + True + _ -> + interactiveAction + if runInteractively + then hostCmdStdIn HostCommandInheritStdin (sudo systemdCmd) Nothing - _ -> + else hostCmd (sudo systemdCmd) timeout umountLoopbackImages :: diff --git a/src/tests/B9/B9ConfigSpec.hs b/src/tests/B9/B9ConfigSpec.hs new file mode 100644 --- /dev/null +++ b/src/tests/B9/B9ConfigSpec.hs @@ -0,0 +1,116 @@ +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE QuasiQuotes #-} + +module B9.B9ConfigSpec + ( spec, + ) +where + +import Data.Maybe (fromMaybe) +import Control.Lens ((^.)) +import B9.B9Config +import B9.B9Monad +import Control.Exception +import Control.Monad +import System.Directory +import System.Environment +import System.FilePath +import System.IO.B9Extras +import Test.Hspec(Spec, it, shouldBe, HasCallStack, describe) +import Test.QuickCheck (property, (===), (==>)) +import Text.Printf +import qualified Data.Text as Text +import Data.ConfigFile.B9Extras + ( + CPError + ) +import NeatInterpolation as Neat +import Data.Either (isRight) + +spec :: HasCallStack => Spec +spec = do + it "forall valid configs: parse . render == id" $ property $ + \cfg -> + let actual = renderThenParseB9Config cfg + in isRight actual ==> (Right cfg === actual) + + describe "parse textual configuration" $ do + let + exampleConfig = Text.unpack [Neat.text| + [global] + build_dir_root: Nothing + keep_temp_dirs: False + log_file: Nothing + max_cached_shared_images: Just 2 + repository: Nothing + repository_cache: Just (InB9UserDir "repo-cache") + unique_build_dirs: True + verbosity: Just LogNothing + timeout_factor: 3 + default_timeout_seconds: 10 + |] + it "correctly parses verbosity" $ do + cfg <- withConfig exampleConfig getB9Config + _verbosity cfg `shouldBe` Just LogNothing + + it "correctly parses timeout_factor" $ do + cfg <- withConfig exampleConfig getB9Config + _timeoutFactor cfg `shouldBe` Just 3 + + it "correctly parses default_timeout" $ do + cfg <- withConfig exampleConfig getB9Config + _defaultTimeout cfg `shouldBe` Just (TimeoutMicros 10_000_000) + +renderThenParseB9Config :: B9Config -> Either CPError B9Config +renderThenParseB9Config = b9ConfigToCPDocument >=> parseB9Config + +withConfig :: String -> B9 a -> IO a +withConfig cfgFileContents testAction = + withTempBuildDirs $ \cfg -> do + let cfgFileName = + fromMaybe + (error "Internal Error") + (cfg ^. customDefaulB9ConfigPath) + cfgFilePath <- resolve cfgFileName + writeFile cfgFilePath cfgFileContents + runB9ConfigActionWithOverrides (runB9 testAction) cfg + +withTempBuildDirs :: HasCallStack => (B9ConfigOverride -> IO a) -> IO a +withTempBuildDirs k = + bracket acquire release use + where + acquire = do + nixOutDirEnv <- lookupEnv "NIX_BUILD_TOP" + let rootDir = maybe InTempDir (((.) . (.)) Path ()) nixOutDirEnv + repoRelPath <- printf "testsRepositoryIOSpec-test-repo-%U" <$> randomUUID + buildRelPath <- printf "RepositoryIOSpec-root-%U" <$> randomUUID + cfgRelPath <- printf "RepositoryIOSpec-b9cfg-%U" <$> randomUUID + let tmpRepoPath = rootDir ("tests" repoRelPath) + tmpBuildPath = rootDir ("tests" buildRelPath) + tmpCfgPath = rootDir ("tests" cfgRelPath) + ensureSystemPath tmpRepoPath + ensureSystemPath tmpBuildPath + tmpBuildPathFileName <- resolve tmpBuildPath + return (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) + release (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = do + let cleanupTmpPath = removePathForcibly <=< resolve + cleanupTmpPath tmpRepoPath + cleanupTmpPath tmpCfgPath + removePathForcibly tmpBuildPathFileName + use (tmpRepoPath, tmpBuildPathFileName, tmpCfgPath) = + let mkCfg cfgIn = + cfgIn + { _repositoryCache = Just tmpRepoPath, + _projectRoot = Just tmpBuildPathFileName + } + oCfg = + overrideB9Config + mkCfg + ( overrideWorkingDirectory + tmpBuildPathFileName + ( overrideDefaultB9ConfigPath + tmpCfgPath + noB9ConfigOverride + ) + ) + in k oCfg