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: <<loop>>" message to be output instead of such a
property using infinite disk space.

This commit was sponsored by Bruno BEAUFILS on Patreon.

1 files changed, 21 insertions, 0 deletions

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