{-# 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 :: 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 FilePath
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])
-> FilePath
-> RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall p. IsProp p => p -> FilePath -> p
`describe` (FilePath
"target system installed to " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetdev)
		(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
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])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux]))
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])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux]))
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])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux]))
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
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (RevertableProperty DebianLike DebianLike)
     (RevertableProperty
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux])
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`before` i
-> [PartSpec DiskPart]
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall i.
UserInput i =>
i
-> [PartSpec DiskPart]
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
mountTarget i
userinput [PartSpec DiskPart]
partspec
			RevertableProperty DebianLike DebianLike
-> RevertableProperty
     (MetaTypes
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (RevertableProperty DebianLike DebianLike)
     (RevertableProperty
        (MetaTypes
           '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux])
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Chroot
-> RevertableProperty
     (HasInfo
      + MetaTypes
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
provisioned Chroot
chroot
	
	chroot :: Chroot
chroot = Host -> RsyncBootstrapper -> FilePath -> Chroot
forall bootstrapper.
ChrootBootstrapper bootstrapper =>
Host -> bootstrapper -> FilePath -> Chroot
hostChroot Host
targethost RsyncBootstrapper
RsyncBootstrapper FilePath
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
-> FilePath
-> Either
     FilePath
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
buildchroot RsyncBootstrapper
RsyncBootstrapper Info
_ FilePath
target = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Either
     FilePath
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall a b. b -> Either a b
Right (Property
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Either
      FilePath
      (Property
         (MetaTypes
            '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
               'Targeting 'OSArchLinux])))
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Either
     FilePath
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall a b. (a -> b) -> a -> b
$
		Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
mountaside
			Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
Property (DebianLike + ArchLinux)
rsynced
			Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property UnixLike
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
     (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
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
mountaside = FilePath
-> FilePath
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
bindMount FilePath
"/" FilePath
"/mnt"
		rsynced :: Property (DebianLike + ArchLinux)
rsynced = [FilePath] -> Property (DebianLike + ArchLinux)
Rsync.rsync
			[ FilePath
"--one-file-system"
			, FilePath
"-aHAXS"
			, FilePath
"--delete"
			, FilePath
"/mnt/"
			, FilePath
target
			]
		umountaside :: Property UnixLike
umountaside = FilePath -> [FilePath] -> UncheckedProperty UnixLike
cmdProperty FilePath
"umount" [FilePath
"-l", FilePath
"/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 :: i
-> [PartSpec DiskPart]
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
mountTarget i
userinput [PartSpec DiskPart]
partspec = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
setup Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
cleanup
  where
	setup :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
setup = FilePath
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property FilePath
"target mounted" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$
		case i -> Maybe TargetDiskDevice
forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
			Just (TargetDiskDevice FilePath
targetdev) -> do
				IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
				[Bool]
r <- IO [Bool] -> Propellor [Bool]
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 FilePath, MountOpts), Integer)]
-> (((Maybe FilePath, 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 FilePath, MountOpts), Integer)]
tomount ((((Maybe FilePath, MountOpts), Integer) -> IO Bool) -> IO [Bool])
-> (((Maybe FilePath, MountOpts), Integer) -> IO Bool) -> IO [Bool]
forall a b. (a -> b) -> a -> b
$
					FilePath -> ((Maybe FilePath, MountOpts), Integer) -> IO Bool
mountone FilePath
targetdev
				if [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
r
					then Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
					else Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
			Maybe TargetDiskDevice
Nothing -> Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
	cleanup :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
cleanup = FilePath
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
FilePath -> Propellor Result -> Property (MetaTypes metatypes)
property FilePath
"target unmounted" (Propellor Result
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Propellor Result
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ do
		IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
		IO () -> Propellor ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
removeDirectoryRecursive FilePath
targetDir
		Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange

	-- Sort so / comes before /home etc
	tomount :: [((Maybe FilePath, MountOpts), Integer)]
tomount = (((Maybe FilePath, MountOpts), Integer) -> Maybe FilePath)
-> [((Maybe FilePath, MountOpts), Integer)]
-> [((Maybe FilePath, MountOpts), Integer)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn ((Maybe FilePath, MountOpts) -> Maybe FilePath
forall a b. (a, b) -> a
fst ((Maybe FilePath, MountOpts) -> Maybe FilePath)
-> (((Maybe FilePath, MountOpts), Integer)
    -> (Maybe FilePath, MountOpts))
-> ((Maybe FilePath, MountOpts), Integer)
-> Maybe FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath, MountOpts), Integer)
-> (Maybe FilePath, MountOpts)
forall a b. (a, b) -> a
fst) ([((Maybe FilePath, MountOpts), Integer)]
 -> [((Maybe FilePath, MountOpts), Integer)])
-> [((Maybe FilePath, MountOpts), Integer)]
-> [((Maybe FilePath, MountOpts), Integer)]
forall a b. (a -> b) -> a -> b
$
		((PartSpec DiskPart, Integer)
 -> ((Maybe FilePath, MountOpts), Integer))
-> [(PartSpec DiskPart, Integer)]
-> [((Maybe FilePath, MountOpts), Integer)]
forall a b. (a -> b) -> [a] -> [b]
map (\((Maybe FilePath
mp, MountOpts
mo, PartSize -> Partition
_, DiskPart
_), Integer
n) -> ((Maybe FilePath
mp, MountOpts
mo), Integer
n)) ([(PartSpec DiskPart, Integer)]
 -> [((Maybe FilePath, MountOpts), Integer)])
-> [(PartSpec DiskPart, Integer)]
-> [((Maybe FilePath, 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 :: FilePath -> ((Maybe FilePath, MountOpts), Integer) -> IO Bool
mountone FilePath
targetdev ((Maybe FilePath
mmountpoint, MountOpts
mountopts), Integer
num) =
		case Maybe FilePath
mmountpoint of
			Maybe FilePath
Nothing -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
			Just FilePath
mountpoint -> do
				let targetmount :: FilePath
targetmount = FilePath
targetDir FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
mountpoint
				Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
True FilePath
targetmount
				let dev :: FilePath
dev = FilePath -> Integer -> FilePath
diskPartition FilePath
targetdev Integer
num
				FilePath -> FilePath -> FilePath -> MountOpts -> IO Bool
mount FilePath
"auto" FilePath
dev FilePath
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 :: i
-> TargetPartTable
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
fstabLists i
userinput (TargetPartTable TableType
_ [PartSpec DiskPart]
partspecs) = Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
setup Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	setup :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
setup = case i -> Maybe TargetDiskDevice
forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
		Just (TargetDiskDevice FilePath
targetdev) ->
			[FilePath]
-> [SwapPartition]
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
Fstab.fstabbed [FilePath]
mnts (FilePath -> [SwapPartition]
swaps FilePath
targetdev)
				Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
devmounted
				Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> CombinedType
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
     (Property
        (MetaTypes
           '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
              'Targeting 'OSArchLinux]))
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
devumounted
		Maybe TargetDiskDevice
Nothing -> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing

	-- needed for ftabbed UUID probing to work
	devmounted :: Property Linux
	devmounted :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
devmounted = Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> MountOpts -> Property UnixLike
mounted FilePath
"devtmpfs" FilePath
"udev" FilePath
"/dev" MountOpts
forall a. Monoid a => a
mempty
	devumounted :: Property Linux
	devumounted :: Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
devumounted = Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets (Property UnixLike
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> Property UnixLike
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> UncheckedProperty UnixLike
cmdProperty FilePath
"umount" [FilePath
"-l", FilePath
"/dev"]
		UncheckedProperty UnixLike -> Result -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
	
	partitions :: [(Maybe FilePath, Partition)]
partitions = (PartSpec DiskPart -> (Maybe FilePath, Partition))
-> [PartSpec DiskPart] -> [(Maybe FilePath, Partition)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe FilePath
mp, MountOpts
_, PartSize -> Partition
mkpart, DiskPart
_) -> (Maybe FilePath
mp, PartSize -> Partition
mkpart PartSize
forall a. Monoid a => a
mempty)) [PartSpec DiskPart]
partspecs
	mnts :: [FilePath]
mnts = ((Maybe FilePath, Partition) -> Maybe FilePath)
-> [(Maybe FilePath, Partition)] -> [FilePath]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Maybe FilePath, Partition) -> Maybe FilePath
forall a b. (a, b) -> a
fst ([(Maybe FilePath, Partition)] -> [FilePath])
-> [(Maybe FilePath, Partition)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
		((Maybe FilePath, Partition) -> Bool)
-> [(Maybe FilePath, Partition)] -> [(Maybe FilePath, Partition)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe FilePath
_, 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 FilePath, Partition)]
partitions
	swaps :: FilePath -> [SwapPartition]
swaps FilePath
targetdev = 
		(((Maybe FilePath, Partition), Integer) -> SwapPartition)
-> [((Maybe FilePath, Partition), Integer)] -> [SwapPartition]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> SwapPartition
Fstab.SwapPartition (FilePath -> SwapPartition)
-> (((Maybe FilePath, Partition), Integer) -> FilePath)
-> ((Maybe FilePath, Partition), Integer)
-> SwapPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Integer -> FilePath
diskPartition FilePath
targetdev (Integer -> FilePath)
-> (((Maybe FilePath, Partition), Integer) -> Integer)
-> ((Maybe FilePath, Partition), Integer)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Maybe FilePath, Partition), Integer) -> Integer
forall a b. (a, b) -> b
snd) ([((Maybe FilePath, Partition), Integer)] -> [SwapPartition])
-> [((Maybe FilePath, Partition), Integer)] -> [SwapPartition]
forall a b. (a -> b) -> a -> b
$
			(((Maybe FilePath, Partition), Integer) -> Bool)
-> [((Maybe FilePath, Partition), Integer)]
-> [((Maybe FilePath, Partition), Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\((Maybe FilePath
_, 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 FilePath, Partition)]
-> [Integer] -> [((Maybe FilePath, Partition), Integer)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe FilePath, Partition)]
partitions [Integer]
partNums)

-- | Make the target bootable using whatever bootloader is installed on it.
targetBootable
	:: UserInput i
	=> i
	-> RevertableProperty Linux Linux
targetBootable :: i
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
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 FilePath
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> 
			FilePath
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go FilePath
targetdev Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing
		(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> RevertableProperty
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property
  (MetaTypes
     '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
        'Targeting 'OSArchLinux])
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing
  where
	desc :: FilePath
desc = FilePath
"bootloader installed on target disk"
	go :: FilePath -> Property Linux
	go :: FilePath
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
go FilePath
targetdev = FilePath
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
forall k (metatypes :: k).
SingI metatypes =>
FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' FilePath
desc ((OuterMetaTypesWitness
    '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
       'Targeting 'OSArchLinux]
  -> Propellor Result)
 -> Property
      (MetaTypes
         '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux]))
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> Propellor Result)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
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
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> 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
   (MetaTypes
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux])
 -> Propellor Result)
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
-> Propellor Result
forall a b. (a -> b) -> a -> b
$
				FilePath
-> FilePath
-> GrubTarget
-> Property
     (MetaTypes
        '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
           'Targeting 'OSArchLinux])
Grub.bootsMounted FilePath
targetDir FilePath
targetdev GrubTarget
gt
			[] -> do
				FilePath -> Propellor ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
warningMessage FilePath
"no bootloader was installed"
				Result -> Propellor Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
			[BootloaderInstalled]
l -> do
				FilePath -> Propellor ()
forall (m :: * -> *). MonadIO m => FilePath -> m ()
warningMessage (FilePath -> Propellor ()) -> FilePath -> Propellor ()
forall a b. (a -> b) -> a -> b
$ FilePath
"don't know how to enable bootloader(s) " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [BootloaderInstalled] -> FilePath
forall a. Show a => a -> FilePath
show [BootloaderInstalled]
l
				Result -> Propellor Result
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 :: 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
$ FilePath
-> (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Propellor Result)
-> Property DebianLike
forall k (metatypes :: k).
SingI metatypes =>
FilePath
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' FilePath
"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 FilePath
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> do
				IO () -> Propellor ()
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 (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO DiskSize -> Propellor DiskSize)
-> IO DiskSize -> Propellor DiskSize
forall a b. (a -> b) -> a -> b
$ FilePath -> IO DiskSize
getDiskSize FilePath
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 -> FilePath -> PartTable -> Property DebianLike
partitioned Eep
YesReallyDeleteDiskContents FilePath
targetdev PartTable
parttable
			(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> FilePath -> Propellor Result
forall a. HasCallStack => FilePath -> a
error FilePath
"user input does not allow partitioning disk"

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

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

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

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

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

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

-- /dev/sda to /dev/sda1
diskPartition :: FilePath -> Integer -> FilePath
diskPartition :: FilePath -> Integer -> FilePath
diskPartition FilePath
dev Integer
num = FilePath
dev FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Integer -> FilePath
forall a. Show a => a -> FilePath
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 :: FilePath -> IO Bool
notmounted FilePath
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
<$> FilePath -> IO (Maybe MinorNumber)
getMinorNumber FilePath
d
	[Candidate]
candidates <- (FilePath -> IO Candidate) -> [FilePath] -> IO [Candidate]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Candidate
probeCandidate
		([FilePath] -> IO [Candidate]) -> IO [FilePath] -> IO [Candidate]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (FilePath -> IO Bool) -> [FilePath] -> IO [FilePath]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM FilePath -> IO Bool
notmounted
		([FilePath] -> IO [FilePath]) -> IO [FilePath] -> IO [FilePath]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [FilePath]
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 FilePath
candidateDevice = Down FilePath
dev } : [Candidate]
_) -> 
			TargetDiskDevice -> IO TargetDiskDevice
forall (m :: * -> *) a. Monad m => a -> m a
return (TargetDiskDevice -> IO TargetDiskDevice)
-> TargetDiskDevice -> IO TargetDiskDevice
forall a b. (a -> b) -> a -> b
$ FilePath -> TargetDiskDevice
TargetDiskDevice FilePath
dev
		[] -> FilePath -> IO TargetDiskDevice
forall a. HasCallStack => FilePath -> a
error FilePath
"Unable to find any disk to install to!"

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

probeCandidate :: FilePath -> IO Candidate
probeCandidate :: FilePath -> IO Candidate
probeCandidate FilePath
dev = do
	DiskSize Integer
sz <- FilePath -> IO DiskSize
getDiskSize FilePath
dev
	Bool
isfixeddisk <- Bool -> Bool
not (Bool -> Bool) -> IO Bool -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO Bool
isRemovableDisk FilePath
dev
	Candidate -> IO Candidate
forall (m :: * -> *) a. Monad m => a -> m a
return (Candidate -> IO Candidate) -> Candidate -> IO Candidate
forall a b. (a -> b) -> a -> b
$ Candidate :: Bool -> Bool -> Down FilePath -> Candidate
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 FilePath
candidateDevice = FilePath -> Down FilePath
forall a. a -> Down a
Down FilePath
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
/= :: MinorNumber -> MinorNumber -> Bool
$c/= :: MinorNumber -> MinorNumber -> Bool
== :: MinorNumber -> MinorNumber -> Bool
$c== :: MinorNumber -> MinorNumber -> Bool
Eq, Int -> MinorNumber -> FilePath -> FilePath
[MinorNumber] -> FilePath -> FilePath
MinorNumber -> FilePath
(Int -> MinorNumber -> FilePath -> FilePath)
-> (MinorNumber -> FilePath)
-> ([MinorNumber] -> FilePath -> FilePath)
-> Show MinorNumber
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [MinorNumber] -> FilePath -> FilePath
$cshowList :: [MinorNumber] -> FilePath -> FilePath
show :: MinorNumber -> FilePath
$cshow :: MinorNumber -> FilePath
showsPrec :: Int -> MinorNumber -> FilePath -> FilePath
$cshowsPrec :: Int -> MinorNumber -> FilePath -> FilePath
Show)

getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs = (FilePath -> Maybe MinorNumber) -> [FilePath] -> [MinorNumber]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe FilePath -> Maybe MinorNumber
parse ([FilePath] -> [MinorNumber])
-> (FilePath -> [FilePath]) -> FilePath -> [MinorNumber]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines (FilePath -> [MinorNumber]) -> IO FilePath -> IO [MinorNumber]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"findmnt"
	[ FilePath
"-rn"
	, FilePath
"--output"
	, FilePath
"MAJ:MIN"
	]
	FilePath
""
  where
	parse :: FilePath -> Maybe MinorNumber
parse = (Integer -> MinorNumber) -> Maybe Integer -> Maybe MinorNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber (Maybe Integer -> Maybe MinorNumber)
-> (FilePath -> Maybe Integer) -> FilePath -> Maybe MinorNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe 
		(FilePath -> Maybe Integer)
-> (FilePath -> FilePath) -> FilePath -> Maybe Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
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) (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> FilePath -> FilePath
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 :: FilePath -> IO (Maybe MinorNumber)
getMinorNumber FilePath
dev = (Integer -> MinorNumber) -> Maybe Integer -> Maybe MinorNumber
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber (Maybe Integer -> Maybe MinorNumber)
-> (FilePath -> Maybe Integer) -> FilePath -> Maybe MinorNumber
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe 
	(FilePath -> Maybe MinorNumber)
-> IO FilePath -> IO (Maybe MinorNumber)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"stat" [ FilePath
"--printf", FilePath
"%T", FilePath
dev ] FilePath
""

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

getDiskSize :: FilePath -> IO DiskSize
getDiskSize :: FilePath -> IO DiskSize
getDiskSize FilePath
dev = do
	Integer
sectors <- Integer -> Maybe Integer -> Integer
forall a. a -> Maybe a -> a
fromMaybe Integer
0 (Maybe Integer -> Integer)
-> (FilePath -> Maybe Integer) -> FilePath -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Maybe Integer
forall a. Read a => FilePath -> Maybe a
readMaybe 
		(FilePath -> Integer) -> IO FilePath -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"blockdev" [FilePath
"--getsz", FilePath
dev] FilePath
""
	DiskSize -> IO DiskSize
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 [(FilePath, Integer)]
getMountsSizes = (FilePath -> Maybe (FilePath, Integer))
-> [FilePath] -> [(FilePath, Integer)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([FilePath] -> Maybe (FilePath, Integer)
forall b. Read b => [FilePath] -> Maybe (FilePath, b)
parse ([FilePath] -> Maybe (FilePath, Integer))
-> (FilePath -> [FilePath])
-> FilePath
-> Maybe (FilePath, Integer)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
words) ([FilePath] -> [(FilePath, Integer)])
-> (FilePath -> [FilePath]) -> FilePath -> [(FilePath, Integer)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> [FilePath]
lines (FilePath -> [(FilePath, Integer)])
-> IO FilePath -> IO [(FilePath, Integer)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> [FilePath] -> FilePath -> IO FilePath
readProcess FilePath
"findmnt" [FilePath]
ps FilePath
""
  where
	ps :: [FilePath]
ps = [FilePath
"-rnb", FilePath
"-o", FilePath
"TARGET,USED"]
	parse :: [FilePath] -> Maybe (FilePath, b)
parse (FilePath
mp:FilePath
szs:[]) = do
		b
sz <- FilePath -> Maybe b
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
szs
		(FilePath, b) -> Maybe (FilePath, b)
forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath
mp, b
sz)
	parse [FilePath]
_ = Maybe (FilePath, 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 -> FilePath -> FilePath
[TargetFilled] -> FilePath -> FilePath
TargetFilled -> FilePath
(Int -> TargetFilled -> FilePath -> FilePath)
-> (TargetFilled -> FilePath)
-> ([TargetFilled] -> FilePath -> FilePath)
-> Show TargetFilled
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [TargetFilled] -> FilePath -> FilePath
$cshowList :: [TargetFilled] -> FilePath -> FilePath
show :: TargetFilled -> FilePath
$cshow :: TargetFilled -> FilePath
showsPrec :: Int -> TargetFilled -> FilePath -> FilePath
$cshowsPrec :: Int -> TargetFilled -> FilePath -> FilePath
Show, TargetFilled -> TargetFilled -> Bool
(TargetFilled -> TargetFilled -> Bool)
-> (TargetFilled -> TargetFilled -> Bool) -> Eq TargetFilled
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
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 FilePath -> IO TargetFilledHandle
go (Maybe FilePath -> IO TargetFilledHandle)
-> IO (Maybe FilePath) -> IO TargetFilledHandle
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FilePath -> IO (Maybe FilePath)
getMountSource FilePath
"/"
  where
	go :: Maybe FilePath -> IO TargetFilledHandle
go (Just FilePath
dev) = do
		-- Assumes that the installer uses a single partition.
		DiskSize Integer
sz <- FilePath -> IO DiskSize
getDiskSize FilePath
dev
		TargetFilledHandle -> IO TargetFilledHandle
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TargetFilledHandle
TargetFilledHandle Integer
sz)
	go Maybe FilePath
Nothing = TargetFilledHandle -> IO TargetFilledHandle
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 (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Integer] -> Integer)
-> ([(FilePath, Integer)] -> [Integer])
-> [(FilePath, Integer)]
-> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, Integer) -> Integer)
-> [(FilePath, Integer)] -> [Integer]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath, Integer) -> Integer
forall a b. (a, b) -> b
snd ([(FilePath, Integer)] -> [Integer])
-> ([(FilePath, Integer)] -> [(FilePath, Integer)])
-> [(FilePath, Integer)]
-> [Integer]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((FilePath, Integer) -> Bool)
-> [(FilePath, Integer)] -> [(FilePath, Integer)]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> Bool
isTargetMountPoint (FilePath -> Bool)
-> ((FilePath, Integer) -> FilePath) -> (FilePath, Integer) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, Integer) -> FilePath
forall a b. (a, b) -> a
fst)
		([(FilePath, Integer)] -> Integer)
-> IO [(FilePath, Integer)] -> IO Integer
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(FilePath, Integer)]
getMountsSizes
	TargetFilled -> IO TargetFilled
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 -> FilePath -> FilePath
[TargetFilledPercent] -> FilePath -> FilePath
TargetFilledPercent -> FilePath
(Int -> TargetFilledPercent -> FilePath -> FilePath)
-> (TargetFilledPercent -> FilePath)
-> ([TargetFilledPercent] -> FilePath -> FilePath)
-> Show TargetFilledPercent
forall a.
(Int -> a -> FilePath -> FilePath)
-> (a -> FilePath) -> ([a] -> FilePath -> FilePath) -> Show a
showList :: [TargetFilledPercent] -> FilePath -> FilePath
$cshowList :: [TargetFilledPercent] -> FilePath -> FilePath
show :: TargetFilledPercent -> FilePath
$cshow :: TargetFilledPercent -> FilePath
showsPrec :: Int -> TargetFilledPercent -> FilePath -> FilePath
$cshowsPrec :: Int -> TargetFilledPercent -> FilePath -> FilePath
Show, TargetFilledPercent -> TargetFilledPercent -> Bool
(TargetFilledPercent -> TargetFilledPercent -> Bool)
-> (TargetFilledPercent -> TargetFilledPercent -> Bool)
-> Eq TargetFilledPercent
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 (Int -> TargetFilledPercent) -> Int -> TargetFilledPercent
forall a b. (a -> b) -> a -> b
$ Double -> Int
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)