propellor

propellor config for hosts.
git clone git://git.ricketyspace.net/propellor.git
Log | Files | Refs | LICENSE

Grub.hs (7007B)


      1 module Propellor.Property.Grub (
      2 	GrubDevice,
      3 	OSDevice,
      4 	GrubTarget(..),
      5 	installed,
      6 	mkConfig,
      7 	installed',
      8 	configured,
      9 	cmdline_Linux_default,
     10 	boots,
     11 	bootsMounted,
     12 	TimeoutSecs,
     13 	chainPVGrub
     14 ) where
     15 
     16 import Propellor.Base
     17 import qualified Propellor.Property.File as File
     18 import qualified Propellor.Property.ConfFile as ConfFile
     19 import qualified Propellor.Property.Apt as Apt
     20 import Propellor.Property.Mount
     21 import Propellor.Types.Info
     22 import Propellor.Types.Bootloader
     23 import Propellor.Types.Container
     24 import Utility.SafeCommand
     25 
     26 import Data.List
     27 
     28 -- | Eg, \"hd0,0\" or \"xen/xvda1\"
     29 type GrubDevice = String
     30 
     31 -- | Eg, \"\/dev/sda\"
     32 type OSDevice = String
     33 
     34 -- | Installs the grub package. This does not make grub be used as the
     35 -- bootloader.
     36 --
     37 -- This includes running update-grub, unless it's run in a chroot
     38 -- or container.
     39 installed :: GrubTarget -> Property (HasInfo + DebianLike)
     40 installed grubtarget = installed' grubtarget 
     41 	`onChange` (check (not <$> hasContainerCapability FilesystemContained) mkConfig)
     42 
     43 -- | Run update-grub, to generate the grub boot menu. It will be
     44 -- automatically updated when kernel packages are installed.
     45 mkConfig :: Property DebianLike
     46 mkConfig = tightenTargets $ cmdProperty "update-grub" []
     47 	`assume` MadeChange
     48 
     49 -- | Installs grub; does not run update-grub.
     50 installed' :: GrubTarget -> Property (HasInfo + DebianLike)
     51 installed' grubtarget = setInfoProperty aptinstall
     52 	(toInfo [GrubInstalled grubtarget])
     53 	`describe` "grub package installed"
     54   where
     55 	aptinstall = Apt.installed [debpkg]
     56 	debpkg = case grubtarget of
     57 		PC -> "grub-pc"
     58 		EFI64 -> "grub-efi-amd64"
     59 		EFI32 -> "grub-efi-ia32"
     60 		Coreboot -> "grub-coreboot"
     61 		Xen -> "grub-xen"
     62 
     63 -- | Sets a simple confguration value, using grub-mkconfig to update
     64 -- the grub boot menu accordingly. On Debian, these are written to
     65 -- </etc/default/grub>
     66 --
     67 -- Example:
     68 --
     69 -- >	& Grub.configured "GRUB_TIMEOUT" "10"
     70 -- >	& Grub.configured "GRUB_TERMINAL_INPUT" "console serial"
     71 configured :: String -> String -> Property DebianLike
     72 configured k v = ConfFile.containsShellSetting simpleConfigFile (k, v)
     73 	`describe` ("grub configured with " ++ k ++ "=" ++ v)
     74 	`onChange` mkConfig
     75 
     76 simpleConfigFile :: FilePath
     77 simpleConfigFile = "/etc/default/grub"
     78 
     79 -- | Adds a word to the default linux command line.
     80 -- Any other words in the command line will be left unchanged.
     81 --
     82 -- Example:
     83 --
     84 -- > 	& Grub.cmdline_Linux_default "i915.enable_psr=1"
     85 -- > 	! Grub.cmdline_Linux_default "quiet"
     86 cmdline_Linux_default :: String -> RevertableProperty DebianLike DebianLike
     87 cmdline_Linux_default w = setup <!> undo
     88   where
     89 	setup = ConfFile.adjustSection
     90 		("linux command line includes " ++ w)
     91 		isline
     92 		(not . isline)
     93 		(map (mkline . addw . getws))
     94 		(++ [mkline [w]])
     95 		simpleConfigFile
     96 		`onChange` mkConfig
     97 	undo = ConfFile.adjustSection
     98 		("linux command line does not include " ++ w)
     99 		isline
    100 		(not . isline)
    101 		(map (mkline . rmw . getws))
    102 		(++ [mkline [""]])
    103 		simpleConfigFile
    104 		`onChange` mkConfig
    105 	k = "GRUB_CMDLINE_LINUX_DEFAULT"
    106 	isline s = (k ++ "=") `isPrefixOf` s
    107 	mkline ws = k ++ "=" ++ shellEscape (unwords ws)
    108 	getws = concatMap words . shellUnEscape . drop 1 . dropWhile (/= '=')
    109 	addw ws
    110 		| w `elem` ws = ws
    111 		| otherwise = ws ++ [w]
    112 	rmw = filter (/= w)
    113 
    114 -- | Installs grub onto a device's boot loader, 
    115 -- so the system can boot from that device.
    116 --
    117 -- You may want to install grub to multiple devices; eg for a system
    118 -- that uses software RAID.
    119 --
    120 -- Note that this property does not check if grub is already installed
    121 -- on the device; it always does the work to reinstall it. It's a good idea
    122 -- to arrange for this property to only run once, by eg making it be run
    123 -- onChange after OS.cleanInstallOnce.
    124 boots :: OSDevice -> Property Linux
    125 boots dev = property' ("grub boots " ++ dev) $ \w -> do
    126 	grubtarget <- askInfo
    127 	let ps = case grubtarget of
    128 		[GrubInstalled t] -> [targetParam t]
    129 		_ -> []
    130 	ensureProperty w $
    131 		cmdProperty "grub-install" (ps ++ [dev])
    132 			`assume` MadeChange
    133 
    134 targetParam :: GrubTarget -> String
    135 targetParam t = "--target=" ++ case t of
    136 	PC -> "i386-pc"
    137 	EFI32 -> "i386-efi"
    138 	EFI64 -> "x86_64-efi"
    139 	Coreboot -> "i386-coreboot"
    140 	Xen -> "x86_64-xen"
    141 
    142 type TimeoutSecs = Int
    143 
    144 -- | Use PV-grub chaining to boot
    145 --
    146 -- Useful when the VPS's pv-grub is too old to boot a modern kernel image.
    147 --
    148 -- <http://notes.pault.ag/linode-pv-grub-chainning/>
    149 --
    150 -- The rootdev should be in the form "hd0", while the bootdev is in the form
    151 -- "xen/xvda".
    152 chainPVGrub :: GrubDevice -> GrubDevice -> TimeoutSecs -> Property (HasInfo + DebianLike)
    153 chainPVGrub rootdev bootdev timeout = combineProperties desc $ props
    154 	& File.dirExists "/boot/grub"
    155 	& "/boot/grub/menu.lst" `File.hasContent`
    156 		[ "default 1" 
    157 		, "timeout " ++ val timeout
    158 		, ""
    159 		, "title grub-xen shim"
    160 		, "root (" ++ rootdev ++ ")"
    161 		, "kernel /boot/xen-shim"
    162 		, "boot"
    163 		]
    164 	& "/boot/load.cf" `File.hasContent`
    165 		[ "configfile (" ++ bootdev ++ ")/boot/grub/grub.cfg" ]
    166 	& installed Xen
    167 	& flip flagFile "/boot/xen-shim" xenshim
    168   where
    169 	desc = "chain PV-grub"
    170 	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"]
    171 		`assume` MadeChange
    172 		`describe` "/boot-xen-shim"
    173 
    174 -- | This is a version of `boots` that makes grub boot the system mounted
    175 -- at a particular directory. The OSDevice should be the underlying disk
    176 -- device that grub will be installed to (generally a whole disk, 
    177 -- not a partition).
    178 bootsMounted :: FilePath -> OSDevice -> GrubTarget -> Property Linux
    179 bootsMounted mnt wholediskdev grubtarget = combineProperties desc $ props
    180 	-- remove mounts that are done below to make sure the right thing
    181 	-- gets mounted
    182 	& cleanupmounts
    183 	-- bind mount host /dev so grub can access the loop devices
    184 	& bindMount "/dev" (inmnt "/dev")
    185 	& mounted "proc" "proc" (inmnt "/proc") mempty
    186 	& mounted "sysfs" "sys" (inmnt "/sys") mempty
    187 	-- update the initramfs so it gets the uuid of the root partition
    188 	& inchroot "update-initramfs" ["-u"]
    189 		`assume` MadeChange
    190 	-- work around for http://bugs.debian.org/802717
    191 	& check haveosprober (inchroot "chmod" ["-x", osprober])
    192 	& inchroot "update-grub" []
    193 		`assume` MadeChange
    194 	& check haveosprober (inchroot "chmod" ["+x", osprober])
    195 	& inchroot "grub-install" [targetParam grubtarget, wholediskdev]
    196 		`assume` MadeChange
    197 	& cleanupmounts
    198 	-- sync all buffered changes out to the disk in case it's
    199 	-- used right away
    200 	& cmdProperty "sync" []
    201 		`assume` NoChange
    202   where
    203 	desc = "grub boots " ++ wholediskdev
    204 
    205   	-- cannot use </> since the filepath is absolute
    206 	inmnt f = mnt ++ f
    207 
    208 	inchroot cmd ps = cmdProperty "chroot" ([mnt, cmd] ++ ps)
    209 
    210 	haveosprober = doesFileExist (inmnt osprober)
    211 	osprober = "/etc/grub.d/30_os-prober"
    212 
    213 	cleanupmounts :: Property Linux
    214 	cleanupmounts = property desc $ liftIO $ do
    215 		cleanup "/sys"
    216 		cleanup "/proc"
    217 		cleanup "/dev"
    218 		return NoChange
    219 	  where
    220 		cleanup m = 
    221 			let mp = inmnt m
    222 			in whenM (isMounted mp) $
    223 				umountLazy mp