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.Types.Info
import Propellor.Types.Bootloader
import Propellor.Types.Container
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
-- or container.
installed :: GrubTarget -> Property (HasInfo + DebianLike)
installed :: GrubTarget -> Property (HasInfo + DebianLike)
installed GrubTarget
grubtarget = GrubTarget -> Property (HasInfo + DebianLike)
installed' GrubTarget
grubtarget 
	forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` (forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContainerCapability -> Propellor Bool
hasContainerCapability ContainerCapability
FilesystemContained) Property DebianLike
mkConfig)

-- | Run update-grub, to generate the grub boot menu. It will be
-- automatically updated when kernel packages are installed.
mkConfig :: Property DebianLike
mkConfig :: Property DebianLike
mkConfig = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"update-grub" []
	forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange

-- | Installs grub; does not run update-grub.
installed' :: GrubTarget -> Property (HasInfo + DebianLike)
installed' :: GrubTarget -> Property (HasInfo + DebianLike)
installed' GrubTarget
grubtarget = forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
setInfoProperty Property DebianLike
aptinstall
	(forall v. IsInfo v => v -> Info
toInfo [GrubTarget -> BootloaderInstalled
GrubInstalled GrubTarget
grubtarget])
	forall p. IsProp p => p -> String -> p
`describe` String
"grub package installed"
  where
	aptinstall :: Property DebianLike
aptinstall = [String] -> Property DebianLike
Apt.installed [String
debpkg]
	debpkg :: String
debpkg = case GrubTarget
grubtarget of
		GrubTarget
PC -> String
"grub-pc"
		GrubTarget
EFI64 -> String
"grub-efi-amd64"
		GrubTarget
EFI32 -> String
"grub-efi-ia32"
		GrubTarget
Coreboot -> String
"grub-coreboot"
		GrubTarget
Xen -> String
"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 :: String -> String -> Property DebianLike
configured String
k String
v = String -> (String, String) -> Property UnixLike
ConfFile.containsShellSetting String
simpleConfigFile (String
k, String
v)
	forall p. IsProp p => p -> String -> p
`describe` (String
"grub configured with " forall a. [a] -> [a] -> [a]
++ String
k forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String
v)
	forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
mkConfig

simpleConfigFile :: FilePath
simpleConfigFile :: String
simpleConfigFile = String
"/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 :: String -> RevertableProperty DebianLike DebianLike
cmdline_Linux_default String
w = Property DebianLike
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property DebianLike
undo
  where
	setup :: CombinedType (Property UnixLike) (Property DebianLike)
setup = String
-> SectionStart
-> SectionStart
-> AdjustSection
-> AdjustSection
-> String
-> Property UnixLike
ConfFile.adjustSection
		(String
"linux command line includes " forall a. [a] -> [a] -> [a]
++ String
w)
		SectionStart
isline
		(Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. SectionStart
isline)
		(forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
mkline forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjustSection
addw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
getws))
		(forall a. [a] -> [a] -> [a]
++ [[String] -> String
mkline [String
w]])
		String
simpleConfigFile
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
mkConfig
	undo :: CombinedType (Property UnixLike) (Property DebianLike)
undo = String
-> SectionStart
-> SectionStart
-> AdjustSection
-> AdjustSection
-> String
-> Property UnixLike
ConfFile.adjustSection
		(String
"linux command line does not include " forall a. [a] -> [a] -> [a]
++ String
w)
		SectionStart
isline
		(Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. SectionStart
isline)
		(forall a b. (a -> b) -> [a] -> [b]
map ([String] -> String
mkline forall b c a. (b -> c) -> (a -> b) -> a -> c
. AdjustSection
rmw forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
getws))
		(forall a. [a] -> [a] -> [a]
++ [[String] -> String
mkline [String
""]])
		String
simpleConfigFile
		forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` Property DebianLike
mkConfig
	k :: String
k = String
"GRUB_CMDLINE_LINUX_DEFAULT"
	isline :: SectionStart
isline String
s = (String
k forall a. [a] -> [a] -> [a]
++ String
"=") forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
s
	mkline :: [String] -> String
mkline [String]
ws = String
k forall a. [a] -> [a] -> [a]
++ String
"=" forall a. [a] -> [a] -> [a]
++ String -> String
shellEscape ([String] -> String
unwords [String]
ws)
	getws :: String -> [String]
getws = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap String -> [String]
words forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
shellUnEscape forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TimeoutSecs -> [a] -> [a]
drop TimeoutSecs
1 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
'=')
	addw :: AdjustSection
addw [String]
ws
		| String
w forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
ws = [String]
ws
		| Bool
otherwise = [String]
ws forall a. [a] -> [a] -> [a]
++ [String
w]
	rmw :: AdjustSection
rmw = forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= String
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 :: String -> Property Linux
boots String
dev = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' (String
"grub boots " forall a. [a] -> [a] -> [a]
++ String
dev) forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w -> do
	[BootloaderInstalled]
grubtarget <- forall v. IsInfo v => Propellor v
askInfo
	let ps :: [String]
ps = case [BootloaderInstalled]
grubtarget of
		[GrubInstalled GrubTarget
t] -> [GrubTarget -> String
targetParam GrubTarget
t]
		[BootloaderInstalled]
_ -> []
	forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$
		String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"grub-install" ([String]
ps forall a. [a] -> [a] -> [a]
++ [String
dev])
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange

targetParam :: GrubTarget -> String
targetParam :: GrubTarget -> String
targetParam GrubTarget
t = String
"--target=" forall a. [a] -> [a] -> [a]
++ case GrubTarget
t of
	GrubTarget
PC -> String
"i386-pc"
	GrubTarget
EFI32 -> String
"i386-efi"
	GrubTarget
EFI64 -> String
"x86_64-efi"
	GrubTarget
Coreboot -> String
"i386-coreboot"
	GrubTarget
Xen -> String
"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 :: String -> String -> TimeoutSecs -> Property (HasInfo + DebianLike)
chainPVGrub String
rootdev String
bootdev TimeoutSecs
timeout = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties String
desc forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> Property UnixLike
File.dirExists String
"/boot/grub"
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String
"/boot/grub/menu.lst" String -> [String] -> Property UnixLike
`File.hasContent`
		[ String
"default 1" 
		, String
"timeout " forall a. [a] -> [a] -> [a]
++ forall t. ConfigurableValue t => t -> String
val TimeoutSecs
timeout
		, String
""
		, String
"title grub-xen shim"
		, String
"root (" forall a. [a] -> [a] -> [a]
++ String
rootdev forall a. [a] -> [a] -> [a]
++ String
")"
		, String
"kernel /boot/xen-shim"
		, String
"boot"
		]
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String
"/boot/load.cf" String -> [String] -> Property UnixLike
`File.hasContent`
		[ String
"configfile (" forall a. [a] -> [a] -> [a]
++ String
bootdev forall a. [a] -> [a] -> [a]
++ String
")/boot/grub/grub.cfg" ]
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& GrubTarget -> Property (HasInfo + DebianLike)
installed GrubTarget
Xen
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& forall a b c. (a -> b -> c) -> b -> a -> c
flip forall i. Property i -> String -> Property i
flagFile String
"/boot/xen-shim" Property UnixLike
xenshim
  where
	desc :: String
desc = String
"chain PV-grub"
	xenshim :: Property UnixLike
xenshim = [String] -> UncheckedProperty UnixLike
scriptProperty [String
"grub-mkimage --prefix '(" forall a. [a] -> [a] -> [a]
++ String
bootdev forall a. [a] -> [a] -> [a]
++ String
")/boot/grub' -c /boot/load.cf -O x86_64-xen /usr/lib/grub/x86_64-xen/*.mod > /boot/xen-shim"]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
		forall p. IsProp p => p -> String -> p
`describe` String
"/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 :: String -> String -> GrubTarget -> Property Linux
bootsMounted String
mnt String
wholediskdev GrubTarget
grubtarget = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
combineProperties String
desc forall a b. (a -> b) -> a -> b
$ Props UnixLike
props
	-- remove mounts that are done below to make sure the right thing
	-- gets mounted
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property Linux
cleanupmounts
	-- bind mount host /dev so grub can access the loop devices
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> String -> Property Linux
bindMount String
"/dev" (String -> String
inmnt String
"/dev")
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> String -> String -> MountOpts -> Property UnixLike
mounted String
"proc" String
"proc" (String -> String
inmnt String
"/proc") forall a. Monoid a => a
mempty
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> String -> String -> MountOpts -> Property UnixLike
mounted String
"sysfs" String
"sys" (String -> String
inmnt String
"/sys") forall a. Monoid a => a
mempty
	-- update the initramfs so it gets the uuid of the root partition
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> [String] -> UncheckedProperty UnixLike
inchroot String
"update-initramfs" [String
"-u"]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	-- work around for http://bugs.debian.org/802717
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check IO Bool
haveosprober (String -> [String] -> UncheckedProperty UnixLike
inchroot String
"chmod" [String
"-x", String
osprober])
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> [String] -> UncheckedProperty UnixLike
inchroot String
"update-grub" []
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check IO Bool
haveosprober (String -> [String] -> UncheckedProperty UnixLike
inchroot String
"chmod" [String
"+x", String
osprober])
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> [String] -> UncheckedProperty UnixLike
inchroot String
"grub-install" [GrubTarget -> String
targetParam GrubTarget
grubtarget, String
wholediskdev]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property Linux
cleanupmounts
	-- sync all buffered changes out to the disk in case it's
	-- used right away
	forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
 CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"sync" []
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
NoChange
  where
	desc :: String
desc = String
"grub boots " forall a. [a] -> [a] -> [a]
++ String
wholediskdev

  	-- cannot use </> since the filepath is absolute
	inmnt :: String -> String
inmnt String
f = String
mnt forall a. [a] -> [a] -> [a]
++ String
f

	inchroot :: String -> [String] -> UncheckedProperty UnixLike
inchroot String
cmd [String]
ps = String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"chroot" ([String
mnt, String
cmd] forall a. [a] -> [a] -> [a]
++ [String]
ps)

	haveosprober :: IO Bool
haveosprober = String -> IO Bool
doesFileExist (String -> String
inmnt String
osprober)
	osprober :: String
osprober = String
"/etc/grub.d/30_os-prober"

	cleanupmounts :: Property Linux
	cleanupmounts :: Property Linux
cleanupmounts = forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
desc forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
		String -> IO ()
cleanup String
"/sys"
		String -> IO ()
cleanup String
"/proc"
		String -> IO ()
cleanup String
"/dev"
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
	  where
		cleanup :: String -> IO ()
cleanup String
m = 
			let mp :: String
mp = String -> String
inmnt String
m
			in forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (String -> IO Bool
isMounted String
mp) forall a b. (a -> b) -> a -> b
$
				String -> IO ()
umountLazy String
mp