From 8a7efe723e4de97065424d1e2396fe0ce5144f56 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 11 Mar 2017 16:08:53 -0400 Subject: Implemented hostChroot As originally seen in my slides at Linux.Conf.Au 2017 in January. Now that it's not vaporware, it allows one Host to build a disk image that has all the properties of another Host. It was easier than I thought to implement this! As expected, Info propagation was slightly tricky. Also, I originally had a lot of machinery to try to use Info to detect infinitely nested chroot loops. But, my machinery didn't work, and when I tested it, ghc did a much better job, causing a "warning: <>" message to be output instead of such a property using infinite disk space. This commit was sponsored by Bruno BEAUFILS on Patreon. --- debian/changelog | 4 ++++ src/Propellor/Property/Chroot.hs | 21 +++++++++++++++++ src/Propellor/Property/DiskImage.hs | 46 ++++++++++++++++++++++++++----------- 3 files changed, 58 insertions(+), 13 deletions(-) diff --git a/debian/changelog b/debian/changelog index 07027273..2791e714 100644 --- a/debian/changelog +++ b/debian/changelog @@ -10,6 +10,10 @@ propellor (3.5.0) UNRELEASED; urgency=medium propellor any longer. * Changed Chroot data type to include Info propigation. (API change) + * Implemented hostChroot, as originally seen in my slides at + Linux.Conf.Au 2017 in January. Now that it's not vaporware, it allows + one Host to build a disk image that has all the properties of another + Host. -- Joey Hess Wed, 08 Mar 2017 14:02:10 -0400 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 9624a0f3..4b9b48e1 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -1,9 +1,11 @@ {-# LANGUAGE FlexibleContexts, GADTs, DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Propellor.Property.Chroot ( debootstrapped, bootstrapped, provisioned, + hostChroot, Chroot(..), ChrootBootstrapper(..), Debootstrapped(..), @@ -290,3 +292,22 @@ setInChroot h = h { hostInfo = hostInfo h `addInfo` InfoVal (InChroot True) } newtype InChroot = InChroot Bool deriving (Typeable, Show) + +-- | Generates a Chroot that has all the properties of a Host. +-- +-- Note that it's possible to create loops using this, where a host +-- contains a Chroot containing itself etc. Such loops will be detected at +-- runtime. +hostChroot :: ChrootBootstrapper bootstrapper => Host -> bootstrapper -> FilePath -> Chroot +hostChroot h bootstrapper d = chroot + where + chroot = Chroot d bootstrapper pinfo h + pinfo = propagateHostChrootInfo h chroot + +-- This is different than propagateChrootInfo in that Info using +-- HostContext is not made to use the name of the chroot as its context, +-- but instead uses the hostname of the Host. +propagateHostChrootInfo :: Host -> Chroot -> InfoPropagator +propagateHostChrootInfo h c p = + propagateContainer (hostName h) c $ + p `setInfoProperty` chrootInfo c diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs index 64ab8bd5..c7868c47 100644 --- a/src/Propellor/Property/DiskImage.hs +++ b/src/Propellor/Property/DiskImage.hs @@ -63,19 +63,20 @@ type DiskImage = FilePath -- Example use: -- -- > import Propellor.Property.DiskImage +-- > import Propellor.Property.Chroot -- > --- > ... --- > & imageBuilt "/srv/images/foo.img" mychroot --- > MSDOS (grubBooted PC) --- > [ partition EXT2 `mountedAt` "/boot" --- > `setFlag` BootFlag --- > , partition EXT4 `mountedAt` "/" --- > `addFreeSpace` MegaBytes 100 --- > `mountOpt` errorReadonly --- > , swapPartition (MegaBytes 256) --- > ] --- > where --- > mychroot d = Chroot.debootstrapped mempty d $ props +-- > foo = host "foo.example.com" $ props +-- > & imageBuilt "/srv/diskimages/disk.img" mychroot +-- > MSDOS (grubBooted PC) +-- > [ 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"] -- > & User.hasPassword (User "root") @@ -84,7 +85,26 @@ type DiskImage = FilePath -- > & User.hasDesktopGroups (User "demo") -- > & ... -- --- +-- This can also be used with `Chroot.hostChroot` to build a disk image +-- that has all the properties of a Host. For example: +-- +-- > foo :: Host +-- > foo = host "foo.example.com" $ props +-- > & imageBuilt "/srv/diskimages/bar-disk.img" +-- > (hostChroot bar (Debootstrapped mempty)) +-- > MSDOS (grubBooted PC) +-- > [ partition EXT2 `mountedAt` "/boot" +-- > `setFlag` BootFlag +-- > , partition EXT4 `mountedAt` "/" +-- > `addFreeSpace` MegaBytes 5000 +-- > , swapPartition (MegaBytes 256) +-- > ] +-- > +-- > bar :: Host +-- > bar = host "bar.example.com" $ props +-- > & osDebian Unstable X86_64 +-- > & Apt.installed ["linux-image-amd64"] +-- > & hasPassword (User "root") imageBuilt :: DiskImage -> (FilePath -> Chroot) -> TableType -> Finalization -> [PartSpec] -> RevertableProperty (HasInfo + DebianLike) Linux imageBuilt = imageBuilt' False -- cgit v1.2.3