summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Debootstrap.hs
diff options
context:
space:
mode:
authorJoey Hess2017-11-16 14:17:33 -0400
committerJoey Hess2017-11-16 14:34:07 -0400
commit22bad99dc00df153aaefe3b5445116b142294504 (patch)
tree8594a4bd5c932de212395889922803f3fa0c8f04 /src/Propellor/Property/Debootstrap.hs
parent5ff40b7d8501f3f7a537a049a2d0cdd14ff7b226 (diff)
Debootstrap.built now supports bootstrapping chroots for foreign OS's
This commit was sponsored by Ethan Aubin.
Diffstat (limited to 'src/Propellor/Property/Debootstrap.hs')
-rw-r--r--src/Propellor/Property/Debootstrap.hs37
1 files changed, 34 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