summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Libvirt.hs
blob: 053b60a65b925efdd57d376a30f09bff36cb7029 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
-- | 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"])
	`requires` installed
  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