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
