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