b9 2.1.0 → 3.1.0

raw patch · 10 files changed

+271/−52 lines, 10 filesdep +posix-ptydep +unixdep ~hashablePVP ok

version bump matches the API change (PVP)

Dependencies added: posix-pty, unix

Dependency ranges changed: hashable

API changes (from Hackage documentation)

Files

• CHANGELOG.md +16/−0
• CONTRIBUTORS +2/−1
• README.md +8/−10
• b9.cabal +5/−3
• src/cli/Main.hs +2/−2
• src/lib/B9/B9Config.hs +11/−9
• src/lib/B9/B9Exec.hs +185/−14
• src/lib/B9/DiskImageBuilder.hs +23/−6
• src/lib/B9/LibVirtLXC.hs +8/−6
• src/tests/B9/DiskImageBuilderSpec.hs +11/−1

@@ -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. 

@@ -1,5 +1,6 @@-Sven Heyll <svh@posteo.de>+sheyll lti2000 rusio sainth+typetetris 

@@ -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:

@@ -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

@@ -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 ->

@@ -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'.

@@ -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)++

@@ -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 =>

@@ -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

@@ -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