{-# 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 (i -> Maybe TargetDiskDevice
forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, i -> Maybe DiskEraseConfirmed
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 RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> String
-> RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall p. IsProp p => p -> String -> p
`describe` (String
"target system installed to " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetdev)
		(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> Property Linux
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property Linux
installdeps Property
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	targethost :: Host
targethost = Versioned v Host
vtargethost Versioned v Host -> v -> Host
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 = Property
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
RevertableProperty
		(RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  DebianLike
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property setupmetatypes
setupRevertableProperty CombinedType
  (RevertableProperty DebianLike DebianLike)
  (RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux)
RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  DebianLike
p)
		-- Versioned needs both "sides" of the RevertableProperty
		-- to have the same type, so add empty Info to make the
		-- types line up.
		(RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  DebianLike
-> Property DebianLike
forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property undometatypes
undoRevertableProperty CombinedType
  (RevertableProperty DebianLike DebianLike)
  (RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux)
RevertableProperty
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
  DebianLike
p Property DebianLike
-> Info
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
`setInfoProperty` Info
forall a. Monoid a => a
mempty)
	  where
		p :: CombinedType
  (RevertableProperty DebianLike DebianLike)
  (RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux)
p = i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
forall i.
UserInput i =>
i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
partitionTargetDisk i
userinput TableType
tabletype [PartSpec DiskPart]
partspec
			RevertableProperty DebianLike DebianLike
-> RevertableProperty Linux Linux
-> CombinedType
     (RevertableProperty DebianLike DebianLike)
     (RevertableProperty Linux Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` i -> [PartSpec DiskPart] -> RevertableProperty Linux Linux
forall i.
UserInput i =>
i -> [PartSpec DiskPart] -> RevertableProperty Linux Linux
mountTarget i
userinput [PartSpec DiskPart]
partspec
			RevertableProperty DebianLike DebianLike
-> RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     Linux
-> CombinedType
     (RevertableProperty DebianLike DebianLike)
     (RevertableProperty
        (MetaTypes
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux])
        Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned Chroot
chroot
	
	chroot :: Chroot
chroot = Host -> RsyncBootstrapper -> String -> 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 = Property Linux -> Either String (Property Linux)
forall a b. b -> Either a b
Right (Property Linux -> Either String (Property Linux))
-> Property Linux -> Either String (Property Linux)
forall a b. (a -> b) -> a -> b
$
		Property Linux
mountaside
			Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property Linux
Property (DebianLike + ArchLinux)
rsynced
			CombinedType (Property Linux) (Property Linux)
-> Property UnixLike
-> CombinedType
     (CombinedType (Property Linux) (Property Linux))
     (Property UnixLike)
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"]
			UncheckedProperty UnixLike -> Result -> Property UnixLike
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 Property Linux -> Property Linux -> RevertableProperty Linux Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
cleanup
  where
	setup :: Property Linux
setup = String -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"target mounted" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$
		case i -> Maybe TargetDiskDevice
forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
			Just (TargetDiskDevice String
targetdev) -> do
				IO () -> Propellor ()
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
				[Bool]
r <- IO [Bool] -> Propellor [Bool]
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [Bool] -> Propellor [Bool]) -> IO [Bool] -> Propellor [Bool]
forall a b. (a -> b) -> a -> b
$ [((Maybe String, MountOpts), Integer)]
-> (((Maybe String, MountOpts), Integer) -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((Maybe String, MountOpts), Integer)]
tomount ((((Maybe String, MountOpts), Integer) -> IO Bool) -> IO [Bool])
-> (((Maybe String, MountOpts), Integer) -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$
					String -> ((Maybe String, MountOpts), Integer) -> IO Bool
mountone String
targetdev
				if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
r
					then Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
					else Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
			Maybe TargetDiskDevice
Nothing -> Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
	cleanup :: Property Linux
cleanup = String -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"target unmounted" (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ do
		IO () -> Propellor ()
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
		IO () -> Propellor ()
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
targetDir
		Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange

	-- Sort so / comes before /home etc
	tomount :: [((Maybe String, MountOpts), Integer)]
tomount = (((Maybe String, MountOpts), Integer) -> Maybe String)
-> [((Maybe String, MountOpts), Integer)]
-> [((Maybe String, MountOpts), Integer)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((Maybe String, MountOpts) -> Maybe String
forall a b. (a, b) -> a
fst ((Maybe String, MountOpts) -> Maybe String)
-> (((Maybe String, MountOpts), Integer)
    -> (Maybe String, MountOpts))
-> ((Maybe String, MountOpts), Integer)
-> Maybe String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe String, MountOpts), Integer) -> (Maybe String, MountOpts)
forall a b. (a, b) -> a
fst) ([((Maybe String, MountOpts), Integer)]
 -> [((Maybe String, MountOpts), Integer)])
-> [((Maybe String, MountOpts), Integer)]
-> [((Maybe String, MountOpts), Integer)]
forall a b. (a -> b) -> a -> b
$
		((PartSpec DiskPart, Integer)
 -> ((Maybe String, MountOpts), Integer))
-> [(PartSpec DiskPart, Integer)]
-> [((Maybe String, MountOpts), Integer)]
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)) ([(PartSpec DiskPart, Integer)]
 -> [((Maybe String, MountOpts), Integer)])
-> [(PartSpec DiskPart, Integer)]
-> [((Maybe String, MountOpts), Integer)]
forall a b. (a -> b) -> a -> b
$
		[PartSpec DiskPart] -> [Integer] -> [(PartSpec DiskPart, Integer)]
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 -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
			Just String
mountpoint -> do
				let targetmount :: String
targetmount = String
targetDir String -> String -> String
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)
Property Linux
setup Property Linux -> Property Linux -> RevertableProperty Linux Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	setup :: CombinedType (Property Linux) (Property Linux)
setup = case i -> Maybe TargetDiskDevice
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)
				Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property Linux
devmounted
				Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property Linux
devumounted
		Maybe TargetDiskDevice
Nothing -> CombinedType (Property Linux) (Property Linux)
Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing

	-- needed for ftabbed UUID probing to work
	devmounted :: Property Linux
	devmounted :: Property Linux
devmounted = Property UnixLike -> Property Linux
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property Linux)
-> Property UnixLike -> Property Linux
forall a b. (a -> b) -> a -> b
$ String -> String -> String -> MountOpts -> Property UnixLike
mounted String
"devtmpfs" String
"udev" String
"/dev" MountOpts
forall a. Monoid a => a
mempty
	devumounted :: Property Linux
	devumounted :: Property Linux
devumounted = Property UnixLike -> Property Linux
forall (untightened :: [MetaType]) (tightened :: [MetaType]).
(TightenTargetsAllowed untightened tightened, SingI tightened) =>
Property (MetaTypes untightened) -> Property (MetaTypes tightened)
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike -> Property Linux)
-> Property UnixLike -> Property Linux
forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"umount" [String
"-l", String
"/dev"]
		UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	
	partitions :: [(Maybe String, Partition)]
partitions = (PartSpec DiskPart -> (Maybe String, Partition))
-> [PartSpec DiskPart] -> [(Maybe String, Partition)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe String
mp, MountOpts
_, PartSize -> Partition
mkpart, DiskPart
_) -> (Maybe String
mp, PartSize -> Partition
mkpart PartSize
forall a. Monoid a => a
mempty)) [PartSpec DiskPart]
partspecs
	mnts :: [String]
mnts = ((Maybe String, Partition) -> Maybe String)
-> [(Maybe String, Partition)] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe String, Partition) -> Maybe String
forall a b. (a, b) -> a
fst ([(Maybe String, Partition)] -> [String])
-> [(Maybe String, Partition)] -> [String]
forall a b. (a -> b) -> a -> b
$
		((Maybe String, Partition) -> Bool)
-> [(Maybe String, Partition)] -> [(Maybe String, Partition)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe String
_, Partition
p) -> Partition -> Maybe Fs
partFs Partition
p Maybe Fs -> Maybe Fs -> Bool
forall a. Eq a => a -> a -> Bool
/= Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
LinuxSwap Bool -> Bool -> Bool
&& Partition -> Maybe Fs
partFs Partition
p Maybe Fs -> Maybe Fs -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Fs
forall a. Maybe a
Nothing) [(Maybe String, Partition)]
partitions
	swaps :: String -> [SwapPartition]
swaps String
targetdev = 
		(((Maybe String, Partition), Integer) -> SwapPartition)
-> [((Maybe String, Partition), Integer)] -> [SwapPartition]
forall a b. (a -> b) -> [a] -> [b]
map (String -> SwapPartition
Fstab.SwapPartition (String -> SwapPartition)
-> (((Maybe String, Partition), Integer) -> String)
-> ((Maybe String, Partition), Integer)
-> SwapPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer -> String
diskPartition String
targetdev (Integer -> String)
-> (((Maybe String, Partition), Integer) -> Integer)
-> ((Maybe String, Partition), Integer)
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe String, Partition), Integer) -> Integer
forall a b. (a, b) -> b
snd) ([((Maybe String, Partition), Integer)] -> [SwapPartition])
-> [((Maybe String, Partition), Integer)] -> [SwapPartition]
forall a b. (a -> b) -> a -> b
$
			(((Maybe String, Partition), Integer) -> Bool)
-> [((Maybe String, Partition), Integer)]
-> [((Maybe String, Partition), Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((Maybe String
_, Partition
p), Integer
_) -> Partition -> Maybe Fs
partFs Partition
p Maybe Fs -> Maybe Fs -> Bool
forall a. Eq a => a -> a -> Bool
== Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
LinuxSwap)
				([(Maybe String, Partition)]
-> [Integer] -> [((Maybe String, Partition), Integer)]
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 (i -> Maybe TargetDiskDevice
forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, i -> Maybe DiskEraseConfirmed
forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
		(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> 
			String -> Property Linux
go String
targetdev Property Linux -> Property Linux -> RevertableProperty Linux Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
		(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing Property Linux -> Property Linux -> RevertableProperty Linux Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
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 = String
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
desc ((OuterMetaTypesWitness
    '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
       'Targeting 'OSArchLinux]
  -> Propellor Result)
 -> Property Linux)
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property Linux
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w -> do
		[BootloaderInstalled]
bootloaders <- Propellor [BootloaderInstalled]
forall v. IsInfo v => Propellor v
askInfo
		case [BootloaderInstalled]
bootloaders of
			[GrubInstalled GrubTarget
gt] -> OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
-> Property Linux -> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w (Property Linux -> Propellor Result)
-> Property Linux -> Propellor Result
forall a b. (a -> b) -> a -> b
$
				String -> String -> GrubTarget -> Property Linux
Grub.bootsMounted String
targetDir String
targetdev GrubTarget
gt
			[] -> do
				String -> Propellor ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
"no bootloader was installed"
				Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
			[BootloaderInstalled]
l -> do
				String -> Propellor ()
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage (String -> Propellor ()) -> String -> Propellor ()
forall a b. (a -> b) -> a -> b
$ String
"don't know how to enable bootloader(s) " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [BootloaderInstalled] -> String
forall a. Show a => a -> String
show [BootloaderInstalled]
l
				Result -> Propellor Result
forall a. a -> Propellor a
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 Property DebianLike
-> Property DebianLike -> RevertableProperty DebianLike DebianLike
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property DebianLike
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	go :: Property DebianLike
go = IO Bool -> Property DebianLike -> Property DebianLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check IO Bool
targetNotMounted (Property DebianLike -> Property DebianLike)
-> Property DebianLike -> Property DebianLike
forall a b. (a -> b) -> a -> b
$ String
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
"target disk partitioned" ((OuterMetaTypesWitness
    '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
  -> Propellor Result)
 -> Property DebianLike)
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		case (i -> Maybe TargetDiskDevice
forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, i -> Maybe DiskEraseConfirmed
forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
			(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> do
				IO () -> Propellor ()
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ IO ()
unmountTarget
				DiskSize
disksize <- IO DiskSize -> Propellor DiskSize
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DiskSize -> Propellor DiskSize)
-> IO DiskSize -> Propellor DiskSize
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
				OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Property DebianLike -> Propellor Result
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w (Property DebianLike -> Propellor Result)
-> Property DebianLike -> Propellor Result
forall a b. (a -> b) -> a -> b
$ 
					Eep -> String -> PartTable -> Property DebianLike
partitioned Eep
YesReallyDeleteDiskContents String
targetdev PartTable
parttable
			(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> String -> Propellor Result
forall a. HasCallStack => String -> a
error String
"user input does not allow partitioning disk"

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

targetMountPoints :: IO [MountPoint]
targetMountPoints :: IO [String]
targetMountPoints = (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isTargetMountPoint ([String] -> [String]) -> IO [String] -> IO [String]
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 String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
targetDir 
		Bool -> Bool -> Bool
|| String -> String
addTrailingPathSeparator String
targetDir String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
mp

targetNotMounted :: IO Bool
targetNotMounted :: IO Bool
targetNotMounted = Bool -> Bool
not (Bool -> Bool) -> ([String] -> Bool) -> [String] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
targetDir) ([String] -> Bool) -> IO [String] -> IO Bool
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 String -> String -> String
forall a. [a] -> [a] -> [a]
++ Integer -> String
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 = (Maybe MinorNumber -> [Maybe MinorNumber] -> Bool)
-> [Maybe MinorNumber] -> Maybe MinorNumber -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Maybe MinorNumber -> [Maybe MinorNumber] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem ((MinorNumber -> Maybe MinorNumber)
-> [MinorNumber] -> [Maybe MinorNumber]
forall a b. (a -> b) -> [a] -> [b]
map MinorNumber -> Maybe MinorNumber
forall a. a -> Maybe a
Just [MinorNumber]
mounteddevs)
		(Maybe MinorNumber -> Bool) -> IO (Maybe MinorNumber) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe MinorNumber)
getMinorNumber String
d
	[Candidate]
candidates <- (String -> IO Candidate) -> [String] -> IO [Candidate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> IO Candidate
probeCandidate
		([String] -> IO [Candidate]) -> IO [String] -> IO [Candidate]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> IO Bool) -> [String] -> IO [String]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
notmounted
		([String] -> IO [String]) -> IO [String] -> IO [String]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
findDiskDevices
	case [Candidate] -> [Candidate]
forall a. [a] -> [a]
reverse ([Candidate] -> [Candidate]
forall a. Ord a => [a] -> [a]
sort [Candidate]
candidates) of
		(Candidate { candidateDevice :: Candidate -> Down String
candidateDevice = Down String
dev } : [Candidate]
_) -> 
			TargetDiskDevice -> IO TargetDiskDevice
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetDiskDevice -> IO TargetDiskDevice)
-> TargetDiskDevice -> IO TargetDiskDevice
forall a b. (a -> b) -> a -> b
$ String -> TargetDiskDevice
TargetDiskDevice String
dev
		[] -> String -> IO TargetDiskDevice
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 = (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String
"/dev" String -> String -> String
</>) ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isdisk
	([String] -> [String]) -> IO [String] -> IO [String]
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
(Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Bool) -> Eq Candidate
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Candidate -> Candidate -> Bool
== :: Candidate -> Candidate -> Bool
$c/= :: Candidate -> Candidate -> Bool
/= :: Candidate -> Candidate -> Bool
Eq, Eq Candidate
Eq Candidate
-> (Candidate -> Candidate -> Ordering)
-> (Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Bool)
-> (Candidate -> Candidate -> Candidate)
-> (Candidate -> Candidate -> Candidate)
-> Ord 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
$ccompare :: Candidate -> Candidate -> Ordering
compare :: Candidate -> Candidate -> Ordering
$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
>= :: Candidate -> Candidate -> Bool
$cmax :: Candidate -> Candidate -> Candidate
max :: Candidate -> Candidate -> Candidate
$cmin :: Candidate -> Candidate -> Candidate
min :: Candidate -> Candidate -> Candidate
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 (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
isRemovableDisk String
dev
	Candidate -> IO Candidate
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Candidate -> IO Candidate) -> Candidate -> IO Candidate
forall a b. (a -> b) -> a -> b
$ Candidate
		{ candidateBigEnoughForOS :: Bool
candidateBigEnoughForOS = Integer
sz Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
8 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
onegb
		, candidateIsFixedDisk :: Bool
candidateIsFixedDisk = Bool
isfixeddisk
		, candidateDevice :: Down String
candidateDevice = String -> Down String
forall a. a -> Down a
Down String
dev
		}
  where
	onegb :: Integer
onegb = Integer
1024Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
1024Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
*Integer
1000

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

getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs = (String -> Maybe MinorNumber) -> [String] -> [MinorNumber]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe MinorNumber
parse ([String] -> [MinorNumber])
-> (String -> [String]) -> String -> [MinorNumber]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [MinorNumber]) -> IO String -> IO [MinorNumber]
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 = (Integer -> MinorNumber) -> Maybe Integer -> Maybe MinorNumber
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber (Maybe Integer -> Maybe MinorNumber)
-> (String -> Maybe Integer) -> String -> Maybe MinorNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe 
		(String -> Maybe Integer)
-> (String -> String) -> String -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
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 = (Integer -> MinorNumber) -> Maybe Integer -> Maybe MinorNumber
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber (Maybe Integer -> Maybe MinorNumber)
-> (String -> Maybe Integer) -> String -> Maybe MinorNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe 
	(String -> Maybe MinorNumber)
-> IO String -> IO (Maybe MinorNumber)
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"
	Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isremovable Bool -> Bool -> Bool
|| Bool
ishotplug)
  where
	checkblk :: String -> IO Bool
checkblk String
field = (String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"1\n") (String -> Bool) -> IO String -> IO Bool
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 <- Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (Maybe Integer -> Integer)
-> (String -> Maybe Integer) -> String -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Maybe Integer
forall a. Read a => String -> Maybe a
readMaybe 
		(String -> Integer) -> IO String -> IO Integer
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
""
	DiskSize -> IO DiskSize
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DiskSize
DiskSize (Integer
sectors Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Integer
512))

getMountsSizes :: IO [(MountPoint, Integer)]
getMountsSizes :: IO [(String, Integer)]
getMountsSizes = (String -> Maybe (String, Integer))
-> [String] -> [(String, Integer)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([String] -> Maybe (String, Integer)
forall {b}. Read b => [String] -> Maybe (String, b)
parse ([String] -> Maybe (String, Integer))
-> (String -> [String]) -> String -> Maybe (String, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) ([String] -> [(String, Integer)])
-> (String -> [String]) -> String -> [(String, Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines (String -> [(String, Integer)])
-> IO String -> IO [(String, Integer)]
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 <- String -> Maybe b
forall a. Read a => String -> Maybe a
readMaybe String
szs
		(String, b) -> Maybe (String, b)
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (String
mp, b
sz)
	parse [String]
_ = Maybe (String, b)
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
(Int -> TargetFilled -> String -> String)
-> (TargetFilled -> String)
-> ([TargetFilled] -> String -> String)
-> Show TargetFilled
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TargetFilled -> String -> String
showsPrec :: Int -> TargetFilled -> String -> String
$cshow :: TargetFilled -> String
show :: TargetFilled -> String
$cshowList :: [TargetFilled] -> String -> String
showList :: [TargetFilled] -> String -> String
Show, TargetFilled -> TargetFilled -> Bool
(TargetFilled -> TargetFilled -> Bool)
-> (TargetFilled -> TargetFilled -> Bool) -> Eq TargetFilled
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetFilled -> TargetFilled -> Bool
== :: TargetFilled -> TargetFilled -> Bool
$c/= :: TargetFilled -> TargetFilled -> Bool
/= :: 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
nRatio Integer -> Ratio Integer -> Ratio Integer
forall a. Num a => a -> a -> a
+Ratio Integer
m) 

instance Monoid TargetFilled where
	mempty :: TargetFilled
mempty = Ratio Integer -> TargetFilled
TargetFilled (Integer
0 Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer
1)
	mappend :: TargetFilled -> TargetFilled -> TargetFilled
mappend = TargetFilled -> TargetFilled -> TargetFilled
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 (Maybe String -> IO TargetFilledHandle)
-> IO (Maybe String) -> IO TargetFilledHandle
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
		TargetFilledHandle -> IO TargetFilledHandle
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TargetFilledHandle
TargetFilledHandle Integer
sz)
	go Maybe String
Nothing = TargetFilledHandle -> IO TargetFilledHandle
forall a. a -> IO a
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 <- [Integer] -> Integer
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer)
-> ([(String, Integer)] -> [Integer])
-> [(String, Integer)]
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Integer) -> Integer) -> [(String, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (String, Integer) -> Integer
forall a b. (a, b) -> b
snd ([(String, Integer)] -> [Integer])
-> ([(String, Integer)] -> [(String, Integer)])
-> [(String, Integer)]
-> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((String, Integer) -> Bool)
-> [(String, Integer)] -> [(String, Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
isTargetMountPoint (String -> Bool)
-> ((String, Integer) -> String) -> (String, Integer) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Integer) -> String
forall a b. (a, b) -> a
fst)
		([(String, Integer)] -> Integer)
-> IO [(String, Integer)] -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, Integer)]
getMountsSizes
	TargetFilled -> IO TargetFilled
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Ratio Integer -> TargetFilled
TargetFilled (Integer
targetsz Integer -> Integer -> Ratio Integer
forall a. Integral a => a -> a -> Ratio a
% Integer -> Integer -> Integer
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
(Int -> TargetFilledPercent -> String -> String)
-> (TargetFilledPercent -> String)
-> ([TargetFilledPercent] -> String -> String)
-> Show TargetFilledPercent
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> TargetFilledPercent -> String -> String
showsPrec :: Int -> TargetFilledPercent -> String -> String
$cshow :: TargetFilledPercent -> String
show :: TargetFilledPercent -> String
$cshowList :: [TargetFilledPercent] -> String -> String
showList :: [TargetFilledPercent] -> String -> String
Show, TargetFilledPercent -> TargetFilledPercent -> Bool
(TargetFilledPercent -> TargetFilledPercent -> Bool)
-> (TargetFilledPercent -> TargetFilledPercent -> Bool)
-> Eq TargetFilledPercent
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TargetFilledPercent -> TargetFilledPercent -> Bool
== :: TargetFilledPercent -> TargetFilledPercent -> Bool
$c/= :: TargetFilledPercent -> TargetFilledPercent -> Bool
/= :: TargetFilledPercent -> TargetFilledPercent -> Bool
Eq)

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