diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,21 @@ # Changelog for B9 +## 3.1.0 + +* Introduced `getVirtualSizeForRawImage`, `cmdStdout`, `hostCmdStdoutEither`, `HostCommandStdout`. +* More stable parsing of qemu-img info output in `getVirtualSizeForRawImage`. +* Fixes a bug were size files contain garbage if newer versions of qemu-img are used. + +## 3.0.0 + +* Run the libvirt_lxc builder in an artificial pseudo-terminal if b9c is run + outside a terminal. +* Relax version constraints for `hashable` dependency + +### Breaking Changes + +* Change B9 configuration API: Change the field to a list + ## 2.1.0 * Add a new config parameter for the default Ext4 file system attributes. diff --git a/CONTRIBUTORS b/CONTRIBUTORS --- a/CONTRIBUTORS +++ b/CONTRIBUTORS @@ -1,5 +1,6 @@ -Sven Heyll +sheyll lti2000 rusio sainth +typetetris diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -4,18 +4,20 @@ **NOTE: The feature list is not completely implemented yet!** -**When version 2 is released of b9, all features listed here can be expected to work.** +**NOTE: Sometimes the [CHANGELOG.md](./CHANGELOG.md) contains additional documentation!** ## Quick-Start ### Mission Statement -**B9** is an executable and a Haskell library, that consumes a Haskell term describing -the generation of VM-Images. +**B9** is an executable and a Haskell library, that consumes a Haskell +term describing the generation of VM-Images. -A few core `data` types form an EDSL, and `B9` contains functions to `read` and `show` then. +A few core `data` types form an EDSL, and describe virtual machine images. +`B9` contains a library as well as an executable to interpret the EDSL. -Such a term can then be stored into a **text file** and is interpreted by a **command line invokation**. +Such a term can then be stored into a **text file** and is interpreted +by a **command line invokation**. ### Installation @@ -23,12 +25,8 @@ * As **command line utility** in current directory: - $ nix-build -E 'import (fetchTarball https://github.com/sheyll/b9-vm-image-builder/archive/1.0.0.tar.gz) {}' + $ nix-env -f https://github.com/sheyll/b9-vm-image-builder/archive/3.1.0.tar.gz -iA b9c - Now the executable `b9c` is in `./result/bin/`: - - $ result/bin/b9c - ### Runtime dependencies To be able to use B9 install: 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: 2.1.0 +version: 3.1.0 synopsis: A tool and library for building virtual machine images. @@ -162,6 +162,7 @@ other-modules: Paths_b9 autogen-modules: Paths_b9 build-depends: ConfigFile >= 1.1.4 && < 1.2 + , async == 2.* , base64-bytestring == 1.* , bifunctors == 5.* @@ -170,11 +171,12 @@ , conduit-extra == 1.* , exceptions == 0.10.* , free >= 4.12 && < 6 - , hashable == 1.2.* + , hashable >= 1.2 && < 2 , monad-control == 1.* , mtl == 2.* , parallel >= 3.2 && < 4 , parsec >= 3.1 && < 4 + , posix-pty >= 0.2 && < 1 , pretty >= 1.1 && < 2 , pretty-show >= 1.6 && < 2 , random >= 1.1 && < 2 @@ -183,7 +185,7 @@ , template >= 0.2 && < 1 , time >= 1.6 && < 2 , transformers >= 0.5 && < 1 - + , unix >= 2.7 && < 3 executable b9c import: b9Extensions, b9Deps main-is: Main.hs diff --git a/src/cli/Main.hs b/src/cli/Main.hs --- a/src/cli/Main.hs +++ b/src/cli/Main.hs @@ -46,7 +46,7 @@ globals :: Parser B9ConfigOverride globals = toGlobalOpts - <$> optional + <$> many ( strOption ( help "Path to user's b9-configuration (default: ~/.b9/b9.conf)" <> short 'c' <> long "configuration-file" <> metavar "FILENAME" @@ -87,7 +87,7 @@ ) where toGlobalOpts :: - Maybe FilePath -> + [FilePath] -> Bool -> Bool -> Maybe FilePath -> 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 @@ -78,7 +78,7 @@ import Control.Eff.Reader.Lazy import Control.Eff.Writer.Lazy import Control.Exception -import Control.Lens as Lens ((<>~), (?~), (^.), makeLenses, set) +import Control.Lens as Lens ((<>~), (?~), (.~), (^.), makeLenses, set) import Control.Monad ((>=>), filterM) import Control.Monad.IO.Class import Data.ConfigFile.B9Extras @@ -97,7 +97,7 @@ ) import Data.Function (on) import Data.List (inits) -import Data.Maybe (fromMaybe) +import Data.Maybe (listToMaybe, fromMaybe) import Data.Monoid import Data.Semigroup as Semigroup hiding (Last (..)) import Data.Set (Set) @@ -256,7 +256,7 @@ -- This is useful, i.e. when dealing with command line parameters. data B9ConfigOverride = B9ConfigOverride - { _customB9ConfigPath :: Maybe SystemPath, + { _customB9ConfigPath :: [SystemPath], _customB9Config :: Endo B9Config, _customEnvironment :: Environment, _customDefaulB9ConfigPath :: Maybe SystemPath @@ -274,7 +274,7 @@ -- | 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 Nothing +noB9ConfigOverride = B9ConfigOverride [] mempty mempty Nothing makeLenses ''B9Config @@ -282,7 +282,7 @@ -- | Convenience utility to override the B9 configuration file path. overrideB9ConfigPath :: SystemPath -> B9ConfigOverride -> B9ConfigOverride -overrideB9ConfigPath p = customB9ConfigPath ?~ p +overrideB9ConfigPath p = customB9ConfigPath .~ [p] -- | Modify the runtime configuration. overrideB9Config :: (B9Config -> B9Config) -> B9ConfigOverride -> B9ConfigOverride @@ -365,10 +365,12 @@ (\v' -> name <.> showVersion (makeVersion v')) <$> reverse (inits myVer) (pathsToTry, pathsToCreate) = case configuredCfgPaths of - Just configuredCfgPath -> - (appendVersionVariations configuredCfgPath, Nothing) - Nothing -> + [] -> (appendVersionVariations defCfgPath, Just defCfgPath) + [configuredCfgPath] -> + (appendVersionVariations configuredCfgPath, Nothing) + (_:_:_) -> + (configuredCfgPaths, Nothing) existingCfgPaths <- filterM doesFileExist pathsToTry cfgPath <- case existingCfgPaths of @@ -399,7 +401,7 @@ (return Nothing) (either (error . printf "Internal configuration update error! Please report this: %s\n" . show) (return . Just)) cpExtErr - mapM_ (writeB9CPDocument (cfg ^. customB9ConfigPath)) cpExt + mapM_ (writeB9CPDocument (listToMaybe (cfg ^. customB9ConfigPath))) cpExt return res -- | Run a 'B9ConfigAction' using 'noB9ConfigOverride'. 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,12 +3,16 @@ -- @since 0.5.65 module B9.B9Exec ( cmd, + cmdStdout, cmdInteractive, hostCmdEither, + hostCmdStdoutEither, hostCmd, hostCmdStdIn, Timeout (..), + ptyCmdInteractive, HostCommandStdin (..), + HostCommandStdout (..), ) where @@ -17,20 +21,15 @@ import B9.B9Logging import B9.BuildInfo (BuildInfoReader, isInteractive) import qualified Conduit as CL -import Control.Concurrent +import Control.Concurrent (readMVar, newMVar, modifyMVar_, threadDelay, MVar) import Control.Concurrent.Async (Concurrently (..), race) import Control.Eff import qualified Control.Exception as ExcIO import Control.Lens (view) -import Control.Monad.IO.Class import Control.Monad.Trans.Control (control, embed_, restoreM) import qualified Data.ByteString as Strict -import Data.Conduit - ( (.|), - ConduitT, - Void, - runConduit, - ) +import qualified Data.ByteString.Lazy as Lazy +import qualified Data.ByteString.Builder as Strict import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.Process @@ -39,7 +38,17 @@ import qualified Data.Text as Text import GHC.Stack import System.Exit +import System.Posix.Terminal +import System.Posix.Types +import System.Posix.Pty +import Control.Applicative ((*>)) +import Control.Exception (try, IOException()) +import Data.Conduit (ConduitT, yield, (.|), runConduit, Void) +import Data.Conduit.Process (ClosedStream (..), streamingProcess, + waitForStreamingProcess) +import Control.Monad.IO.Class (liftIO) + -- | Execute the given shell command. -- -- If 'isInteractive' is true, the standard-in will be passed to the external command, @@ -91,6 +100,30 @@ Left e -> errorExitL ("SYSTEM COMMAND FAILED: " ++ show e) +-- | Execute the given shell command and collect its standard output. +-- +-- The command and the output is additionally 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 3.1.0 +cmdStdout :: + (HasCallStack, Member ExcB9 e, CommandIO e) => + String -> + Eff e Strict.ByteString +cmdStdout str = do + t <- view defaultTimeout <$> getB9Config + ok <- hostCmdStdoutEither HostCommandNoStdin HostCommandStdoutLogAndCapture str t + case ok of + Right (out, ExitSuccess) -> + return out + Right (_, e@(ExitFailure _)) -> + errorExitL ("SYSTEM COMMAND FAILED: " ++ show e) + Left e -> + errorExitL ("SYSTEM COMMAND FAILED: " ++ show e) + -- | Run a shell command defined by a string and optionally interrupt the command -- after a given time has elapsed. -- If the shell command did not exit with 'ExitSuccess', or the timer elapsed, @@ -175,6 +208,51 @@ Maybe Timeout -> Eff e (Either Timeout ExitCode) hostCmdEither inputSource cmdStr timeoutArg = do + hostCmdStdoutEither inputSource HostCommandStdoutLog cmdStr timeoutArg + +-- | Ways to process std-output. +-- +-- @since 3.1.0 +data HostCommandStdout a where + -- | Write std-out to the log sink. + HostCommandStdoutLog :: HostCommandStdout ExitCode + -- | Write std-out to the log sink, additionally collect and return it. + HostCommandStdoutLogAndCapture :: HostCommandStdout (Strict.ByteString, ExitCode) + +data HostCommandStdoutState a where + HostCommandStdoutStateLog :: HostCommandStdoutState ExitCode + HostCommandStdoutStateLogAndCapture :: MVar Strict.Builder -> HostCommandStdoutState (Strict.ByteString, ExitCode) + +emptyState :: (CommandIO e) => HostCommandStdout a -> Eff e (HostCommandStdoutState a) +emptyState HostCommandStdoutLog = return HostCommandStdoutStateLog +emptyState HostCommandStdoutLogAndCapture = liftIO (newMVar mempty) >>= return . HostCommandStdoutStateLogAndCapture + +-- | Run a shell command defined by a string and optionally interrupt the command +-- after a given time has elapsed. +-- This is only useful for non-interactive commands. +-- +-- Also provide the possibility to receive the stdout of the command. It of course be collected +-- in ram, so be sure the command doesn't have to much output. +-- +-- @since 3.1.0 +hostCmdStdoutEither :: + forall e a. + (CommandIO e) => + -- | A 'HostCommandStdin' to define standard input. + -- If the value is 'HostCommandInheritStdin' then + -- **also stdout and stderr** will be redirected to + -- the 'Inherited' file descriptors. + HostCommandStdin -> + -- | A 'HostCommandStdout' to define standard output. + -- No output will be returned in case of timeout or + -- 'HostComandStdin' being 'HostComandInheritStdin'. + HostCommandStdout a -> + -- | The shell command to execute. + String -> + -- | An optional 'Timeout' + Maybe Timeout -> + Eff e (Either Timeout a) +hostCmdStdoutEither inputSource outputSinkType cmdStr timeoutArg = do let tag = "[" ++ printHash cmdStr ++ "]" traceL $ "COMMAND " ++ tag ++ ": " ++ cmdStr tf <- fromMaybe 1 . view timeoutFactor <$> getB9Config @@ -190,23 +268,34 @@ (runInIO (go timeout tag)) ( \(e :: ExcIO.SomeException) -> do runInIO (errorL ("COMMAND " ++ tag ++ " interrupted: " ++ show e)) - runInIO (return (Right (ExitFailure 126) :: Either Timeout ExitCode)) + runInIO (return (wrapEmptyOutputResult outputSinkType (ExitFailure 126))) ) >>= restoreM where - go :: Maybe Timeout -> String -> Eff e (Either Timeout ExitCode) + wrapEmptyOutputResult :: HostCommandStdout a -> ExitCode -> Either Timeout a + wrapEmptyOutputResult HostCommandStdoutLog ec = Right ec + wrapEmptyOutputResult HostCommandStdoutLogAndCapture ec = Right (mempty, ec) + + wrapOutputResult :: HostCommandStdoutState a -> ExitCode -> Eff e a + wrapOutputResult HostCommandStdoutStateLog ec = return ec + wrapOutputResult (HostCommandStdoutStateLogAndCapture mvar) ec = do + value <- liftIO (readMVar mvar) + return (Lazy.toStrict (Strict.toLazyByteString value), ec) + + go :: Maybe Timeout -> String -> Eff e (Either Timeout a) go timeout tag = do - traceLC <- traceMsgProcessLogger tag errorLC <- errorMsgProcessLogger tag let timer t@(TimeoutMicros micros) = do threadDelay micros return t + stdoutState <- emptyState outputSinkType (cph, runCmd) <- case inputSource of HostCommandNoStdin -> do + outSink <- createStdoutSink stdoutState tag (ClosedStream, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr) let runCmd = runConcurrently - ( Concurrently (runConduit (cpOut .| runProcessLogger traceLC)) + ( Concurrently (runConduit (cpOut .| runStdoutSink outSink)) *> Concurrently (runConduit (cpErr .| runProcessLogger errorLC)) *> Concurrently (waitForStreamingProcess cph) ) @@ -216,10 +305,11 @@ let runCmd = waitForStreamingProcess cph return (cph, runCmd) HostCommandStdInConduit inputC -> do + outSink <- createStdoutSink stdoutState tag (stdIn, cpOut, cpErr, cph) <- streamingProcess (shell cmdStr) let runCmd = runConcurrently - ( Concurrently (runConduit (cpOut .| runProcessLogger traceLC)) + ( Concurrently (runConduit (cpOut .| runStdoutSink outSink)) *> Concurrently (runConduit (cpErr .| runProcessLogger errorLC)) *> Concurrently (runConduit (inputC .| stdIn)) *> Concurrently (waitForStreamingProcess cph) @@ -234,8 +324,64 @@ traceL $ "COMMAND FINISHED " ++ tag Right (ExitFailure ec) -> errorL $ "COMMAND FAILED EXIT CODE: " ++ show ec ++ " " ++ tag - return e + traverse (wrapOutputResult stdoutState) e +-- | Execute the given shell command in a newly created pseudo terminal, if necessary. +-- +-- @since 2.1.1 +ptyCmdInteractive :: + (HasCallStack, Member ExcB9 e, Member BuildInfoReader e, CommandIO e) => + Maybe Timeout -> + String -> + [String] -> + Eff e () +ptyCmdInteractive timeoutArg progName progArgs = do +-- isInATerm <- liftIO (queryTerminal (Fd 0)) + let cmdStr = unwords (progName: progArgs) +-- if isInATerm then cmdInteractive cmdStr +-- else do + let tag = "[" ++ printHash cmdStr ++ "]" + traceL $ "PTY-COMMAND " ++ tag ++ ": " ++ cmdStr + tf <- fromMaybe 1 . view timeoutFactor <$> getB9Config + timeout <- + fmap (TimeoutMicros . \(TimeoutMicros t) -> tf * t) + <$> maybe + (view defaultTimeout <$> getB9Config) + (return . Just) + timeoutArg + traceLC <- traceMsgProcessLogger tag + let timer t@(TimeoutMicros micros) = do + threadDelay micros + return t + + runCmd = liftIO $ do + (pty, procH) <- spawnWithPty Nothing True progName progArgs (80, 25) + let close = liftIO (do + cleanupProcess (Nothing, Nothing, Nothing, procH) + closePty pty) + output = runConduit $ fromProcess .| runProcessLogger traceLC + fromProcess = do + res <- liftIO (try (readPty pty)) + case res of + Left (_ :: IOException) -> do + close + Right d -> do + yield d + fromProcess + + runConcurrently $ + Concurrently output *> + Concurrently (waitForProcess procH) + + e <- liftIO (maybe (fmap Right) (race . timer) timeout runCmd) + case e of + Left _ -> + errorL $ "PTY-COMMAND TIMED OUT " ++ tag + Right ExitSuccess -> + traceL $ "PTY-COMMAND FINISHED " ++ tag + Right (ExitFailure ec) -> + errorL $ "PTY-COMMAND FAILED EXIT CODE: " ++ show ec ++ " " ++ tag + newtype ProcessLogger = MkProcessLogger {runProcessLogger :: ConduitT Strict.ByteString Void IO ()} @@ -260,3 +406,28 @@ .| CL.mapM_ (liftIO . logIO) ) ) + +newtype StdoutSink + = MkStdoutSink + {runStdoutSink :: ConduitT Strict.ByteString Void IO ()} + +createStdoutSink :: (CommandIO e) => HostCommandStdoutState a -> String -> Eff e StdoutSink +createStdoutSink HostCommandStdoutStateLog tag = traceMsgProcessLogger tag >>= return . MkStdoutSink . runProcessLogger +createStdoutSink (HostCommandStdoutStateLogAndCapture _stdoutCollector) _tag = do + logger <- runProcessLogger <$> traceMsgProcessLogger _tag + return + ( MkStdoutSink + ( CL.getZipSink + ( CL.ZipSink logger + *> CL.ZipSink (writeToMVar _stdoutCollector) + ) + ) + ) + where + writeToMVar mvar = do + chunk <- CL.await + case chunk of + Nothing -> return () + (Just val) -> liftIO $ modifyMVar_ mvar $ \old -> return (old <> Strict.byteString val) + + diff --git a/src/lib/B9/DiskImageBuilder.hs b/src/lib/B9/DiskImageBuilder.hs --- a/src/lib/B9/DiskImageBuilder.hs +++ b/src/lib/B9/DiskImageBuilder.hs @@ -15,6 +15,7 @@ convertImage, shareImage, ensureAbsoluteImageDirExists, + getVirtualSizeForRawImage ) where @@ -34,6 +35,8 @@ import Control.Lens (view, (^.)) import Control.Monad import Control.Monad.IO.Class +import qualified Data.ByteString.Char8 as Strict +import Data.Char (isDigit) import Data.Generics.Aliases import Data.Generics.Schemes import Data.List @@ -242,16 +245,30 @@ versFile = repo "machines" name "disks" "raw" "VERSION" exportAndRemoveImage buildImg destImg - cmd - ( printf - "echo $(qemu-img info -f raw '%s' | gawk -e '/virtual size/ {print $4}' | tr -d '(') > '%s'" - destFile - sizeFile - ) + eitherSize <- getVirtualSizeForRawImage destFile + case eitherSize of + Left err -> error err + Right value -> liftIO (writeFile sizeFile (show value)) buildDate <- getBuildDate buildId <- getBuildId liftIO (writeFile versFile (buildId ++ "-" ++ buildDate)) Transient -> return () + +-- | Determine the virtual size of a raw image +getVirtualSizeForRawImage :: (IsB9 e) => FilePath -> Eff e (Either String Integer) +getVirtualSizeForRawImage file = do + outPut <- cmdStdout (printf "qemu-img info -f raw '%s'" file) + return (getVirtualSizeFromQemuImgInfoOutput outPut) + +getVirtualSizeFromQemuImgInfoOutput :: Strict.ByteString -> Either String Integer +getVirtualSizeFromQemuImgInfoOutput qemuOutput = case filter (Strict.isPrefixOf (Strict.pack "virtual size")) (Strict.lines qemuOutput) of + [] -> Left ("no line starting with 'virtual size' in output while parsing " <> Strict.unpack qemuOutput) + (_ : _ : _) -> Left ("multiple lines starting with 'virtual size' in output" <> Strict.unpack qemuOutput) + [x] -> let (digits, rest) = (Strict.span isDigit . Strict.drop 1 . Strict.dropWhile (/= '(')) x + in + if Strict.isPrefixOf (Strict.pack " bytes)") rest + then Right (read (Strict.unpack digits)) + else Left ("rest after digits didn't continue in ' bytes)'" <> Strict.unpack qemuOutput) createEmptyImage :: IsB9 e => 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 @@ -80,15 +80,17 @@ execute :: (Member ExcB9 e, CommandIO e, Member BuildInfoReader e, Member B9ConfigReader e) => Context -> Eff e Bool execute (Context scriptDirHost _uuid domainFile cfg) = do - cmdInteractive $ printf "%s create '%s' --console --autodestroy" virshCommand domainFile + let (prog, args) = virshCommand + ptyCmdInteractive Nothing prog (args ++ ["create", domainFile, "--console", "--autodestroy"]) -- cmd $ printf "%s console %U" virsh uuid liftIO (doesFileExist $ scriptDirHost successMarkerFile) where - virshCommand :: String - virshCommand = printf "%svirsh -c %s" useSudo' virshURI' - where - useSudo' = if useSudo cfg then "sudo " else "" - virshURI' = virshURI cfg + virshCommand :: (String, [String]) + virshCommand = + if useSudo cfg then + ("sudo", ["virsh", "-c", virshURI cfg]) + else + ("virsh", ["-c", virshURI cfg]) data Context = Context diff --git a/src/tests/B9/DiskImageBuilderSpec.hs b/src/tests/B9/DiskImageBuilderSpec.hs --- a/src/tests/B9/DiskImageBuilderSpec.hs +++ b/src/tests/B9/DiskImageBuilderSpec.hs @@ -10,7 +10,17 @@ import Control.Arrow ((>>>)) spec :: Spec -spec = +spec = do + it "can extract the virtual size from qemu-img info output" $ do + e <- b9Wrapper [] $ do + d <- getBuildDir + let outFile = d "test.raw" + materializeImageSource + (EmptyImage "test" Ext4 Raw (ImageSize 10 MB)) + (Image outFile Raw Ext4) + getVirtualSizeForRawImage outFile + e `shouldBe` Right (10 * 1024 * 1024) + it "passes the mkfs.ext4 options defined in the B9Config" $ do let expectedOptions = ["^metadata_csum", "64bit"] actual <- b9Wrapper expectedOptions $ do