diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -7,7 +7,7 @@ sources: - hvr-ghc packages: - - ghc-8.2.2 + - ghc-8.4.4 - genisoimage before_install: diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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` diff --git a/b9.cabal b/b9.cabal --- a/b9.cabal +++ b/b9.cabal @@ -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 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 @@ -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") 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 @@ -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 = - "\n " ++ - buildId ++ - "\n " ++ - uuid ++ - "\n " ++ - memoryAmount cfg e ++ - "\n " ++ - memoryAmount cfg e ++ - "\n " ++ - cpuCountStr e ++ - "\n \n \n " ++ - renderGuestCapabilityEntries cfg ++ - "\n \n \n \n exe\n " ++ - scriptDirGuest initScript ++ - "\n \n \n destroy\n restart\n destroy\n \n " ++ - emulator cfg ++ - "\n" ++ - unlines - (libVirtNetwork (_networkId cfg) ++ (fsImage <$> envImageMounts e) ++ (fsSharedDir <$> envSharedDirectories e)) ++ - "\n" ++ - " \n \n \n \n \n \n \n \n\n" +createDomain + :: MonadIO m + => LibVirtLXCConfig + -> ExecEnv + -> String + -> String + -> FilePath + -> FilePath + -> m String +createDomain cfg e buildId uuid scriptDirHost scriptDirGuest = do + emulatorPath <- getEmulatorPath cfg + pure + ( "\n " + ++ buildId + ++ "\n " + ++ uuid + ++ "\n " + ++ memoryAmount cfg e + ++ "\n " + ++ memoryAmount cfg e + ++ "\n " + ++ cpuCountStr e + ++ "\n \n \n " + ++ renderGuestCapabilityEntries cfg + ++ "\n \n \n \n exe\n " + ++ scriptDirGuest + initScript + ++ "\n \n \n destroy\n restart\n destroy\n \n " + ++ emulatorPath + ++ "\n" + ++ unlines + ( libVirtNetwork (_networkId cfg) + ++ (fsImage <$> envImageMounts e) + ++ (fsSharedDir <$> envSharedDirectories e) + ) + ++ "\n" + ++ " \n \n \n \n \n \n \n \n\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) = ["", " ", ""] +libVirtNetwork (Just n) = + [ "" + , " " + , "" + ] fsImage :: (Image, MountPoint) -> String -fsImage (img, mnt) = - case fsTarget mnt of - Just mntXml -> - "\n " ++ - fsImgDriver img ++ "\n " ++ fsImgSource img ++ "\n " ++ mntXml ++ "\n" - Nothing -> "" - where - fsImgDriver (Image _img fmt _fs) = printf "" 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) = "" +fsImage (img, mnt) = case fsTarget mnt of + Just mntXml -> + "\n " + ++ fsImgDriver img + ++ "\n " + ++ fsImgSource img + ++ "\n " + ++ mntXml + ++ "\n" + Nothing -> "" + where + fsImgDriver (Image _img fmt _fs) = printf "" 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) = "" fsSharedDir :: SharedDirectory -> String -fsSharedDir (SharedDirectory hostDir mnt) = - case fsTarget mnt of - Just mntXml -> - "\n " ++ "" ++ "\n " ++ mntXml ++ "\n" - Nothing -> "" -fsSharedDir (SharedDirectoryRO hostDir mnt) = - case fsTarget mnt of - Just mntXml -> - "\n " ++ - "" ++ "\n " ++ mntXml ++ "\n \n" - Nothing -> "" +fsSharedDir (SharedDirectory hostDir mnt) = case fsTarget mnt of + Just mntXml -> + "\n " + ++ "" + ++ "\n " + ++ mntXml + ++ "\n" + Nothing -> "" +fsSharedDir (SharedDirectoryRO hostDir mnt) = case fsTarget mnt of + Just mntXml -> + "\n " + ++ "" + ++ "\n " + ++ mntXml + ++ "\n \n" + Nothing -> "" fsSharedDir (SharedSources _) = error "Unreachable code reached!" fsTarget :: MountPoint -> Maybe String fsTarget (MountPoint dir) = Just $ "" -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