diff options
| -rw-r--r-- | debian/changelog | 3 | ||||
| -rw-r--r-- | propellor.cabal | 1 | ||||
| -rw-r--r-- | src/Propellor/Property/Debootstrap.hs | 37 | ||||
| -rw-r--r-- | src/Propellor/Property/Qemu.hs | 47 |
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 |