{-# LANGUAGE TypeOperators, RankNTypes, TypeFamilies, FlexibleContexts #-}

-- | 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
-- >	& Hostname.mailname
-- > 	& 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 qualified Data.Semigroup as Sem
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 :: forall i v.
UserInput i =>
Versioned v Host
-> v
-> i
-> TargetPartTable
-> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike)
targetInstalled Versioned v Host
vtargethost v
v i
userinput (TargetPartTable TableType
tabletype [PartSpec DiskPart]
partspec) = 
	case (forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
		(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> 
			RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
go forall p. IsProp p => p -> String -> p
`describe` (String
"target system installed to " forall a. [a] -> [a] -> [a]
++ String
targetdev)
		(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property Linux
installdeps forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	targethost :: Host
targethost = Versioned v Host
vtargethost forall v t. Versioned v t -> v -> t
`version` v
v
	go :: RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
go = forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
RevertableProperty
		(forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property setupmetatypes
setupRevertableProperty CombinedType
  (RevertableProperty DebianLike DebianLike)
  (RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux)
p)
		-- Versioned needs both "sides" of the RevertableProperty
		-- to have the same type, so add empty Info to make the
		-- types line up.
		(forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property undometatypes
undoRevertableProperty CombinedType
  (RevertableProperty DebianLike DebianLike)
  (RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux)
p forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
`setInfoProperty` forall a. Monoid a => a
mempty)
	  where
		p :: CombinedType
  (RevertableProperty DebianLike DebianLike)
  (RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux)
p = forall i.
UserInput i =>
i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
partitionTargetDisk i
userinput TableType
tabletype [PartSpec DiskPart]
partspec
			forall x y. Combines x y => x -> y -> CombinedType x y
`before` forall i.
UserInput i =>
i -> [PartSpec DiskPart] -> RevertableProperty Linux Linux
mountTarget i
userinput [PartSpec DiskPart]
partspec
			forall x y. Combines x y => x -> y -> CombinedType x y
`before` Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned Chroot
chroot
	
	chroot :: Chroot
chroot = forall bootstrapper.
ChrootBootstrapper bootstrapper =>
Host -> bootstrapper -> String -> Chroot
hostChroot Host
targethost RsyncBootstrapper
RsyncBootstrapper String
targetDir

	-- Install dependencies that will be needed later when installing
	-- the target.
	installdeps :: Property (DebianLike + ArchLinux)
installdeps = Property (DebianLike + ArchLinux)
Rsync.installed

data RsyncBootstrapper = RsyncBootstrapper

instance ChrootBootstrapper RsyncBootstrapper where
	buildchroot :: RsyncBootstrapper
-> Info -> String -> Either String (Property Linux)
buildchroot RsyncBootstrapper
RsyncBootstrapper Info
_ String
target = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
		Property Linux
mountaside
			forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property (DebianLike + ArchLinux)
rsynced
			forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property UnixLike
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 :: Property Linux
mountaside = String -> String -> Property Linux
bindMount String
"/" String
"/mnt"
		rsynced :: Property (DebianLike + ArchLinux)
rsynced = [String] -> Property (DebianLike + ArchLinux)
Rsync.rsync
			[ String
"--one-file-system"
			, String
"-aHAXS"
			, String
"--delete"
			, String
"/mnt/"
			, String
target
			]
		umountaside :: Property UnixLike
umountaside = String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"umount" [String
"-l", String
"/mnt"]
			forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange

-- | Gets the target mounted.
mountTarget
	:: UserInput i
	=> i
	-> [PartSpec DiskPart]
	-> RevertableProperty Linux Linux
mountTarget :: forall i.
UserInput i =>
i -> [PartSpec DiskPart] -> RevertableProperty Linux Linux
mountTarget i
userinput [PartSpec DiskPart]
partspec = Property Linux
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
cleanup
  where
	setup :: Property Linux
setup = forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"target mounted" forall a b. (a -> b) -> a -> b
$
		case forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
			Just (TargetDiskDevice String
targetdev) -> do
				forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
				[Bool]
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((Maybe String, MountOpts), Integer)]
tomount forall a b. (a -> b) -> a -> b
$
					String -> ((Maybe String, MountOpts), Integer) -> IO Bool
mountone String
targetdev
				if forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
r
					then forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
					else forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
			Maybe TargetDiskDevice
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
	cleanup :: Property Linux
cleanup = forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"target unmounted" forall a b. (a -> b) -> a -> b
$ do
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
targetDir
		forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange

	-- Sort so / comes before /home etc
	tomount :: [((Maybe String, MountOpts), Integer)]
tomount = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
		forall a b. (a -> b) -> [a] -> [b]
map (\((Maybe String
mp, MountOpts
mo, PartSize -> Partition
_, DiskPart
_), Integer
n) -> ((Maybe String
mp, MountOpts
mo), Integer
n)) forall a b. (a -> b) -> a -> b
$
		forall a b. [a] -> [b] -> [(a, b)]
zip [PartSpec DiskPart]
partspec [Integer]
partNums

	mountone :: String -> ((Maybe String, MountOpts), Integer) -> IO Bool
mountone String
targetdev ((Maybe String
mmountpoint, MountOpts
mountopts), Integer
num) =
		case Maybe String
mmountpoint of
			Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
			Just String
mountpoint -> do
				let targetmount :: String
targetmount = String
targetDir forall a. [a] -> [a] -> [a]
++ String
mountpoint
				Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetmount
				let dev :: String
dev = String -> Integer -> String
diskPartition String
targetdev Integer
num
				String -> String -> String -> MountOpts -> IO Bool
mount String
"auto" String
dev String
targetmount MountOpts
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 :: forall i.
UserInput i =>
i -> TargetPartTable -> RevertableProperty Linux Linux
fstabLists i
userinput (TargetPartTable TableType
_ [PartSpec DiskPart]
partspecs) = CombinedType (Property Linux) (Property Linux)
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	setup :: CombinedType (Property Linux) (Property Linux)
setup = case forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
		Just (TargetDiskDevice String
targetdev) ->
			[String] -> [SwapPartition] -> Property Linux
Fstab.fstabbed [String]
mnts (String -> [SwapPartition]
swaps String
targetdev)
				forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property Linux
devmounted
				forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property Linux
devumounted
		Maybe TargetDiskDevice
Nothing -> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing

	-- needed for ftabbed UUID probing to work
	devmounted :: Property Linux
	devmounted :: Property Linux
devmounted = 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 -> String -> MountOpts -> Property UnixLike
mounted String
"devtmpfs" String
"udev" String
"/dev" forall a. Monoid a => a
mempty
	devumounted :: Property Linux
	devumounted :: Property Linux
devumounted = 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
"umount" [String
"-l", String
"/dev"]
		forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	
	partitions :: [(Maybe String, Partition)]
partitions = forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe String
mp, MountOpts
_, PartSize -> Partition
mkpart, DiskPart
_) -> (Maybe String
mp, PartSize -> Partition
mkpart forall a. Monoid a => a
mempty)) [PartSpec DiskPart]
partspecs
	mnts :: [String]
mnts = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
		forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe String
_, Partition
p) -> Partition -> Maybe Fs
partFs Partition
p forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Fs
LinuxSwap Bool -> Bool -> Bool
&& Partition -> Maybe Fs
partFs Partition
p forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a
Nothing) [(Maybe String, Partition)]
partitions
	swaps :: String -> [SwapPartition]
swaps String
targetdev = 
		forall a b. (a -> b) -> [a] -> [b]
map (String -> SwapPartition
Fstab.SwapPartition forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer -> String
diskPartition String
targetdev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
			forall a. (a -> Bool) -> [a] -> [a]
filter (\((Maybe String
_, Partition
p), Integer
_) -> Partition -> Maybe Fs
partFs Partition
p forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Fs
LinuxSwap)
				(forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe String, Partition)]
partitions [Integer]
partNums)

-- | Make the target bootable using whatever bootloader is installed on it.
targetBootable
	:: UserInput i
	=> i
	-> RevertableProperty Linux Linux
targetBootable :: forall i. UserInput i => i -> RevertableProperty Linux Linux
targetBootable i
userinput = 
	case (forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
		(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> 
			String -> Property Linux
go String
targetdev forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
		(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	desc :: String
desc = String
"bootloader installed on target disk"
	go :: FilePath -> Property Linux
	go :: String -> Property Linux
go String
targetdev = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w -> do
		[BootloaderInstalled]
bootloaders <- forall v. IsInfo v => Propellor v
askInfo
		case [BootloaderInstalled]
bootloaders of
			[GrubInstalled GrubTarget
gt] -> 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 -> GrubTarget -> Property Linux
Grub.bootsMounted String
targetDir String
targetdev GrubTarget
gt
			[] -> do
				forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
"no bootloader was installed"
				forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
			[BootloaderInstalled]
l -> do
				forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage forall a b. (a -> b) -> a -> b
$ String
"don't know how to enable bootloader(s) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [BootloaderInstalled]
l
				forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange

-- | Partitions the target disk.
partitionTargetDisk
	:: UserInput i
	=> i
	-> TableType
	-> [PartSpec DiskPart]
	-> RevertableProperty DebianLike DebianLike
partitionTargetDisk :: forall i.
UserInput i =>
i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
partitionTargetDisk i
userinput TableType
tabletype [PartSpec DiskPart]
partspec = Property DebianLike
go forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	go :: Property DebianLike
go = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check IO Bool
targetNotMounted forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
"target disk partitioned" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		case (forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
			(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> do
				forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ()
unmountTarget
				DiskSize
disksize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO DiskSize
getDiskSize String
targetdev
				let parttable :: PartTable
parttable = DiskSize
-> TableType -> Alignment -> [PartSpec DiskPart] -> PartTable
calcPartTable DiskSize
disksize TableType
tabletype Alignment
safeAlignment [PartSpec DiskPart]
partspec
				forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ 
					Eep -> String -> PartTable -> Property DebianLike
partitioned Eep
YesReallyDeleteDiskContents String
targetdev PartTable
parttable
			(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> forall a. HasCallStack => String -> a
error String
"user input does not allow partitioning disk"

unmountTarget :: IO ()
unmountTarget :: IO ()
unmountTarget = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
umountLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
targetMountPoints

targetMountPoints :: IO [MountPoint]
targetMountPoints :: IO [String]
targetMountPoints = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isTargetMountPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
mountPoints

isTargetMountPoint :: MountPoint -> Bool
isTargetMountPoint :: String -> Bool
isTargetMountPoint String
mp = 
	String
mp forall a. Eq a => a -> a -> Bool
== String
targetDir 
		Bool -> Bool -> Bool
|| String -> String
addTrailingPathSeparator String
targetDir forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
mp

targetNotMounted :: IO Bool
targetNotMounted :: IO Bool
targetNotMounted = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== String
targetDir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
mountPoints

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

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

-- /dev/sda to /dev/sda1
diskPartition :: FilePath -> Integer -> FilePath
diskPartition :: String -> Integer -> String
diskPartition String
dev Integer
num = String
dev forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
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 :: IO TargetDiskDevice
probeDisk = do
	IO ()
unmountTarget
	[MinorNumber]
mounteddevs <- IO [MinorNumber]
getMountedDeviceIDs
	let notmounted :: String -> IO Bool
notmounted String
d = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [MinorNumber]
mounteddevs)
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe MinorNumber)
getMinorNumber String
d
	[Candidate]
candidates <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Candidate
probeCandidate
		forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
notmounted
		forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
findDiskDevices
	case forall a. [a] -> [a]
reverse (forall a. Ord a => [a] -> [a]
sort [Candidate]
candidates) of
		(Candidate { candidateDevice :: Candidate -> Down String
candidateDevice = Down String
dev } : [Candidate]
_) -> 
			forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> TargetDiskDevice
TargetDiskDevice String
dev
		[] -> forall a. HasCallStack => String -> a
error String
"Unable to find any disk to install to!"

-- | Find disk devices, such as /dev/sda (not partitions)
findDiskDevices :: IO [FilePath]
findDiskDevices :: IO [String]
findDiskDevices = forall a b. (a -> b) -> [a] -> [b]
map (String
"/dev" String -> String -> String
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isdisk
	forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
"/dev"
  where
	isdisk :: String -> Bool
isdisk (Char
's':Char
'd':Char
_:[]) = Bool
True
	isdisk String
_ = Bool
False

-- | When comparing two Candidates, the better of the two will be larger.
data Candidate = Candidate
	{ Candidate -> Bool
candidateBigEnoughForOS :: Bool
	, Candidate -> Bool
candidateIsFixedDisk :: Bool
	-- use Down so that /dev/sda orders larger than /dev/sdb
	, Candidate -> Down String
candidateDevice :: Down FilePath
	} deriving (Candidate -> Candidate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Candidate -> Candidate -> Bool
$c/= :: Candidate -> Candidate -> Bool
== :: Candidate -> Candidate -> Bool
$c== :: Candidate -> Candidate -> Bool
Eq, Eq Candidate
Candidate -> Candidate -> Bool
Candidate -> Candidate -> Ordering
Candidate -> Candidate -> Candidate
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Candidate -> Candidate -> Candidate
$cmin :: Candidate -> Candidate -> Candidate
max :: Candidate -> Candidate -> Candidate
$cmax :: Candidate -> Candidate -> Candidate
>= :: Candidate -> Candidate -> Bool
$c>= :: Candidate -> Candidate -> Bool
> :: Candidate -> Candidate -> Bool
$c> :: Candidate -> Candidate -> Bool
<= :: Candidate -> Candidate -> Bool
$c<= :: Candidate -> Candidate -> Bool
< :: Candidate -> Candidate -> Bool
$c< :: Candidate -> Candidate -> Bool
compare :: Candidate -> Candidate -> Ordering
$ccompare :: Candidate -> Candidate -> Ordering
Ord)

probeCandidate :: FilePath -> IO Candidate
probeCandidate :: String -> IO Candidate
probeCandidate String
dev = do
	DiskSize Integer
sz <- String -> IO DiskSize
getDiskSize String
dev
	Bool
isfixeddisk <- Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
isRemovableDisk String
dev
	forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Candidate
		{ candidateBigEnoughForOS :: Bool
candidateBigEnoughForOS = Integer
sz forall a. Ord a => a -> a -> Bool
>= Integer
8 forall a. Num a => a -> a -> a
* Integer
onegb
		, candidateIsFixedDisk :: Bool
candidateIsFixedDisk = Bool
isfixeddisk
		, candidateDevice :: Down String
candidateDevice = forall a. a -> Down a
Down String
dev
		}
  where
	onegb :: Integer
onegb = Integer
1024forall a. Num a => a -> a -> a
*Integer
1024forall a. Num a => a -> a -> a
*Integer
1000

newtype MinorNumber = MinorNumber Integer
	deriving (MinorNumber -> MinorNumber -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MinorNumber -> MinorNumber -> Bool
$c/= :: MinorNumber -> MinorNumber -> Bool
== :: MinorNumber -> MinorNumber -> Bool
$c== :: MinorNumber -> MinorNumber -> Bool
Eq, Int -> MinorNumber -> String -> String
[MinorNumber] -> String -> String
MinorNumber -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MinorNumber] -> String -> String
$cshowList :: [MinorNumber] -> String -> String
show :: MinorNumber -> String
$cshow :: MinorNumber -> String
showsPrec :: Int -> MinorNumber -> String -> String
$cshowsPrec :: Int -> MinorNumber -> String -> String
Show)

getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe MinorNumber
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"findmnt"
	[ String
"-rn"
	, String
"--output"
	, String
"MAJ:MIN"
	]
	String
""
  where
	parse :: String -> Maybe MinorNumber
parse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe 
		forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) 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
':')

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

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

getDiskSize :: FilePath -> IO DiskSize
getDiskSize :: String -> IO DiskSize
getDiskSize String
dev = do
	Integer
sectors <- forall a. a -> Maybe a -> a
fromMaybe Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe 
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"blockdev" [String
"--getsz", String
dev] String
""
	forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DiskSize
DiskSize (Integer
sectors forall a. Num a => a -> a -> a
* Integer
512))

getMountsSizes :: IO [(MountPoint, Integer)]
getMountsSizes :: IO [(String, Integer)]
getMountsSizes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {b}. Read b => [String] -> Maybe (String, b)
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"findmnt" [String]
ps String
""
  where
	ps :: [String]
ps = [String
"-rnb", String
"-o", String
"TARGET,USED"]
	parse :: [String] -> Maybe (String, b)
parse (String
mp:String
szs:[]) = do
		b
sz <- forall a. Read a => String -> Maybe a
readMaybe String
szs
		forall (m :: * -> *) a. Monad m => a -> m a
return (String
mp, b
sz)
	parse [String]
_ = forall a. Maybe a
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 (Int -> TargetFilled -> String -> String
[TargetFilled] -> String -> String
TargetFilled -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TargetFilled] -> String -> String
$cshowList :: [TargetFilled] -> String -> String
show :: TargetFilled -> String
$cshow :: TargetFilled -> String
showsPrec :: Int -> TargetFilled -> String -> String
$cshowsPrec :: Int -> TargetFilled -> String -> String
Show, TargetFilled -> TargetFilled -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TargetFilled -> TargetFilled -> Bool
$c/= :: TargetFilled -> TargetFilled -> Bool
== :: TargetFilled -> TargetFilled -> Bool
$c== :: TargetFilled -> TargetFilled -> Bool
Eq)

instance Sem.Semigroup TargetFilled where
	TargetFilled Ratio Integer
n <> :: TargetFilled -> TargetFilled -> TargetFilled
<> TargetFilled Ratio Integer
m = Ratio Integer -> TargetFilled
TargetFilled (Ratio Integer
nforall a. Num a => a -> a -> a
+Ratio Integer
m) 

instance Monoid TargetFilled where
	mempty :: TargetFilled
mempty = Ratio Integer -> TargetFilled
TargetFilled (Integer
0 forall a. Integral a => a -> a -> Ratio a
% Integer
1)
	mappend :: TargetFilled -> TargetFilled -> TargetFilled
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)

newtype TargetFilledHandle = TargetFilledHandle Integer

-- | Prepare for getting `TargetFilled`.
prepTargetFilled :: IO TargetFilledHandle
prepTargetFilled :: IO TargetFilledHandle
prepTargetFilled = Maybe String -> IO TargetFilledHandle
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
getMountSource String
"/"
  where
	go :: Maybe String -> IO TargetFilledHandle
go (Just String
dev) = do
		-- Assumes that the installer uses a single partition.
		DiskSize Integer
sz <- String -> IO DiskSize
getDiskSize String
dev
		forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TargetFilledHandle
TargetFilledHandle Integer
sz)
	go Maybe String
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TargetFilledHandle
TargetFilledHandle Integer
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 -> IO TargetFilled
checkTargetFilled (TargetFilledHandle Integer
installsz) = do
	Integer
targetsz <- forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
isTargetMountPoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
		forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, Integer)]
getMountsSizes
	forall (m :: * -> *) a. Monad m => a -> m a
return (Ratio Integer -> TargetFilled
TargetFilled (Integer
targetsz forall a. Integral a => a -> a -> Ratio a
% forall a. Ord a => a -> a -> a
max Integer
1 Integer
installsz))

newtype TargetFilledPercent = TargetFilledPercent Int
	deriving (Int -> TargetFilledPercent -> String -> String
[TargetFilledPercent] -> String -> String
TargetFilledPercent -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TargetFilledPercent] -> String -> String
$cshowList :: [TargetFilledPercent] -> String -> String
show :: TargetFilledPercent -> String
$cshow :: TargetFilledPercent -> String
showsPrec :: Int -> TargetFilledPercent -> String -> String
$cshowsPrec :: Int -> TargetFilledPercent -> String -> String
Show, TargetFilledPercent -> TargetFilledPercent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TargetFilledPercent -> TargetFilledPercent -> Bool
$c/= :: TargetFilledPercent -> TargetFilledPercent -> Bool
== :: TargetFilledPercent -> TargetFilledPercent -> Bool
$c== :: TargetFilledPercent -> TargetFilledPercent -> Bool
Eq)

targetFilledPercent :: TargetFilled -> TargetFilledPercent
targetFilledPercent :: TargetFilled -> TargetFilledPercent
targetFilledPercent (TargetFilled Ratio Integer
r) = Int -> TargetFilledPercent
TargetFilledPercent forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor Double
percent
  where
	percent :: Double
	percent :: Double
percent = forall a. Ord a => a -> a -> a
min Double
100 (forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
r forall a. Num a => a -> a -> a
* Double
100)