{-# LANGUAGE TypeOperators #-}

-- | Installation to a target disk.
-- 
-- Note that the RevertableProperties in this module are not really
-- revertable; the target disk can't be put back how it was. 
-- The RevertableProperty type is used only to let them  be used
-- in a Versioned Host as shown below.
--
-- Here's an example of a noninteractive installer image using
-- these properties.
--
-- There are two versions of Hosts, the installer and the target system.
-- 
-- > data Variety = Installer | Target
-- > 	deriving (Eq)
-- 
-- The seed of both the installer and the target. They have some properties
-- in common, and some different properties. The `targetInstalled`
-- property knows how to convert the installer it's running on into a
-- target system.
--
-- > seed :: Versioned Variety Host
-- > seed ver = host "debian.local" $ props
-- > 	& osDebian Unstable X86_64
-- > 	& Hostname.sane
-- > 	& Apt.stdSourcesList
-- > 	& Apt.installed ["linux-image-amd64"]
-- > 	& Grub.installed PC
-- > 	& "en_US.UTF-8" `Locale.selectedFor` ["LANG"]
-- > 	& ver ( (== Installer) --> targetInstalled seed Target (userInput ver) parts)
-- > 	& ver ( (== Target)    --> fstabLists (userInput ver) parts)
-- > 	& ver ( (== Installer) --> targetBootable (userInput ver))
-- >   where
-- > 	parts = TargetPartTable MSDOS
-- > 		[ partition EXT4 `mountedAt` "/"
-- > 			`useDiskSpace` RemainingSpace
-- > 		, swapPartition (MegaBytes 1024)
-- > 		]
-- 
-- The installer disk image can then be built from the seed as follows:
-- 
-- > installerBuilt :: RevertableProperty (HasInfo + DebianLike) Linux
-- > installerBuilt = imageBuilt (VirtualBoxPointer "/srv/installer.vmdk")
-- >	(hostChroot (seed `version` installer) (Debootstrapped mempty))
-- >	MSDOS
-- > 	 [ partition EXT4 `mountedAt` "/"
-- >		`setFlag` BootFlag
-- >		`reservedSpacePercentage` 0
-- > 		`addFreeSpace` MegaBytes 256
-- > 	]
--
-- When the installer is booted up, and propellor is run, it installs
-- to the target disk. Since this example is a noninteractive installer,
-- the details of what it installs to are configured before it's built.
-- 
-- > data HardCodedUserInput = HardCodedUserInput (Maybe TargetDiskDevice) (Maybe DiskEraseConfirmed)
-- > 
-- > instance UserInput HardCodedUserInput where 
-- > 	targetDiskDevice (HardCodedUserInput t _) = Just t
-- > 	diskEraseConfirmed (HardCodedUserInput _ c) = Just c
-- > 
-- > userInput :: Version -> HardCodedUserInput
-- > userInput Installer =  HardCodedUserInput Nothing Nothing
-- > userInput Target = HardCodedUserInput (Just (TargetDiskDevice "/dev/sda")) (Just DiskEraseConfirmed)
--
-- For an example of how to use this to make an interactive installer,
-- see <https://git.joeyh.name/index.cgi/secret-project.git/>

module Propellor.Property.Installer.Target (
	-- * Main interface
	TargetPartTable(..),
	targetInstalled,
	fstabLists,
	-- * Additional properties
	mountTarget,
	targetBootable,
	partitionTargetDisk,
	-- * Utility functions
	targetDir,
	probeDisk,
	findDiskDevices,
	-- * Installation progress tracking
	TargetFilled,
	TargetFilledHandle,
	prepTargetFilled,
	checkTargetFilled,
	TargetFilledPercent(..),
	targetFilledPercent,
) where

import Propellor
import Propellor.Property.Installer.Types
import Propellor.Message
import Propellor.Types.Bootloader
import Propellor.Types.PartSpec
import Propellor.Property.Chroot
import Propellor.Property.Versioned
import Propellor.Property.Parted
import Propellor.Property.Mount
import qualified Propellor.Property.Fstab as Fstab
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.Rsync as Rsync

import Text.Read
import Control.Monad
import Control.Monad.IO.Class (liftIO)
import System.Directory
import System.FilePath
import Data.Maybe
import Data.List
import Data.Char
import Data.Ord
import Data.Ratio
import System.Process (readProcess)

-- | Partition table for the target disk.
data TargetPartTable = TargetPartTable TableType [PartSpec DiskPart]

-- | Property that installs the target system to the TargetDiskDevice
-- specified in the UserInput. That device will be re-partitioned and
-- formatted and all files erased.
--
-- The installation is done efficiently by rsyncing the installer's files
-- to the target, which forms the basis for a chroot that is provisioned with
-- the specified version of the Host. Thanks to
-- Propellor.Property.Versioned, any unwanted properties of the installer
-- will be automatically reverted in the chroot.
--
-- When there is no TargetDiskDevice or the user has not confirmed the
-- installation, nothing is done except for installing dependencies. 
-- So, this can also be used as a property of the installer
-- image.
targetInstalled
	:: UserInput i 
	=> Versioned v Host
	-> v
	-> i
	-> TargetPartTable
	-> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike)
targetInstalled vtargethost v userinput (TargetPartTable tabletype partspec) = 
	case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
		(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> 
			go `describe` ("target system installed to " ++ targetdev)
		_ -> tightenTargets installdeps <!> doNothing
  where
	targethost = vtargethost `version` v
	go = RevertableProperty
		(setupRevertableProperty p)
		-- Versioned needs both "sides" of the RevertableProperty
		-- to have the same type, so add empty Info to make the
		-- types line up.
		(undoRevertableProperty p `setInfoProperty` mempty)
	  where
		p = partitionTargetDisk userinput tabletype partspec
			`before` mountTarget userinput partspec
			`before` provisioned chroot
	
	chroot = hostChroot targethost RsyncBootstrapper targetDir

	-- Install dependencies that will be needed later when installing
	-- the target.
	installdeps = Rsync.installed

data RsyncBootstrapper = RsyncBootstrapper

instance ChrootBootstrapper RsyncBootstrapper where
	buildchroot RsyncBootstrapper _ target = Right $
		mountaside
			`before` rsynced
			`before` umountaside
	  where
	  	-- bind mount the root filesystem to /mnt, which exposes
		-- the contents of all directories that have things mounted
		-- on top of them to rsync.
		mountaside = bindMount "/" "/mnt"
		rsynced = Rsync.rsync
			[ "--one-file-system"
			, "-aHAXS"
			, "--delete"
			, "/mnt/"
			, target
			]
		umountaside = cmdProperty "umount" ["-l", "/mnt"]
			`assume` MadeChange

-- | Gets the target mounted.
mountTarget
	:: UserInput i
	=> i
	-> [PartSpec DiskPart]
	-> RevertableProperty Linux Linux
mountTarget userinput partspec = setup <!> cleanup
  where
	setup = property "target mounted" $
		case targetDiskDevice userinput of
			Just (TargetDiskDevice targetdev) -> do
				liftIO unmountTarget
				r <- liftIO $ forM tomount $
					mountone targetdev
				if and r
					then return MadeChange
					else return FailedChange
			Nothing -> return NoChange
	cleanup = property "target unmounted" $ do
		liftIO unmountTarget
		liftIO $ removeDirectoryRecursive targetDir
		return NoChange

	-- Sort so / comes before /home etc
	tomount = sortOn (fst . fst) $
		map (\((mp, mo, _, _), n) -> ((mp, mo), n)) $
		zip partspec partNums

	mountone targetdev ((mmountpoint, mountopts), num) =
		case mmountpoint of
			Nothing -> return True
			Just mountpoint -> do
				let targetmount = targetDir ++ mountpoint
				createDirectoryIfMissing True targetmount
				let dev = diskPartition targetdev num
				mount "auto" dev targetmount mountopts

-- | Property for use in the target Host to set up its fstab.
-- Should be passed the same TargetPartTable as `targetInstalled`.
fstabLists
	:: UserInput i
	=> i
	-> TargetPartTable
	-> RevertableProperty Linux Linux
fstabLists userinput (TargetPartTable _ partspecs) = setup <!> doNothing
  where
	setup = case targetDiskDevice userinput of
		Just (TargetDiskDevice targetdev) ->
			Fstab.fstabbed mnts (swaps targetdev)
				`requires` devmounted
				`before` devumounted
		Nothing -> doNothing

	-- needed for ftabbed UUID probing to work
	devmounted :: Property Linux
	devmounted = tightenTargets $ mounted "devtmpfs" "udev" "/dev" mempty
	devumounted :: Property Linux
	devumounted = tightenTargets $ cmdProperty "umount" ["-l", "/dev"]
		`assume` MadeChange
	
	partitions = map (\(mp, _, mkpart, _) -> (mp, mkpart mempty)) partspecs
	mnts = mapMaybe fst $
		filter (\(_, p) -> partFs p /= Just LinuxSwap && partFs p /= Nothing) partitions
	swaps targetdev = 
		map (Fstab.SwapPartition . diskPartition targetdev . snd) $
			filter (\((_, p), _) -> partFs p == Just LinuxSwap)
				(zip partitions partNums)

-- | Make the target bootable using whatever bootloader is installed on it.
targetBootable
	:: UserInput i
	=> i
	-> RevertableProperty Linux Linux
targetBootable userinput = 
	case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
		(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> 
			go targetdev <!> doNothing
		_ -> doNothing <!> doNothing
  where
	desc = "bootloader installed on target disk"
	go :: FilePath -> Property Linux
	go targetdev = property' desc $ \w -> do
		bootloaders <- askInfo
		case bootloaders of
			[GrubInstalled gt] -> ensureProperty w $
				Grub.bootsMounted targetDir targetdev gt
			[] -> do
				warningMessage "no bootloader was installed"
				return NoChange
			l -> do
				warningMessage $ "don't know how to enable bootloader(s) " ++ show l
				return FailedChange

-- | Partitions the target disk.
partitionTargetDisk
	:: UserInput i
	=> i
	-> TableType
	-> [PartSpec DiskPart]
	-> RevertableProperty DebianLike DebianLike
partitionTargetDisk userinput tabletype partspec = go <!> doNothing
  where
	go = check targetNotMounted $ property' "target disk partitioned" $ \w -> do
		case (targetDiskDevice userinput, diskEraseConfirmed userinput) of
			(Just (TargetDiskDevice targetdev), Just _diskeraseconfirmed) -> do
				liftIO $ unmountTarget
				disksize <- liftIO $ getDiskSize targetdev
				let parttable = calcPartTable disksize tabletype safeAlignment partspec
				ensureProperty w $ 
					partitioned YesReallyDeleteDiskContents targetdev parttable
			_ -> error "user input does not allow partitioning disk"

unmountTarget :: IO ()
unmountTarget = mapM_ umountLazy . reverse . sort =<< targetMountPoints

targetMountPoints :: IO [MountPoint]
targetMountPoints = filter isTargetMountPoint <$> mountPoints

isTargetMountPoint :: MountPoint -> Bool
isTargetMountPoint mp = 
	mp == targetDir 
		|| addTrailingPathSeparator targetDir `isPrefixOf` mp

targetNotMounted :: IO Bool
targetNotMounted = not . any (== targetDir) <$> mountPoints

-- | Where the target disk is mounted while it's being installed.
targetDir :: FilePath
targetDir = "/target"

partNums :: [Integer]
partNums = [1..]

-- /dev/sda to /dev/sda1
diskPartition :: FilePath -> Integer -> FilePath
diskPartition dev num = dev ++ show num

-- | This can be used to find a likely disk device to use as the target
-- for an installation.
--
-- This is a bit of a hack; of course the user could be prompted but to
-- avoid prompting, some heuristics...
--   * It should not already be mounted. 
--   * Prefer disks big enough to comfortably hold a Linux installation,
--     so at least 8 gb.
--     (But, if the system only has a smaller disk, it should be used.)
--   * A medium size internal disk is better than a large removable disk,
--     because removable or added drives are often used for data storage
--     on systems with smaller internal disk for the OS.
--     (But, if the internal disk is too small, prefer removable disk;
--     some systems have an unusably small internal disk.)
--   * Prefer the first disk in BIOS order, all other things being equal,
--     because the main OS disk typically comes first. This can be
--     approximated by preferring /dev/sda to /dev/sdb.
probeDisk :: IO TargetDiskDevice
probeDisk = do
	unmountTarget
	mounteddevs <- getMountedDeviceIDs
	let notmounted d = flip notElem (map Just mounteddevs)
		<$> getMinorNumber d
	candidates <- mapM probeCandidate
		=<< filterM notmounted
		=<< findDiskDevices
	case reverse (sort candidates) of
		(Candidate { candidateDevice = Down dev } : _) -> 
			return $ TargetDiskDevice dev
		[] -> error "Unable to find any disk to install to!"

-- | Find disk devices, such as /dev/sda (not partitions)
findDiskDevices :: IO [FilePath]
findDiskDevices = map ("/dev" </>) . filter isdisk
	<$> getDirectoryContents "/dev"
  where
	isdisk ('s':'d':_:[]) = True
	isdisk _ = False

-- | When comparing two Candidates, the better of the two will be larger.
data Candidate = Candidate
	{ candidateBigEnoughForOS :: Bool
	, candidateIsFixedDisk :: Bool
	-- use Down so that /dev/sda orders larger than /dev/sdb
	, candidateDevice :: Down FilePath
	} deriving (Eq, Ord)

probeCandidate :: FilePath -> IO Candidate
probeCandidate dev = do
	DiskSize sz <- getDiskSize dev
	isfixeddisk <- not <$> isRemovableDisk dev
	return $ Candidate
		{ candidateBigEnoughForOS = sz >= 8 * onegb
		, candidateIsFixedDisk = isfixeddisk
		, candidateDevice = Down dev
		}
  where
	onegb = 1024*1024*1000

newtype MinorNumber = MinorNumber Integer
	deriving (Eq, Show)

getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs = mapMaybe parse . lines <$> readProcess "findmnt"
	[ "-rn"
	, "--output"
	, "MAJ:MIN"
	]
	""
  where
	parse = fmap MinorNumber . readMaybe 
		. dropWhile (not . isDigit) . dropWhile (/= ':')

-- There is not currently a native haskell interface for getting the minor
-- number of a device.
getMinorNumber :: FilePath -> IO (Maybe MinorNumber)
getMinorNumber dev = fmap MinorNumber . readMaybe 
	<$> readProcess "stat" [ "--printf", "%T", dev ] ""

-- A removable disk may show up as removable or as hotplug.
isRemovableDisk :: FilePath -> IO Bool
isRemovableDisk dev = do
	isremovable <- checkblk "RM"
	ishotplug <- checkblk "HOTPLUG"
	return (isremovable || ishotplug)
  where
	checkblk field = (== "1\n") <$> readProcess "lsblk"
		[ "-rn"
		, "--nodeps"
		, "--output", field
		, dev
		]
		""

getDiskSize :: FilePath -> IO DiskSize
getDiskSize dev = do
	sectors <- fromMaybe 0 . readMaybe 
		<$> readProcess "blockdev" ["--getsz", dev] ""
	return (DiskSize (sectors * 512))

getMountsSizes :: IO [(MountPoint, Integer)]
getMountsSizes = mapMaybe (parse . words) . lines <$> readProcess "findmnt" ps ""
  where
	ps = ["-rnb", "-o", "TARGET,USED"]
	parse (mp:szs:[]) = do
		sz <- readMaybe szs
		return (mp, sz)
	parse _ = Nothing

-- | How much of the target disks are used, compared with the size of the
-- installer's root device. Since the main part of an installation
-- is `targetInstalled` rsyncing the latter to the former, this allows
-- roughly estimating the percent done while an install is running,
-- and can be used in some sort of progress display.
data TargetFilled = TargetFilled (Ratio Integer)
	deriving (Show, Eq)

instance Monoid TargetFilled where
	mempty = TargetFilled (0 % 1)
	mappend (TargetFilled n) (TargetFilled m) = TargetFilled (n+m)

newtype TargetFilledHandle = TargetFilledHandle Integer

-- | Prepare for getting `TargetFilled`.
prepTargetFilled :: IO TargetFilledHandle
prepTargetFilled = go =<< getMountSource "/"
  where
	go (Just dev) = do
		-- Assumes that the installer uses a single partition.
		DiskSize sz <- getDiskSize dev
		return (TargetFilledHandle sz)
	go Nothing = return (TargetFilledHandle 0)

-- | Get the current `TargetFilled` value. This is fast enough to be run
-- multiple times per second without using much CPU.
checkTargetFilled :: TargetFilledHandle -> IO TargetFilled
checkTargetFilled (TargetFilledHandle installsz) = do
	targetsz <- sum . map snd . filter (isTargetMountPoint . fst)
		<$> getMountsSizes
	return (TargetFilled (targetsz % max 1 installsz))

newtype TargetFilledPercent = TargetFilledPercent Int
	deriving (Show, Eq)

targetFilledPercent :: TargetFilled -> TargetFilledPercent
targetFilledPercent (TargetFilled r) = TargetFilledPercent $ floor percent
  where
	percent :: Double
	percent = min 100 (fromRational r * 100)
