summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Libvirt.hs
blob: 71f59d6544fbf7cb18c9efed4bf3cd6e5e5bc2ee (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
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
-- | Maintainer: Sean Whitton <spwhitton@spwhitton.name>

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