{-# LANGUAGE TypeOperators, RankNTypes, TypeFamilies, FlexibleContexts #-}
module Propellor.Property.Installer.Target (
TargetPartTable(..),
targetInstalled,
fstabLists,
mountTarget,
targetBootable,
partitionTargetDisk,
targetDir,
probeDisk,
findDiskDevices,
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)
data TargetPartTable = TargetPartTable TableType [PartSpec DiskPart]
targetInstalled
:: UserInput i
=> Versioned v Host
-> v
-> i
-> TargetPartTable
-> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike)
targetInstalled :: forall i v.
UserInput i =>
Versioned v Host
-> v
-> i
-> TargetPartTable
-> RevertableProperty (HasInfo + DebianLike) (HasInfo + DebianLike)
targetInstalled Versioned v Host
vtargethost v
v i
userinput (TargetPartTable TableType
tabletype [PartSpec DiskPart]
partspec) =
case (forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) ->
RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
go forall p. IsProp p => p -> String -> p
`describe` (String
"target system installed to " forall a. [a] -> [a] -> [a]
++ String
targetdev)
(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets Property Linux
installdeps forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
where
targethost :: Host
targethost = Versioned v Host
vtargethost forall v t. Versioned v t -> v -> t
`version` v
v
go :: RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
go = forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
RevertableProperty
(forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property setupmetatypes
setupRevertableProperty CombinedType
(RevertableProperty DebianLike DebianLike)
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux)
p)
(forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property undometatypes
undoRevertableProperty CombinedType
(RevertableProperty DebianLike DebianLike)
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux)
p forall {k} (metatypes' :: k) metatypes.
(MetaTypes metatypes' ~ (HasInfo + metatypes), SingI metatypes') =>
Property metatypes -> Info -> Property (MetaTypes metatypes')
`setInfoProperty` forall a. Monoid a => a
mempty)
where
p :: CombinedType
(RevertableProperty DebianLike DebianLike)
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux)
p = forall i.
UserInput i =>
i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
partitionTargetDisk i
userinput TableType
tabletype [PartSpec DiskPart]
partspec
forall x y. Combines x y => x -> y -> CombinedType x y
`before` forall i.
UserInput i =>
i -> [PartSpec DiskPart] -> RevertableProperty Linux Linux
mountTarget i
userinput [PartSpec DiskPart]
partspec
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Chroot -> RevertableProperty (HasInfo + Linux) Linux
provisioned Chroot
chroot
chroot :: Chroot
chroot = forall bootstrapper.
ChrootBootstrapper bootstrapper =>
Host -> bootstrapper -> String -> Chroot
hostChroot Host
targethost RsyncBootstrapper
RsyncBootstrapper String
targetDir
installdeps :: Property (DebianLike + ArchLinux)
installdeps = Property (DebianLike + ArchLinux)
Rsync.installed
data RsyncBootstrapper = RsyncBootstrapper
instance ChrootBootstrapper RsyncBootstrapper where
buildchroot :: RsyncBootstrapper
-> Info -> String -> Either String (Property Linux)
buildchroot RsyncBootstrapper
RsyncBootstrapper Info
_ String
target = forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
Property Linux
mountaside
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property (DebianLike + ArchLinux)
rsynced
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property UnixLike
umountaside
where
mountaside :: Property Linux
mountaside = String -> String -> Property Linux
bindMount String
"/" String
"/mnt"
rsynced :: Property (DebianLike + ArchLinux)
rsynced = [String] -> Property (DebianLike + ArchLinux)
Rsync.rsync
[ String
"--one-file-system"
, String
"-aHAXS"
, String
"--delete"
, String
"/mnt/"
, String
target
]
umountaside :: Property UnixLike
umountaside = String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"umount" [String
"-l", String
"/mnt"]
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
mountTarget
:: UserInput i
=> i
-> [PartSpec DiskPart]
-> RevertableProperty Linux Linux
mountTarget :: forall i.
UserInput i =>
i -> [PartSpec DiskPart] -> RevertableProperty Linux Linux
mountTarget i
userinput [PartSpec DiskPart]
partspec = Property Linux
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
cleanup
where
setup :: Property Linux
setup = forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"target mounted" forall a b. (a -> b) -> a -> b
$
case forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
Just (TargetDiskDevice String
targetdev) -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
[Bool]
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [((Maybe String, MountOpts), Integer)]
tomount forall a b. (a -> b) -> a -> b
$
String -> ((Maybe String, MountOpts), Integer) -> IO Bool
mountone String
targetdev
if forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
r
then forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
else forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
Maybe TargetDiskDevice
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
cleanup :: Property Linux
cleanup = forall {k} (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property String
"target unmounted" forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO ()
unmountTarget
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeDirectoryRecursive String
targetDir
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
tomount :: [((Maybe String, MountOpts), Integer)]
tomount = forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map (\((Maybe String
mp, MountOpts
mo, PartSize -> Partition
_, DiskPart
_), Integer
n) -> ((Maybe String
mp, MountOpts
mo), Integer
n)) forall a b. (a -> b) -> a -> b
$
forall a b. [a] -> [b] -> [(a, b)]
zip [PartSpec DiskPart]
partspec [Integer]
partNums
mountone :: String -> ((Maybe String, MountOpts), Integer) -> IO Bool
mountone String
targetdev ((Maybe String
mmountpoint, MountOpts
mountopts), Integer
num) =
case Maybe String
mmountpoint of
Maybe String
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Just String
mountpoint -> do
let targetmount :: String
targetmount = String
targetDir forall a. [a] -> [a] -> [a]
++ String
mountpoint
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
targetmount
let dev :: String
dev = String -> Integer -> String
diskPartition String
targetdev Integer
num
String -> String -> String -> MountOpts -> IO Bool
mount String
"auto" String
dev String
targetmount MountOpts
mountopts
fstabLists
:: UserInput i
=> i
-> TargetPartTable
-> RevertableProperty Linux Linux
fstabLists :: forall i.
UserInput i =>
i -> TargetPartTable -> RevertableProperty Linux Linux
fstabLists i
userinput (TargetPartTable TableType
_ [PartSpec DiskPart]
partspecs) = CombinedType (Property Linux) (Property Linux)
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
where
setup :: CombinedType (Property Linux) (Property Linux)
setup = case forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput of
Just (TargetDiskDevice String
targetdev) ->
[String] -> [SwapPartition] -> Property Linux
Fstab.fstabbed [String]
mnts (String -> [SwapPartition]
swaps String
targetdev)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Property Linux
devmounted
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Property Linux
devumounted
Maybe TargetDiskDevice
Nothing -> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
devmounted :: Property Linux
devmounted :: Property Linux
devmounted = forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> String -> String -> MountOpts -> Property UnixLike
mounted String
"devtmpfs" String
"udev" String
"/dev" forall a. Monoid a => a
mempty
devumounted :: Property Linux
devumounted :: Property Linux
devumounted = forall (p :: * -> *) (untightened :: [MetaType])
(tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"umount" [String
"-l", String
"/dev"]
forall (p :: * -> *) i.
Checkable p i =>
p i -> Result -> Property i
`assume` Result
MadeChange
partitions :: [(Maybe String, Partition)]
partitions = forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe String
mp, MountOpts
_, PartSize -> Partition
mkpart, DiskPart
_) -> (Maybe String
mp, PartSize -> Partition
mkpart forall a. Monoid a => a
mempty)) [PartSpec DiskPart]
partspecs
mnts :: [String]
mnts = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe String
_, Partition
p) -> Partition -> Maybe Fs
partFs Partition
p forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just Fs
LinuxSwap Bool -> Bool -> Bool
&& Partition -> Maybe Fs
partFs Partition
p forall a. Eq a => a -> a -> Bool
/= forall a. Maybe a
Nothing) [(Maybe String, Partition)]
partitions
swaps :: String -> [SwapPartition]
swaps String
targetdev =
forall a b. (a -> b) -> [a] -> [b]
map (String -> SwapPartition
Fstab.SwapPartition forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Integer -> String
diskPartition String
targetdev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> [a]
filter (\((Maybe String
_, Partition
p), Integer
_) -> Partition -> Maybe Fs
partFs Partition
p forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Fs
LinuxSwap)
(forall a b. [a] -> [b] -> [(a, b)]
zip [(Maybe String, Partition)]
partitions [Integer]
partNums)
targetBootable
:: UserInput i
=> i
-> RevertableProperty Linux Linux
targetBootable :: forall i. UserInput i => i -> RevertableProperty Linux Linux
targetBootable i
userinput =
case (forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) ->
String -> Property Linux
go String
targetdev forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
where
desc :: String
desc = String
"bootloader installed on target disk"
go :: FilePath -> Property Linux
go :: String -> Property Linux
go String
targetdev = forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w -> do
[BootloaderInstalled]
bootloaders <- forall v. IsInfo v => Propellor v
askInfo
case [BootloaderInstalled]
bootloaders of
[GrubInstalled GrubTarget
gt] -> forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$
String -> String -> GrubTarget -> Property Linux
Grub.bootsMounted String
targetDir String
targetdev GrubTarget
gt
[] -> do
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage String
"no bootloader was installed"
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
[BootloaderInstalled]
l -> do
forall (m :: * -> *). MonadIO m => String -> m ()
warningMessage forall a b. (a -> b) -> a -> b
$ String
"don't know how to enable bootloader(s) " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [BootloaderInstalled]
l
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
partitionTargetDisk
:: UserInput i
=> i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
partitionTargetDisk :: forall i.
UserInput i =>
i
-> TableType
-> [PartSpec DiskPart]
-> RevertableProperty DebianLike DebianLike
partitionTargetDisk i
userinput TableType
tabletype [PartSpec DiskPart]
partspec = Property DebianLike
go forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
where
go :: Property DebianLike
go = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check IO Bool
targetNotMounted forall a b. (a -> b) -> a -> b
$ forall {k} (metatypes :: k).
SingI metatypes =>
String
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' String
"target disk partitioned" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
case (forall i. UserInput i => i -> Maybe TargetDiskDevice
targetDiskDevice i
userinput, forall i. UserInput i => i -> Maybe DiskEraseConfirmed
diskEraseConfirmed i
userinput) of
(Just (TargetDiskDevice String
targetdev), Just DiskEraseConfirmed
_diskeraseconfirmed) -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO ()
unmountTarget
DiskSize
disksize <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ String -> IO DiskSize
getDiskSize String
targetdev
let parttable :: PartTable
parttable = DiskSize
-> TableType -> Alignment -> [PartSpec DiskPart] -> PartTable
calcPartTable DiskSize
disksize TableType
tabletype Alignment
safeAlignment [PartSpec DiskPart]
partspec
forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$
Eep -> String -> PartTable -> Property DebianLike
partitioned Eep
YesReallyDeleteDiskContents String
targetdev PartTable
parttable
(Maybe TargetDiskDevice, Maybe DiskEraseConfirmed)
_ -> forall a. HasCallStack => String -> a
error String
"user input does not allow partitioning disk"
unmountTarget :: IO ()
unmountTarget :: IO ()
unmountTarget = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> IO ()
umountLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Ord a => [a] -> [a]
sort forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
targetMountPoints
targetMountPoints :: IO [MountPoint]
targetMountPoints :: IO [String]
targetMountPoints = forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isTargetMountPoint forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
mountPoints
isTargetMountPoint :: MountPoint -> Bool
isTargetMountPoint :: String -> Bool
isTargetMountPoint String
mp =
String
mp forall a. Eq a => a -> a -> Bool
== String
targetDir
Bool -> Bool -> Bool
|| String -> String
addTrailingPathSeparator String
targetDir forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
mp
targetNotMounted :: IO Bool
targetNotMounted :: IO Bool
targetNotMounted = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall a. Eq a => a -> a -> Bool
== String
targetDir) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [String]
mountPoints
targetDir :: FilePath
targetDir :: String
targetDir = String
"/target"
partNums :: [Integer]
partNums :: [Integer]
partNums = [Integer
1..]
diskPartition :: FilePath -> Integer -> FilePath
diskPartition :: String -> Integer -> String
diskPartition String
dev Integer
num = String
dev forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Integer
num
probeDisk :: IO TargetDiskDevice
probeDisk :: IO TargetDiskDevice
probeDisk = do
IO ()
unmountTarget
[MinorNumber]
mounteddevs <- IO [MinorNumber]
getMountedDeviceIDs
let notmounted :: String -> IO Bool
notmounted String
d = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
notElem (forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> Maybe a
Just [MinorNumber]
mounteddevs)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe MinorNumber)
getMinorNumber String
d
[Candidate]
candidates <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> IO Candidate
probeCandidate
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM String -> IO Bool
notmounted
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO [String]
findDiskDevices
case forall a. [a] -> [a]
reverse (forall a. Ord a => [a] -> [a]
sort [Candidate]
candidates) of
(Candidate { candidateDevice :: Candidate -> Down String
candidateDevice = Down String
dev } : [Candidate]
_) ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> TargetDiskDevice
TargetDiskDevice String
dev
[] -> forall a. HasCallStack => String -> a
error String
"Unable to find any disk to install to!"
findDiskDevices :: IO [FilePath]
findDiskDevices :: IO [String]
findDiskDevices = forall a b. (a -> b) -> [a] -> [b]
map (String
"/dev" String -> String -> String
</>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter String -> Bool
isdisk
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [String]
getDirectoryContents String
"/dev"
where
isdisk :: String -> Bool
isdisk (Char
's':Char
'd':Char
_:[]) = Bool
True
isdisk String
_ = Bool
False
data Candidate = Candidate
{ Candidate -> Bool
candidateBigEnoughForOS :: Bool
, Candidate -> Bool
candidateIsFixedDisk :: Bool
, Candidate -> Down String
candidateDevice :: Down FilePath
} deriving (Candidate -> Candidate -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Candidate -> Candidate -> Bool
$c/= :: Candidate -> Candidate -> Bool
== :: Candidate -> Candidate -> Bool
$c== :: Candidate -> Candidate -> Bool
Eq, Eq Candidate
Candidate -> Candidate -> Bool
Candidate -> Candidate -> Ordering
Candidate -> Candidate -> Candidate
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Candidate -> Candidate -> Candidate
$cmin :: Candidate -> Candidate -> Candidate
max :: Candidate -> Candidate -> Candidate
$cmax :: Candidate -> Candidate -> Candidate
>= :: Candidate -> Candidate -> Bool
$c>= :: Candidate -> Candidate -> Bool
> :: Candidate -> Candidate -> Bool
$c> :: Candidate -> Candidate -> Bool
<= :: Candidate -> Candidate -> Bool
$c<= :: Candidate -> Candidate -> Bool
< :: Candidate -> Candidate -> Bool
$c< :: Candidate -> Candidate -> Bool
compare :: Candidate -> Candidate -> Ordering
$ccompare :: Candidate -> Candidate -> Ordering
Ord)
probeCandidate :: FilePath -> IO Candidate
probeCandidate :: String -> IO Candidate
probeCandidate String
dev = do
DiskSize Integer
sz <- String -> IO DiskSize
getDiskSize String
dev
Bool
isfixeddisk <- Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO Bool
isRemovableDisk String
dev
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Candidate
{ candidateBigEnoughForOS :: Bool
candidateBigEnoughForOS = Integer
sz forall a. Ord a => a -> a -> Bool
>= Integer
8 forall a. Num a => a -> a -> a
* Integer
onegb
, candidateIsFixedDisk :: Bool
candidateIsFixedDisk = Bool
isfixeddisk
, candidateDevice :: Down String
candidateDevice = forall a. a -> Down a
Down String
dev
}
where
onegb :: Integer
onegb = Integer
1024forall a. Num a => a -> a -> a
*Integer
1024forall a. Num a => a -> a -> a
*Integer
1000
newtype MinorNumber = MinorNumber Integer
deriving (MinorNumber -> MinorNumber -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MinorNumber -> MinorNumber -> Bool
$c/= :: MinorNumber -> MinorNumber -> Bool
== :: MinorNumber -> MinorNumber -> Bool
$c== :: MinorNumber -> MinorNumber -> Bool
Eq, Int -> MinorNumber -> String -> String
[MinorNumber] -> String -> String
MinorNumber -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [MinorNumber] -> String -> String
$cshowList :: [MinorNumber] -> String -> String
show :: MinorNumber -> String
$cshow :: MinorNumber -> String
showsPrec :: Int -> MinorNumber -> String -> String
$cshowsPrec :: Int -> MinorNumber -> String -> String
Show)
getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs :: IO [MinorNumber]
getMountedDeviceIDs = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe String -> Maybe MinorNumber
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"findmnt"
[ String
"-rn"
, String
"--output"
, String
"MAJ:MIN"
]
String
""
where
parse :: String -> Maybe MinorNumber
parse = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isDigit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
/= Char
':')
getMinorNumber :: FilePath -> IO (Maybe MinorNumber)
getMinorNumber :: String -> IO (Maybe MinorNumber)
getMinorNumber String
dev = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> MinorNumber
MinorNumber forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"stat" [ String
"--printf", String
"%T", String
dev ] String
""
isRemovableDisk :: FilePath -> IO Bool
isRemovableDisk :: String -> IO Bool
isRemovableDisk String
dev = do
Bool
isremovable <- String -> IO Bool
checkblk String
"RM"
Bool
ishotplug <- String -> IO Bool
checkblk String
"HOTPLUG"
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
isremovable Bool -> Bool -> Bool
|| Bool
ishotplug)
where
checkblk :: String -> IO Bool
checkblk String
field = (forall a. Eq a => a -> a -> Bool
== String
"1\n") forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"lsblk"
[ String
"-rn"
, String
"--nodeps"
, String
"--output", String
field
, String
dev
]
String
""
getDiskSize :: FilePath -> IO DiskSize
getDiskSize :: String -> IO DiskSize
getDiskSize String
dev = do
Integer
sectors <- forall a. a -> Maybe a -> a
fromMaybe Integer
0 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Maybe a
readMaybe
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"blockdev" [String
"--getsz", String
dev] String
""
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> DiskSize
DiskSize (Integer
sectors forall a. Num a => a -> a -> a
* Integer
512))
getMountsSizes :: IO [(MountPoint, Integer)]
getMountsSizes :: IO [(String, Integer)]
getMountsSizes = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall {b}. Read b => [String] -> Maybe (String, b)
parse forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
words) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [String]
lines forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [String] -> String -> IO String
readProcess String
"findmnt" [String]
ps String
""
where
ps :: [String]
ps = [String
"-rnb", String
"-o", String
"TARGET,USED"]
parse :: [String] -> Maybe (String, b)
parse (String
mp:String
szs:[]) = do
b
sz <- forall a. Read a => String -> Maybe a
readMaybe String
szs
forall (m :: * -> *) a. Monad m => a -> m a
return (String
mp, b
sz)
parse [String]
_ = forall a. Maybe a
Nothing
data TargetFilled = TargetFilled (Ratio Integer)
deriving (Int -> TargetFilled -> String -> String
[TargetFilled] -> String -> String
TargetFilled -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TargetFilled] -> String -> String
$cshowList :: [TargetFilled] -> String -> String
show :: TargetFilled -> String
$cshow :: TargetFilled -> String
showsPrec :: Int -> TargetFilled -> String -> String
$cshowsPrec :: Int -> TargetFilled -> String -> String
Show, TargetFilled -> TargetFilled -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TargetFilled -> TargetFilled -> Bool
$c/= :: TargetFilled -> TargetFilled -> Bool
== :: TargetFilled -> TargetFilled -> Bool
$c== :: TargetFilled -> TargetFilled -> Bool
Eq)
instance Sem.Semigroup TargetFilled where
TargetFilled Ratio Integer
n <> :: TargetFilled -> TargetFilled -> TargetFilled
<> TargetFilled Ratio Integer
m = Ratio Integer -> TargetFilled
TargetFilled (Ratio Integer
nforall a. Num a => a -> a -> a
+Ratio Integer
m)
instance Monoid TargetFilled where
mempty :: TargetFilled
mempty = Ratio Integer -> TargetFilled
TargetFilled (Integer
0 forall a. Integral a => a -> a -> Ratio a
% Integer
1)
mappend :: TargetFilled -> TargetFilled -> TargetFilled
mappend = forall a. Semigroup a => a -> a -> a
(Sem.<>)
newtype TargetFilledHandle = TargetFilledHandle Integer
prepTargetFilled :: IO TargetFilledHandle
prepTargetFilled :: IO TargetFilledHandle
prepTargetFilled = Maybe String -> IO TargetFilledHandle
go forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO (Maybe String)
getMountSource String
"/"
where
go :: Maybe String -> IO TargetFilledHandle
go (Just String
dev) = do
DiskSize Integer
sz <- String -> IO DiskSize
getDiskSize String
dev
forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TargetFilledHandle
TargetFilledHandle Integer
sz)
go Maybe String
Nothing = forall (m :: * -> *) a. Monad m => a -> m a
return (Integer -> TargetFilledHandle
TargetFilledHandle Integer
0)
checkTargetFilled :: TargetFilledHandle -> IO TargetFilled
checkTargetFilled :: TargetFilledHandle -> IO TargetFilled
checkTargetFilled (TargetFilledHandle Integer
installsz) = do
Integer
targetsz <- forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (String -> Bool
isTargetMountPoint forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [(String, Integer)]
getMountsSizes
forall (m :: * -> *) a. Monad m => a -> m a
return (Ratio Integer -> TargetFilled
TargetFilled (Integer
targetsz forall a. Integral a => a -> a -> Ratio a
% forall a. Ord a => a -> a -> a
max Integer
1 Integer
installsz))
newtype TargetFilledPercent = TargetFilledPercent Int
deriving (Int -> TargetFilledPercent -> String -> String
[TargetFilledPercent] -> String -> String
TargetFilledPercent -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [TargetFilledPercent] -> String -> String
$cshowList :: [TargetFilledPercent] -> String -> String
show :: TargetFilledPercent -> String
$cshow :: TargetFilledPercent -> String
showsPrec :: Int -> TargetFilledPercent -> String -> String
$cshowsPrec :: Int -> TargetFilledPercent -> String -> String
Show, TargetFilledPercent -> TargetFilledPercent -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TargetFilledPercent -> TargetFilledPercent -> Bool
$c/= :: TargetFilledPercent -> TargetFilledPercent -> Bool
== :: TargetFilledPercent -> TargetFilledPercent -> Bool
$c== :: TargetFilledPercent -> TargetFilledPercent -> Bool
Eq)
targetFilledPercent :: TargetFilled -> TargetFilledPercent
targetFilledPercent :: TargetFilled -> TargetFilledPercent
targetFilledPercent (TargetFilled Ratio Integer
r) = Int -> TargetFilledPercent
TargetFilledPercent forall a b. (a -> b) -> a -> b
$ forall a b. (RealFrac a, Integral b) => a -> b
floor Double
percent
where
percent :: Double
percent :: Double
percent = forall a. Ord a => a -> a -> a
min Double
100 (forall a. Fractional a => Ratio Integer -> a
fromRational Ratio Integer
r forall a. Num a => a -> a -> a
* Double
100)