summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
authorSean Whitton2019-11-12 14:55:42 -0700
committerJoey Hess2019-11-13 10:17:55 -0400
commit0ce27912fb2371590e6a1c44f76f51f408d9b79f (patch)
tree52fd6b5651b8a3f2c61c0be7d4a1a2eaef71f698 /src/Propellor/Property
parenta85d01661501b16da6bf97e543ce88e4f4f1fd77 (diff)
Chroot.debootstrapped: respect chroot's Apt.proxy and Apt.mirror
Closes: https://propellor.branchable.com/todo/Debootstrap_module_should_respect_a_configured_Apt.proxy/ Signed-off-by: Sean Whitton <spwhitton@spwhitton.name>
Diffstat (limited to 'src/Propellor/Property')
-rw-r--r--src/Propellor/Property/Chroot.hs26
-rw-r--r--src/Propellor/Property/Debootstrap.hs22
2 files changed, 45 insertions, 3 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 5be39bd6..ddb7f884 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -26,6 +26,7 @@ import Propellor.Types.Container
import Propellor.Types.Info
import Propellor.Types.Core
import Propellor.Property.Chroot.Util
+import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
import qualified Propellor.Property.File as File
@@ -102,8 +103,22 @@ instance ChrootBootstrapper Debootstrapped where
(Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap."
Nothing -> Left "Cannot debootstrap; OS not specified"
where
- debootstrap s = Debootstrap.built loc s cf
+ debootstrap s = Debootstrap.built loc s
+ (cf <> proxyConf <> mirrorConf)
system = fromInfoVal (fromInfo info)
+ -- If the chroot has a configured apt proxy and/or mirror, pass
+ -- these on to debootstrap. Note that Debootstrap.built does
+ -- not get passed the Chroot, so the info inspection has to
+ -- happen here, not there
+ proxyConf = case (fromInfoVal . fromInfo) info of
+ Just (Apt.HostAptProxy u) ->
+ Debootstrap.DebootstrapProxy u
+ Nothing -> mempty
+ mirrorConf = case (fromInfoVal . fromInfo) info of
+ Just (Apt.HostMirror u) ->
+ Debootstrap.DebootstrapMirror u
+ Nothing -> mempty
+
-- | Defines a Chroot at the given location, built with debootstrap.
--
@@ -111,6 +126,11 @@ instance ChrootBootstrapper Debootstrapped where
-- add a property such as `osDebian` to specify the operating system
-- to bootstrap.
--
+-- If @conf@ does not include a 'DebootstrapProxy' entry, and the Chroot has a
+-- defined 'Apt.proxy', then the Chroot's apt proxy will be used by debootstrap
+-- in creating the Chroot, too. Similarly if the @conf@ does not include a
+-- 'DebootstrapMirror' and the Chroot has a defined 'Apt.mirror'.
+--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
-- > & osDebian Unstable X86_64
-- > & Apt.installed ["ghc", "haskell-platform"]
@@ -120,6 +140,10 @@ debootstrapped conf = bootstrapped (Debootstrapped conf)
-- | Defines a Chroot at the given location, bootstrapped with the
-- specified ChrootBootstrapper.
+--
+-- Like 'Chroot.debootstrapped', if the ChrootBootstrapper is Debootstrap, this
+-- property respects the Chroot's configured Apt.proxy and Apt.mirror, if either
+-- exists.
bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
bootstrapped bootstrapper location ps = c
where
diff --git a/src/Propellor/Property/Debootstrap.hs b/src/Propellor/Property/Debootstrap.hs
index 6336e775..adf0879b 100644
--- a/src/Propellor/Property/Debootstrap.hs
+++ b/src/Propellor/Property/Debootstrap.hs
@@ -32,6 +32,8 @@ data DebootstrapConfig
| BuilddD
| DebootstrapParam String
| UseEmulation
+ | DebootstrapProxy Url
+ | DebootstrapMirror Url
| DebootstrapConfig :+ DebootstrapConfig
deriving (Show)
@@ -48,6 +50,8 @@ toParams MinBase = [Param "--variant=minbase"]
toParams BuilddD = [Param "--variant=buildd"]
toParams (DebootstrapParam p) = [Param p]
toParams UseEmulation = []
+toParams (DebootstrapProxy _) = []
+toParams (DebootstrapMirror _) = []
toParams (c1 :+ c2) = toParams c1 <> toParams c2
useEmulation :: DebootstrapConfig -> Bool
@@ -55,6 +59,16 @@ useEmulation UseEmulation = True
useEmulation (a :+ b) = useEmulation a || useEmulation b
useEmulation _ = False
+debootstrapProxy :: DebootstrapConfig -> Maybe Url
+debootstrapProxy (DebootstrapProxy u) = Just u
+debootstrapProxy (a :+ b) = debootstrapProxy a <|> debootstrapProxy b
+debootstrapProxy _ = Nothing
+
+debootstrapMirror :: DebootstrapConfig -> Maybe Url
+debootstrapMirror (DebootstrapMirror u) = Just u
+debootstrapMirror (a :+ b) = debootstrapMirror a <|> debootstrapMirror b
+debootstrapMirror _ = Nothing
+
-- | Builds a chroot in the given directory using debootstrap.
--
-- The System can be any OS and architecture that debootstrap
@@ -99,11 +113,15 @@ built' installprop target system@(System _ arch) config =
[ Param $ "--arch=" ++ architectureToDebianArchString arch
, Param suite
, Param target
- ]
+ ] ++ case debootstrapMirror config of
+ Just u -> [Param u]
+ Nothing -> []
cmd <- if useEmulation config
then pure "qemu-debootstrap"
else fromMaybe "debootstrap" <$> programPath
- de <- standardPathEnv
+ de <- case debootstrapProxy config of
+ Just u -> addEntry "http_proxy" u <$> standardPathEnv
+ Nothing -> standardPathEnv
ifM (boolSystemEnv cmd params (Just de))
( return MadeChange
, return FailedChange