Debootstrap.built now supports bootstrapping chroots for foreign OS's

This commit was sponsored by Ethan Aubin.

2 files changed, 81 insertions, 3 deletions

diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index a9412b95..7c8e9618 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeFamilies #-}
+
 module Propellor.Property.Debootstrap (
 	Url,
 	DebootstrapConfig(..),
@@ -6,12 +8,12 @@ module Propellor.Property.Debootstrap (
 	extractSuite,
 	installed,
 	sourceInstall,
-	programPath,
 ) where
 
 import Propellor.Base
 import qualified Propellor.Property.Apt as Apt
 import Propellor.Property.Chroot.Util
+import Propellor.Property.Qemu
 import Utility.Path
 import Utility.FileMode
 
@@ -29,6 +31,7 @@ data DebootstrapConfig
 	| MinBase
 	| BuilddD
 	| DebootstrapParam String
+	| UseEmulation
 	| DebootstrapConfig :+ DebootstrapConfig
 	deriving (Show)
 
@@ -41,15 +44,41 @@ toParams DefaultConfig = []
 toParams MinBase = [Param "--variant=minbase"]
 toParams BuilddD = [Param "--variant=buildd"]
 toParams (DebootstrapParam p) = [Param p]
+toParams UseEmulation = []
 toParams (c1 :+ c2) = toParams c1 <> toParams c2
 
+useEmulation :: DebootstrapConfig -> Bool
+useEmulation UseEmulation = True
+useEmulation (a :+ b) = useEmulation a || useEmulation b
+useEmulation _ = False
+
 -- | Builds a chroot in the given directory using debootstrap.
 --
 -- The System can be any OS and architecture that debootstrap
 -- and the kernel support.
+--
+-- When the System is architecture that the kernel does not support,
+-- it can still be bootstrapped using emulation. This is determined
+-- by checking `supportsArch`, or can be configured with `UseEmulation`.
+--
+-- When emulation is used, the chroot will have an additional binary 
+-- installed in it. To get a completelty clean chroot (eg for producing a
+-- bootable disk image), use the `removeHostEmulationBinary` property.
 built :: FilePath -> System -> DebootstrapConfig -> Property Linux
-built target system config = built' (setupRevertableProperty installed) target system config
+built target system@(System _ targetarch) config =
+	withOS ("debootstrapped " ++ target) go
+  where
+	go w (Just hostos)
+		| supportsArch hostos targetarch && not (useEmulation config) =
+			ensureProperty w $
+				built' (setupRevertableProperty installed)
+					target system config
+	go w _ = ensureProperty w $ do
+		let p = setupRevertableProperty foreignBinariesEmulated
+			`before` setupRevertableProperty installed
+		built' p target system (config :+ UseEmulation)
 
+-- | Like `built`,  but uses the provided Property to install debootstrap.
 built' :: Property Linux -> FilePath -> System -> DebootstrapConfig -> Property Linux
 built' installprop target system@(System _ arch) config = 
 	go `before` oldpermfix
@@ -68,7 +97,9 @@ built' installprop target system@(System _ arch) config =
 			, Param suite
 			, Param target
 			]
-		cmd <- fromMaybe "debootstrap" <$> programPath
+		cmd <- if useEmulation config
+			then pure "qemu-debootstrap"
+			else fromMaybe "debootstrap" <$> programPath
 		de <- standardPathEnv
 		ifM (boolSystemEnv cmd params (Just de))
 			( return MadeChange
diff --git a/src/Propellor/Property/Qemu.hs b/src/Propellor/Property/Qemu.hs
new file mode 100644
index 00000000..4d9e8b1f
--- /dev/null
+++ b/src/Propellor/Property/Qemu.hs
@@ -0,0 +1,47 @@
+module Propellor.Property.Qemu where
+
+import Propellor.Base
+import qualified Propellor.Property.Apt as Apt
+
+-- | Installs qemu user mode emulation binaries, built statically,
+-- which allow foreign binaries to run directly.
+foreignBinariesEmulated :: RevertableProperty Linux Linux
+foreignBinariesEmulated = (setup <!> cleanup)
+	`describe` "foreign binary emulation"
+  where
+	setup = Apt.installed p `pickOS` unsupportedOS
+	cleanup = Apt.removed p `pickOS` unsupportedOS
+	p = ["qemu-user-static"]
+
+-- | Removes qemu user mode emulation binary for the host CPU.
+-- This binary is copied into a chroot by qemu-debootstrap, and is not
+-- part of any package.
+--
+-- Note that removing the binary will prevent using the chroot on the host
+-- system.
+removeHostEmulationBinary :: Property DebianLike
+removeHostEmulationBinary = tightenTargets $ 
+	scriptProperty ["rm -f /usr/bin/qemu-*-static"]
+		`assume` MadeChange
+
+-- | Check if the given System supports an Architecture.
+--
+-- For example, on Debian, X86_64 supports X86_32, and vice-versa.
+supportsArch :: System -> Architecture -> Bool
+supportsArch (System os a) b
+	| a == b = True
+	| otherwise = case os of
+		Debian _ _ -> debianlike
+		Buntish _ -> debianlike
+		-- don't know about other OS's
+		_ -> False
+  where
+	debianlike =
+		let l = 
+			[ (X86_64, X86_32)
+			, (ARMHF, ARMEL)
+			, (PPC, PPC64)
+			, (SPARC, SPARC64)
+			, (S390, S390X)
+			]
+		in elem (a, b) l || elem (b, a) l