-- | Disk image generation.
--
-- This module is designed to be imported unqualified.

{-# LANGUAGE TypeFamilies #-}

module Propellor.Property.DiskImage (
	-- * Partition specification
	module Propellor.Property.DiskImage.PartSpec,
	-- * Properties
	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

-- | Type class of disk image formats.
class DiskImage d where
	-- | Get the location where the raw disk image should be stored.
	rawDiskImage :: d -> RawDiskImage
	-- | Describe the disk image (for display to the user)
	describeDiskImage :: d -> String
	-- | Convert the raw disk image file in the
	-- `rawDiskImage` location into the desired disk image format.
	-- For best efficiency, the raw disk imasge file should be left
	-- unchanged on disk.
	buildDiskImage :: d -> RevertableProperty DebianLike Linux

-- | A raw disk image, that can be written directly out to a disk.
newtype RawDiskImage = RawDiskImage FilePath

instance DiskImage RawDiskImage where
	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
_) = forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing

-- | A virtualbox .vmdk file, which contains a pointer to the raw disk
-- image. This can be built very quickly.
newtype VirtualBoxPointer = VirtualBoxPointer FilePath

instance DiskImage VirtualBoxPointer where
	rawDiskImage :: VirtualBoxPointer -> RawDiskImage
rawDiskImage (VirtualBoxPointer MountPoint
f) = MountPoint -> RawDiskImage
RawDiskImage forall a b. (a -> b) -> a -> b
$
		MountPoint -> MountPoint
dropExtension MountPoint
f 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)
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
cleanup)
		forall p. IsProp p => p -> MountPoint -> p
`describe` (MountPoint
vmdkfile 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
			]
			forall (p :: * -> *) i.
Checkable p i =>
p i -> MountPoint -> Property i
`changesFile` MountPoint
vmdkfile
			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 forall a. a -> [a] -> [a]
: [FileMode]
readModes))
			forall x y. Combines x y => x -> y -> CombinedType x y
`requires` [MountPoint] -> Property DebianLike
Apt.installed [MountPoint
"virtualbox"]
			forall x y. Combines x y => x -> y -> CombinedType x y
`requires` MountPoint -> Property UnixLike
File.notPresent MountPoint
vmdkfile
		cleanup :: Property Linux
cleanup = forall (p :: * -> *) (untightened :: [MetaType])
       (tightened :: [MetaType]).
(TightenTargets p, TightenTargetsAllowed untightened tightened,
 SingI tightened) =>
p (MetaTypes untightened) -> p (MetaTypes tightened)
tightenTargets forall a b. (a -> b) -> a -> b
$ MountPoint -> Property UnixLike
File.notPresent MountPoint
vmdkfile
		RawDiskImage MountPoint
diskimage = forall d. DiskImage d => d -> RawDiskImage
rawDiskImage (MountPoint -> VirtualBoxPointer
VirtualBoxPointer MountPoint
vmdkfile)

-- | Creates a bootable disk image.
--
-- First the specified Chroot is set up, and its properties are satisfied.
--
-- Then, the disk image is set up, and the chroot is copied into the
-- appropriate partition(s) of it. 
--
-- The partitions default to being sized just large enough to fit the files
-- from the chroot. You can use `addFreeSpace` to make them a bit larger
-- than that, or `setSize` to use a fixed size.
-- 
-- Note that the disk image file is reused if it already exists,
-- to avoid expensive IO to generate a new one. And, it's updated in-place,
-- so its contents are undefined during the build process.
--
-- Note that the `Service.noServices` property is automatically added to the
-- chroot while the disk image is being built, which should prevent any
-- daemons that are included from being started on the system that is
-- building the disk image.
--
-- Example use:
--
-- > import Propellor.Property.DiskImage
-- > import Propellor.Property.Chroot
-- > 
-- > foo = host "foo.example.com" $ props
-- > 	& imageBuilt (RawDiskImage "/srv/diskimages/disk.img") mychroot
-- >		MSDOS
-- >		[ partition EXT2 `mountedAt` "/boot"
-- >			`setFlag` BootFlag
-- >		, partition EXT4 `mountedAt` "/"
-- >			`addFreeSpace` MegaBytes 100
-- >			`mountOpt` errorReadonly
-- >		, swapPartition (MegaBytes 256)
-- >		]
-- >  where
-- >	mychroot d = debootstrapped mempty d $ props
-- >		& osDebian Unstable X86_64
-- >		& Apt.installed ["linux-image-amd64"]
-- >		& Grub.installed PC
-- >		& User.hasPassword (User "root")
-- >		& User.accountFor (User "demo")
-- > 		& User.hasPassword (User "demo")
-- >		& User.hasDesktopGroups (User "demo")
-- > 		& ...
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 = forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
False

-- | Like 'imageBuilt', but the chroot is deleted and rebuilt from scratch
-- each time. This is more expensive, but useful to ensure reproducible
-- results when the properties of the chroot have been changed.
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 = forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
True

-- | Create a bootable disk image for a Host.
--
-- This works just like 'imageBuilt', but partition table is
-- determined by looking at the Host's 'hasPartitionTableType',
-- `hasPartition', and 'adjustPartition' properties.
--
-- For example:
--
-- > foo :: Host
-- > foo = host "foo.example.com" $ props
-- >	& imageBuiltFor bar
-- >		(RawDiskImage "/srv/diskimages/bar-disk.img")
-- >		(Debootstrapped mempty)
-- >
-- > bar :: Host
-- > bar = host "bar.example.com" $ props
-- >	& hasPartiton
-- >		( partition EXT2
-- >		`mountedAt` "/boot"
-- >		`partLocation` Beginning
-- >		`addFreeSpace` MegaBytes 150
-- >		)
-- >	& hasPartiton
-- >		( partition EXT4
-- >		`mountedAt` "/"
-- >		`addFreeSpace` MegaBytes 500
-- >		)
-- >	& osDebian Unstable X86_64
-- >	& Apt.installed ["linux-image-amd64"]
-- >	& Grub.installed PC
-- >	& hasPassword (User "root")
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 = forall d bootstrapper.
(DiskImage d, ChrootBootstrapper bootstrapper) =>
Bool
-> Host
-> d
-> bootstrapper
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFor' Bool
False

-- | Like 'imageBuiltFor', but the chroot is deleted and rebuilt from
-- scratch each time.
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 = 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 =
	forall d.
DiskImage d =>
Bool
-> d
-> (MountPoint -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
rebuild d
d (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 (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 =
	forall d.
DiskImage d =>
d
-> MountPoint
-> TableType
-> Finalization
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom d
img MountPoint
chrootdir TableType
tabletype Finalization
final [PartSpec ()]
partspec
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` Chroot -> RevertableProperty (HasInfo + Linux) Linux
Chroot.provisioned Chroot
chroot
		forall x y. Combines x y => x -> y -> CombinedType x y
`requires` (Property Linux
cleanrebuild forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> (forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing :: Property UnixLike))
		forall p. IsProp p => p -> MountPoint -> p
`describe` MountPoint
desc
  where
	desc :: MountPoint
desc = MountPoint
"built disk image " forall a. [a] -> [a] -> [a]
++ forall d. DiskImage d => d -> MountPoint
describeDiskImage d
img
	cleanrebuild :: Property Linux
	cleanrebuild :: Property Linux
cleanrebuild
		| Bool
rebuild = forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property MountPoint
desc forall a b. (a -> b) -> a -> b
$ do
			forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
removeChroot MountPoint
chrootdir
			forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
		| Bool
otherwise = forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing
	chrootdir :: MountPoint
chrootdir = forall d. DiskImage d => d -> MountPoint
imageChroot d
img
	chroot :: Chroot
chroot =
		let c :: Chroot
c = Chroot -> Chroot
propprivdataonly forall a b. (a -> b) -> a -> b
$ MountPoint -> Chroot
mkchroot MountPoint
chrootdir
		in forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Chroot
c forall a b. (a -> b) -> a -> b
$ forall c. IsContainer c => c -> Props UnixLike
containerProps Chroot
c
			-- Before ensuring any other properties of the chroot,
			-- avoid starting services. Reverted by imageFinalized.
			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 (HasInfo + UnixLike) UnixLike
Service.noServices
			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
	-- Only propagate privdata Info from this chroot, nothing else.
	propprivdataonly :: Chroot -> Chroot
propprivdataonly (Chroot.Chroot MountPoint
d b
b InfoPropagator
ip Host
h) =
		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
	-- Pick boot loader finalization based on which bootloader is
	-- installed.
	final :: Finalization
final = case forall v. IsInfo v => Info -> v
fromInfo (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"

-- | This property is automatically added to the chroot when building a
-- disk image. It cleans any caches of information that can be omitted;
-- eg the apt cache on Debian.
cachesCleaned :: Property UnixLike
cachesCleaned :: Property UnixLike
cachesCleaned = MountPoint
"cache cleaned" forall i.
IsProp (Property i) =>
MountPoint -> Property i -> Property i
==> (Property DebianLike
Apt.cacheCleaned 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 = forall {k} (t :: k). SingI t => Property (MetaTypes t)
doNothing :: Property UnixLike

-- | Builds a disk image from the contents of a chroot.
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 forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> CombinedType (Property Linux) (Property UnixLike)
rmimg
  where
	desc :: MountPoint
desc = forall d. DiskImage d => d -> MountPoint
describeDiskImage d
img forall a. [a] -> [a] -> [a]
++ MountPoint
" built from " forall a. [a] -> [a] -> [a]
++ MountPoint
chrootdir
	dest :: RawDiskImage
dest@(RawDiskImage MountPoint
imgfile) = forall d. DiskImage d => d -> RawDiskImage
rawDiskImage d
img
	mkimg :: Property
  (MetaTypes
     '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
mkimg = forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		-- Unmount helper filesystems such as proc from the chroot
		-- first; don't want to include the contents of those.
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
unmountBelow MountPoint
chrootdir
		Map MountPoint PartSize
szm <- forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
M.mapKeys (MountPoint -> MountPoint -> MountPoint
toSysDir MountPoint
chrootdir) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b k. (a -> b) -> Map k a -> Map k b
M.map Integer -> PartSize
toPartSize
			forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe PartSize
defSz PartSize -> PartSize
fudgeSz 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
		-- tie the knot!
		let ([Maybe MountPoint]
mnts, [MountOpts]
mntopts, PartTable
parttable) = TableType
-> [PartSpec ()]
-> [PartSize]
-> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize TableType
tabletype [PartSpec ()]
partspec forall a b. (a -> b) -> a -> b
$
			forall a b. (a -> b) -> [a] -> [b]
map ([Maybe MountPoint] -> Maybe MountPoint -> PartSize
calcsz [Maybe MountPoint]
mnts) [Maybe MountPoint]
mnts
		forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$
			RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' RawDiskImage
dest PartTable
parttable
				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)
				forall x y. Combines x y => x -> y -> CombinedType x y
`before`
			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
			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 = forall setupmetatypes undometatypes.
RevertableProperty setupmetatypes undometatypes
-> Property undometatypes
undoRevertableProperty (forall d. DiskImage d => d -> RevertableProperty DebianLike Linux
buildDiskImage d
img)
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` 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 = forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w ->
	forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ 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 " 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 = forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO Bool
doesDirectoryExist MountPoint
srcdir) forall a b. (a -> b) -> a -> b
$
		( forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
MountPoint -> (MountPoint -> m a) -> m a
withTmpDir MountPoint
"mnt" forall a b. (a -> b) -> a -> b
$ \MountPoint
tmpdir -> forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
			(forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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)
			(forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
umountLazy MountPoint
tmpdir)
			forall a b. (a -> b) -> a -> b
$ \Bool
ismounted -> if Bool
ismounted
				then forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$
					[Filter]
-> MountPoint -> MountPoint -> Property (DebianLike + ArchLinux)
syncDirFiltered (MountPoint -> [Filter]
filtersfor MountPoint
mnt) MountPoint
srcdir MountPoint
tmpdir
				else forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
		, forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
		)
	  where
		srcdir :: MountPoint
srcdir = MountPoint
chrootdir forall a. [a] -> [a] -> [a]
++ MountPoint
mnt

	filtersfor :: MountPoint -> [Filter]
filtersfor MountPoint
mnt =
		let childmnts :: [MountPoint]
childmnts = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length (MountPoint -> MountPoint
dropTrailingPathSeparator MountPoint
mnt))) forall a b. (a -> b) -> a -> b
$
			forall a. (a -> Bool) -> [a] -> [a]
filter (\MountPoint
m -> MountPoint
m forall a. Eq a => a -> a -> Bool
/= MountPoint
mnt Bool -> Bool -> Bool
&& MountPoint -> MountPoint
addTrailingPathSeparator MountPoint
mnt forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` MountPoint
m)
				(forall a. [Maybe a] -> [a]
catMaybes [Maybe MountPoint]
mnts)
		in forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\MountPoint
m ->
			-- Include the child mount point, but exclude its contents.
			[ Pattern -> Filter
Include (MountPoint -> Pattern
Pattern MountPoint
m)
			, Pattern -> Filter
Exclude (MountPoint -> Pattern
filesUnder MountPoint
m)
			-- Preserve any lost+found directory that mkfs made
			, Pattern -> Filter
Protect (MountPoint -> Pattern
Pattern MountPoint
"lost+found")
			]) [MountPoint]
childmnts

-- The constructor for each Partition is passed the size of the files
-- from the chroot that will be put in that partition.
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, [()]
_) = 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 (forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall a. a -> a
id [PartSize -> Partition]
sizers [PartSize]
basesizes)

-- | Generates a map of the sizes of the contents of
-- every directory in a filesystem tree.
--
-- (Hard links are counted multiple times for simplicity)
--
-- Should be same values as du -bl
dirSizes :: FilePath -> IO (M.Map FilePath Integer)
dirSizes :: MountPoint -> IO (Map MountPoint Integer)
dirSizes MountPoint
top = forall {b}.
Num b =>
Map MountPoint b
-> MountPoint -> [MountPoint] -> IO (Map MountPoint b)
go 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
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return Map MountPoint b
m
	go Map MountPoint b
m MountPoint
dir (MountPoint
i:[MountPoint]
is) = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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) forall a b. (a -> b) -> a -> b
$ do
		FileStatus
s <- MountPoint -> IO FileStatus
getSymbolicLinkStatus MountPoint
i
		let sz :: b
sz = 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 forall k a. Map k a
M.empty MountPoint
i forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< MountPoint -> IO [MountPoint]
dirContents MountPoint
i
				let sz' :: b
sz' = forall a b k. (a -> b -> b) -> b -> Map k a -> b
M.foldr' forall a. Num a => a -> a -> a
(+) b
sz
					(forall k a. (k -> a -> Bool) -> Map k a -> Map k a
M.filterWithKey (forall a b. a -> b -> a
const 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 (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith forall a. Num a => a -> a -> a
(+) MountPoint
i b
sz' (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 (forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
M.insertWith 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 = forall a. Maybe a
Nothing
getMountSz Map MountPoint PartSize
szm [Maybe MountPoint]
l (Just MountPoint
mntpt) =
	forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PartSize -> PartSize -> PartSize
`reducePartSize` PartSize
childsz) (forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup MountPoint
mntpt Map MountPoint PartSize
szm)
  where
	childsz :: PartSize
childsz = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ 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) (forall a. (a -> Bool) -> [a] -> [a]
filter (MountPoint -> Maybe MountPoint -> Bool
isChild MountPoint
mntpt) [Maybe MountPoint]
l)

-- | Ensures that a disk image file of the specified size exists.
--
-- If the file doesn't exist, or is too small, creates a new one, full of 0's.
--
-- If the file is too large, truncates it down to the specified size.
imageExists :: RawDiskImage -> ByteSize -> Property Linux
imageExists :: RawDiskImage -> Integer -> Property Linux
imageExists (RawDiskImage MountPoint
img) Integer
isz = forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property (MountPoint
"disk image exists" forall a. [a] -> [a] -> [a]
++ MountPoint
img) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
	Maybe FileStatus
ms <- forall (m :: * -> *) a. MonadCatch m => m a -> m (Maybe a)
catchMaybeIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO FileStatus
getFileStatus MountPoint
img
	case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Integral a => a -> Integer
toInteger forall b c a. (b -> c) -> (a -> b) -> a -> c
. FileStatus -> FileOffset
fileSize) Maybe FileStatus
ms of
		Just Integer
s
			| Integer
s forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a -> Integer
toInteger Integer
sz -> forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
			| Integer
s forall a. Ord a => a -> a -> Bool
> forall a. Integral a => a -> Integer
toInteger Integer
sz -> do
				forall (m :: * -> *). MonadIO m => [MountPoint] -> m ()
infoMessage [MountPoint
"truncating " forall a. [a] -> [a] -> [a]
++ MountPoint
img forall a. [a] -> [a] -> [a]
++ MountPoint
" to " forall a. [a] -> [a] -> [a]
++ MountPoint
humansz]
				MountPoint -> FileOffset -> IO ()
setFileSize MountPoint
img (forall a. Num a => Integer -> a
fromInteger Integer
sz)
				forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
			| Bool
otherwise -> do
				forall (m :: * -> *). MonadIO m => [MountPoint] -> m ()
infoMessage [MountPoint
"expanding " forall a. [a] -> [a] -> [a]
++ MountPoint
img forall a. [a] -> [a] -> [a]
++ MountPoint
" from " forall a. [a] -> [a] -> [a]
++ [Unit] -> Bool -> Integer -> MountPoint
roughSize [Unit]
storageUnits Bool
False Integer
s forall a. [a] -> [a] -> [a]
++ MountPoint
" to " forall a. [a] -> [a] -> [a]
++ MountPoint
humansz]
				MountPoint -> ByteString -> IO ()
L.writeFile MountPoint
img (Int64 -> Word8 -> ByteString
L.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sz) Word8
0)
				forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
		Maybe Integer
Nothing -> do
			forall (m :: * -> *). MonadIO m => [MountPoint] -> m ()
infoMessage [MountPoint
"creating " forall a. [a] -> [a] -> [a]
++ MountPoint
img forall a. [a] -> [a] -> [a]
++ MountPoint
" of size " forall a. [a] -> [a] -> [a]
++ MountPoint
humansz]
			MountPoint -> ByteString -> IO ()
L.writeFile MountPoint
img (Int64 -> Word8 -> ByteString
L.replicate (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
sz) Word8
0)
			forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
  where
	sz :: Integer
sz = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Num a => Integer -> a
fromInteger Integer
isz forall a. Fractional a => a -> a -> a
/ Double
sectorsize) forall a. Num a => a -> a -> a
* forall a b. (RealFrac a, Integral b) => a -> b
ceiling Double
sectorsize
	humansz :: MountPoint
humansz = [Unit] -> Bool -> Integer -> MountPoint
roughSize [Unit]
storageUnits Bool
False (forall a. Integral a => a -> Integer
toInteger Integer
sz)
	-- Disks have a sector size, and making a disk image not
	-- aligned to a sector size will confuse some programs.
	-- Common sector sizes are 512 and 4096; use 4096 as it's larger.
	sectorsize :: Double
sectorsize = Double
4096 :: Double

-- | Ensure that disk image file exists and is partitioned.
--
-- Avoids repartitioning the disk image, when a file of the right size
-- already exists, and it has the same PartTable.
imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' dest :: RawDiskImage
dest@(RawDiskImage MountPoint
img) PartTable
parttable = (Property DebianLike
setup forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> CombinedType (Property UnixLike) (Property UnixLike)
cleanup) forall p. IsProp p => p -> MountPoint -> p
`describe` MountPoint
desc
  where
	desc :: MountPoint
desc = MountPoint
"disk image exists " forall a. [a] -> [a] -> [a]
++ MountPoint
img
	parttablefile :: MountPoint
parttablefile = forall d. DiskImage d => d -> MountPoint
imageParttableFile RawDiskImage
dest
	setup :: Property DebianLike
setup = forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
desc forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> do
		MountPoint
oldparttable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO MountPoint
"" forall a b. (a -> b) -> a -> b
$ MountPoint -> IO MountPoint
readFileStrict MountPoint
parttablefile
		Result
res <- forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ RawDiskImage -> Integer -> Property Linux
imageExists RawDiskImage
dest (PartTable -> Integer
partTableSize PartTable
parttable)
		if Result
res forall a. Eq a => a -> a -> Bool
== Result
NoChange Bool -> Bool -> Bool
&& MountPoint
oldparttable forall a. Eq a => a -> a -> Bool
== forall a. Show a => a -> MountPoint
show PartTable
parttable
			then forall (m :: * -> *) a. Monad m => a -> m a
return Result
NoChange
			else if Result
res forall a. Eq a => a -> a -> Bool
== Result
FailedChange
				then forall (m :: * -> *) a. Monad m => a -> m a
return Result
FailedChange
				else do
					forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> MountPoint -> IO ()
writeFile MountPoint
parttablefile (forall a. Show a => a -> MountPoint
show PartTable
parttable)
					forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w forall a b. (a -> b) -> a -> b
$ Eep -> 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
		forall x y. Combines x y => x -> y -> CombinedType x y
`before`
		MountPoint -> Property UnixLike
File.notPresent MountPoint
parttablefile

-- | A property that is run after the disk image is created, with
-- its populated partition tree mounted in the provided
-- location from the provided loop devices. This is typically used to
-- install a boot loader in the image's superblock.
--
-- It's ok if the property leaves additional things mounted
-- in the partition tree.
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) =
	forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' MountPoint
"disk image finalized" forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w ->
		forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
MountPoint -> (MountPoint -> m a) -> m a
withTmpDir MountPoint
"mnt" 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 forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
`finally` 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
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
mountall MountPoint
top
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
writefstab MountPoint
top
		forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ MountPoint -> IO ()
allowservices MountPoint
top
		forall (inner :: [MetaType]) (outer :: [MetaType]).
EnsurePropertyAllowed inner outer =>
OuterMetaTypesWitness outer
-> Property (MetaTypes inner) -> Propellor Result
ensureProperty OuterMetaTypesWitness
  '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
     'Targeting 'OSArchLinux]
w forall a b. (a -> b) -> a -> b
$ 
			Finalization
final RawDiskImage
img MountPoint
top [LoopDev]
devs

	-- Ordered lexographically by mount point, so / comes before /usr
	-- comes before /usr/local
	orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
	orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs = forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Maybe MountPoint]
mnts (forall a b. [a] -> [b] -> [(a, b)]
zip [MountOpts]
mntopts [LoopDev]
devs)

	swaps :: [SwapPartition]
swaps = forall a b. (a -> b) -> [a] -> [b]
map (MountPoint -> SwapPartition
SwapPartition forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoopDev -> MountPoint
partitionLoopDev forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$
		forall a. (a -> Bool) -> [a] -> [a]
filter ((forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Fs
LinuxSwap) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Partition -> Maybe Fs
partFs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$
			forall a b. [a] -> [b] -> [(a, b)]
zip [Partition]
parts [LoopDev]
devs

	mountall :: MountPoint -> IO ()
mountall MountPoint
top = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(Maybe MountPoint, (MountOpts, LoopDev))]
orderedmntsdevs forall a b. (a -> b) -> a -> b
$ \(Maybe MountPoint
mp, (MountOpts
mopts, LoopDev
loopdev)) -> case Maybe MountPoint
mp of
		Maybe MountPoint
Nothing -> forall (m :: * -> *). Monad m => m ()
noop
		Just MountPoint
p -> do
			let mnt :: MountPoint
mnt = MountPoint
top forall a. [a] -> [a] -> [a]
++ MountPoint
p
			Bool -> MountPoint -> IO ()
createDirectoryIfMissing Bool
True MountPoint
mnt
			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) forall a b. (a -> b) -> a -> b
$
				forall a. HasCallStack => MountPoint -> a
error forall a b. (a -> b) -> a -> b
$ MountPoint
"failed mounting " 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 forall a. [a] -> [a] -> [a]
++ MountPoint
"/etc/fstab"
		[MountPoint]
old <- forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
catchDefaultIO [] forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> Bool
unconfigured) forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> [MountPoint]
lines
			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 (forall a b. (a -> b) -> [a] -> [b]
map (MountPoint
top forall a. [a] -> [a] -> [a]
++) (forall a. [Maybe a] -> [a]
catMaybes [Maybe MountPoint]
mnts))
			[SwapPartition]
swaps (MountPoint -> MountPoint -> MountPoint
toSysDir MountPoint
top)
		MountPoint -> MountPoint -> IO ()
writeFile MountPoint
fstab forall a b. (a -> b) -> a -> b
$ [MountPoint] -> MountPoint
unlines forall a b. (a -> b) -> a -> b
$ [MountPoint]
new forall a. [a] -> [a] -> [a]
++ [MountPoint]
old
	-- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM"
	unconfigured :: MountPoint -> Bool
unconfigured MountPoint
s = MountPoint
"UNCONFIGURED" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` MountPoint
s

	allowservices :: MountPoint -> IO ()
allowservices MountPoint
top = MountPoint -> IO ()
nukeFile (MountPoint
top forall a. [a] -> [a] -> [a]
++ MountPoint
"/usr/sbin/policy-rc.d")

unbootable :: String -> Finalization
unbootable :: MountPoint -> Finalization
unbootable MountPoint
msg = \RawDiskImage
_ MountPoint
_ [LoopDev]
_ -> forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property MountPoint
desc forall a b. (a -> b) -> a -> b
$ do
	forall (m :: * -> *). MonadIO m => MountPoint -> m ()
warningMessage (MountPoint
desc forall a. [a] -> [a] -> [a]
++ MountPoint
": " forall a. [a] -> [a] -> [a]
++ MountPoint
msg)
	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
		forall p. IsProp p => p -> MountPoint -> p
`describe` MountPoint
"disk image boots using grub"
  where
	-- It doesn't matter which loopdev we use; all
	-- come from the same disk image, and it's the loop dev
	-- for the whole disk image we seek.
	wholediskloopdev :: MountPoint
wholediskloopdev = case [LoopDev]
loopdevs of
		(LoopDev
l:[LoopDev]
_) -> LoopDev -> MountPoint
wholeDiskLoopDev LoopDev
l
		[] -> 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
		forall x y. Combines x y => x -> y -> CombinedType x y
`before` Finalization
flashKernelFinalized RawDiskImage
img MountPoint
mnt [LoopDev]
loopdevs

-- | Normally a boot loader is installed on a disk image. However,
-- when the disk image will be booted by eg qemu booting the kernel and
-- initrd, no boot loader is needed, and this property can be used.
noBootloader :: Property (HasInfo + UnixLike)
noBootloader :: Property (HasInfo + UnixLike)
noBootloader = 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 = 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 = forall (p :: * -> *) i (m :: * -> *).
(Checkable p i, LiftPropellor m) =>
m Bool -> p i -> Property i
check (MountPoint -> IO Bool
doesDirectoryExist MountPoint
dir) forall a b. (a -> b) -> a -> b
$
	forall {k} (metatypes :: k).
SingI metatypes =>
MountPoint -> Propellor Result -> Property (MetaTypes metatypes)
property MountPoint
"destroy the chroot used to build the image" forall a b. (a -> b) -> a -> b
$ IO () -> Propellor Result
makeChange forall a b. (a -> b) -> a -> b
$ do
		MountPoint -> IO ()
removeChroot MountPoint
dir
		MountPoint -> IO ()
nukeFile forall a b. (a -> b) -> a -> b
$ forall d. DiskImage d => d -> MountPoint
imageParttableFile d
img
  where
	dir :: MountPoint
dir = 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 = 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 = 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

-- | From a location in a chroot (eg, /tmp/chroot/usr) to
-- the corresponding location inside (eg, /usr).
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
"/" forall a. [a] -> [a] -> [a]
++ MountPoint
sysdir