summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Container.hs19
-rw-r--r--src/Propellor/PrivData.hs6
-rw-r--r--src/Propellor/Property/Chroot.hs13
-rw-r--r--src/Propellor/Property/Conductor.hs6
-rw-r--r--src/Propellor/Property/DiskImage.hs5
-rw-r--r--src/Propellor/Property/Docker.hs5
-rw-r--r--src/Propellor/Property/FreeBSD/Pkg.hs5
-rw-r--r--src/Propellor/Property/FreeBSD/Poudriere.hs2
-rw-r--r--src/Propellor/Property/Ssh.hs4
-rw-r--r--src/Propellor/Types/Chroot.hs2
-rw-r--r--src/Propellor/Types/Dns.hs6
-rw-r--r--src/Propellor/Types/Docker.hs2
-rw-r--r--src/Propellor/Types/Info.hs20
13 files changed, 59 insertions, 36 deletions
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index 26194456..b64f5949 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -51,15 +51,30 @@ propagateContainer
)
=> String
-> c
+ -> (PropagateInfo -> Bool)
-> Property metatypes
-> Property metatypes
-propagateContainer containername c prop = prop
+propagateContainer containername c wanted prop = prop
`addChildren` map convert (containerProperties c)
where
convert p =
let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
n' = n
`setInfoProperty` mapInfo (forceHostContext containername)
- (propagatableInfo (getInfo p))
+ (propagatableInfo wanted (getInfo p))
`addChildren` map convert (getChildren p)
in toChildProperty n'
+
+-- | Filters out parts of the Info that should not propagate out of a
+-- container.
+propagatableInfo :: (PropagateInfo -> Bool) -> Info -> Info
+propagatableInfo wanted (Info l) = Info $
+ filter (\(InfoEntry a) -> wanted (propagateInfo a)) l
+
+normalContainerInfo :: PropagateInfo -> Bool
+normalContainerInfo PropagatePrivData = True
+normalContainerInfo (PropagateInfo b) = b
+
+onlyPrivData :: PropagateInfo -> Bool
+onlyPrivData PropagatePrivData = True
+onlyPrivData (PropagateInfo _) = False
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index 8ca51e23..516eda03 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -281,10 +281,10 @@ newtype PrivInfo = PrivInfo
{ fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) }
deriving (Eq, Ord, Show, Typeable, Monoid)
--- PrivInfo is propagated out of containers, so that propellor can see which
--- hosts need it.
+-- PrivInfo always propagates out of containers, so that propellor
+-- can see which hosts need it.
instance IsInfo PrivInfo where
- propagateInfo _ = True
+ propagateInfo _ = PropagatePrivData
-- | Sets the context of any privdata that uses HostContext to the
-- provided name.
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 4b9b48e1..8f18d724 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -135,7 +135,7 @@ provisioned'
-> Bool
-> RevertableProperty (HasInfo + Linux) Linux
provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly =
- (infopropigator $ setup `describe` chrootDesc c "exists")
+ (infopropigator normalContainerInfo $ setup `describe` chrootDesc c "exists")
<!>
(teardown `describe` chrootDesc c "removed")
where
@@ -154,11 +154,12 @@ provisioned' c@(Chroot loc bootstrapper infopropigator _) systemdonly =
property ("removed " ++ loc) $
makeChange (removeChroot loc)
-type InfoPropagator = Property Linux -> Property (HasInfo + Linux)
+type InfoPropagator = (PropagateInfo -> Bool) -> Property Linux -> Property (HasInfo + Linux)
propagateChrootInfo :: Chroot -> InfoPropagator
-propagateChrootInfo c@(Chroot location _ _ _) p = propagateContainer location c $
- p `setInfoProperty` chrootInfo c
+propagateChrootInfo c@(Chroot location _ _ _) pinfo p =
+ propagateContainer location c pinfo $
+ p `setInfoProperty` chrootInfo c
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ _ h) = mempty `addInfo`
@@ -308,6 +309,6 @@ hostChroot h bootstrapper d = chroot
-- HostContext is not made to use the name of the chroot as its context,
-- but instead uses the hostname of the Host.
propagateHostChrootInfo :: Host -> Chroot -> InfoPropagator
-propagateHostChrootInfo h c p =
- propagateContainer (hostName h) c $
+propagateHostChrootInfo h c pinfo p =
+ propagateContainer (hostName h) c pinfo $
p `setInfoProperty` chrootInfo c
diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs
index 8aa18d20..cfeb5aa7 100644
--- a/src/Propellor/Property/Conductor.hs
+++ b/src/Propellor/Property/Conductor.hs
@@ -323,15 +323,15 @@ instance Show NotConductorFor where
show (NotConductorFor l) = "NotConductorFor " ++ show (map hostName l)
instance IsInfo ConductorFor where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance IsInfo NotConductorFor where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
-- Added to Info when a host has been orchestrated.
newtype Orchestrated = Orchestrated Any
deriving (Typeable, Monoid, Show)
instance IsInfo Orchestrated where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
isOrchestrated :: Orchestrated -> Bool
isOrchestrated (Orchestrated v) = getAny v
diff --git a/src/Propellor/Property/DiskImage.hs b/src/Propellor/Property/DiskImage.hs
index c7868c47..06d0694e 100644
--- a/src/Propellor/Property/DiskImage.hs
+++ b/src/Propellor/Property/DiskImage.hs
@@ -130,7 +130,7 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
| otherwise = doNothing
chrootdir = img ++ ".chroot"
chroot =
- let c = mkchroot chrootdir
+ let c = propprivdataonly $ mkchroot chrootdir
in setContainerProps c $ containerProps c
-- Before ensuring any other properties of the chroot,
-- avoid starting services. Reverted by imageFinalized.
@@ -138,6 +138,9 @@ imageBuilt' rebuild img mkchroot tabletype final partspec =
-- First stage finalization.
& fst final
& cachesCleaned
+ -- Only propagate privdata Info from this chroot, nothing else.
+ propprivdataonly (Chroot.Chroot d b ip h) =
+ Chroot.Chroot d b (const $ ip onlyPrivData) h
-- | This property is automatically added to the chroot when building a
-- disk image. It cleans any caches of information that can be omitted;
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index d2b2ee35..1080418b 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -184,8 +184,9 @@ imagePulled ctr = pulled `describe` msg
image = getImageName ctr
propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux)
-propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $
- p `addInfoProperty` dockerinfo
+propagateContainerInfo ctr@(Container _ h) p =
+ propagateContainer cn ctr normalContainerInfo $
+ p `addInfoProperty` dockerinfo
where
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton cn h }
diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs
index 704c1db9..77bf5768 100644
--- a/src/Propellor/Property/FreeBSD/Pkg.hs
+++ b/src/Propellor/Property/FreeBSD/Pkg.hs
@@ -39,7 +39,7 @@ pkgCmd cmd args =
newtype PkgUpdate = PkgUpdate String
deriving (Typeable, Monoid, Show)
instance IsInfo PkgUpdate where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
pkgUpdated :: PkgUpdate -> Bool
pkgUpdated (PkgUpdate _) = True
@@ -55,8 +55,9 @@ update =
newtype PkgUpgrade = PkgUpgrade String
deriving (Typeable, Monoid, Show)
+
instance IsInfo PkgUpgrade where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
pkgUpgraded :: PkgUpgrade -> Bool
pkgUpgraded (PkgUpgrade _) = True
diff --git a/src/Propellor/Property/FreeBSD/Poudriere.hs b/src/Propellor/Property/FreeBSD/Poudriere.hs
index e6ddea16..378c5530 100644
--- a/src/Propellor/Property/FreeBSD/Poudriere.hs
+++ b/src/Propellor/Property/FreeBSD/Poudriere.hs
@@ -21,7 +21,7 @@ newtype PoudriereConfigured = PoudriereConfigured String
deriving (Typeable, Monoid, Show)
instance IsInfo PoudriereConfigured where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
poudriereConfigured :: PoudriereConfigured -> Bool
poudriereConfigured (PoudriereConfigured _) = True
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index 828601b8..fd89f97a 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -227,7 +227,7 @@ newtype HostKeyInfo = HostKeyInfo
deriving (Eq, Ord, Typeable, Show)
instance IsInfo HostKeyInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid HostKeyInfo where
mempty = HostKeyInfo M.empty
@@ -248,7 +248,7 @@ newtype UserKeyInfo = UserKeyInfo
deriving (Eq, Ord, Typeable, Show)
instance IsInfo UserKeyInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid UserKeyInfo where
mempty = UserKeyInfo M.empty
diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs
index fc049603..da912120 100644
--- a/src/Propellor/Types/Chroot.hs
+++ b/src/Propellor/Types/Chroot.hs
@@ -16,7 +16,7 @@ data ChrootInfo = ChrootInfo
deriving (Show, Typeable)
instance IsInfo ChrootInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid ChrootInfo where
mempty = ChrootInfo mempty mempty
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 4cb8b111..8d62e63b 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -28,7 +28,7 @@ newtype AliasesInfo = AliasesInfo (S.Set HostName)
deriving (Show, Eq, Ord, Monoid, Typeable)
instance IsInfo AliasesInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
toAliasesInfo :: [HostName] -> AliasesInfo
toAliasesInfo l = AliasesInfo (S.fromList l)
@@ -45,7 +45,7 @@ toDnsInfo = DnsInfo
-- | DNS Info is propagated, so that eg, aliases of a container
-- are reflected in the dns for the host where it runs.
instance IsInfo DnsInfo where
- propagateInfo _ = True
+ propagateInfo _ = PropagateInfo True
-- | Represents a bind 9 named.conf file.
data NamedConf = NamedConf
@@ -157,7 +157,7 @@ newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
deriving (Eq, Ord, Show, Typeable)
instance IsInfo NamedConfMap where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
-- | Adding a Master NamedConf stanza for a particulr domain always
-- overrides an existing Secondary stanza for that domain, while a
diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs
index f3cc4a52..6ff340e5 100644
--- a/src/Propellor/Types/Docker.hs
+++ b/src/Propellor/Types/Docker.hs
@@ -16,7 +16,7 @@ data DockerInfo = DockerInfo
deriving (Show, Typeable)
instance IsInfo DockerInfo where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
instance Monoid DockerInfo where
mempty = DockerInfo mempty mempty
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
index 2e188ae5..06212780 100644
--- a/src/Propellor/Types/Info.hs
+++ b/src/Propellor/Types/Info.hs
@@ -1,13 +1,14 @@
{-# LANGUAGE GADTs, DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
module Propellor.Types.Info (
- Info,
+ Info(..),
+ InfoEntry(..),
IsInfo(..),
+ PropagateInfo(..),
addInfo,
toInfo,
fromInfo,
mapInfo,
- propagatableInfo,
InfoVal(..),
fromInfoVal,
Typeable,
@@ -44,7 +45,13 @@ extractInfoEntry (InfoEntry v) = cast v
class (Typeable v, Monoid v, Show v) => IsInfo v where
-- | Should info of this type be propagated out of a
-- container to its Host?
- propagateInfo :: v -> Bool
+ propagateInfo :: v -> PropagateInfo
+
+data PropagateInfo
+ = PropagateInfo Bool
+ | PropagatePrivData
+ -- ^ Info about PrivData generally will be propigated even in cases
+ -- where other Info is not, so it treated specially.
-- | Any value in the `IsInfo` type class can be added to an Info.
addInfo :: IsInfo v => Info -> v -> Info
@@ -68,11 +75,6 @@ mapInfo f (Info l) = Info (map go l)
Nothing -> i
Just v -> InfoEntry (f v)
--- | Filters out parts of the Info that should not propagate out of a
--- container.
-propagatableInfo :: Info -> Info
-propagatableInfo (Info l) = Info (filter (\(InfoEntry a) -> propagateInfo a) l)
-
-- | Use this to put a value in Info that is not a monoid.
-- The last value set will be used. This info does not propagate
-- out of a container.
@@ -85,7 +87,7 @@ instance Monoid (InfoVal v) where
mappend v NoInfoVal = v
instance (Typeable v, Show v) => IsInfo (InfoVal v) where
- propagateInfo _ = False
+ propagateInfo _ = PropagateInfo False
fromInfoVal :: InfoVal v -> Maybe v
fromInfoVal NoInfoVal = Nothing
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-15 17:48:36 +0000