-- | Maintainer: Sean Whitton module Propellor.Property.Libvirt ( NumVCPUs(..), MiBMemory(..), AutoStart(..), DiskImageType(..), installed, defaultNetworkAutostarted, defaultNetworkStarted, defined, ) where import Propellor.Base import Propellor.Types.Info import Propellor.Property.Chroot import Propellor.Property.DiskImage import qualified Propellor.Property.Apt as Apt import Utility.Split -- | The number of virtual CPUs to assign to the virtual machine newtype NumVCPUs = NumVCPUs Int -- | The number of MiB of memory to assign to the virtual machine newtype MiBMemory = MiBMemory Int -- | Whether the virtual machine should be started after it is defined, and at -- host system boot data AutoStart = AutoStart | NoAutoStart -- | Which type of disk image to build for the virtual machine data DiskImageType = Raw -- TODO: | QCow2 -- | Install basic libvirt components installed :: Property DebianLike installed = Apt.installed ["libvirt-clients", "virtinst", "libvirt-daemon", "libvirt-daemon-system"] -- | Ensure that the default libvirt network is set to autostart, and start it. -- -- On Debian, it is not started by default after installation of libvirt. defaultNetworkAutostarted :: Property DebianLike defaultNetworkAutostarted = autostarted `requires` installed `before` defaultNetworkStarted where autostarted = check (not <$> doesFileExist autostartFile) $ cmdProperty "virsh" ["net-autostart", "default"] autostartFile = "/etc/libvirt/qemu/networks/autostart/default.xml" -- | Ensure that the default libvirt network is started. defaultNetworkStarted :: Property DebianLike defaultNetworkStarted = go `requires` installed where go :: Property UnixLike go = property "start libvirt's default network" $ do runningNetworks <- liftIO $ virshGetColumns ["net-list"] if ["default"] `elem` (take 1 <$> runningNetworks) then noChange else makeChange $ unlessM startIt $ errorMessage "failed to start default network" startIt = boolSystem "virsh" [Param "net-start", Param "default"] -- | Builds a disk image with the properties of the given Host, installs a -- libvirt configuration file to boot the image, and if it is set to autostart, -- start the VM. -- -- Note that building the disk image happens only once. So if you change the -- properties of the given Host, this property will not modify the disk image. -- In order to later apply properties to the VM, you should spin it directly, or -- arrange to have it spun with a property like 'Cron.runPropellor', or use -- 'Propellor.Property.Conductor' from the VM host. -- -- Suggested usage in @config.hs@: -- -- > mybox = host "mybox.example.com" $ props -- > & osDebian (Stable "stretch") X86_64 -- > & Libvirt.defaultNetworkAutostarted -- > & Libvirt.defined Libvirt.Raw -- > (Libvirt.MiBMemory 2048) (Libvirt.NumVCPUs 2) -- > Libvirt.NoAutoStart subbox -- > -- > subbox = host "subbox.mybox.example.com" $ props -- > & osDebian Unstable X86_64 -- > & hasPartition -- > ( partition EXT4 -- > `mountedAt` "/" -- > `addFreeSpace` MegaBytes 10240 -- > ) -- > & Apt.installed ["linux-image-amd64"] -- > & Grub.installed PC -- > -- > & ipv4 "192.168.122.31" -- > & Network.static "ens3" (IPv4 "192.168.122.31") -- > (Just (Network.Gateway (IPv4 "192.168.122.1"))) -- > `requires` Network.cleanInterfacesFile -- > & Hostname.sane defined :: DiskImageType -> MiBMemory -> NumVCPUs -> AutoStart -> Host -> Property (HasInfo + DebianLike) defined imageType (MiBMemory mem) (NumVCPUs cpus) auto h = (built `before` nuked `before` xmlDefined `before` started) `requires` installed where built :: Property (HasInfo + DebianLike) built = check (not <$> doesFileExist imageLoc) $ setupRevertableProperty $ imageBuiltFor h (image) (Debootstrapped mempty) nuked :: Property UnixLike nuked = imageChrootNotPresent image xmlDefined :: Property UnixLike xmlDefined = check (not <$> doesFileExist conf) $ property "define the libvirt VM" $ withTmpFile (hostName h) $ \t fh -> do xml <- liftIO $ readProcess "virt-install" $ [ "-n", hostName h , "--memory=" ++ show mem , "--vcpus=" ++ show cpus , "--disk" , "path=" ++ imageLoc ++ ",device=disk,bus=virtio" , "--print-xml" ] ++ autoStartArg ++ osVariantArg liftIO $ hPutStrLn fh xml liftIO $ hClose fh makeChange $ unlessM (defineIt t) $ errorMessage "failed to define VM" where defineIt t = boolSystem "virsh" [Param "define", Param t] started :: Property UnixLike started = case auto of AutoStart -> property "start the VM" $ do runningVMs <- liftIO $ virshGetColumns ["list"] -- From the point of view of `virsh start`, the "State" -- column in the output of `virsh list` is not relevant. -- So long as the VM is listed, it's considered started. if [hostName h] `elem` (take 1 . drop 1 <$> runningVMs) then noChange else makeChange $ unlessM startIt $ errorMessage "failed to start VM" NoAutoStart -> doNothing where startIt = boolSystem "virsh" [Param "start", Param $ hostName h] image = case imageType of Raw -> RawDiskImage imageLoc imageLoc = "/var/lib/libvirt/images" hostName h <.> case imageType of Raw -> "img" conf = "/etc/libvirt/qemu" hostName h <.> "xml" osVariantArg = maybe [] (\v -> ["--os-variant=" ++ v]) $ osVariant h autoStartArg = case auto of AutoStart -> ["--autostart"] NoAutoStart -> [] -- ==== utility functions ==== -- The --os-variant property is optional, per virt-install(1), so return Nothing -- if there isn't a known correct value. The VM will still be defined. Pass -- the value if we can, though, to optimise the generated XML for the host's OS osVariant :: Host -> Maybe String osVariant h = hostSystem h >>= \s -> case s of System (Debian _ (Stable "jessie")) _ -> Just "debian8" System (Debian _ (Stable "stretch")) _ -> Just "debian9" System (Debian _ Testing) _ -> Just "debiantesting" System (Debian _ Unstable) _ -> Just "debiantesting" System (Buntish "trusty") _ -> Just "ubuntu14.04" System (Buntish "utopic") _ -> Just "ubuntu14.10" System (Buntish "vivid") _ -> Just "ubuntu15.04" System (Buntish "wily") _ -> Just "ubuntu15.10" System (Buntish "xenial") _ -> Just "ubuntu16.04" System (Buntish "yakkety") _ -> Just "ubuntu16.10" System (Buntish "zesty") _ -> Just "ubuntu17.04" System (Buntish "artful") _ -> Just "ubuntu17.10" System (Buntish "bionic") _ -> Just "ubuntu18.04" System (FreeBSD (FBSDProduction FBSD101)) _ -> Just "freebsd10.1" System (FreeBSD (FBSDProduction FBSD102)) _ -> Just "freebsd10.2" System (FreeBSD (FBSDProduction FBSD093)) _ -> Just "freebsd9.3" System (FreeBSD (FBSDLegacy FBSD101)) _ -> Just "freebsd10.1" System (FreeBSD (FBSDLegacy FBSD102)) _ -> Just "freebsd10.2" System (FreeBSD (FBSDLegacy FBSD093)) _ -> Just "freebsd9.3" -- libvirt doesn't have an archlinux variant yet, it seems System ArchLinux _ -> Nothing -- other stable releases that we don't know about (since there are -- infinitely many possible stable release names, as it is a freeform -- string, we need this to avoid a compiler warning) System (Debian _ _) _ -> Nothing System (Buntish _) _ -> Nothing -- Run a virsh command with the given list of arguments, that is expected to -- yield tabular output, and return the rows virshGetColumns :: [String] -> IO [[String]] virshGetColumns args = map (filter (not . null) . split " ") . drop 2 . lines <$> readProcess "virsh" args hostSystem :: Host -> Maybe System hostSystem = fromInfoVal . fromInfo . hostInfo