{-# LANGUAGE TypeFamilies #-}
module Propellor.Property.DiskImage (
module Propellor.Property.DiskImage.PartSpec,
DiskImage(..),
RawDiskImage(..),
VirtualBoxPointer(..),
imageBuilt,
imageRebuilt,
imageBuiltFor,
imageRebuiltFor,
imageBuiltFrom,
imageExists,
imageChrootNotPresent,
GrubTarget(..),
noBootloader,
) where
import Propellor.Base
import Propellor.Property.DiskImage.PartSpec
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
import Propellor.Property.Mount
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.FlashKernel as FlashKernel
import Propellor.Property.Parted
import Propellor.Property.Fstab (SwapPartition(..), genFstab)
import Propellor.Property.Partition
import Propellor.Property.Rsync
import Propellor.Types.Info
import Propellor.Types.Bootloader
import Propellor.Container
import Utility.Path
import Utility.DataUnits
import Data.List (isPrefixOf, isInfixOf, sortBy, unzip4)
import Data.Function (on)
import qualified Data.Map.Strict as M
import qualified Data.ByteString.Lazy as L
import System.Posix.Files
class DiskImage d where
rawDiskImage :: d -> RawDiskImage
describeDiskImage :: d -> String
buildDiskImage :: d -> RevertableProperty DebianLike Linux
newtype RawDiskImage = RawDiskImage FilePath
instance DiskImage RawDiskImage where
rawDiskImage :: RawDiskImage -> RawDiskImage
rawDiskImage = RawDiskImage -> RawDiskImage
forall a. a -> a
id
describeDiskImage :: RawDiskImage -> MountPoint
describeDiskImage (RawDiskImage MountPoint
f) = MountPoint
f
buildDiskImage :: RawDiskImage -> RevertableProperty DebianLike Linux
buildDiskImage (RawDiskImage MountPoint
_) = Property DebianLike
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing Property DebianLike
-> Property Linux -> RevertableProperty DebianLike Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
newtype VirtualBoxPointer = VirtualBoxPointer FilePath
instance DiskImage VirtualBoxPointer where
rawDiskImage :: VirtualBoxPointer -> RawDiskImage
rawDiskImage (VirtualBoxPointer MountPoint
f) = MountPoint -> RawDiskImage
RawDiskImage (MountPoint -> RawDiskImage) -> MountPoint -> RawDiskImage
forall a b. (a -> b) -> a -> b
$
MountPoint -> MountPoint
dropExtension MountPoint
f MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
".img"
describeDiskImage :: VirtualBoxPointer -> MountPoint
describeDiskImage (VirtualBoxPointer MountPoint
f) = MountPoint
f
buildDiskImage :: VirtualBoxPointer -> RevertableProperty DebianLike Linux
buildDiskImage (VirtualBoxPointer MountPoint
vmdkfile) = (CombinedType
(CombinedType (Property UnixLike) (Property DebianLike))
(Property UnixLike)
Property DebianLike
setup Property DebianLike
-> Property Linux -> RevertableProperty DebianLike Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
cleanup)
RevertableProperty DebianLike Linux
-> MountPoint -> RevertableProperty DebianLike Linux
forall p. IsProp p => p -> MountPoint -> p
`describe` (MountPoint
vmdkfile MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" built")
where
setup :: CombinedType
(CombinedType (Property UnixLike) (Property DebianLike))
(Property UnixLike)
setup = MountPoint -> [MountPoint] -> UncheckedProperty UnixLike
cmdProperty MountPoint
"VBoxManage"
[ MountPoint
"internalcommands", MountPoint
"createrawvmdk"
, MountPoint
"-filename", MountPoint
vmdkfile
, MountPoint
"-rawdisk", MountPoint
diskimage
]
UncheckedProperty UnixLike -> MountPoint -> Property UnixLike
forall (p :: * -> *) i.
Checkable p i =>
p i -> MountPoint -> Property i
`changesFile` MountPoint
vmdkfile
Property UnixLike
-> Property UnixLike
-> CombinedType (Property UnixLike) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`onChange` MountPoint -> FileMode -> Property UnixLike
File.mode MountPoint
vmdkfile ([FileMode] -> FileMode
combineModes (FileMode
ownerWriteMode FileMode -> [FileMode] -> [FileMode]
forall a. a -> [a] -> [a]
: [FileMode]
readModes))
Property UnixLike
-> Property DebianLike
-> CombinedType (Property UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` [MountPoint] -> Property DebianLike
Apt.installed [MountPoint
"virtualbox"]
CombinedType (Property UnixLike) (Property DebianLike)
-> Property UnixLike
-> CombinedType
(CombinedType (Property UnixLike) (Property DebianLike))
(Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` MountPoint -> Property UnixLike
File.notPresent MountPoint
vmdkfile
cleanup :: Property Linux
cleanup = 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
$ MountPoint -> Property UnixLike
File.notPresent MountPoint
vmdkfile
RawDiskImage MountPoint
diskimage = VirtualBoxPointer -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage (MountPoint -> VirtualBoxPointer
VirtualBoxPointer MountPoint
vmdkfile)
imageBuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt :: forall d.
DiskImage d =>
d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt = Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
False
imageRebuilt :: DiskImage d => d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt :: forall d.
DiskImage d =>
d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuilt = Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
True
imageBuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor :: forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor = Bool
-> Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Bool
-> Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor' Bool
False
imageRebuiltFor :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuiltFor :: forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageRebuiltFor = Bool
-> Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Bool
-> Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor' Bool
False
imageBuiltFor' :: (DiskImage d, Chroot.ChrootBootstrapper bootstrapper) => Bool -> Host -> d -> bootstrapper -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor' :: forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Bool
-> Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor' Bool
rebuild Host
h d
d bootstrapper
bs =
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
rebuild d
d (Host -> bootstrapper -> MountPoint -> Chroot
forall bootstrapper.
ChrootBootstrapper bootstrapper =>
Host -> bootstrapper -> MountPoint -> Chroot
Chroot.hostChroot Host
h bootstrapper
bs) TableType
tt [PartSpec ()]
pil
where
PartTableSpec TableType
tt [PartSpec ()]
pil = PartInfo -> PartTableSpec
toPartTableSpec (Info -> PartInfo
forall v. IsInfo v => Info -> v
fromInfo (Host -> Info
hostInfo Host
h))
imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' :: forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
rebuild d
img MountPoint -> Chroot
mkchroot TableType
tabletype [PartSpec ()]
partspec =
d
-> MountPoint
-> TableType
-> Finalization
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
forall d.
DiskImage d =>
d
-> MountPoint
-> TableType
-> Finalization
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom d
img MountPoint
chrootdir TableType
tabletype Finalization
final [PartSpec ()]
partspec
RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
-> RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux
-> CombinedType
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux)
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Chroot -> RevertableProperty (HasInfo + Linux) Linux
Chroot.provisioned Chroot
chroot
CombinedType
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux)
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux)
-> RevertableProperty Linux UnixLike
-> CombinedType
(CombinedType
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux)
(RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux])
Linux))
(RevertableProperty Linux UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`requires` (Property Linux
cleanrebuild Property Linux
-> Property UnixLike -> RevertableProperty Linux UnixLike
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> (Property UnixLike
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing :: Property UnixLike))
RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
-> MountPoint
-> RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
forall p. IsProp p => p -> MountPoint -> p
`describe` MountPoint
desc
where
desc :: MountPoint
desc = MountPoint
"built disk image " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ d -> MountPoint
forall d. DiskImage d => d -> MountPoint
describeDiskImage d
img
cleanrebuild :: Property Linux
cleanrebuild :: Property Linux
cleanrebuild
| Bool
rebuild = MountPoint -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property MountPoint
desc (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 () -> Propellor ()) -> IO () -> Propellor ()
forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
removeChroot MountPoint
chrootdir
Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
| Bool
otherwise = Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
chrootdir :: MountPoint
chrootdir = d -> MountPoint
forall d. DiskImage d => d -> MountPoint
imageChroot d
img
chroot :: Chroot
chroot =
let c :: Chroot
c = Chroot -> Chroot
propprivdataonly (Chroot -> Chroot) -> Chroot -> Chroot
forall a b. (a -> b) -> a -> b
$ MountPoint -> Chroot
mkchroot MountPoint
chrootdir
in Chroot
-> Props
(MetaTypes
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
-> Chroot
forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Chroot
c (Props
(MetaTypes
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
-> Chroot)
-> Props
(MetaTypes
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
-> Chroot
forall a b. (a -> b) -> a -> b
$ Chroot -> Props UnixLike
forall c. IsContainer c => c -> Props UnixLike
containerProps Chroot
c
Props UnixLike
-> RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
UnixLike
-> Props
(Sing
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&^"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
&^ RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
UnixLike
RevertableProperty (HasInfo + UnixLike) UnixLike
Service.noServices
Props
(Sing
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
-> Property UnixLike
-> Props
(MetaTypes
(Combine
(Combine
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
forall {a} p (y :: [a]) (x :: [a]).
(IsProp p, MetaTypes y ~ GetMetaTypes p,
CheckCombinableNote x y (NoteFor ('Text "&"))) =>
Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y))
& Property UnixLike
cachesCleaned
propprivdataonly :: Chroot -> Chroot
propprivdataonly (Chroot.Chroot MountPoint
d b
b InfoPropagator
ip Host
h) =
MountPoint -> b -> InfoPropagator -> Host -> Chroot
forall b.
ChrootBootstrapper b =>
MountPoint -> b -> InfoPropagator -> Host -> Chroot
Chroot.Chroot MountPoint
d b
b (\Chroot
c PropagateInfo -> Bool
_ -> InfoPropagator
ip Chroot
c PropagateInfo -> Bool
onlyPrivData) Host
h
final :: Finalization
final = case Info -> [BootloaderInstalled]
forall v. IsInfo v => Info -> v
fromInfo (Chroot -> Info
forall c. IsContainer c => c -> Info
containerInfo Chroot
chroot) of
[] -> MountPoint -> Finalization
unbootable MountPoint
"no bootloader is installed"
[GrubInstalled GrubTarget
grubtarget] -> GrubTarget -> Finalization
grubFinalized GrubTarget
grubtarget
[UbootInstalled MountPoint -> MountPoint -> Property Linux
p] -> (MountPoint -> MountPoint -> Property Linux) -> Finalization
ubootFinalized MountPoint -> MountPoint -> Property Linux
p
[BootloaderInstalled
FlashKernelInstalled] -> Finalization
flashKernelFinalized
[UbootInstalled MountPoint -> MountPoint -> Property Linux
p, BootloaderInstalled
FlashKernelInstalled] ->
(MountPoint -> MountPoint -> Property Linux) -> Finalization
ubootFlashKernelFinalized MountPoint -> MountPoint -> Property Linux
p
[BootloaderInstalled
FlashKernelInstalled, UbootInstalled MountPoint -> MountPoint -> Property Linux
p] ->
(MountPoint -> MountPoint -> Property Linux) -> Finalization
ubootFlashKernelFinalized MountPoint -> MountPoint -> Property Linux
p
[BootloaderInstalled
NoBootloader] -> Finalization
noBootloaderFinalized
[BootloaderInstalled]
_ -> MountPoint -> Finalization
unbootable MountPoint
"multiple bootloaders are installed; don't know which to use"
cachesCleaned :: Property UnixLike
cachesCleaned :: Property UnixLike
cachesCleaned = MountPoint
"cache cleaned" MountPoint -> Property UnixLike -> Property UnixLike
forall i.
IsProp (Property i) =>
MountPoint -> Property i -> Property i
==> (Property DebianLike
Apt.cacheCleaned Property DebianLike -> Property UnixLike -> Property UnixLike
forall {k} ka kb (c :: k) (a :: ka) (b :: kb).
(HasCallStack, SingKind 'KProxy, SingKind 'KProxy,
DemoteRep 'KProxy ~ [MetaType], DemoteRep 'KProxy ~ [MetaType],
SingI c) =>
Property (MetaTypes a)
-> Property (MetaTypes b) -> Property (MetaTypes c)
`pickOS` Property UnixLike
skipit)
where
skipit :: Property UnixLike
skipit = Property UnixLike
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing :: Property UnixLike
imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom :: forall d.
DiskImage d =>
d
-> MountPoint
-> TableType
-> Finalization
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom d
img MountPoint
chrootdir TableType
tabletype Finalization
final [PartSpec ()]
partspec = Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
mkimg Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
-> Property Linux
-> RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> CombinedType (Property Linux) (Property UnixLike)
Property Linux
rmimg
where
desc :: MountPoint
desc = d -> MountPoint
forall d. DiskImage d => d -> MountPoint
describeDiskImage d
img MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" built from " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
chrootdir
dest :: RawDiskImage
dest@(RawDiskImage MountPoint
imgfile) = d -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage d
img
mkimg :: Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
mkimg = MountPoint
-> (OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
desc ((OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
-> (OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> 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
$ MountPoint -> IO ()
unmountBelow MountPoint
chrootdir
Map MountPoint PartSize
szm <- (MountPoint -> MountPoint)
-> Map MountPoint PartSize -> Map MountPoint PartSize
forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (MountPoint -> MountPoint -> MountPoint
toSysDir MountPoint
chrootdir) (Map MountPoint PartSize -> Map MountPoint PartSize)
-> (Map MountPoint Integer -> Map MountPoint PartSize)
-> Map MountPoint Integer
-> Map MountPoint PartSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Integer -> PartSize)
-> Map MountPoint Integer -> Map MountPoint PartSize
forall a b k. (a -> b) -> Map k a -> Map k b
M.map Integer -> PartSize
toPartSize
(Map MountPoint Integer -> Map MountPoint PartSize)
-> Propellor (Map MountPoint Integer)
-> Propellor (Map MountPoint PartSize)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Map MountPoint Integer) -> Propellor (Map MountPoint Integer)
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MountPoint -> IO (Map MountPoint Integer)
dirSizes MountPoint
chrootdir)
let calcsz :: [Maybe MountPoint] -> Maybe MountPoint -> PartSize
calcsz [Maybe MountPoint]
mnts = PartSize -> (PartSize -> PartSize) -> Maybe PartSize -> PartSize
forall b a. b -> (a -> b) -> Maybe a -> b
maybe PartSize
defSz PartSize -> PartSize
fudgeSz (Maybe PartSize -> PartSize)
-> (Maybe MountPoint -> Maybe PartSize)
-> Maybe MountPoint
-> PartSize
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map MountPoint PartSize
-> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz Map MountPoint PartSize
szm [Maybe MountPoint]
mnts
let ([Maybe MountPoint]
mnts, [MountOpts]
mntopts, PartTable
parttable) = TableType
-> [PartSpec ()]
-> [PartSize]
-> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize TableType
tabletype [PartSpec ()]
partspec ([PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable))
-> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
forall a b. (a -> b) -> a -> b
$
(Maybe MountPoint -> PartSize) -> [Maybe MountPoint] -> [PartSize]
forall a b. (a -> b) -> [a] -> [b]
map ([Maybe MountPoint] -> Maybe MountPoint -> PartSize
calcsz [Maybe MountPoint]
mnts) [Maybe MountPoint]
mnts
OuterMetaTypesWitness
'[ 'WithInfo, '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
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w (Property DebianLike -> Propellor Result)
-> Property DebianLike -> Propellor Result
forall a b. (a -> b) -> a -> b
$
RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' RawDiskImage
dest PartTable
parttable
RevertableProperty DebianLike UnixLike
-> Property DebianLike
-> CombinedType
(RevertableProperty DebianLike UnixLike) (Property DebianLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before`
MountPoint
-> ([LoopDev] -> Property DebianLike) -> Property DebianLike
kpartx MountPoint
imgfile ([Maybe MountPoint]
-> [MountOpts]
-> PartTable
-> [LoopDev]
-> CombinedType (Property DebianLike) (Property Linux)
mkimg' [Maybe MountPoint]
mnts [MountOpts]
mntopts PartTable
parttable)
Property DebianLike
-> RevertableProperty DebianLike Linux
-> CombinedType
(Property DebianLike) (RevertableProperty DebianLike Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before`
d -> RevertableProperty DebianLike Linux
forall d. DiskImage d => d -> RevertableProperty DebianLike Linux
buildDiskImage d
img
mkimg' :: [Maybe MountPoint]
-> [MountOpts]
-> PartTable
-> [LoopDev]
-> CombinedType (Property DebianLike) (Property Linux)
mkimg' [Maybe MountPoint]
mnts [MountOpts]
mntopts PartTable
parttable [LoopDev]
devs =
MountPoint
-> [Maybe MountPoint]
-> [MountOpts]
-> [LoopDev]
-> Property DebianLike
partitionsPopulated MountPoint
chrootdir [Maybe MountPoint]
mnts [MountOpts]
mntopts [LoopDev]
devs
Property DebianLike
-> Property Linux
-> CombinedType (Property DebianLike) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before`
Finalization
-> RawDiskImage
-> [Maybe MountPoint]
-> [MountOpts]
-> [LoopDev]
-> PartTable
-> Property Linux
imageFinalized Finalization
final RawDiskImage
dest [Maybe MountPoint]
mnts [MountOpts]
mntopts [LoopDev]
devs PartTable
parttable
rmimg :: CombinedType (Property Linux) (Property UnixLike)
rmimg = RevertableProperty DebianLike Linux -> Property Linux
forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property undometatypes
undoRevertableProperty (d -> RevertableProperty DebianLike Linux
forall d. DiskImage d => d -> RevertableProperty DebianLike Linux
buildDiskImage d
img)
Property Linux
-> Property UnixLike
-> CombinedType (Property Linux) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` RevertableProperty DebianLike UnixLike -> Property UnixLike
forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property undometatypes
undoRevertableProperty (RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' RawDiskImage
dest PartTable
dummyparttable)
dummyparttable :: PartTable
dummyparttable = TableType -> Alignment -> [Partition] -> PartTable
PartTable TableType
tabletype Alignment
safeAlignment []
partitionsPopulated :: FilePath -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> Property DebianLike
partitionsPopulated :: MountPoint
-> [Maybe MountPoint]
-> [MountOpts]
-> [LoopDev]
-> Property DebianLike
partitionsPopulated MountPoint
chrootdir [Maybe MountPoint]
mnts [MountOpts]
mntopts [LoopDev]
devs = MountPoint
-> (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property DebianLike
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
desc ((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 ->
[Propellor Result] -> Propellor Result
forall a. Monoid a => [a] -> a
mconcat ([Propellor Result] -> Propellor Result)
-> [Propellor Result] -> Propellor Result
forall a b. (a -> b) -> a -> b
$ (Maybe MountPoint -> MountOpts -> LoopDev -> Propellor Result)
-> [Maybe MountPoint]
-> [MountOpts]
-> [LoopDev]
-> [Propellor Result]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Maybe MountPoint -> MountOpts -> LoopDev -> Propellor Result
go OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w) [Maybe MountPoint]
mnts [MountOpts]
mntopts [LoopDev]
devs
where
desc :: MountPoint
desc = MountPoint
"partitions populated from " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
chrootdir
go :: OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Maybe MountPoint -> MountOpts -> LoopDev -> Propellor Result
go OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
_ Maybe MountPoint
Nothing MountOpts
_ LoopDev
_ = Propellor Result
noChange
go OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w (Just MountPoint
mnt) MountOpts
mntopt LoopDev
loopdev = Propellor Bool
-> (Propellor Result, Propellor Result) -> Propellor Result
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (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
$ MountPoint -> IO Bool
doesDirectoryExist MountPoint
srcdir) ((Propellor Result, Propellor Result) -> Propellor Result)
-> (Propellor Result, Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$
( MountPoint -> (MountPoint -> Propellor Result) -> Propellor Result
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
MountPoint -> (MountPoint -> m a) -> m a
withTmpDir MountPoint
"mnt" ((MountPoint -> Propellor Result) -> Propellor Result)
-> (MountPoint -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \MountPoint
tmpdir -> Propellor Bool
-> (Bool -> Propellor ())
-> (Bool -> Propellor Result)
-> Propellor Result
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(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
$ MountPoint -> MountPoint -> MountPoint -> MountOpts -> IO Bool
mount MountPoint
"auto" (LoopDev -> MountPoint
partitionLoopDev LoopDev
loopdev) MountPoint
tmpdir MountOpts
mntopt)
(Propellor () -> Bool -> Propellor ()
forall a b. a -> b -> a
const (Propellor () -> Bool -> Propellor ())
-> Propellor () -> Bool -> Propellor ()
forall a b. (a -> b) -> a -> b
$ 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
$ MountPoint -> IO ()
umountLazy MountPoint
tmpdir)
((Bool -> Propellor Result) -> Propellor Result)
-> (Bool -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \Bool
ismounted -> if Bool
ismounted
then OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> 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]
w (Property Linux -> Propellor Result)
-> Property Linux -> Propellor Result
forall a b. (a -> b) -> a -> b
$
[Filter]
-> MountPoint -> MountPoint -> Property (DebianLike + ArchLinux)
syncDirFiltered (MountPoint -> [Filter]
filtersfor MountPoint
mnt) MountPoint
srcdir MountPoint
tmpdir
else Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
, Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
)
where
srcdir :: MountPoint
srcdir = MountPoint
chrootdir MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
mnt
filtersfor :: MountPoint -> [Filter]
filtersfor MountPoint
mnt =
let childmnts :: [MountPoint]
childmnts = (MountPoint -> MountPoint) -> [MountPoint] -> [MountPoint]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> MountPoint -> MountPoint
forall a. Int -> [a] -> [a]
drop (MountPoint -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (MountPoint -> MountPoint
dropTrailingPathSeparator MountPoint
mnt))) ([MountPoint] -> [MountPoint]) -> [MountPoint] -> [MountPoint]
forall a b. (a -> b) -> a -> b
$
(MountPoint -> Bool) -> [MountPoint] -> [MountPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter (\MountPoint
m -> MountPoint
m MountPoint -> MountPoint -> Bool
forall a. Eq a => a -> a -> Bool
/= MountPoint
mnt Bool -> Bool -> Bool
&& MountPoint -> MountPoint
addTrailingPathSeparator MountPoint
mnt MountPoint -> MountPoint -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` MountPoint
m)
([Maybe MountPoint] -> [MountPoint]
forall a. [Maybe a] -> [a]
catMaybes [Maybe MountPoint]
mnts)
in (MountPoint -> [Filter]) -> [MountPoint] -> [Filter]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\MountPoint
m ->
[ Pattern -> Filter
Include (MountPoint -> Pattern
Pattern MountPoint
m)
, Pattern -> Filter
Exclude (MountPoint -> Pattern
filesUnder MountPoint
m)
, Pattern -> Filter
Protect (MountPoint -> Pattern
Pattern MountPoint
"lost+found")
]) [MountPoint]
childmnts
fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize :: TableType
-> [PartSpec ()]
-> [PartSize]
-> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize TableType
tt [PartSpec ()]
l [PartSize]
basesizes = ([Maybe MountPoint]
mounts, [MountOpts]
mountopts, PartTable
parttable)
where
([Maybe MountPoint]
mounts, [MountOpts]
mountopts, [PartSize -> Partition]
sizers, [()]
_) = [PartSpec ()]
-> ([Maybe MountPoint], [MountOpts], [PartSize -> Partition], [()])
forall a b c d. [(a, b, c, d)] -> ([a], [b], [c], [d])
unzip4 [PartSpec ()]
l
parttable :: PartTable
parttable = TableType -> Alignment -> [Partition] -> PartTable
PartTable TableType
tt Alignment
safeAlignment (((PartSize -> Partition) -> PartSize -> Partition)
-> [PartSize -> Partition] -> [PartSize] -> [Partition]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (PartSize -> Partition) -> PartSize -> Partition
forall a. a -> a
id [PartSize -> Partition]
sizers [PartSize]
basesizes)
dirSizes :: FilePath -> IO (M.Map FilePath Integer)
dirSizes :: MountPoint -> IO (Map MountPoint Integer)
dirSizes MountPoint
top = Map MountPoint Integer
-> MountPoint -> [MountPoint] -> IO (Map MountPoint Integer)
forall {b}.
Num b =>
Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go Map MountPoint Integer
forall k a. Map k a
M.empty MountPoint
top [MountPoint
top]
where
go :: Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go Map MountPoint b
m MountPoint
_ [] = Map MountPoint b -> IO (Map MountPoint b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Map MountPoint b
m
go Map MountPoint b
m MountPoint
dir (MountPoint
i:[MountPoint]
is) = (IO (Map MountPoint b)
-> (IOException -> IO (Map MountPoint b)) -> IO (Map MountPoint b))
-> (IOException -> IO (Map MountPoint b))
-> IO (Map MountPoint b)
-> IO (Map MountPoint b)
forall a b c. (a -> b -> c) -> b -> a -> c
flip IO (Map MountPoint b)
-> (IOException -> IO (Map MountPoint b)) -> IO (Map MountPoint b)
forall (m :: * -> *) a.
MonadCatch m =>
m a -> (IOException -> m a) -> m a
catchIO (\IOException
_ioerr -> Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go Map MountPoint b
m MountPoint
dir [MountPoint]
is) (IO (Map MountPoint b) -> IO (Map MountPoint b))
-> IO (Map MountPoint b) -> IO (Map MountPoint b)
forall a b. (a -> b) -> a -> b
$ do
FileStatus
s <- MountPoint -> IO FileStatus
getSymbolicLinkStatus MountPoint
i
let sz :: b
sz = FileOffset -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FileStatus -> FileOffset
fileSize FileStatus
s)
if FileStatus -> Bool
isDirectory FileStatus
s
then do
Map MountPoint b
subm <- Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go Map MountPoint b
forall k a. Map k a
M.empty MountPoint
i ([MountPoint] -> IO (Map MountPoint b))
-> IO [MountPoint] -> IO (Map MountPoint b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MountPoint -> IO [MountPoint]
dirContents MountPoint
i
let sz' :: b
sz' = (b -> b -> b) -> b -> Map MountPoint b -> b
forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr' b -> b -> b
forall a. Num a => a -> a -> a
(+) b
sz
((MountPoint -> b -> Bool) -> Map MountPoint b -> Map MountPoint b
forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (Bool -> b -> Bool
forall a b. a -> b -> a
const (Bool -> b -> Bool)
-> (MountPoint -> Bool) -> MountPoint -> b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> MountPoint -> Bool
subdirof MountPoint
i) Map MountPoint b
subm)
Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go ((b -> b -> b)
-> MountPoint -> b -> Map MountPoint b -> Map MountPoint b
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith b -> b -> b
forall a. Num a => a -> a -> a
(+) MountPoint
i b
sz' (Map MountPoint b -> Map MountPoint b -> Map MountPoint b
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map MountPoint b
m Map MountPoint b
subm)) MountPoint
dir [MountPoint]
is
else Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go ((b -> b -> b)
-> MountPoint -> b -> Map MountPoint b -> Map MountPoint b
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith b -> b -> b
forall a. Num a => a -> a -> a
(+) MountPoint
dir b
sz Map MountPoint b
m) MountPoint
dir [MountPoint]
is
subdirof :: MountPoint -> MountPoint -> Bool
subdirof MountPoint
parent MountPoint
i = Bool -> Bool
not (MountPoint
i MountPoint -> MountPoint -> Bool
`equalFilePath` MountPoint
parent) Bool -> Bool -> Bool
&& MountPoint -> MountPoint
takeDirectory MountPoint
i MountPoint -> MountPoint -> Bool
`equalFilePath` MountPoint
parent
getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz :: Map MountPoint PartSize
-> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz Map MountPoint PartSize
_ [Maybe MountPoint]
_ Maybe MountPoint
Nothing = Maybe PartSize
forall a. Maybe a
Nothing
getMountSz Map MountPoint PartSize
szm [Maybe MountPoint]
l (Just MountPoint
mntpt) =
(PartSize -> PartSize) -> Maybe PartSize -> Maybe PartSize
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PartSize -> PartSize -> PartSize
`reducePartSize` PartSize
childsz) (MountPoint -> Map MountPoint PartSize -> Maybe PartSize
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MountPoint
mntpt Map MountPoint PartSize
szm)
where
childsz :: PartSize
childsz = [PartSize] -> PartSize
forall a. Monoid a => [a] -> a
mconcat ([PartSize] -> PartSize) -> [PartSize] -> PartSize
forall a b. (a -> b) -> a -> b
$ (Maybe MountPoint -> Maybe PartSize)
-> [Maybe MountPoint] -> [PartSize]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Map MountPoint PartSize
-> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
getMountSz Map MountPoint PartSize
szm [Maybe MountPoint]
l) ((Maybe MountPoint -> Bool)
-> [Maybe MountPoint] -> [Maybe MountPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter (MountPoint -> Maybe MountPoint -> Bool
isChild MountPoint
mntpt) [Maybe MountPoint]
l)
imageExists :: RawDiskImage -> ByteSize -> Property Linux
imageExists :: RawDiskImage -> Integer -> Property Linux
imageExists (RawDiskImage MountPoint
img) Integer
isz = MountPoint -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property (MountPoint
"disk image exists" MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
img) (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ IO Result -> Propellor Result
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Result -> Propellor Result) -> IO Result -> Propellor Result
forall a b. (a -> b) -> a -> b
$ do
Maybe FileStatus
ms <- IO FileStatus -> IO (Maybe FileStatus)
forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO (IO FileStatus -> IO (Maybe FileStatus))
-> IO FileStatus -> IO (Maybe FileStatus)
forall a b. (a -> b) -> a -> b
$ MountPoint -> IO FileStatus
getFileStatus MountPoint
img
case (FileStatus -> Integer) -> Maybe FileStatus -> Maybe Integer
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileOffset -> Integer
forall a. Integral a => a -> Integer
toInteger (FileOffset -> Integer)
-> (FileStatus -> FileOffset) -> FileStatus -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
fileSize) Maybe FileStatus
ms of
Just Integer
s
| Integer
s Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
sz -> Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
| Integer
s Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
sz -> do
[MountPoint] -> IO ()
forall (m :: * -> *). MonadIO m => [MountPoint] -> m ()
infoMessage [MountPoint
"truncating " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
img MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" to " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
humansz]
MountPoint -> FileOffset -> IO ()
setFileSize MountPoint
img (Integer -> FileOffset
forall a. Num a => Integer -> a
fromInteger Integer
sz)
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
| Bool
otherwise -> do
[MountPoint] -> IO ()
forall (m :: * -> *). MonadIO m => [MountPoint] -> m ()
infoMessage [MountPoint
"expanding " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
img MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" from " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ [Unit] -> Bool -> Integer -> MountPoint
roughSize [Unit]
storageUnits Bool
False Integer
s MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" to " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
humansz]
MountPoint -> ByteString -> IO ()
L.writeFile MountPoint
img (Int64 -> Word8 -> ByteString
L.replicate (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sz) Word8
0)
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
Maybe Integer
Nothing -> do
[MountPoint] -> IO ()
forall (m :: * -> *). MonadIO m => [MountPoint] -> m ()
infoMessage [MountPoint
"creating " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
img MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
" of size " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
humansz]
MountPoint -> ByteString -> IO ()
L.writeFile MountPoint
img (Int64 -> Word8 -> ByteString
L.replicate (Integer -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sz) Word8
0)
Result -> IO Result
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
where
sz :: Integer
sz = Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Integer -> Double
forall a. Num a => Integer -> a
fromInteger Integer
isz Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
sectorsize) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
* Double -> Integer
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
sectorsize
humansz :: MountPoint
humansz = [Unit] -> Bool -> Integer -> MountPoint
roughSize [Unit]
storageUnits Bool
False (Integer -> Integer
forall a. Integral a => a -> Integer
toInteger Integer
sz)
sectorsize :: Double
sectorsize = Double
4096 :: Double
imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' dest :: RawDiskImage
dest@(RawDiskImage MountPoint
img) PartTable
parttable = (Property DebianLike
setup Property DebianLike
-> Property UnixLike -> RevertableProperty DebianLike UnixLike
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> CombinedType (Property UnixLike) (Property UnixLike)
Property UnixLike
cleanup) RevertableProperty DebianLike UnixLike
-> MountPoint -> RevertableProperty DebianLike UnixLike
forall p. IsProp p => p -> MountPoint -> p
`describe` MountPoint
desc
where
desc :: MountPoint
desc = MountPoint
"disk image exists " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
img
parttablefile :: MountPoint
parttablefile = RawDiskImage -> MountPoint
forall d. DiskImage d => d -> MountPoint
imageParttableFile RawDiskImage
dest
setup :: Property DebianLike
setup = MountPoint
-> (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> Propellor Result)
-> Property DebianLike
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
desc ((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
MountPoint
oldparttable <- IO MountPoint -> Propellor MountPoint
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MountPoint -> Propellor MountPoint)
-> IO MountPoint -> Propellor MountPoint
forall a b. (a -> b) -> a -> b
$ MountPoint -> IO MountPoint -> IO MountPoint
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO MountPoint
"" (IO MountPoint -> IO MountPoint) -> IO MountPoint -> IO MountPoint
forall a b. (a -> b) -> a -> b
$ MountPoint -> IO MountPoint
readFileStrict MountPoint
parttablefile
Result
res <- OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
-> 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]
w (Property Linux -> Propellor Result)
-> Property Linux -> Propellor Result
forall a b. (a -> b) -> a -> b
$ RawDiskImage -> Integer -> Property Linux
imageExists RawDiskImage
dest (PartTable -> Integer
partTableSize PartTable
parttable)
if Result
res Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
NoChange Bool -> Bool -> Bool
&& MountPoint
oldparttable MountPoint -> MountPoint -> Bool
forall a. Eq a => a -> a -> Bool
== PartTable -> MountPoint
forall a. Show a => a -> MountPoint
show PartTable
parttable
then Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
else if Result
res Result -> Result -> Bool
forall a. Eq a => a -> a -> Bool
== Result
FailedChange
then Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
else 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
$ MountPoint -> MountPoint -> IO ()
writeFile MountPoint
parttablefile (PartTable -> MountPoint
forall a. Show a => a -> MountPoint
show PartTable
parttable)
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 -> MountPoint -> PartTable -> Property DebianLike
partitioned Eep
YesReallyDeleteDiskContents MountPoint
img PartTable
parttable
cleanup :: CombinedType (Property UnixLike) (Property UnixLike)
cleanup = MountPoint -> Property UnixLike
File.notPresent MountPoint
img
Property UnixLike
-> Property UnixLike
-> CombinedType (Property UnixLike) (Property UnixLike)
forall x y. Combines x y => x -> y -> CombinedType x y
`before`
MountPoint -> Property UnixLike
File.notPresent MountPoint
parttablefile
type Finalization = (RawDiskImage -> FilePath -> [LoopDev] -> Property Linux)
imageFinalized :: Finalization -> RawDiskImage -> [Maybe MountPoint] -> [MountOpts] -> [LoopDev] -> PartTable -> Property Linux
imageFinalized :: Finalization
-> RawDiskImage
-> [Maybe MountPoint]
-> [MountOpts]
-> [LoopDev]
-> PartTable
-> Property Linux
imageFinalized Finalization
final RawDiskImage
img [Maybe MountPoint]
mnts [MountOpts]
mntopts [LoopDev]
devs (PartTable TableType
_ Alignment
_ [Partition]
parts) =
MountPoint
-> (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
"disk image finalized" ((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 ->
MountPoint -> (MountPoint -> Propellor Result) -> Propellor Result
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
MountPoint -> (MountPoint -> m a) -> m a
withTmpDir MountPoint
"mnt" ((MountPoint -> Propellor Result) -> Propellor Result)
-> (MountPoint -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \MountPoint
top ->
OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> MountPoint -> Propellor Result
go OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w MountPoint
top Propellor Result -> Propellor () -> Propellor Result
forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` IO () -> Propellor ()
forall a. IO a -> Propellor a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (MountPoint -> IO ()
unmountall MountPoint
top)
where
go :: OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> MountPoint -> Propellor Result
go OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w MountPoint
top = 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
$ MountPoint -> IO ()
mountall MountPoint
top
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
$ MountPoint -> IO ()
writefstab MountPoint
top
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
$ MountPoint -> IO ()
allowservices MountPoint
top
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
$
Finalization
final RawDiskImage
img MountPoint
top [LoopDev]
devs
orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs = ((Maybe MountPoint, (MountOpts, LoopDev))
-> (Maybe MountPoint, (MountOpts, LoopDev)) -> Ordering)
-> [(Maybe MountPoint, (MountOpts, LoopDev))]
-> [(Maybe MountPoint, (MountOpts, LoopDev))]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (Maybe MountPoint -> Maybe MountPoint -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (Maybe MountPoint -> Maybe MountPoint -> Ordering)
-> ((Maybe MountPoint, (MountOpts, LoopDev)) -> Maybe MountPoint)
-> (Maybe MountPoint, (MountOpts, LoopDev))
-> (Maybe MountPoint, (MountOpts, LoopDev))
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (Maybe MountPoint, (MountOpts, LoopDev)) -> Maybe MountPoint
forall a b. (a, b) -> a
fst) ([(Maybe MountPoint, (MountOpts, LoopDev))]
-> [(Maybe MountPoint, (MountOpts, LoopDev))])
-> [(Maybe MountPoint, (MountOpts, LoopDev))]
-> [(Maybe MountPoint, (MountOpts, LoopDev))]
forall a b. (a -> b) -> a -> b
$ [Maybe MountPoint]
-> [(MountOpts, LoopDev)]
-> [(Maybe MountPoint, (MountOpts, LoopDev))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe MountPoint]
mnts ([MountOpts] -> [LoopDev] -> [(MountOpts, LoopDev)]
forall a b. [a] -> [b] -> [(a, b)]
zip [MountOpts]
mntopts [LoopDev]
devs)
swaps :: [SwapPartition]
swaps = ((Partition, LoopDev) -> SwapPartition)
-> [(Partition, LoopDev)] -> [SwapPartition]
forall a b. (a -> b) -> [a] -> [b]
map (MountPoint -> SwapPartition
SwapPartition (MountPoint -> SwapPartition)
-> ((Partition, LoopDev) -> MountPoint)
-> (Partition, LoopDev)
-> SwapPartition
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoopDev -> MountPoint
partitionLoopDev (LoopDev -> MountPoint)
-> ((Partition, LoopDev) -> LoopDev)
-> (Partition, LoopDev)
-> MountPoint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Partition, LoopDev) -> LoopDev
forall a b. (a, b) -> b
snd) ([(Partition, LoopDev)] -> [SwapPartition])
-> [(Partition, LoopDev)] -> [SwapPartition]
forall a b. (a -> b) -> a -> b
$
((Partition, LoopDev) -> Bool)
-> [(Partition, LoopDev)] -> [(Partition, LoopDev)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Maybe Fs -> Maybe Fs -> Bool
forall a. Eq a => a -> a -> Bool
== Fs -> Maybe Fs
forall a. a -> Maybe a
Just Fs
LinuxSwap) (Maybe Fs -> Bool)
-> ((Partition, LoopDev) -> Maybe Fs)
-> (Partition, LoopDev)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partition -> Maybe Fs
partFs (Partition -> Maybe Fs)
-> ((Partition, LoopDev) -> Partition)
-> (Partition, LoopDev)
-> Maybe Fs
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Partition, LoopDev) -> Partition
forall a b. (a, b) -> a
fst) ([(Partition, LoopDev)] -> [(Partition, LoopDev)])
-> [(Partition, LoopDev)] -> [(Partition, LoopDev)]
forall a b. (a -> b) -> a -> b
$
[Partition] -> [LoopDev] -> [(Partition, LoopDev)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Partition]
parts [LoopDev]
devs
mountall :: MountPoint -> IO ()
mountall MountPoint
top = [(Maybe MountPoint, (MountOpts, LoopDev))]
-> ((Maybe MountPoint, (MountOpts, LoopDev)) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs (((Maybe MountPoint, (MountOpts, LoopDev)) -> IO ()) -> IO ())
-> ((Maybe MountPoint, (MountOpts, LoopDev)) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Maybe MountPoint
mp, (MountOpts
mopts, LoopDev
loopdev)) -> case Maybe MountPoint
mp of
Maybe MountPoint
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
noop
Just MountPoint
p -> do
let mnt :: MountPoint
mnt = MountPoint
top MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
p
Bool -> MountPoint -> IO ()
createDirectoryIfMissing Bool
True MountPoint
mnt
IO Bool -> IO () -> IO ()
forall {m :: * -> *}. Monad m => m Bool -> m () -> m ()
unlessM (MountPoint -> MountPoint -> MountPoint -> MountOpts -> IO Bool
mount MountPoint
"auto" (LoopDev -> MountPoint
partitionLoopDev LoopDev
loopdev) MountPoint
mnt MountOpts
mopts) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
MountPoint -> IO ()
forall a. HasCallStack => MountPoint -> a
error (MountPoint -> IO ()) -> MountPoint -> IO ()
forall a b. (a -> b) -> a -> b
$ MountPoint
"failed mounting " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
mnt
unmountall :: MountPoint -> IO ()
unmountall MountPoint
top = do
MountPoint -> IO ()
unmountBelow MountPoint
top
MountPoint -> IO ()
umountLazy MountPoint
top
writefstab :: MountPoint -> IO ()
writefstab MountPoint
top = do
let fstab :: MountPoint
fstab = MountPoint
top MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
"/etc/fstab"
[MountPoint]
old <- [MountPoint] -> IO [MountPoint] -> IO [MountPoint]
forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] (IO [MountPoint] -> IO [MountPoint])
-> IO [MountPoint] -> IO [MountPoint]
forall a b. (a -> b) -> a -> b
$ (MountPoint -> Bool) -> [MountPoint] -> [MountPoint]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (MountPoint -> Bool) -> MountPoint -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> Bool
unconfigured) ([MountPoint] -> [MountPoint])
-> (MountPoint -> [MountPoint]) -> MountPoint -> [MountPoint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> [MountPoint]
lines
(MountPoint -> [MountPoint]) -> IO MountPoint -> IO [MountPoint]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MountPoint -> IO MountPoint
readFileStrict MountPoint
fstab
[MountPoint]
new <- [MountPoint]
-> [SwapPartition] -> (MountPoint -> MountPoint) -> IO [MountPoint]
genFstab ((MountPoint -> MountPoint) -> [MountPoint] -> [MountPoint]
forall a b. (a -> b) -> [a] -> [b]
map (MountPoint
top MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++) ([Maybe MountPoint] -> [MountPoint]
forall a. [Maybe a] -> [a]
catMaybes [Maybe MountPoint]
mnts))
[SwapPartition]
swaps (MountPoint -> MountPoint -> MountPoint
toSysDir MountPoint
top)
MountPoint -> MountPoint -> IO ()
writeFile MountPoint
fstab (MountPoint -> IO ()) -> MountPoint -> IO ()
forall a b. (a -> b) -> a -> b
$ [MountPoint] -> MountPoint
unlines ([MountPoint] -> MountPoint) -> [MountPoint] -> MountPoint
forall a b. (a -> b) -> a -> b
$ [MountPoint]
new [MountPoint] -> [MountPoint] -> [MountPoint]
forall a. [a] -> [a] -> [a]
++ [MountPoint]
old
unconfigured :: MountPoint -> Bool
unconfigured MountPoint
s = MountPoint
"UNCONFIGURED" MountPoint -> MountPoint -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` MountPoint
s
allowservices :: MountPoint -> IO ()
allowservices MountPoint
top = MountPoint -> IO ()
nukeFile (MountPoint
top MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
"/usr/sbin/policy-rc.d")
unbootable :: String -> Finalization
unbootable :: MountPoint -> Finalization
unbootable MountPoint
msg = \RawDiskImage
_ MountPoint
_ [LoopDev]
_ -> MountPoint -> Propellor Result -> Property Linux
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property MountPoint
desc (Propellor Result -> Property Linux)
-> Propellor Result -> Property Linux
forall a b. (a -> b) -> a -> b
$ do
MountPoint -> Propellor ()
forall (m :: * -> *). MonadIO m => MountPoint -> m ()
warningMessage (MountPoint
desc MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
": " MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
msg)
Result -> Propellor Result
forall a. a -> Propellor a
forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
where
desc :: MountPoint
desc = MountPoint
"image is not bootable"
grubFinalized :: GrubTarget -> Finalization
grubFinalized :: GrubTarget -> Finalization
grubFinalized GrubTarget
grubtarget RawDiskImage
_img MountPoint
mnt [LoopDev]
loopdevs =
MountPoint -> MountPoint -> GrubTarget -> Property Linux
Grub.bootsMounted MountPoint
mnt MountPoint
wholediskloopdev GrubTarget
grubtarget
Property Linux -> MountPoint -> Property Linux
forall p. IsProp p => p -> MountPoint -> p
`describe` MountPoint
"disk image boots using grub"
where
wholediskloopdev :: MountPoint
wholediskloopdev = case [LoopDev]
loopdevs of
(LoopDev
l:[LoopDev]
_) -> LoopDev -> MountPoint
wholeDiskLoopDev LoopDev
l
[] -> MountPoint -> MountPoint
forall a. HasCallStack => MountPoint -> a
error MountPoint
"No loop devs provided!"
ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
ubootFinalized :: (MountPoint -> MountPoint -> Property Linux) -> Finalization
ubootFinalized MountPoint -> MountPoint -> Property Linux
p (RawDiskImage MountPoint
img) MountPoint
mnt [LoopDev]
_loopdevs = MountPoint -> MountPoint -> Property Linux
p MountPoint
img MountPoint
mnt
flashKernelFinalized :: Finalization
flashKernelFinalized :: Finalization
flashKernelFinalized RawDiskImage
_img MountPoint
mnt [LoopDev]
_loopdevs = MountPoint -> Property Linux
FlashKernel.flashKernelMounted MountPoint
mnt
ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
ubootFlashKernelFinalized :: (MountPoint -> MountPoint -> Property Linux) -> Finalization
ubootFlashKernelFinalized MountPoint -> MountPoint -> Property Linux
p RawDiskImage
img MountPoint
mnt [LoopDev]
loopdevs =
(MountPoint -> MountPoint -> Property Linux) -> Finalization
ubootFinalized MountPoint -> MountPoint -> Property Linux
p RawDiskImage
img MountPoint
mnt [LoopDev]
loopdevs
Property Linux
-> Property Linux -> CombinedType (Property Linux) (Property Linux)
forall x y. Combines x y => x -> y -> CombinedType x y
`before` Finalization
flashKernelFinalized RawDiskImage
img MountPoint
mnt [LoopDev]
loopdevs
noBootloader :: Property (HasInfo + UnixLike)
noBootloader :: Property (HasInfo + UnixLike)
noBootloader = MountPoint
-> [BootloaderInstalled] -> Property (HasInfo + UnixLike)
forall v.
IsInfo v =>
MountPoint -> v -> Property (HasInfo + UnixLike)
pureInfoProperty MountPoint
"no bootloader" [BootloaderInstalled
NoBootloader]
noBootloaderFinalized :: Finalization
noBootloaderFinalized :: Finalization
noBootloaderFinalized RawDiskImage
_img MountPoint
_mnt [LoopDev]
_loopDevs = Property Linux
forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
imageChrootNotPresent :: DiskImage d => d -> Property UnixLike
imageChrootNotPresent :: forall d. DiskImage d => d -> Property UnixLike
imageChrootNotPresent d
img = IO Bool -> Property UnixLike -> Property UnixLike
forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (MountPoint -> IO Bool
doesDirectoryExist MountPoint
dir) (Property UnixLike -> Property UnixLike)
-> Property UnixLike -> Property UnixLike
forall a b. (a -> b) -> a -> b
$
MountPoint -> Propellor Result -> Property UnixLike
forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property MountPoint
"destroy the chroot used to build the image" (Propellor Result -> Property UnixLike)
-> Propellor Result -> Property UnixLike
forall a b. (a -> b) -> a -> b
$ IO () -> Propellor Result
makeChange (IO () -> Propellor Result) -> IO () -> Propellor Result
forall a b. (a -> b) -> a -> b
$ do
MountPoint -> IO ()
removeChroot MountPoint
dir
MountPoint -> IO ()
nukeFile (MountPoint -> IO ()) -> MountPoint -> IO ()
forall a b. (a -> b) -> a -> b
$ d -> MountPoint
forall d. DiskImage d => d -> MountPoint
imageParttableFile d
img
where
dir :: MountPoint
dir = d -> MountPoint
forall d. DiskImage d => d -> MountPoint
imageChroot d
img
imageChroot :: DiskImage d => d -> FilePath
imageChroot :: forall d. DiskImage d => d -> MountPoint
imageChroot d
img = MountPoint
imgfile MountPoint -> MountPoint -> MountPoint
<.> MountPoint
"chroot"
where
RawDiskImage MountPoint
imgfile = d -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage d
img
imageParttableFile :: DiskImage d => d -> FilePath
imageParttableFile :: forall d. DiskImage d => d -> MountPoint
imageParttableFile d
img = MountPoint
imgfile MountPoint -> MountPoint -> MountPoint
<.> MountPoint
"parttable"
where
RawDiskImage MountPoint
imgfile = d -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage d
img
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild :: MountPoint -> Maybe MountPoint -> Bool
isChild MountPoint
mntpt (Just MountPoint
d)
| MountPoint
d MountPoint -> MountPoint -> Bool
`equalFilePath` MountPoint
mntpt = Bool
False
| Bool
otherwise = MountPoint
mntpt MountPoint -> MountPoint -> Bool
`dirContains` MountPoint
d
isChild MountPoint
_ Maybe MountPoint
Nothing = Bool
False
toSysDir :: FilePath -> FilePath -> FilePath
toSysDir :: MountPoint -> MountPoint -> MountPoint
toSysDir MountPoint
chrootdir MountPoint
d = case MountPoint -> MountPoint -> MountPoint
makeRelative MountPoint
chrootdir MountPoint
d of
MountPoint
"." -> MountPoint
"/"
MountPoint
sysdir -> MountPoint
"/" MountPoint -> MountPoint -> MountPoint
forall a. [a] -> [a] -> [a]
++ MountPoint
sysdir