summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog3
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Property/Debootstrap.hs37
-rw-r--r--src/Propellor/Property/Qemu.hs47
4 files changed, 85 insertions, 3 deletions
diff --git a/debian/changelog b/debian/changelog
index e753130d..a0290cf4 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -7,6 +7,9 @@ propellor (4.9.1) UNRELEASED; urgency=medium
Thanks, Félix Sipma.
* Fail2Ban: Renamed jail.d conf file to use .local.
Thanks, Félix Sipma.
+ * Debootstrap.built now supports bootstrapping chroots for foreign
+ OS's, using qemu-user-static.
+ * Qemu: New module.
-- Joey Hess <id@joeyh.name> Thu, 02 Nov 2017 10:28:44 -0400
diff --git a/propellor.cabal b/propellor.cabal
index ed9f6bf1..ec3dec32 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -141,6 +141,7 @@ Library
Propellor.Property.Postfix
Propellor.Property.PropellorRepo
Propellor.Property.Prosody
+ Propellor.Property.Qemu
Propellor.Property.Reboot
Propellor.Property.Restic
Propellor.Property.Rsync
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