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
newtype NumVCPUs = NumVCPUs Int
newtype MiBMemory = MiBMemory Int
data AutoStart = AutoStart | NoAutoStart
data DiskImageType = Raw
installed :: Property DebianLike
installed = Apt.installed ["libvirt-clients", "virtinst"]
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"
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"]
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"]
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 -> []
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"
System ArchLinux _ -> Nothing
System (Debian _ _) _ -> Nothing
System (Buntish _) _ -> Nothing
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