summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Grub.hs
blob: 79ecd8c95ea5ae82161236d54bde0ee944f4250a (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
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
module Propellor.Property.Grub (
	GrubDevice,
	OSDevice,
	GrubTarget(..),
	installed,
	mkConfig,
	installed',
	configured,
	cmdline_Linux_default,
	boots,
	bootsMounted,
	TimeoutSecs,
	chainPVGrub
) where

import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.ConfFile as ConfFile
import qualified Propellor.Property.Apt as Apt
import Propellor.Property.Mount
import Propellor.Property.Chroot (inChroot)
import Propellor.Types.Info
import Propellor.Types.Bootloader
import Utility.SafeCommand

import Data.List

-- | Eg, \"hd0,0\" or \"xen/xvda1\"
type GrubDevice = String

-- | Eg, \"\/dev/sda\"
type OSDevice = String

-- | Installs the grub package. This does not make grub be used as the
-- bootloader.
--
-- This includes running update-grub, unless it's run in a chroot.
installed :: GrubTarget -> Property (HasInfo + DebianLike)
installed grubtarget = installed' grubtarget 
	`onChange` (check (not <$> inChroot) mkConfig)

-- | Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
mkConfig :: Property DebianLike
mkConfig = tightenTargets $ cmdProperty "update-grub" []
	`assume` MadeChange

-- | Installs grub; does not run update-grub.
installed' :: GrubTarget -> Property (HasInfo + DebianLike)
installed' grubtarget = setInfoProperty aptinstall
	(toInfo [GrubInstalled grubtarget])
	`describe` "grub package installed"
  where
	aptinstall = Apt.installed [debpkg]
	debpkg = case grubtarget of
		PC -> "grub-pc"
		EFI64 -> "grub-efi-amd64"
		EFI32 -> "grub-efi-ia32"
		Coreboot -> "grub-coreboot"
		Xen -> "grub-xen"

-- | Sets a simple confguration value, using grub-mkconfig to update
-- the grub boot menu accordingly. On Debian, these are written to
-- </etc/default/grub>
--
-- Example:
--
-- >	& Grub.configured "GRUB_TIMEOUT" "10"
-- >	& Grub.configured "GRUB_TERMINAL_INPUT" "console serial"
configured :: String -> String -> Property DebianLike
configured k v = ConfFile.adjustSection 
	("grub configured with " ++ k ++ "=" ++ v)
	isline
	(not . isline)
	(const [l])
	(const [l])
	simpleConfigFile
	`onChange` mkConfig
  where
	isline s = (k ++ "=") `isPrefixOf` s
	l = k ++ "=" ++ shellEscape v

simpleConfigFile :: FilePath
simpleConfigFile = "/etc/default/grub"

-- | Adds a word to the default linux command line.
-- Any other words in the command line will be left unchanged.
--
-- Example:
--
-- > 	& Grub.cmdline_Linux_default "i915.enable_psr=1"
-- > 	! Grub.cmdline_Linux_default "quiet"
cmdline_Linux_default :: String -> RevertableProperty DebianLike DebianLike
cmdline_Linux_default w = setup <!> undo
  where
	setup = ConfFile.adjustSection
		("linux command line includes " ++ w)
		isline
		(not . isline)
		(map (mkline . addw . getws))
		(++ [mkline [w]])
		simpleConfigFile
		`onChange` mkConfig
	undo = ConfFile.adjustSection
		("linux command line does not include " ++ w)
		isline
		(not . isline)
		(map (mkline . rmw . getws))
		(++ [mkline [""]])
		simpleConfigFile
		`onChange` mkConfig
	k = "GRUB_CMDLINE_LINUX_DEFAULT"
	isline s = (k ++ "=") `isPrefixOf` s
	mkline ws = k ++ "=" ++ shellEscape (unwords ws)
	getws = concatMap words . shellUnEscape . drop 1 . dropWhile (/= '=')
	addw ws
		| w `elem` ws = ws
		| otherwise = ws ++ [w]
	rmw = filter (/= w)

-- | Installs grub onto a device's boot loader, 
-- so the system can boot from that device.
--
-- You may want to install grub to multiple devices; eg for a system
-- that uses software RAID.
--
-- Note that this property does not check if grub is already installed
-- on the device; it always does the work to reinstall it. It's a good idea
-- to arrange for this property to only run once, by eg making it be run
-- onChange after OS.cleanInstallOnce.
boots :: OSDevice -> Property Linux
boots dev = property' ("grub boots " ++ dev) $ \w -> do
	grubtarget <- askInfo
	let ps = case grubtarget of
		[GrubInstalled t] -> [targetParam t]
		_ -> []
	ensureProperty w $
		cmdProperty "grub-install" (ps ++ [dev])
			`assume` MadeChange

targetParam :: GrubTarget -> String
targetParam t = "--target=" ++ case t of
	PC -> "i386-pc"
	EFI32 -> "i386-efi"
	EFI64 -> "x86_64-efi"
	Coreboot -> "i386-coreboot"
	Xen -> "x86_64-xen"

type TimeoutSecs = Int

-- | Use PV-grub chaining to boot
--
-- Useful when the VPS's pv-grub is too old to boot a modern kernel image.
--
-- <http://notes.pault.ag/linode-pv-grub-chainning/>
--
-- The rootdev should be in the form "hd0", while the bootdev is in the form
-- "xen/xvda".
chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property (HasInfo + DebianLike)
chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
	& File.dirExists "/boot/grub"
	& "/boot/grub/menu.lst" `File.hasContent`
		[ "default 1" 
		, "timeout " ++ val timeout
		, ""
		, "title grub-xen shim"
		, "root (" ++ rootdev ++ ")"
		, "kernel /boot/xen-shim"
		, "boot"
		]
	& "/boot/load.cf" `File.hasContent`
		[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]
	& installed Xen
	& flip flagFile "/boot/xen-shim" xenshim
  where
	desc = "chain PV-grub"
	xenshim = scriptProperty ["grub-mkimage --prefix '(" ++ bootdev ++ ")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
		`assume` MadeChange
		`describe` "/boot-xen-shim"

-- | This is a version of `boots` that makes grub boot the system mounted
-- at a particular directory. The OSDevice should be the underlying disk
-- device that grub will be installed to (generally a whole disk, 
-- not a partition).
bootsMounted :: FilePath -> OSDevice -> GrubTarget -> Property Linux
bootsMounted mnt wholediskdev grubtarget = combineProperties desc $ props
	-- remove mounts that are done below to make sure the right thing
	-- gets mounted
	& cleanupmounts
	-- bind mount host /dev so grub can access the loop devices
	& bindMount "/dev" (inmnt "/dev")
	& mounted "proc" "proc" (inmnt "/proc") mempty
	& mounted "sysfs" "sys" (inmnt "/sys") mempty
	-- update the initramfs so it gets the uuid of the root partition
	& inchroot "update-initramfs" ["-u"]
		`assume` MadeChange
	-- work around for http://bugs.debian.org/802717
	& check haveosprober (inchroot "chmod" ["-x", osprober])
	& inchroot "update-grub" []
		`assume` MadeChange
	& check haveosprober (inchroot "chmod" ["+x", osprober])
	& inchroot "grub-install" [targetParam grubtarget, wholediskdev]
		`assume` MadeChange
	& cleanupmounts
	-- sync all buffered changes out to the disk in case it's
	-- used right away
	& cmdProperty "sync" []
		`assume` NoChange
  where
	desc = "grub boots " ++ wholediskdev

  	-- cannot use </> since the filepath is absolute
	inmnt f = mnt ++ f

	inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)

	haveosprober = doesFileExist (inmnt osprober)
	osprober = "/etc/grub.d/30_os-prober"

	cleanupmounts :: Property Linux
	cleanupmounts = property desc $ liftIO $ do
		cleanup "/sys"
		cleanup "/proc"
		cleanup "/dev"
		return NoChange
	  where
		cleanup m = 
			let mp = inmnt m
			in whenM (isMounted mp) $
				umountLazy mp