{-# LANGUAGE TypeFamilies #-}
module Propellor.Property.DiskImage (
module Propellor.Property.DiskImage.PartSpec,
DiskImage(..),
RawDiskImage(..),
VirtualBoxPointer(..),
imageBuilt,
imageRebuilt,
imageBuiltFor,
imageRebuiltFor,
imageBuiltFrom,
imageExists,
imageChrootNotPresent,
GrubTarget(..),
noBootloader,
) where
import Propellor.Base
import Propellor.Property.DiskImage.PartSpec
import Propellor.Property.Chroot (Chroot)
import Propellor.Property.Chroot.Util (removeChroot)
import Propellor.Property.Mount
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Service as Service
import qualified Propellor.Property.Grub as Grub
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.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
class DiskImage d where
rawDiskImage :: d -> RawDiskImage
describeDiskImage :: d -> String
buildDiskImage :: d -> RevertableProperty DebianLike Linux
newtype RawDiskImage = RawDiskImage FilePath
instance DiskImage RawDiskImage where
rawDiskImage :: RawDiskImage -> RawDiskImage
rawDiskImage = RawDiskImage -> RawDiskImage
forall a. a -> a
id
describeDiskImage :: RawDiskImage -> String
describeDiskImage (RawDiskImage String
f) = String
f
buildDiskImage :: RawDiskImage -> RevertableProperty DebianLike Linux
buildDiskImage (RawDiskImage String
_) = Property DebianLike
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing Property DebianLike
-> Property Linux -> RevertableProperty DebianLike Linux
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> Property Linux
forall k (t :: k). SingI t => Property (MetaTypes t)
doNothing
newtype VirtualBoxPointer = VirtualBoxPointer FilePath
instance DiskImage VirtualBoxPointer where
rawDiskImage :: VirtualBoxPointer -> RawDiskImage
rawDiskImage (VirtualBoxPointer 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]
++ String
".img"
describeDiskImage :: VirtualBoxPointer -> String
describeDiskImage (VirtualBoxPointer String
f) = String
f
buildDiskImage :: VirtualBoxPointer -> RevertableProperty DebianLike Linux
buildDiskImage (VirtualBoxPointer 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]
++ String
" built")
where
setup :: CombinedType (Property DebianLike) (Property UnixLike)
setup = String -> [String] -> UncheckedProperty UnixLike
cmdProperty String
"VBoxManage"
[ String
"internalcommands", String
"createrawvmdk"
, String
"-filename", String
vmdkfile
, String
"-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 [String
"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 String
diskimage = VirtualBoxPointer -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage (String -> VirtualBoxPointer
VirtualBoxPointer String
vmdkfile)
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
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
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
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' Bool
rebuild Host
h d
d 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 TableType
tt [PartSpec ()]
pil = PartInfo -> PartTableSpec
toPartTableSpec (Info -> PartInfo
forall v. IsInfo v => Info -> v
fromInfo (Host -> Info
hostInfo Host
h))
imageBuilt' :: DiskImage d => Bool -> d -> (FilePath -> Chroot) -> TableType -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' :: Bool
-> d
-> (String -> Chroot)
-> TableType
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuilt' Bool
rebuild d
img String -> Chroot
mkchroot TableType
tabletype [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 = String
"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, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Chroot
forall c metatypes. IsContainer c => c -> Props metatypes -> c
setContainerProps Chroot
c (Props
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Chroot)
-> Props
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
-> Chroot
forall a b. (a -> b) -> a -> b
$ Chroot -> Props UnixLike
forall c. IsContainer c => c -> Props UnixLike
containerProps Chroot
c
Props UnixLike
-> RevertableProperty
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
UnixLike
-> Props
(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
(MetaTypes
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux, 'Targeting 'OSFreeBSD])
UnixLike
RevertableProperty (HasInfo + UnixLike) UnixLike
Service.noServices
Props
(MetaTypes
'[ '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
propprivdataonly :: Chroot -> Chroot
propprivdataonly (Chroot.Chroot String
d b
b InfoPropagator
ip Host
h) =
String -> b -> InfoPropagator -> Host -> Chroot
forall b.
ChrootBootstrapper b =>
String -> b -> InfoPropagator -> Host -> Chroot
Chroot.Chroot String
d b
b (\Chroot
c PropagateInfo -> Bool
_ -> InfoPropagator
ip Chroot
c PropagateInfo -> Bool
onlyPrivData) Host
h
final :: Finalization
final = case Info -> [BootloaderInstalled]
forall v. IsInfo v => Info -> v
fromInfo (Chroot -> Info
forall c. IsContainer c => c -> Info
containerInfo Chroot
chroot) of
[] -> String -> Finalization
unbootable String
"no bootloader is installed"
[GrubInstalled GrubTarget
grubtarget] -> GrubTarget -> Finalization
grubFinalized GrubTarget
grubtarget
[UbootInstalled String -> String -> Property Linux
p] -> (String -> String -> Property Linux) -> Finalization
ubootFinalized String -> String -> Property Linux
p
[BootloaderInstalled
FlashKernelInstalled] -> Finalization
flashKernelFinalized
[UbootInstalled String -> String -> Property Linux
p, BootloaderInstalled
FlashKernelInstalled] ->
(String -> String -> Property Linux) -> Finalization
ubootFlashKernelFinalized String -> String -> Property Linux
p
[BootloaderInstalled
FlashKernelInstalled, UbootInstalled String -> String -> Property Linux
p] ->
(String -> String -> Property Linux) -> Finalization
ubootFlashKernelFinalized String -> String -> Property Linux
p
[BootloaderInstalled
NoBootloader] -> Finalization
noBootloaderFinalized
[BootloaderInstalled]
_ -> String -> Finalization
unbootable String
"multiple bootloaders are installed; don't know which to use"
cachesCleaned :: Property UnixLike
cachesCleaned :: Property UnixLike
cachesCleaned = String
"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
imageBuiltFrom :: DiskImage d => d -> FilePath -> TableType -> Finalization -> [PartSpec ()] -> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom :: d
-> String
-> TableType
-> Finalization
-> [PartSpec ()]
-> RevertableProperty (HasInfo + DebianLike) Linux
imageBuiltFrom d
img String
chrootdir TableType
tabletype Finalization
final [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]
++ String
" built from " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
chrootdir
dest :: RawDiskImage
dest@(RawDiskImage 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
$ \OuterMetaTypesWitness
'[ 'WithInfo, 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w -> 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 ()
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 [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
let ([Maybe String]
mnts, [MountOpts]
mntopts, 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' [Maybe String]
mnts [MountOpts]
mntopts PartTable
parttable [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 String
chrootdir [Maybe String]
mnts [MountOpts]
mntopts [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
$ \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 = String
"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 OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
_ Maybe String
Nothing MountOpts
_ LoopDev
_ = Propellor Result
noChange
go OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish]
w (Just String
mnt) MountOpts
mntopt LoopDev
loopdev = Propellor Bool
-> (Propellor Result, Propellor Result) -> Propellor Result
forall (m :: * -> *) a. Monad m => m Bool -> (m a, m a) -> m a
ifM (IO Bool -> Propellor Bool
forall (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 String
"mnt" ((String -> Propellor Result) -> Propellor Result)
-> (String -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \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 String
"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
$ \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 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 (\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 (\String
m ->
[ Pattern -> Filter
Include (String -> Pattern
Pattern String
m)
, Pattern -> Filter
Exclude (String -> Pattern
filesUnder String
m)
, Pattern -> Filter
Protect (String -> Pattern
Pattern String
"lost+found")
]) [String]
childmnts
fitChrootSize :: TableType -> [PartSpec ()] -> [PartSize] -> ([Maybe MountPoint], [MountOpts], PartTable)
fitChrootSize :: TableType
-> [PartSpec ()]
-> [PartSize]
-> ([Maybe String], [MountOpts], PartTable)
fitChrootSize TableType
tt [PartSpec ()]
l [PartSize]
basesizes = ([Maybe String]
mounts, [MountOpts]
mountopts, PartTable
parttable)
where
([Maybe String]
mounts, [MountOpts]
mountopts, [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)
dirSizes :: FilePath -> IO (M.Map FilePath Integer)
dirSizes :: String -> IO (Map String ByteSize)
dirSizes 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 Map String a
m String
_ [] = Map String a -> IO (Map String a)
forall (m :: * -> *) a. Monad m => a -> m a
return Map String a
m
go Map String a
m String
dir (String
i:[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 (\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 String
parent 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 Map String PartSize
_ [Maybe String]
_ Maybe String
Nothing = Maybe PartSize
forall a. Maybe a
Nothing
getMountSz Map String PartSize
szm [Maybe String]
l (Just 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)
imageExists :: RawDiskImage -> ByteSize -> Property Linux
imageExists :: RawDiskImage -> ByteSize -> Property Linux
imageExists (RawDiskImage String
img) ByteSize
isz = String -> Propellor Result -> Property Linux
forall k (metatypes :: k).
SingI metatypes =>
String -> Propellor Result -> Property (MetaTypes metatypes)
property (String
"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 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 [String
"truncating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
img String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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 [String
"expanding " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
img String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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]
++ String
" 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) Word8
0)
Result -> IO Result
forall (m :: * -> *) a. Monad m => a -> m a
return Result
MadeChange
Maybe ByteSize
Nothing -> do
[String] -> IO ()
forall (m :: * -> *). MonadIO m => [String] -> m ()
infoMessage [String
"creating " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
img String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" 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) Word8
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)
sectorsize :: Double
sectorsize = Double
4096 :: Double
imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' :: RawDiskImage -> PartTable -> RevertableProperty DebianLike UnixLike
imageExists' dest :: RawDiskImage
dest@(RawDiskImage String
img) PartTable
parttable = (Property DebianLike
setup Property DebianLike
-> Property UnixLike -> RevertableProperty DebianLike UnixLike
forall setupmetatypes undometatypes.
Property setupmetatypes
-> Property undometatypes
-> RevertableProperty setupmetatypes undometatypes
<!> CombinedType (Property UnixLike) (Property UnixLike)
Property UnixLike
cleanup) RevertableProperty DebianLike UnixLike
-> String -> RevertableProperty DebianLike UnixLike
forall p. IsProp p => p -> String -> p
`describe` String
desc
where
desc :: String
desc = String
"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
$ \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 String
"" (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
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 Finalization
final RawDiskImage
img [Maybe String]
mnts [MountOpts]
mntopts [LoopDev]
devs (PartTable TableType
_ Alignment
_ [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' String
"disk image finalized" ((OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property Linux)
-> (OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
-> Propellor Result)
-> Property Linux
forall a b. (a -> b) -> a -> b
$ \OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w ->
String -> (String -> Propellor Result) -> Propellor Result
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
String -> (String -> m a) -> m a
withTmpDir String
"mnt" ((String -> Propellor Result) -> Propellor Result)
-> (String -> Propellor Result) -> Propellor Result
forall a b. (a -> b) -> a -> b
$ \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 OuterMetaTypesWitness
'[ 'Targeting 'OSDebian, 'Targeting 'OSBuntish,
'Targeting 'OSArchLinux]
w 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
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 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
$ \(Maybe String
mp, (MountOpts
mopts, LoopDev
loopdev)) -> case Maybe String
mp of
Maybe String
Nothing -> IO ()
forall (m :: * -> *). Monad m => m ()
noop
Just 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 String
"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
$ String
"failed mounting " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
mnt
unmountall :: String -> IO ()
unmountall String
top = do
String -> IO ()
unmountBelow String
top
String -> IO ()
umountLazy String
top
writefstab :: String -> IO ()
writefstab String
top = do
let fstab :: String
fstab = String
top String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/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
unconfigured :: String -> Bool
unconfigured String
s = String
"UNCONFIGURED" String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` String
s
allowservices :: String -> IO ()
allowservices String
top = String -> IO ()
nukeFile (String
top String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"/usr/sbin/policy-rc.d")
unbootable :: String -> Finalization
unbootable :: String -> Finalization
unbootable String
msg = \RawDiskImage
_ String
_ [LoopDev]
_ -> 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 -> 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 = String
"image is not bootable"
grubFinalized :: GrubTarget -> Finalization
grubFinalized :: GrubTarget -> Finalization
grubFinalized GrubTarget
grubtarget RawDiskImage
_img String
mnt [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` String
"disk image boots using grub"
where
wholediskloopdev :: String
wholediskloopdev = case [LoopDev]
loopdevs of
(LoopDev
l:[LoopDev]
_) -> LoopDev -> String
wholeDiskLoopDev LoopDev
l
[] -> String -> String
forall a. HasCallStack => String -> a
error String
"No loop devs provided!"
ubootFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
ubootFinalized :: (String -> String -> Property Linux) -> Finalization
ubootFinalized String -> String -> Property Linux
p (RawDiskImage String
img) String
mnt [LoopDev]
_loopdevs = String -> String -> Property Linux
p String
img String
mnt
flashKernelFinalized :: Finalization
flashKernelFinalized :: Finalization
flashKernelFinalized RawDiskImage
_img String
mnt [LoopDev]
_loopdevs = String -> Property Linux
FlashKernel.flashKernelMounted String
mnt
ubootFlashKernelFinalized :: (FilePath -> FilePath -> Property Linux) -> Finalization
ubootFlashKernelFinalized :: (String -> String -> Property Linux) -> Finalization
ubootFlashKernelFinalized String -> String -> Property Linux
p RawDiskImage
img String
mnt [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
noBootloader :: Property (HasInfo + UnixLike)
noBootloader :: Property (HasInfo + UnixLike)
noBootloader = String -> [BootloaderInstalled] -> Property (HasInfo + UnixLike)
forall v. IsInfo v => String -> v -> Property (HasInfo + UnixLike)
pureInfoProperty String
"no bootloader" [BootloaderInstalled
NoBootloader]
noBootloaderFinalized :: Finalization
noBootloaderFinalized :: Finalization
noBootloaderFinalized RawDiskImage
_img String
_mnt [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 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 String
"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 d
img = String
imgfile String -> String -> String
<.> String
"chroot"
where
RawDiskImage String
imgfile = d -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage d
img
imageParttableFile :: DiskImage d => d -> FilePath
imageParttableFile :: d -> String
imageParttableFile d
img = String
imgfile String -> String -> String
<.> String
"parttable"
where
RawDiskImage String
imgfile = d -> RawDiskImage
forall d. DiskImage d => d -> RawDiskImage
rawDiskImage d
img
isChild :: FilePath -> Maybe MountPoint -> Bool
isChild :: String -> Maybe String -> Bool
isChild String
mntpt (Just String
d)
| String
d String -> String -> Bool
`equalFilePath` String
mntpt = Bool
False
| Bool
otherwise = String
mntpt String -> String -> Bool
`dirContains` String
d
isChild String
_ Maybe String
Nothing = Bool
False
toSysDir :: FilePath -> FilePath -> FilePath
toSysDir :: String -> String -> String
toSysDir String
chrootdir String
d = case String -> String -> String
makeRelative String
chrootdir String
d of
String
"." -> String
"/"
String
sysdir -> String
"/" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
sysdir