summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Property/Chroot.hs52
-rw-r--r--src/Propellor/Property/Debootstrap.hs22
-rw-r--r--src/Propellor/Property/Sbuild.hs17
-rw-r--r--src/Propellor/Types/Core.hs3
-rw-r--r--src/Propellor/Types/Info.hs1
5 files changed, 73 insertions, 22 deletions
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 48d96dcf..13511902 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -10,6 +10,7 @@ module Propellor.Property.Chroot (
Debootstrapped(..),
ChrootTarball(..),
exposeTrueLocaldir,
+ useHostProxy,
-- * Internal use
provisioned',
propagateChrootInfo,
@@ -26,6 +27,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
@@ -60,7 +62,11 @@ class ChrootBootstrapper b where
-- | Do initial bootstrapping of an operating system in a chroot.
-- If the operating System is not supported, return
-- Left error message.
- buildchroot :: b -> Maybe System -> FilePath -> Either String (Property Linux)
+ buildchroot
+ :: b
+ -> Info -- ^ info of the Properties of the chroot
+ -> FilePath -- ^ where to bootstrap the chroot
+ -> Either String (Property Linux)
-- | Use this to bootstrap a chroot by extracting a tarball.
--
@@ -91,14 +97,28 @@ extractTarball target src = check (isUnpopulated target) $
data Debootstrapped = Debootstrapped Debootstrap.DebootstrapConfig
instance ChrootBootstrapper Debootstrapped where
- buildchroot (Debootstrapped cf) system loc = case system of
+ buildchroot (Debootstrapped cf) info loc = case system of
(Just s@(System (Debian _ _) _)) -> Right $ debootstrap s
(Just s@(System (Buntish _) _)) -> Right $ debootstrap s
(Just (System ArchLinux _)) -> Left "Arch Linux not supported by debootstrap."
(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.
--
@@ -106,6 +126,11 @@ instance ChrootBootstrapper Debootstrapped where
-- add a property such as `osDebian` to specify the operating system
-- to bootstrap.
--
+-- If the 'Debootstrap.DebootstrapConfig' does not include a
+-- 'Debootstrap.DebootstrapMirror',
+-- any 'Apt.mirror' property of the chroot will configure debootstrap.
+-- Same for 'Debootstrap.DebootstrapProxy' and 'Apt.proxy'.
+--
-- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" $ props
-- > & osDebian Unstable X86_64
-- > & Apt.installed ["ghc", "haskell-platform"]
@@ -115,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
+-- 'Debootstrapped', this property respects the Chroot's
+-- 'Apt.proxy' and 'Apt.mirror' properties.
bootstrapped :: ChrootBootstrapper b => b -> FilePath -> Props metatypes -> Chroot
bootstrapped bootstrapper location ps = c
where
@@ -143,7 +172,7 @@ provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly caps =
setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly caps
`requires` built
- built = case buildchroot bootstrapper (chrootSystem c) loc of
+ built = case buildchroot bootstrapper (containerInfo c) loc of
Right p -> p
Left e -> cantbuild e
@@ -304,3 +333,18 @@ propagateHostChrootInfo :: Host -> InfoPropagator
propagateHostChrootInfo h c pinfo p =
propagateContainer (hostName h) c pinfo $
p `setInfoProperty` chrootInfo c
+
+-- | Ensure that a chroot uses the host's Apt proxy.
+--
+-- This property is often used for 'Sbuild.built' chroots, when the host has
+-- 'Apt.useLocalCacher'.
+useHostProxy :: Host -> Property DebianLike
+useHostProxy h = property' "use host's apt proxy" $ \w ->
+ -- Note that we can't look at getProxyInfo outside the property,
+ -- as that would loop, but it's ok to look at it inside the
+ -- property. Thus the slightly strange construction here.
+ case getProxyInfo h of
+ Just (Apt.HostAptProxy u) -> ensureProperty w (Apt.proxy' u)
+ Nothing -> noChange
+ where
+ getProxyInfo = fromInfoVal . fromInfo . hostInfo
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
diff --git a/src/Propellor/Property/Sbuild.hs b/src/Propellor/Property/Sbuild.hs
index 1562f80e..3242014d 100644
--- a/src/Propellor/Property/Sbuild.hs
+++ b/src/Propellor/Property/Sbuild.hs
@@ -31,7 +31,7 @@ Suggested usage in @config.hs@:
> & osDebian Unstable X86_32
> & Sbuild.osDebianStandard
> & Sbuild.update `period` Weekly (Just 1)
-> & Sbuild.useHostProxy mybox
+> & Chroot.useHostProxy mybox
If you are using sbuild older than 0.70.0, you also need:
@@ -65,7 +65,6 @@ module Propellor.Property.Sbuild (
built,
-- * Properties for use inside sbuild schroots
update,
- useHostProxy,
osDebianStandard,
-- * Global sbuild configuration
-- blockNetwork,
@@ -268,20 +267,6 @@ osDebianStandard = propertyList "standard Debian sbuild properties" $ props
update :: Property DebianLike
update = Apt.update `before` Apt.upgrade `before` Apt.autoRemove
--- | Ensure that an sbuild schroot uses the host's Apt proxy.
---
--- This property is typically used when the host has 'Apt.useLocalCacher'.
-useHostProxy :: Host -> Property DebianLike
-useHostProxy h = property' "use host's apt proxy" $ \w ->
- -- Note that we can't look at getProxyInfo outside the property,
- -- as that would loop, but it's ok to look at it inside the
- -- property. Thus the slightly strange construction here.
- case getProxyInfo of
- Just (Apt.HostAptProxy u) -> ensureProperty w (Apt.proxy' u)
- Nothing -> noChange
- where
- getProxyInfo = fromInfoVal . fromInfo . hostInfo $ h
-
aptCacheLine :: String
aptCacheLine = "/var/cache/apt/archives /var/cache/apt/archives none rw,bind 0 0"
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
index 88c749b3..9f4dc519 100644
--- a/src/Propellor/Types/Core.hs
+++ b/src/Propellor/Types/Core.hs
@@ -109,3 +109,6 @@ instance IsProp ChildProperty where
getInfo (ChildProperty _ _ i _) = i
toChildProperty = id
getSatisfy (ChildProperty _ a _ _) = a
+
+propsInfo :: Props metatypes -> Info
+propsInfo (Props l) = mconcat (map getInfo l)
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index b941cc8f..27633712 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -63,6 +63,7 @@ addInfo (Info l) v = Info (l++[InfoEntry v])
toInfo :: IsInfo v => v -> Info
toInfo = addInfo mempty
+-- | Extracts a value from an Info.
fromInfo :: IsInfo v => Info -> v
fromInfo (Info l) = mconcat (mapMaybe extractInfoEntry l)