b9 0.5.65 → 0.5.66

raw patch · 5 files changed

+253/−189 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• .travis.yml +1/−1
• CHANGELOG.md +14/−7
• b9.cabal +2/−2
• src/lib/B9/B9Config/LibVirtLXC.hs +57/−38
• src/lib/B9/LibVirtLXC.hs +179/−141

@@ -7,7 +7,7 @@     sources:     - hvr-ghc     packages:-    - ghc-8.2.2+    - ghc-8.4.4     - genisoimage  before_install:

@@ -1,5 +1,13 @@ # Changelog for B9 +## 0.5.66++* Fix the Nix package:++  * Get rid of the virsh path configuration item++  * Allow setting the path to @/.../libexec/libvirt_lxc@ via environment variable+ ## 0.5.65  * Refactor the B9 Monad to use `extensible-effects`@@ -21,11 +29,9 @@  * Replace `ConcatableSyntax` by using `Binary` instances, and also -    * Remove/Inline `encodeSyntax` by using `Binary.encode`--    * Rename `decodeSyntax` to `decodeOrFail'` and delegate-      to `Binary.decodeOrFail`.+  * Remove/Inline `encodeSyntax` by using `Binary.encode` +  * Rename `decodeSyntax` to `decodeOrFail'` and delegate to `Binary.decodeOrFail`.  * Add a newtype wrapper around `YamlObject` for **cloud-init** yaml documents   `CloudConfigYaml`@@ -47,7 +53,7 @@ * Introduce the type `Environment` that replaces the ubiquotus `[(String, String)]`   by a lazy `Text` based `HashMap`. -     * Add `addLocalPositionalArguments`+* Add `addLocalPositionalArguments`  * Rename the previous `B9.Artifact.Content` to `B9.Artifact.Content` @@ -69,6 +75,7 @@ * Rename `FromAST` to `FromAST`  * Rearrange modules for content generation:-   - Introduce `Content.FromByteString` -* Remove deprecated `Concatenation`+  * Introduce `Content.FromByteString`++  * Remove deprecated `Concatenation`

@@ -1,5 +1,5 @@ name:                b9-version:             0.5.65+version:             0.5.66  synopsis:            A tool and library for building virtual machine images. @@ -60,7 +60,7 @@                    , CONTRIBUTING.md                    , CODE_OF_CONDUCT.md                    , CHANGELOG.md-cabal-version:       >=1.22+cabal-version:     1.22  source-repository head   type:                 git

@@ -5,17 +5,20 @@   , LibVirtLXCConfig(..)   , networkId   , LXCGuestCapability(..)-  ) where+  , getEmulatorPath+  )+where -import B9.DiskImages-import B9.ExecEnv-import Control.Lens (makeLenses)-import Data.ConfigFile.B9Extras+import           B9.DiskImages+import           B9.ExecEnv+import           Control.Lens                   ( makeLenses )+import           Data.ConfigFile.B9Extras+import           Control.Monad.IO.Class+import           System.Environment.Blank      as SysIO  data LibVirtLXCConfig = LibVirtLXCConfig   { useSudo :: Bool-  , virshPath :: FilePath-  , emulator :: FilePath+  , emulator :: Maybe FilePath   , virshURI :: FilePath   , _networkId :: Maybe String   , guestCapabilities :: [LXCGuestCapability]@@ -68,24 +71,22 @@ makeLenses ''LibVirtLXCConfig  defaultLibVirtLXCConfig :: LibVirtLXCConfig-defaultLibVirtLXCConfig =-  LibVirtLXCConfig-    True-    "/usr/bin/virsh"-    "/usr/lib/libvirt/libvirt_lxc"-    "lxc:///"-    Nothing-    [ CAP_MKNOD-    , CAP_SYS_ADMIN-    , CAP_SYS_CHROOT-    , CAP_SETGID-    , CAP_SETUID-    , CAP_NET_BIND_SERVICE-    , CAP_SETPCAP-    , CAP_SYS_PTRACE-    , CAP_SYS_MODULE-    ]-    (RamSize 1 GB)+defaultLibVirtLXCConfig = LibVirtLXCConfig+  True+  (Just "/usr/lib/libvirt/libvirt_lxc")+  "lxc:///"+  Nothing+  [ CAP_MKNOD+  , CAP_SYS_ADMIN+  , CAP_SYS_CHROOT+  , CAP_SETGID+  , CAP_SETUID+  , CAP_NET_BIND_SERVICE+  , CAP_SETPCAP+  , CAP_SYS_PTRACE+  , CAP_SYS_MODULE+  ]+  (RamSize 1 GB)  cfgFileSection :: String cfgFileSection = "libvirt-lxc"@@ -93,12 +94,14 @@ useSudoK :: String useSudoK = "use_sudo" -virshPathK :: String-virshPathK = "virsh_path"- emulatorK :: String emulatorK = "emulator_path" +-- NOTE: This variable name is also specified in the NIX build+-- in @default.nix@.+emulatorEnvVar :: String+emulatorEnvVar = "B9_LIBVIRT_LXC"+ virshURIK :: String virshURIK = "connection" @@ -111,21 +114,37 @@ guestRamSizeK :: String guestRamSizeK = "guest_ram_size" -libVirtLXCConfigToCPDocument :: LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument+libVirtLXCConfigToCPDocument+  :: LibVirtLXCConfig -> CPDocument -> Either CPError CPDocument libVirtLXCConfigToCPDocument c cp = do   cp1 <- addSectionCP cp cfgFileSection   cp2 <- setShowCP cp1 cfgFileSection useSudoK $ useSudo c-  cp3 <- setCP cp2 cfgFileSection virshPathK $ virshPath c-  cp4 <- setCP cp3 cfgFileSection emulatorK $ emulator c-  cp5 <- setCP cp4 cfgFileSection virshURIK $ virshURI c-  cp6 <- setShowCP cp5 cfgFileSection networkIdK $ _networkId c-  cp7 <- setShowCP cp6 cfgFileSection guestCapabilitiesK $ guestCapabilities c-  setShowCP cp7 cfgFileSection guestRamSizeK $ guestRamSize c+  cp3 <- setShowCP cp2 cfgFileSection emulatorK $ emulator c+  cp4 <- setCP cp3 cfgFileSection virshURIK $ virshURI c+  cp5 <- setShowCP cp4 cfgFileSection networkIdK $ _networkId c+  cp6 <- setShowCP cp5 cfgFileSection guestCapabilitiesK $ guestCapabilities c+  setShowCP cp6 cfgFileSection guestRamSizeK $ guestRamSize c  parseLibVirtLXCConfig :: CPDocument -> Either CPError LibVirtLXCConfig parseLibVirtLXCConfig cp =   let getr :: (CPGet a) => CPOptionSpec -> Either CPError a       getr = readCP cp cfgFileSection-   in LibVirtLXCConfig <$> getr useSudoK <*> getr virshPathK <*> getr emulatorK <*> getr virshURIK <*> getr networkIdK <*>-      getr guestCapabilitiesK <*>-      getr guestRamSizeK+  in  LibVirtLXCConfig+        <$> getr useSudoK+        <*> getr emulatorK+        <*> getr virshURIK+        <*> getr networkIdK+        <*> getr guestCapabilitiesK+        <*> getr guestRamSizeK++-- | Return the path to @/usr/lib/libvirt/libexec/libvirt_lxc@+--  the 'emulatorK' field from the config file, or set the path+-- in the environment variable named like the value in 'emulatorEnvVar'+-- dictates.+--+-- @since 0.5.66+getEmulatorPath :: MonadIO m => LibVirtLXCConfig -> m FilePath+getEmulatorPath cfg = maybe fromEnv return (emulator cfg)+ where+  fromEnv =+    liftIO (SysIO.getEnvDefault emulatorEnvVar "/usr/lib/libexec/libvirt_lxc")

@@ -4,24 +4,29 @@   , supportedImageTypes   , logLibVirtLXCConfig   , module X-  ) where+  )+where -import B9.B9Config (getB9Config, libVirtLXCConfigs)-import B9.B9Config.LibVirtLXC as X-import B9.B9Exec-import B9.B9Logging-import B9.BuildInfo-import B9.DiskImages-import B9.ExecEnv-import B9.ShellScript-import Control.Eff-import Control.Lens (view)-import Control.Monad.IO.Class (liftIO)-import Data.Char (toLower)-import System.Directory-import System.FilePath-import System.IO.B9Extras (UUID(), randomUUID)-import Text.Printf (printf)+import           B9.B9Config                    ( getB9Config+                                                , libVirtLXCConfigs+                                                )+import           B9.B9Config.LibVirtLXC        as X+import           B9.B9Exec+import           B9.B9Logging+import           B9.BuildInfo+import           B9.DiskImages+import           B9.ExecEnv+import           B9.ShellScript+import           Control.Eff+import           Control.Lens                   ( view )+import           Control.Monad.IO.Class         ( MonadIO, liftIO )+import           Data.Char                      ( toLower )+import           System.Directory+import           System.FilePath+import           System.IO.B9Extras             ( UUID()+                                                , randomUUID+                                                )+import           Text.Printf                    ( printf )  logLibVirtLXCConfig :: CommandIO e => LibVirtLXCConfig -> Eff e () logLibVirtLXCConfig c = traceL $ printf "USING LibVirtLXCConfig: %s" (show c)@@ -29,52 +34,55 @@ supportedImageTypes :: [ImageType] supportedImageTypes = [Raw] -runInEnvironment ::-     forall e. (Member BuildInfoReader e, CommandIO e)+runInEnvironment+  :: forall e+   . (Member BuildInfoReader e, CommandIO e)   => ExecEnv   -> Script   -> Eff e Bool-runInEnvironment env scriptIn =-  if emptyScript scriptIn-    then return True-    else setUp >>= execute-  where-    setUp = do-      mcfg <- view libVirtLXCConfigs <$> getB9Config-      cfg <- maybe (fail "No LibVirtLXC Configuration!") return mcfg-      buildId <- getBuildId-      buildBaseDir <- getBuildDir-      uuid <- randomUUID-      let scriptDirHost = buildDir </> "init-script"-          scriptDirGuest = "/" ++ buildId-          domainFile = buildBaseDir </> uuid' <.> domainConfig-          domain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest-          uuid' = printf "%U" uuid-          setupEnv = Begin [Run "export" ["HOME=/root"], Run "export" ["USER=root"], Run "source" ["/etc/profile"]]-          script = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]-          buildDir = buildBaseDir </> uuid'-      liftIO $ do-        createDirectoryIfMissing True scriptDirHost-        writeSh (scriptDirHost </> initScript) script-        writeFile domainFile domain-      return $ Context scriptDirHost uuid domainFile cfg-    successMarkerCmd scriptDirGuest = In scriptDirGuest [Run "touch" [successMarkerFile]]-    execute :: Context -> Eff e Bool-    execute (Context scriptDirHost _uuid domainFile cfg) = do-      let virsh = virshCommand cfg-      cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile-    -- cmd $ printf "%s console %U" virsh uuid-      liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)-    successMarkerFile = "SUCCESS"-    virshCommand :: LibVirtLXCConfig -> String-    virshCommand cfg = printf "%s%s -c %s" useSudo' virshPath' virshURI'-      where-        useSudo' =-          if useSudo cfg-            then "sudo "-            else ""-        virshPath' = virshPath cfg-        virshURI' = virshURI cfg+runInEnvironment env scriptIn = if emptyScript scriptIn+  then return True+  else setUp >>= execute+ where+  setUp = do+    mcfg         <- view libVirtLXCConfigs <$> getB9Config+    cfg          <- maybe (fail "No LibVirtLXC Configuration!") return mcfg+    buildId      <- getBuildId+    buildBaseDir <- getBuildDir+    uuid         <- randomUUID+    let+      scriptDirHost  = buildDir </> "init-script"+      scriptDirGuest = "/" ++ buildId+      domainFile     = buildBaseDir </> uuid' <.> domainConfig+      mkDomain = createDomain cfg env buildId uuid' scriptDirHost scriptDirGuest+      uuid'          = printf "%U" uuid+      setupEnv       = Begin+        [ Run "export" ["HOME=/root"]+        , Run "export" ["USER=root"]+        , Run "source" ["/etc/profile"]+        ]+      script   = Begin [setupEnv, scriptIn, successMarkerCmd scriptDirGuest]+      buildDir = buildBaseDir </> uuid'+    liftIO $ do+      createDirectoryIfMissing True scriptDirHost+      writeSh (scriptDirHost </> initScript) script+      domain <- mkDomain+      writeFile domainFile domain+    return $ Context scriptDirHost uuid domainFile cfg+  successMarkerCmd scriptDirGuest =+    In scriptDirGuest [Run "touch" [successMarkerFile]]+  execute :: Context -> Eff e Bool+  execute (Context scriptDirHost _uuid domainFile cfg) = do+    let virsh = virshCommand cfg+    cmd $ printf "%s create '%s' --console --autodestroy" virsh domainFile+  -- cmd $ printf "%s console %U" virsh uuid+    liftIO (doesFileExist $ scriptDirHost </> successMarkerFile)+  successMarkerFile = "SUCCESS"+  virshCommand :: LibVirtLXCConfig -> String+  virshCommand cfg = printf "%svirsh -c %s" useSudo' virshURI'+   where+    useSudo'   = if useSudo cfg then "sudo " else ""+    virshURI'  = virshURI cfg  data Context =   Context FilePath@@ -88,109 +96,139 @@ domainConfig :: String domainConfig = "domain.xml" -createDomain :: LibVirtLXCConfig -> ExecEnv -> String -> String -> FilePath -> FilePath -> String-createDomain cfg e buildId uuid scriptDirHost scriptDirGuest =-  "<domain type='lxc'>\n  <name>" ++-  buildId ++-  "</name>\n  <uuid>" ++-  uuid ++-  "</uuid>\n  <memory unit='" ++-  memoryUnit cfg e ++-  "'>" ++-  memoryAmount cfg e ++-  "</memory>\n  <currentMemory unit='" ++-  memoryUnit cfg e ++-  "'>" ++-  memoryAmount cfg e ++-  "</currentMemory>\n  <vcpu placement='static'>" ++-  cpuCountStr e ++-  "</vcpu>\n  <features>\n   <capabilities policy='default'>\n     " ++-  renderGuestCapabilityEntries cfg ++-  "\n   </capabilities>\n  </features>\n  <os>\n    <type arch='" ++-  osArch e ++-  "'>exe</type>\n    <init>" ++-  scriptDirGuest </> initScript ++-  "</init>\n  </os>\n  <clock offset='utc'/>\n  <on_poweroff>destroy</on_poweroff>\n  <on_reboot>restart</on_reboot>\n  <on_crash>destroy</on_crash>\n  <devices>\n    <emulator>" ++-  emulator cfg ++-  "</emulator>\n" ++-  unlines-    (libVirtNetwork (_networkId cfg) ++ (fsImage <$> envImageMounts e) ++ (fsSharedDir <$> envSharedDirectories e)) ++-  "\n" ++-  "    <filesystem type='mount'>\n      <source dir='" ++-  scriptDirHost ++-  "'/>\n      <target dir='" ++-  scriptDirGuest ++-  "'/>\n    </filesystem>\n    <console>\n      <target type='lxc' port='0'/>\n    </console>\n  </devices>\n</domain>\n"+createDomain+  :: MonadIO m+  => LibVirtLXCConfig+  -> ExecEnv+  -> String+  -> String+  -> FilePath+  -> FilePath+  -> m String+createDomain cfg e buildId uuid scriptDirHost scriptDirGuest = do+ emulatorPath <- getEmulatorPath cfg+ pure+  (   "<domain type='lxc'>\n  <name>"+  ++  buildId+  ++  "</name>\n  <uuid>"+  ++  uuid+  ++  "</uuid>\n  <memory unit='"+  ++  memoryUnit cfg e+  ++  "'>"+  ++  memoryAmount cfg e+  ++  "</memory>\n  <currentMemory unit='"+  ++  memoryUnit cfg e+  ++  "'>"+  ++  memoryAmount cfg e+  ++  "</currentMemory>\n  <vcpu placement='static'>"+  ++  cpuCountStr e+  ++  "</vcpu>\n  <features>\n   <capabilities policy='default'>\n     "+  ++  renderGuestCapabilityEntries cfg+  ++  "\n   </capabilities>\n  </features>\n  <os>\n    <type arch='"+  ++  osArch e+  ++  "'>exe</type>\n    <init>"+  ++  scriptDirGuest+  </> initScript+  ++ "</init>\n  </os>\n  <clock offset='utc'/>\n  <on_poweroff>destroy</on_poweroff>\n  <on_reboot>restart</on_reboot>\n  <on_crash>destroy</on_crash>\n  <devices>\n    <emulator>"+  ++  emulatorPath+  ++  "</emulator>\n"+  ++  unlines+        (  libVirtNetwork (_networkId cfg)+        ++ (fsImage <$> envImageMounts e)+        ++ (fsSharedDir <$> envSharedDirectories e)+        )+  ++  "\n"+  ++  "    <filesystem type='mount'>\n      <source dir='"+  ++  scriptDirHost+  ++  "'/>\n      <target dir='"+  ++  scriptDirGuest+  ++ "'/>\n    </filesystem>\n    <console>\n      <target type='lxc' port='0'/>\n    </console>\n  </devices>\n</domain>\n"+  ) + renderGuestCapabilityEntries :: LibVirtLXCConfig -> String renderGuestCapabilityEntries = unlines . map render . guestCapabilities-  where-    render :: LXCGuestCapability -> String-    render cap =-      let capStr = toLower <$> drop (length "CAP_") (show cap)-       in printf "<%s state='on'/>" capStr+ where+  render :: LXCGuestCapability -> String+  render cap =+    let capStr = toLower <$> drop (length "CAP_") (show cap)+    in  printf "<%s state='on'/>" capStr  osArch :: ExecEnv -> String-osArch e =-  case cpuArch (envResources e) of-    X86_64 -> "x86_64"-    I386 -> "i686"+osArch e = case cpuArch (envResources e) of+  X86_64 -> "x86_64"+  I386   -> "i686"  libVirtNetwork :: Maybe String -> [String] libVirtNetwork Nothing = []-libVirtNetwork (Just n) = ["<interface type='network'>", "  <source network='" ++ n ++ "'/>", "</interface>"]+libVirtNetwork (Just n) =+  [ "<interface type='network'>"+  , "  <source network='" ++ n ++ "'/>"+  , "</interface>"+  ]  fsImage :: (Image, MountPoint) -> String-fsImage (img, mnt) =-  case fsTarget mnt of-    Just mntXml ->-      "<filesystem type='file' accessmode='passthrough'>\n  " ++-      fsImgDriver img ++ "\n  " ++ fsImgSource img ++ "\n  " ++ mntXml ++ "\n</filesystem>"-    Nothing -> ""-  where-    fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" driver fmt'-      where-        (driver, fmt') =-          case fmt of-            Raw -> ("type='loop'", "format='raw'")-            QCow2 -> ("type='nbd'", "format='qcow2'")-            Vmdk -> ("type='nbd'", "format='vmdk'")-    fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"+fsImage (img, mnt) = case fsTarget mnt of+  Just mntXml ->+    "<filesystem type='file' accessmode='passthrough'>\n  "+      ++ fsImgDriver img+      ++ "\n  "+      ++ fsImgSource img+      ++ "\n  "+      ++ mntXml+      ++ "\n</filesystem>"+  Nothing -> ""+ where+  fsImgDriver (Image _img fmt _fs) = printf "<driver %s %s/>" driver fmt'+   where+    (driver, fmt') = case fmt of+      Raw   -> ("type='loop'", "format='raw'")+      QCow2 -> ("type='nbd'", "format='qcow2'")+      Vmdk  -> ("type='nbd'", "format='vmdk'")+  fsImgSource (Image src _fmt _fs) = "<source file='" ++ src ++ "'/>"  fsSharedDir :: SharedDirectory -> String-fsSharedDir (SharedDirectory hostDir mnt) =-  case fsTarget mnt of-    Just mntXml ->-      "<filesystem type='mount'>\n  " ++ "<source dir='" ++ hostDir ++ "'/>" ++ "\n  " ++ mntXml ++ "\n</filesystem>"-    Nothing -> ""-fsSharedDir (SharedDirectoryRO hostDir mnt) =-  case fsTarget mnt of-    Just mntXml ->-      "<filesystem type='mount'>\n  " ++-      "<source dir='" ++ hostDir ++ "'/>" ++ "\n  " ++ mntXml ++ "\n  <readonly />\n</filesystem>"-    Nothing -> ""+fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of+  Just mntXml ->+    "<filesystem type='mount'>\n  "+      ++ "<source dir='"+      ++ hostDir+      ++ "'/>"+      ++ "\n  "+      ++ mntXml+      ++ "\n</filesystem>"+  Nothing -> ""+fsSharedDir (SharedDirectoryRO hostDir mnt) = case fsTarget mnt of+  Just mntXml ->+    "<filesystem type='mount'>\n  "+      ++ "<source dir='"+      ++ hostDir+      ++ "'/>"+      ++ "\n  "+      ++ mntXml+      ++ "\n  <readonly />\n</filesystem>"+  Nothing -> "" fsSharedDir (SharedSources _) = error "Unreachable code reached!"  fsTarget :: MountPoint -> Maybe String fsTarget (MountPoint dir) = Just $ "<target dir='" ++ dir ++ "'/>"-fsTarget _ = Nothing+fsTarget _                = Nothing  memoryUnit :: LibVirtLXCConfig -> ExecEnv -> String memoryUnit cfg = toUnit . maxMemory . envResources-  where-    toUnit AutomaticRamSize = toUnit (guestRamSize cfg)-    toUnit (RamSize _ u) =-      case u of-        GB -> "GiB"-        MB -> "MiB"-        KB -> "KiB"-        B -> "B"+ where+  toUnit AutomaticRamSize = toUnit (guestRamSize cfg)+  toUnit (RamSize _ u)    = case u of+    GB -> "GiB"+    MB -> "MiB"+    KB -> "KiB"+    B  -> "B"  memoryAmount :: LibVirtLXCConfig -> ExecEnv -> String memoryAmount cfg = show . toAmount . maxMemory . envResources-  where-    toAmount AutomaticRamSize = toAmount (guestRamSize cfg)-    toAmount (RamSize n _) = n+ where+  toAmount AutomaticRamSize = toAmount (guestRamSize cfg)+  toAmount (RamSize n _)    = n  cpuCountStr :: ExecEnv -> String cpuCountStr = show . cpuCount . envResources