{-# 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 :: 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)
(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
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
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
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
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
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
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)
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
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
targetDir :: FilePath
targetDir :: FilePath
targetDir = FilePath
"/target"
partNums :: [Integer]
partNums :: [Integer]
partNums = [Integer
1..]
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
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!"
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
data Candidate = Candidate
{ Candidate -> Bool
candidateBigEnoughForOS :: Bool
, Candidate -> Bool
candidateIsFixedDisk :: Bool
, 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
':')
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
""
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
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
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
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)
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)