summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Property/Libvirt.hs98
2 files changed, 99 insertions, 0 deletions
diff --git a/propellor.cabal b/propellor.cabal
index 0454fc92..d021a300 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -101,6 +101,7 @@ Library
Propellor.Property.Kerberos
Propellor.Property.Laptop
Propellor.Property.LetsEncrypt
+ Propellor.Property.Libvirt
Propellor.Property.List
Propellor.Property.LightDM
Propellor.Property.Locale
diff --git a/src/Propellor/Property/Libvirt.hs b/src/Propellor/Property/Libvirt.hs
new file mode 100644
index 00000000..0f4c274c
--- /dev/null
+++ b/src/Propellor/Property/Libvirt.hs
@@ -0,0 +1,98 @@
+-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>
+
+module Propellor.Property.Libvirt (
+ installed,
+ defaultNetworkAutostarted,
+ kvmDefined,
+) where
+
+import Propellor.Base
+import Propellor.Types.Info
+import Propellor.Property.Chroot
+import Propellor.Property.DiskImage
+import Propellor.Property.Chroot.Util (removeChroot)
+import qualified Propellor.Property.Apt as Apt
+
+type NumVCPUs = Int
+type MiBMemory = Int
+data AutoStart = AutoStart | NoAutoStart
+data DiskImageType = Raw | QCow2
+
+installed :: Property DebianLike
+installed = Apt.installed ["libvirt-clients", "virtinst"]
+
+defaultNetworkAutostarted :: Property UnixLike
+defaultNetworkAutostarted = check (not <$> doesFileExist autostartFile)
+ (cmdProperty "virsh" ["net-autostart", "default"])
+ where
+ autostartFile = "/etc/libvirt/qemu/networks/autostart/default.xml"
+
+kvmDefined
+ :: DiskImageType
+ -> MiBMemory
+ -> NumVCPUs
+ -> AutoStart
+ -> Host
+ -> Property (HasInfo + DebianLike)
+kvmDefined imageType mem cpus auto h =
+ (built `before` nuked `before` defined `before` started)
+ `requires` installed
+ where
+ built :: Property (HasInfo + DebianLike)
+ built = check (not <$> doesFileExist imageLoc)
+ (setupRevertableProperty $ imageBuiltFor h
+ (image) (Debootstrapped mempty))
+ nuked :: Property UnixLike
+ nuked = property "destroy the chroot used to build the image" $ do
+ liftIO $ removeChroot (imageLoc <.> "chroot")
+ liftIO $ nukeFile (imageLoc <.> "parttable")
+ return MadeChange
+ defined :: Property UnixLike
+ defined = check (not <$> doesFileExist conf)
+ (scriptProperty
+ [ "virt-install -n " ++ hostName h
+ ++ osTypeArg ++ osVariantArg
+ ++ " --memory=" ++ show mem
+ ++ " --vcpus=" ++ show cpus
+ ++ " --disk path=" ++ imageLoc
+ ++ ",device=disk,bus=virtio"
+ ++ autoStartArg
+ ++ " --print-xml"
+ ++ " >" ++ confTmp
+ , "virsh define " ++ confTmp
+ , "rm " ++ confTmp
+ ])
+ started :: Property UnixLike
+ started = case AutoStart of
+ AutoStart -> cmdProperty "virsh" ["start", hostName h]
+ `assume` MadeChange
+ NoAutoStart -> doNothing
+
+ image = case imageType of
+ Raw -> RawDiskImage imageLoc
+ imageLoc =
+ "/var/lib/libvirt/images" </> hostName h <.> case imageType of
+ Raw -> "xml"
+ conf = "/etc/libvirt/qemu" </> hostName h <.> "xml"
+ confTmp = conf <.> "tmp"
+
+ osTypeArg = maybe "" ("--os-type=" ++) $ osType h
+ osVariantArg = maybe "" ("--os-variant=" ++) $ osVariant h
+ autoStartArg = case auto of
+ AutoStart -> " --autostart"
+ NoAutoStart -> ""
+
+osType :: Host -> Maybe String
+osType h = hostSystem h >>= \s -> case s of
+ System (Debian Linux _) _ -> Just "Linux"
+ System (Buntish _) _ -> Just "Linux"
+ System ArchLinux _ -> Just "Linux"
+ _ -> Nothing
+
+osVariant :: Host -> Maybe String
+osVariant h = hostSystem h >>= \s -> case s of
+ System (Debian _ (Stable "stretch")) _ -> Just "debian9"
+ _ -> Nothing
+
+hostSystem :: Host -> Maybe System
+hostSystem = fromInfoVal . fromInfo . hostInfo