    -- | 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.Qemu as Qemu
    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 = RawDiskImage -> RawDiskImage
    forall a. a -> a
    id
    	describeDiskImage :: RawDiskImage -> String
    describeDiskImage (RawDiskImage f :: String
    f) = String
    f
    	buildDiskImage :: RawDiskImage -> RevertableProperty DebianLike Linux
    buildDiskImage (RawDiskImage _) = 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

    -- | 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 f :: String
    f) = String -> RawDiskImage
    RawDiskImage (String -> RawDiskImage) -> String -> RawDiskImage
    forall a b. (a -> b) -> a -> b
    $
    		String -> String
    dropExtension String
    f String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ".img"
    	describeDiskImage :: VirtualBoxPointer -> String
    describeDiskImage (VirtualBoxPointer f :: String
    f) = String
    f
    	buildDiskImage :: VirtualBoxPointer -> RevertableProperty DebianLike Linux
    buildDiskImage (VirtualBoxPointer vmdkfile :: String
    vmdkfile) = (CombinedType (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
    -> String -> RevertableProperty DebianLike Linux
    forall p. IsProp p => p -> String -> p
    `describe` (String
    vmdkfile String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " built")
    	  where
    		setup :: CombinedType (Property DebianLike) (Property UnixLike)
    setup = String -> [String] -> UncheckedProperty UnixLike
    cmdProperty "VBoxManage"
    			[ "internalcommands", "createrawvmdk"
    			, "-filename", String
    vmdkfile
    			, "-rawdisk", String
    diskimage
    			]
    			UncheckedProperty UnixLike -> String -> Property UnixLike
    forall (p :: * -> *) i.
    Checkable p i =>
    p i -> String -> Property i
    `changesFile` String
    vmdkfile
    			Property UnixLike
    -> Property UnixLike
    -> CombinedType (Property UnixLike) (Property UnixLike)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `onChange` String -> FileMode -> Property UnixLike
    File.mode String
    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` [String] -> Property DebianLike
    Apt.installed ["virtualbox"]
    			Property DebianLike
    -> Property UnixLike
    -> CombinedType (Property DebianLike) (Property UnixLike)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `requires` String -> Property UnixLike
    File.notPresent String
    vmdkfile
    		cleanup :: Property Linux
    cleanup = Property UnixLike -> Property Linux
    forall (p :: * -> *) (untightened :: [MetaType])
           (tightened :: [MetaType]).
    (TightenTargets p, TightenTargetsAllowed untightened tightened,
     SingI tightened) =>
    p (MetaTypes untightened) -> p (MetaTypes tightened)
    tightenTargets (Property UnixLike -> Property Linux)
    -> Property UnixLike -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ String -> Property UnixLike
    File.notPresent String
    vmdkfile
    		RawDiskImage diskimage :: String
    diskimage = VirtualBoxPointer -> RawDiskImage
    forall d. DiskImage d => d -> RawDiskImage
    rawDiskImage (String -> VirtualBoxPointer
    VirtualBoxPointer String
    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 :: d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuilt = Bool
    -> d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    forall d.
    DiskImage d =>
    Bool
    -> d
    -> (String -> 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 :: d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageRebuilt = Bool
    -> d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    forall d.
    DiskImage d =>
    Bool
    -> d
    -> (String -> 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 :: 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

    -- | 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 :: 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' :: Bool
    -> Host
    -> d
    -> bootstrapper
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuiltFor' rebuild :: Bool
    rebuild h :: Host
    h d :: d
    d bs :: bootstrapper
    bs =
    	Bool
    -> d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    forall d.
    DiskImage d =>
    Bool
    -> d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuilt' Bool
    rebuild d
    d (Host -> bootstrapper -> String -> Chroot
    forall bootstrapper.
    ChrootBootstrapper bootstrapper =>
    Host -> bootstrapper -> String -> Chroot
    Chroot.hostChroot Host
    h bootstrapper
    bs) TableType
    tt [PartSpec ()]
    pil
      where
    	PartTableSpec tt :: TableType
    tt pil :: [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' :: Bool
    -> d
    -> (String -> Chroot)
    -> TableType
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuilt' rebuild :: Bool
    rebuild img :: d
    img mkchroot :: String -> Chroot
    mkchroot tabletype :: TableType
    tabletype partspec :: [PartSpec ()]
    partspec =
    	d
    -> String
    -> TableType
    -> Finalization
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    forall d.
    DiskImage d =>
    d
    -> String
    -> TableType
    -> Finalization
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuiltFrom d
    img String
    chrootdir TableType
    tabletype Finalization
    final [PartSpec ()]
    partspec
    		RevertableProperty
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
      Linux
    -> RevertableProperty
         (MetaTypes
            '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
               'Targeting 'OSArchLinux])
         Linux
    -> CombinedType
         (RevertableProperty
            (Sing '[ '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
    		RevertableProperty
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
      Linux
    -> RevertableProperty Linux UnixLike
    -> CombinedType
         (RevertableProperty
            (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
            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
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
      Linux
    -> String
    -> RevertableProperty
         (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
         Linux
    forall p. IsProp p => p -> String -> p
    `describe` String
    desc
      where
    	desc :: String
    desc = "built disk image " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ d -> String
    forall d. DiskImage d => d -> String
    describeDiskImage d
    img
    	cleanrebuild :: Property Linux
    	cleanrebuild :: Property Linux
    cleanrebuild
    		| Bool
    rebuild = String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property String
    desc (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ do
    			IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    removeChroot String
    chrootdir
    			Result -> Propellor Result
    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 :: String
    chrootdir = d -> String
    forall d. DiskImage d => d -> String
    imageChroot d
    img
    	chroot :: Chroot
    chroot =
    		let c :: Chroot
    c = Chroot -> Chroot
    propprivdataonly (Chroot -> Chroot) -> Chroot -> Chroot
    forall a b. (a -> b) -> a -> b
    $ String -> Chroot
    mkchroot String
    chrootdir
    		in Chroot
    -> Props
         (MetaTypes
            ('WithInfo
               : Concat
                   '[]
                   '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
                      'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
    -> Chroot
    forall c metatypes. IsContainer c => c -> Props metatypes -> c
    setContainerProps Chroot
    c (Props
       (MetaTypes
          ('WithInfo
             : Concat
                 '[]
                 '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
                    'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD]))
     -> Chroot)
    -> Props
         (MetaTypes
            ('WithInfo
               : Concat
                   '[]
                   '[ '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
    			-- Before ensuring any other properties of the chroot,
    			-- avoid starting services. Reverted by imageFinalized.
    			Props UnixLike
    -> RevertableProperty
         (Sing
            '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
               'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
         UnixLike
    -> Props
         (MetaTypes
            (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
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
      UnixLike
    RevertableProperty (HasInfo + UnixLike) UnixLike
    Service.noServices
    			Props
      (Sing
         '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
            'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
    -> Property UnixLike
    -> Props
         (MetaTypes
            (Combine
               '[ '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
    	-- Only propagate privdata Info from this chroot, nothing else.
    	propprivdataonly :: Chroot -> Chroot
    propprivdataonly (Chroot.Chroot d :: String
    d b :: b
    b ip :: InfoPropagator
    ip h :: Host
    h) =
    		String -> b -> InfoPropagator -> Host -> Chroot
    forall b.
    ChrootBootstrapper b =>
    String -> b -> InfoPropagator -> Host -> Chroot
    Chroot.Chroot String
    d b
    b (\c :: Chroot
    c _ -> InfoPropagator
    ip Chroot
    c PropagateInfo -> Bool
    onlyPrivData) Host
    h
    	-- Pick boot loader finalization based on which bootloader is
    	-- installed.
    	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
    		[] -> String -> Finalization
    unbootable "no bootloader is installed"
    		[GrubInstalled grubtarget :: GrubTarget
    grubtarget] -> GrubTarget -> Finalization
    grubFinalized GrubTarget
    grubtarget
    		[UbootInstalled p :: String -> String -> Property Linux
    p] -> (String -> String -> Property Linux) -> Finalization
    ubootFinalized String -> String -> Property Linux
    p
    		[FlashKernelInstalled] -> Finalization
    flashKernelFinalized
    		[UbootInstalled p :: String -> String -> Property Linux
    p, FlashKernelInstalled] ->
    			(String -> String -> Property Linux) -> Finalization
    ubootFlashKernelFinalized String -> String -> Property Linux
    p
    		[FlashKernelInstalled, UbootInstalled p :: String -> String -> Property Linux
    p] ->
    			(String -> String -> Property Linux) -> Finalization
    ubootFlashKernelFinalized String -> String -> Property Linux
    p
    		[NoBootloader] -> Finalization
    noBootloaderFinalized
    		_ -> String -> Finalization
    unbootable "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 = "cache cleaned" String -> Property UnixLike -> Property UnixLike
    forall i. IsProp (Property i) => String -> 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

    -- | Builds a disk image from the contents of a chroot.
    imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuiltFrom :: d
    -> String
    -> TableType
    -> Finalization
    -> [PartSpec ()]
    -> RevertableProperty (HasInfo + DebianLike) Linux
    imageBuiltFrom img :: d
    img chrootdir :: String
    chrootdir tabletype :: TableType
    tabletype final :: Finalization
    final partspec :: [PartSpec ()]
    partspec = Property
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
    mkimg Property
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
    -> Property Linux
    -> RevertableProperty
         (Sing '[ '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 :: String
    desc = d -> String
    forall d. DiskImage d => d -> String
    describeDiskImage d
    img String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " built from " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    chrootdir
    	dest :: RawDiskImage
    dest@(RawDiskImage imgfile :: String
    imgfile) = d -> RawDiskImage
    forall d. DiskImage d => d -> RawDiskImage
    rawDiskImage d
    img
    	mkimg :: Property
      (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
    mkimg = String
    -> (OuterMetaTypesWitness
          '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
        -> Propellor Result)
    -> Property
         (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
    forall k (metatypes :: k).
    SingI metatypes =>
    String
    -> (OuterMetaTypesWitness metatypes -> Propellor Result)
    -> Property (MetaTypes metatypes)
    property' String
    desc ((OuterMetaTypesWitness
        '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
      -> Propellor Result)
     -> Property
          (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]))
    -> (OuterMetaTypesWitness
          '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
        -> Propellor Result)
    -> Property
         (Sing '[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish])
    forall a b. (a -> b) -> a -> b
    $ \w :: 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.
    		IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    unmountBelow String
    chrootdir
    		Map String PartSize
    szm <- (String -> String) -> Map String PartSize -> Map String PartSize
    forall k2 k1 a. Ord k2 => (k1 -> k2) -> Map k1 a -> Map k2 a
    M.mapKeys (String -> String -> String
    toSysDir String
    chrootdir) (Map String PartSize -> Map String PartSize)
    -> (Map String ByteSize -> Map String PartSize)
    -> Map String ByteSize
    -> Map String PartSize
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ByteSize -> PartSize)
    -> Map String ByteSize -> Map String PartSize
    forall a b k. (a -> b) -> Map k a -> Map k b
    M.map ByteSize -> PartSize
    toPartSize
    			(Map String ByteSize -> Map String PartSize)
    -> Propellor (Map String ByteSize)
    -> Propellor (Map String PartSize)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> IO (Map String ByteSize) -> Propellor (Map String ByteSize)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (String -> IO (Map String ByteSize)
    dirSizes String
    chrootdir)
    		let calcsz :: [Maybe String] -> Maybe String -> PartSize
    calcsz mnts :: [Maybe String]
    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 String -> Maybe PartSize) -> Maybe String -> PartSize
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Map String PartSize
    -> [Maybe String] -> Maybe String -> Maybe PartSize
    getMountSz Map String PartSize
    szm [Maybe String]
    mnts
    		-- tie the knot!
    		let (mnts :: [Maybe String]
    mnts, mntopts :: [MountOpts]
    mntopts, parttable :: PartTable
    parttable) = TableType
    -> [PartSpec ()]
    -> [PartSize]
    -> ([Maybe String], [MountOpts], PartTable)
    fitChrootSize TableType
    tabletype [PartSpec ()]
    partspec ([PartSize] -> ([Maybe String], [MountOpts], PartTable))
    -> [PartSize] -> ([Maybe String], [MountOpts], PartTable)
    forall a b. (a -> b) -> a -> b
    $
    			(Maybe String -> PartSize) -> [Maybe String] -> [PartSize]
    forall a b. (a -> b) -> [a] -> [b]
    map ([Maybe String] -> Maybe String -> PartSize
    calcsz [Maybe String]
    mnts) [Maybe String]
    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`
    			String -> ([LoopDev] -> Property DebianLike) -> Property DebianLike
    kpartx String
    imgfile ([Maybe String]
    -> [MountOpts]
    -> PartTable
    -> [LoopDev]
    -> CombinedType (Property DebianLike) (Property Linux)
    mkimg' [Maybe String]
    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 String]
    -> [MountOpts]
    -> PartTable
    -> [LoopDev]
    -> CombinedType (Property DebianLike) (Property Linux)
    mkimg' mnts :: [Maybe String]
    mnts mntopts :: [MountOpts]
    mntopts parttable :: PartTable
    parttable devs :: [LoopDev]
    devs =
    		String
    -> [Maybe String]
    -> [MountOpts]
    -> [LoopDev]
    -> Property DebianLike
    partitionsPopulated String
    chrootdir [Maybe String]
    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 String]
    -> [MountOpts]
    -> [LoopDev]
    -> PartTable
    -> Property Linux
    imageFinalized Finalization
    final RawDiskImage
    dest [Maybe String]
    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 :: String
    -> [Maybe String]
    -> [MountOpts]
    -> [LoopDev]
    -> Property DebianLike
    partitionsPopulated chrootdir :: String
    chrootdir mnts :: [Maybe String]
    mnts mntopts :: [MountOpts]
    mntopts devs :: [LoopDev]
    devs = String
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
        -> Propellor Result)
    -> Property DebianLike
    forall k (metatypes :: k).
    SingI metatypes =>
    String
    -> (OuterMetaTypesWitness metatypes -> Propellor Result)
    -> Property (MetaTypes metatypes)
    property' String
    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
    $ \w :: 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 String -> MountOpts -> LoopDev -> Propellor Result)
    -> [Maybe String] -> [MountOpts] -> [LoopDev] -> [Propellor Result]
    forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
    zipWith3 (OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Maybe String -> MountOpts -> LoopDev -> Propellor Result
    go OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    w) [Maybe String]
    mnts [MountOpts]
    mntopts [LoopDev]
    devs
      where
    	desc :: String
    desc = "partitions populated from " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    chrootdir

    	go :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    -> Maybe String -> MountOpts -> LoopDev -> Propellor Result
    go _ Nothing _ _ = Propellor Result
    noChange
    	go w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    w (Just mnt :: String
    mnt) mntopt :: MountOpts
    mntopt loopdev :: 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 (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> Propellor Bool) -> IO Bool -> Propellor Bool
    forall a b. (a -> b) -> a -> b
    $ String -> IO Bool
    doesDirectoryExist String
    srcdir) ((Propellor Result, Propellor Result) -> Propellor Result)
    -> (Propellor Result, Propellor Result) -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $
    		( String -> (String -> Propellor Result) -> Propellor Result
    forall (m :: * -> *) a.
    (MonadMask m, MonadIO m) =>
    String -> (String -> m a) -> m a
    withTmpDir "mnt" ((String -> Propellor Result) -> Propellor Result)
    -> (String -> Propellor Result) -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ \tmpdir :: String
    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 (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Bool -> Propellor Bool) -> IO Bool -> Propellor Bool
    forall a b. (a -> b) -> a -> b
    $ String -> String -> String -> MountOpts -> IO Bool
    mount "auto" (LoopDev -> String
    partitionLoopDev LoopDev
    loopdev) String
    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 (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    umountLazy String
    tmpdir)
    			((Bool -> Propellor Result) -> Propellor Result)
    -> (Bool -> Propellor Result) -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ \ismounted :: 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] -> String -> String -> Property (DebianLike + ArchLinux)
    syncDirFiltered (String -> [Filter]
    filtersfor String
    mnt) String
    srcdir String
    tmpdir
    				else Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    FailedChange
    		, Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange
    		)
    	  where
    		srcdir :: String
    srcdir = String
    chrootdir String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    mnt

    	filtersfor :: String -> [Filter]
    filtersfor mnt :: String
    mnt =
    		let childmnts :: [String]
    childmnts = (String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (Int -> String -> String
    forall a. Int -> [a] -> [a]
    drop (String -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length (String -> String
    dropTrailingPathSeparator String
    mnt))) ([String] -> [String]) -> [String] -> [String]
    forall a b. (a -> b) -> a -> b
    $
    			(String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (\m :: String
    m -> String
    m String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    /= String
    mnt Bool -> Bool -> Bool
    && String -> String
    addTrailingPathSeparator String
    mnt String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    m)
    				([Maybe String] -> [String]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe String]
    mnts)
    		in (String -> [Filter]) -> [String] -> [Filter]
    forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
    concatMap (\m :: String
    m ->
    			-- Include the child mount point, but exclude its contents.
    			[ Pattern -> Filter
    Include (String -> Pattern
    Pattern String
    m)
    			, Pattern -> Filter
    Exclude (String -> Pattern
    filesUnder String
    m)
    			-- Preserve any lost+found directory that mkfs made
    			, Pattern -> Filter
    Protect (String -> Pattern
    Pattern "lost+found")
    			]) [String]
    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 String], [MountOpts], PartTable)
    fitChrootSize tt :: TableType
    tt l :: [PartSpec ()]
    l basesizes :: [PartSize]
    basesizes = ([Maybe String]
    mounts, [MountOpts]
    mountopts, PartTable
    parttable)
      where
    	(mounts :: [Maybe String]
    mounts, mountopts :: [MountOpts]
    mountopts, sizers :: [PartSize -> Partition]
    sizers, _) = [PartSpec ()]
    -> ([Maybe String], [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)

    -- | 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 :: String -> IO (Map String ByteSize)
    dirSizes top :: String
    top = Map String ByteSize
    -> String -> [String] -> IO (Map String ByteSize)
    forall a.
    Num a =>
    Map String a -> String -> [String] -> IO (Map String a)
    go Map String ByteSize
    forall k a. Map k a
    M.empty String
    top [String
    top]
      where
    	go :: Map String a -> String -> [String] -> IO (Map String a)
    go m :: Map String a
    m _ [] = Map String a -> IO (Map String a)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Map String a
    m
    	go m :: Map String a
    m dir :: String
    dir (i :: String
    i:is :: [String]
    is) = (IO (Map String a)
     -> (IOException -> IO (Map String a)) -> IO (Map String a))
    -> (IOException -> IO (Map String a))
    -> IO (Map String a)
    -> IO (Map String a)
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip IO (Map String a)
    -> (IOException -> IO (Map String a)) -> IO (Map String a)
    forall (m :: * -> *) a.
    MonadCatch m =>
    m a -> (IOException -> m a) -> m a
    catchIO (\_ioerr :: IOException
    _ioerr -> Map String a -> String -> [String] -> IO (Map String a)
    go Map String a
    m String
    dir [String]
    is) (IO (Map String a) -> IO (Map String a))
    -> IO (Map String a) -> IO (Map String a)
    forall a b. (a -> b) -> a -> b
    $ do
    		FileStatus
    s <- String -> IO FileStatus
    getSymbolicLinkStatus String
    i
    		let sz :: a
    sz = FileOffset -> a
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral (FileStatus -> FileOffset
    fileSize FileStatus
    s)
    		if FileStatus -> Bool
    isDirectory FileStatus
    s
    			then do
    				Map String a
    subm <- Map String a -> String -> [String] -> IO (Map String a)
    go Map String a
    forall k a. Map k a
    M.empty String
    i ([String] -> IO (Map String a)) -> IO [String] -> IO (Map String a)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
    =<< String -> IO [String]
    dirContents String
    i
    				let sz' :: a
    sz' = (a -> a -> a) -> a -> Map String a -> a
    forall a b k. (a -> b -> b) -> b -> Map k a -> b
    M.foldr' a -> a -> a
    forall a. Num a => a -> a -> a
    (+) a
    sz
    					((String -> a -> Bool) -> Map String a -> Map String a
    forall k a. (k -> a -> Bool) -> Map k a -> Map k a
    M.filterWithKey (Bool -> a -> Bool
    forall a b. a -> b -> a
    const (Bool -> a -> Bool) -> (String -> Bool) -> String -> a -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> String -> Bool
    subdirof String
    i) Map String a
    subm)
    				Map String a -> String -> [String] -> IO (Map String a)
    go ((a -> a -> a) -> String -> a -> Map String a -> Map String a
    forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
    M.insertWith a -> a -> a
    forall a. Num a => a -> a -> a
    (+) String
    i a
    sz' (Map String a -> Map String a -> Map String a
    forall k a. Ord k => Map k a -> Map k a -> Map k a
    M.union Map String a
    m Map String a
    subm)) String
    dir [String]
    is
    			else Map String a -> String -> [String] -> IO (Map String a)
    go ((a -> a -> a) -> String -> a -> Map String a -> Map String a
    forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
    M.insertWith a -> a -> a
    forall a. Num a => a -> a -> a
    (+) String
    dir a
    sz Map String a
    m) String
    dir [String]
    is
    	subdirof :: String -> String -> Bool
    subdirof parent :: String
    parent i :: String
    i = Bool -> Bool
    not (String
    i String -> String -> Bool
    `equalFilePath` String
    parent) Bool -> Bool -> Bool
    && String -> String
    takeDirectory String
    i String -> String -> Bool
    `equalFilePath` String
    parent

    getMountSz :: (M.Map FilePath PartSize) -> [Maybe MountPoint] -> Maybe MountPoint -> Maybe PartSize
    getMountSz :: Map String PartSize
    -> [Maybe String] -> Maybe String -> Maybe PartSize
    getMountSz _ _ Nothing = Maybe PartSize
    forall a. Maybe a
    Nothing
    getMountSz szm :: Map String PartSize
    szm l :: [Maybe String]
    l (Just mntpt :: String
    mntpt) =
    	(PartSize -> PartSize) -> Maybe PartSize -> Maybe PartSize
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (PartSize -> PartSize -> PartSize
    `reducePartSize` PartSize
    childsz) (String -> Map String PartSize -> Maybe PartSize
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup String
    mntpt Map String 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 String -> Maybe PartSize) -> [Maybe String] -> [PartSize]
    forall a b. (a -> Maybe b) -> [a] -> [b]
    mapMaybe (Map String PartSize
    -> [Maybe String] -> Maybe String -> Maybe PartSize
    getMountSz Map String PartSize
    szm [Maybe String]
    l) ((Maybe String -> Bool) -> [Maybe String] -> [Maybe String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (String -> Maybe String -> Bool
    isChild String
    mntpt) [Maybe String]
    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 -> ByteSize -> Property Linux
    imageExists (RawDiskImage img :: String
    img) isz :: ByteSize
    isz = String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property ("disk image exists" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    img) (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ IO Result -> Propellor Result
    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
    $ String -> IO FileStatus
    getFileStatus String
    img
    	case (FileStatus -> ByteSize) -> Maybe FileStatus -> Maybe ByteSize
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap (FileOffset -> ByteSize
    forall a. Integral a => a -> ByteSize
    toInteger (FileOffset -> ByteSize)
    -> (FileStatus -> FileOffset) -> FileStatus -> ByteSize
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . FileStatus -> FileOffset
    fileSize) Maybe FileStatus
    ms of
    		Just s :: ByteSize
    s
    			| ByteSize
    s ByteSize -> ByteSize -> Bool
    forall a. Eq a => a -> a -> Bool
    == ByteSize -> ByteSize
    forall a. Integral a => a -> ByteSize
    toInteger ByteSize
    sz -> Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    NoChange
    			| ByteSize
    s ByteSize -> ByteSize -> Bool
    forall a. Ord a => a -> a -> Bool
    > ByteSize -> ByteSize
    forall a. Integral a => a -> ByteSize
    toInteger ByteSize
    sz -> do
    				[String] -> IO ()
    forall (m :: * -> *). MonadIO m => [String] -> m ()
    infoMessage ["truncating " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    img String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " to " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    humansz]
    				String -> FileOffset -> IO ()
    setFileSize String
    img (ByteSize -> FileOffset
    forall a. Num a => ByteSize -> a
    fromInteger ByteSize
    sz)
    				Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    			| Bool
    otherwise -> do
    				[String] -> IO ()
    forall (m :: * -> *). MonadIO m => [String] -> m ()
    infoMessage ["expanding " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    img String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " from " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ [Unit] -> Bool -> ByteSize -> String
    roughSize [Unit]
    storageUnits Bool
    False ByteSize
    s String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " to " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    humansz]
    				String -> ByteString -> IO ()
    L.writeFile String
    img (Int64 -> Word8 -> ByteString
    L.replicate (ByteSize -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral ByteSize
    sz) 0)
    				Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
    		Nothing -> do
    			[String] -> IO ()
    forall (m :: * -> *). MonadIO m => [String] -> m ()
    infoMessage ["creating " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    img String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ " of size " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    humansz]
    			String -> ByteString -> IO ()
    L.writeFile String
    img (Int64 -> Word8 -> ByteString
    L.replicate (ByteSize -> Int64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral ByteSize
    sz) 0)
    			Result -> IO Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    MadeChange
      where
    	sz :: ByteSize
    sz = Double -> ByteSize
    forall a b. (RealFrac a, Integral b) => a -> b
    ceiling (ByteSize -> Double
    forall a. Num a => ByteSize -> a
    fromInteger ByteSize
    isz Double -> Double -> Double
    forall a. Fractional a => a -> a -> a
    / Double
    sectorsize) ByteSize -> ByteSize -> ByteSize
    forall a. Num a => a -> a -> a
    * Double -> ByteSize
    forall a b. (RealFrac a, Integral b) => a -> b
    ceiling Double
    sectorsize
    	humansz :: String
    humansz = [Unit] -> Bool -> ByteSize -> String
    roughSize [Unit]
    storageUnits Bool
    False (ByteSize -> ByteSize
    forall a. Integral a => a -> ByteSize
    toInteger ByteSize
    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 = 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 img :: String
    img) parttable :: 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
    -> String -> RevertableProperty DebianLike UnixLike
    forall p. IsProp p => p -> String -> p
    `describe` String
    desc
      where
    	desc :: String
    desc = "disk image exists " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    img
    	parttablefile :: String
    parttablefile = RawDiskImage -> String
    forall d. DiskImage d => d -> String
    imageParttableFile RawDiskImage
    dest
    	setup :: Property DebianLike
    setup = String
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
        -> Propellor Result)
    -> Property DebianLike
    forall k (metatypes :: k).
    SingI metatypes =>
    String
    -> (OuterMetaTypesWitness metatypes -> Propellor Result)
    -> Property (MetaTypes metatypes)
    property' String
    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
    $ \w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
    w -> do
    		String
    oldparttable <- IO String -> Propellor String
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO String -> Propellor String) -> IO String -> Propellor String
    forall a b. (a -> b) -> a -> b
    $ String -> IO String -> IO String
    forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
    catchDefaultIO "" (IO String -> IO String) -> IO String -> IO String
    forall a b. (a -> b) -> a -> b
    $ String -> IO String
    readFileStrict String
    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 -> ByteSize -> Property Linux
    imageExists RawDiskImage
    dest (PartTable -> ByteSize
    partTableSize PartTable
    parttable)
    		if Result
    res Result -> Result -> Bool
    forall a. Eq a => a -> a -> Bool
    == Result
    NoChange Bool -> Bool -> Bool
    && String
    oldparttable String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == PartTable -> String
    forall a. Show a => a -> String
    show PartTable
    parttable
    			then Result -> Propellor Result
    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 (m :: * -> *) a. Monad m => a -> m a
    return Result
    FailedChange
    				else do
    					IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> String -> IO ()
    writeFile String
    parttablefile (PartTable -> String
    forall a. Show a => a -> String
    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 -> String -> PartTable -> Property DebianLike
    partitioned Eep
    YesReallyDeleteDiskContents String
    img PartTable
    parttable
    	cleanup :: CombinedType (Property UnixLike) (Property UnixLike)
    cleanup = String -> Property UnixLike
    File.notPresent String
    img
    		Property UnixLike
    -> Property UnixLike
    -> CombinedType (Property UnixLike) (Property UnixLike)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `before`
    		String -> Property UnixLike
    File.notPresent String
    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 String]
    -> [MountOpts]
    -> [LoopDev]
    -> PartTable
    -> Property Linux
    imageFinalized final :: Finalization
    final img :: RawDiskImage
    img mnts :: [Maybe String]
    mnts mntopts :: [MountOpts]
    mntopts devs :: [LoopDev]
    devs (PartTable _ _ parts :: [Partition]
    parts) =
    	String
    -> (OuterMetaTypesWitness
          '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
             'Targeting 'OSArchLinux]
        -> Propellor Result)
    -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String
    -> (OuterMetaTypesWitness metatypes -> Propellor Result)
    -> Property (MetaTypes metatypes)
    property' "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
    $ \w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w ->
    		String -> (String -> Propellor Result) -> Propellor Result
    forall (m :: * -> *) a.
    (MonadMask m, MonadIO m) =>
    String -> (String -> m a) -> m a
    withTmpDir "mnt" ((String -> Propellor Result) -> Propellor Result)
    -> (String -> Propellor Result) -> Propellor Result
    forall a b. (a -> b) -> a -> b
    $ \top :: String
    top ->
    			OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> String -> Propellor Result
    go OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w String
    top Propellor Result -> Propellor () -> Propellor Result
    forall (m :: * -> *) a b. MonadMask m => m a -> m b -> m a
    `finally` IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (String -> IO ()
    unmountall String
    top)
      where
    	go :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    -> String -> Propellor Result
    go w :: OuterMetaTypesWitness
      '[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
         'Targeting 'OSArchLinux]
    w top :: String
    top = do
    		IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    mountall String
    top
    		IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    writefstab String
    top
    		IO () -> Propellor ()
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO () -> Propellor ()) -> IO () -> Propellor ()
    forall a b. (a -> b) -> a -> b
    $ String -> IO ()
    allowservices String
    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 String
    top [LoopDev]
    devs
    				Property Linux
    -> Property Linux -> CombinedType (Property Linux) (Property Linux)
    forall x y. Combines x y => x -> y -> CombinedType x y
    `before` String -> Property Linux
    Qemu.removeHostEmulationBinary String
    top

    	-- Ordered lexographically by mount point, so / comes before /usr
    	-- comes before /usr/local
    	orderedmntsdevs :: [(Maybe MountPoint, (MountOpts, LoopDev))]
    	orderedmntsdevs :: [(Maybe String, (MountOpts, LoopDev))]
    orderedmntsdevs = ((Maybe String, (MountOpts, LoopDev))
     -> (Maybe String, (MountOpts, LoopDev)) -> Ordering)
    -> [(Maybe String, (MountOpts, LoopDev))]
    -> [(Maybe String, (MountOpts, LoopDev))]
    forall a. (a -> a -> Ordering) -> [a] -> [a]
    sortBy (Maybe String -> Maybe String -> Ordering
    forall a. Ord a => a -> a -> Ordering
    compare (Maybe String -> Maybe String -> Ordering)
    -> ((Maybe String, (MountOpts, LoopDev)) -> Maybe String)
    -> (Maybe String, (MountOpts, LoopDev))
    -> (Maybe String, (MountOpts, LoopDev))
    -> Ordering
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` (Maybe String, (MountOpts, LoopDev)) -> Maybe String
    forall a b. (a, b) -> a
    fst) ([(Maybe String, (MountOpts, LoopDev))]
     -> [(Maybe String, (MountOpts, LoopDev))])
    -> [(Maybe String, (MountOpts, LoopDev))]
    -> [(Maybe String, (MountOpts, LoopDev))]
    forall a b. (a -> b) -> a -> b
    $ [Maybe String]
    -> [(MountOpts, LoopDev)] -> [(Maybe String, (MountOpts, LoopDev))]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Maybe String]
    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 (String -> SwapPartition
    SwapPartition (String -> SwapPartition)
    -> ((Partition, LoopDev) -> String)
    -> (Partition, LoopDev)
    -> SwapPartition
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . LoopDev -> String
    partitionLoopDev (LoopDev -> String)
    -> ((Partition, LoopDev) -> LoopDev)
    -> (Partition, LoopDev)
    -> String
    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 :: String -> IO ()
    mountall top :: String
    top = [(Maybe String, (MountOpts, LoopDev))]
    -> ((Maybe String, (MountOpts, LoopDev)) -> IO ()) -> IO ()
    forall (t :: * -> *) (m :: * -> *) a b.
    (Foldable t, Monad m) =>
    t a -> (a -> m b) -> m ()
    forM_ [(Maybe String, (MountOpts, LoopDev))]
    orderedmntsdevs (((Maybe String, (MountOpts, LoopDev)) -> IO ()) -> IO ())
    -> ((Maybe String, (MountOpts, LoopDev)) -> IO ()) -> IO ()
    forall a b. (a -> b) -> a -> b
    $ \(mp :: Maybe String
    mp, (mopts :: MountOpts
    mopts, loopdev :: LoopDev
    loopdev)) -> case Maybe String
    mp of
    		Nothing -> IO ()
    forall (m :: * -> *). Monad m => m ()
    noop
    		Just p :: String
    p -> do
    			let mnt :: String
    mnt = String
    top String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    p
    			Bool -> String -> IO ()
    createDirectoryIfMissing Bool
    True String
    mnt
    			IO Bool -> IO () -> IO ()
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
    unlessM (String -> String -> String -> MountOpts -> IO Bool
    mount "auto" (LoopDev -> String
    partitionLoopDev LoopDev
    loopdev) String
    mnt MountOpts
    mopts) (IO () -> IO ()) -> IO () -> IO ()
    forall a b. (a -> b) -> a -> b
    $
    				String -> IO ()
    forall a. HasCallStack => String -> a
    error (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ "failed mounting " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    mnt

    	unmountall :: String -> IO ()
    unmountall top :: String
    top = do
    		String -> IO ()
    unmountBelow String
    top
    		String -> IO ()
    umountLazy String
    top

    	writefstab :: String -> IO ()
    writefstab top :: String
    top = do
    		let fstab :: String
    fstab = String
    top String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ "/etc/fstab"
    		[String]
    old <- [String] -> IO [String] -> IO [String]
    forall (m :: * -> *) a. MonadCatch m => a -> m a -> m a
    catchDefaultIO [] (IO [String] -> IO [String]) -> IO [String] -> IO [String]
    forall a b. (a -> b) -> a -> b
    $ (String -> Bool) -> [String] -> [String]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (String -> Bool) -> String -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Bool
    unconfigured) ([String] -> [String])
    -> (String -> [String]) -> String -> [String]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> [String]
    lines
    			(String -> [String]) -> IO String -> IO [String]
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> IO String
    readFileStrict String
    fstab
    		[String]
    new <- [String] -> [SwapPartition] -> (String -> String) -> IO [String]
    genFstab ((String -> String) -> [String] -> [String]
    forall a b. (a -> b) -> [a] -> [b]
    map (String
    top String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++) ([Maybe String] -> [String]
    forall a. [Maybe a] -> [a]
    catMaybes [Maybe String]
    mnts))
    			[SwapPartition]
    swaps (String -> String -> String
    toSysDir String
    top)
    		String -> String -> IO ()
    writeFile String
    fstab (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ [String] -> String
    unlines ([String] -> String) -> [String] -> String
    forall a b. (a -> b) -> a -> b
    $ [String]
    new [String] -> [String] -> [String]
    forall a. [a] -> [a] -> [a]
    ++ [String]
    old
    	-- Eg "UNCONFIGURED FSTAB FOR BASE SYSTEM"
    	unconfigured :: String -> Bool
    unconfigured s :: String
    s = "UNCONFIGURED" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isInfixOf` String
    s

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

    unbootable :: String -> Finalization
    unbootable :: String -> Finalization
    unbootable msg :: String
    msg = \_ _ _ -> String -> Propellor Result -> Property Linux
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property String
    desc (Propellor Result -> Property Linux)
    -> Propellor Result -> Property Linux
    forall a b. (a -> b) -> a -> b
    $ do
    	String -> Propellor ()
    forall (m :: * -> *). MonadIO m => String -> m ()
    warningMessage (String
    desc String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ ": " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    msg)
    	Result -> Propellor Result
    forall (m :: * -> *) a. Monad m => a -> m a
    return Result
    FailedChange
      where
    	desc :: String
    desc = "image is not bootable"

    grubFinalized :: GrubTarget -> Finalization
    grubFinalized :: GrubTarget -> Finalization
    grubFinalized grubtarget :: GrubTarget
    grubtarget _img :: RawDiskImage
    _img mnt :: String
    mnt loopdevs :: [LoopDev]
    loopdevs =
    	String -> String -> GrubTarget -> Property Linux
    Grub.bootsMounted String
    mnt String
    wholediskloopdev GrubTarget
    grubtarget
    		Property Linux -> String -> Property Linux
    forall p. IsProp p => p -> String -> p
    `describe` "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 :: String
    wholediskloopdev = case [LoopDev]
    loopdevs of
    		(l :: LoopDev
    l:_) -> LoopDev -> String
    wholeDiskLoopDev LoopDev
    l
    		[] -> String -> String
    forall a. HasCallStack => String -> a
    error "No loop devs provided!"

    ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
    ubootFinalized :: (String -> String -> Property Linux) -> Finalization
    ubootFinalized p :: String -> String -> Property Linux
    p (RawDiskImage img :: String
    img) mnt :: String
    mnt _loopdevs :: [LoopDev]
    _loopdevs = String -> String -> Property Linux
    p String
    img String
    mnt

    flashKernelFinalized :: Finalization
    flashKernelFinalized :: Finalization
    flashKernelFinalized _img :: RawDiskImage
    _img mnt :: String
    mnt _loopdevs :: [LoopDev]
    _loopdevs = String -> Property Linux
    FlashKernel.flashKernelMounted String
    mnt

    ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
    ubootFlashKernelFinalized :: (String -> String -> Property Linux) -> Finalization
    ubootFlashKernelFinalized p :: String -> String -> Property Linux
    p img :: RawDiskImage
    img mnt :: String
    mnt loopdevs :: [LoopDev]
    loopdevs =
    	(String -> String -> Property Linux) -> Finalization
    ubootFinalized String -> String -> Property Linux
    p RawDiskImage
    img String
    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 String
    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 = String -> [BootloaderInstalled] -> Property (HasInfo + UnixLike)
    forall v. IsInfo v => String -> v -> Property (HasInfo + UnixLike)
    pureInfoProperty "no bootloader" [BootloaderInstalled
    NoBootloader]

    noBootloaderFinalized :: Finalization
    noBootloaderFinalized :: Finalization
    noBootloaderFinalized _img :: RawDiskImage
    _img _mnt :: String
    _mnt _loopDevs :: [LoopDev]
    _loopDevs = Property Linux
    forall k (t :: k). SingI t => Property (MetaTypes t)
    doNothing

    imageChrootNotPresent :: DiskImage d => d -> Property UnixLike
    imageChrootNotPresent :: d -> Property UnixLike
    imageChrootNotPresent img :: d
    img = IO Bool -> Property UnixLike -> Property UnixLike
    forall (p :: * -> *) i (m :: * -> *).
    (Checkable p i, LiftPropellor m) =>
    m Bool -> p i -> Property i
    check (String -> IO Bool
    doesDirectoryExist String
    dir) (Property UnixLike -> Property UnixLike)
    -> Property UnixLike -> Property UnixLike
    forall a b. (a -> b) -> a -> b
    $
    	String -> Propellor Result -> Property UnixLike
    forall k (metatypes :: k).
    SingI metatypes =>
    String -> Propellor Result -> Property (MetaTypes metatypes)
    property "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
    		String -> IO ()
    removeChroot String
    dir
    		String -> IO ()
    nukeFile (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ d -> String
    forall d. DiskImage d => d -> String
    imageParttableFile d
    img
      where
    	dir :: String
    dir = d -> String
    forall d. DiskImage d => d -> String
    imageChroot d
    img

    imageChroot :: DiskImage d => d -> FilePath
    imageChroot :: d -> String
    imageChroot img :: d
    img = String
    imgfile String -> String -> String
    <.> "chroot"
      where
    	RawDiskImage imgfile :: String
    imgfile = d -> RawDiskImage
    forall d. DiskImage d => d -> RawDiskImage
    rawDiskImage d
    img

    imageParttableFile :: DiskImage d => d -> FilePath
    imageParttableFile :: d -> String
    imageParttableFile img :: d
    img = String
    imgfile String -> String -> String
    <.> "parttable"
      where
    	RawDiskImage imgfile :: String
    imgfile = d -> RawDiskImage
    forall d. DiskImage d => d -> RawDiskImage
    rawDiskImage d
    img

    isChild :: FilePath -> Maybe MountPoint -> Bool
    isChild :: String -> Maybe String -> Bool
    isChild mntpt :: String
    mntpt (Just d :: String
    d)
    	| String
    d String -> String -> Bool
    `equalFilePath` String
    mntpt = Bool
    False
    	| Bool
    otherwise = String
    mntpt String -> String -> Bool
    `dirContains` String
    d
    isChild _ 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 :: String -> String -> String
    toSysDir chrootdir :: String
    chrootdir d :: String
    d = case String -> String -> String
    makeRelative String
    chrootdir String
    d of
    		"." -> "/"
    		sysdir :: String
    sysdir -> "/" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    sysdir