summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--debian/changelog4
-rw-r--r--src/Propellor/Engine.hs2
-rw-r--r--src/Propellor/Host.hs46
-rw-r--r--src/Propellor/Info.hs2
-rw-r--r--src/Propellor/Property.hs20
-rw-r--r--src/Propellor/Property/Chroot.hs4
-rw-r--r--src/Propellor/Property/Dns.hs2
-rw-r--r--src/Propellor/Property/Docker.hs4
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs1
-rw-r--r--src/Propellor/Types.hs33
10 files changed, 67 insertions, 51 deletions
diff --git a/debian/changelog b/debian/changelog
index c36472e4..c458de81 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,7 +1,9 @@
propellor (1.4.0) UNRELEASED; urgency=medium
* Add descriptions of how to set missing fields to --list-fields output.
- (Minor API changes)
+ * Properties now form a tree, instead of the flat list used before.
+ This includes the properties used inside a container.
+ (API change)
-- Joey Hess <id@joeyh.name> Thu, 15 Jan 2015 20:14:29 -0400
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 667f6bfb..22fbdfbb 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -35,7 +35,7 @@ import Utility.Monad
mainProperties :: Host -> IO ()
mainProperties host = do
ret <- runPropellor host $
- ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty]
+ ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty mempty]
h <- mkMessageHandle
whenConsole h $
setTitle "propellor: done"
diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs
index 896db676..cfe90949 100644
--- a/src/Propellor/Host.hs
+++ b/src/Propellor/Host.hs
@@ -3,12 +3,9 @@
module Propellor.Host where
import Data.Monoid
-import qualified Data.Set as S
import Propellor.Types
-import Propellor.Info
import Propellor.Property
-import Propellor.PrivData
-- | Starts accumulating the properties of a Host.
--
@@ -35,8 +32,10 @@ class Hostlike h where
getHost :: h -> Host
instance Hostlike Host where
- (Host hn ps is) & p = Host hn (ps ++ [toProp p]) (is <> getInfo p)
- (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo p <> is)
+ (Host hn ps is) & p = Host hn (ps ++ [toProp p])
+ (is <> getInfoRecursive p)
+ (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps)
+ (getInfoRecursive p <> is)
getHost h = h
-- | Adds a property in reverted form.
@@ -47,18 +46,29 @@ infixl 1 &^
infixl 1 &
infixl 1 !
--- | When eg, docking a container, some of the Info about the container
--- should propigate out to the Host it's on. This includes DNS info,
--- so that eg, aliases of the container are reflected in the dns for the
--- host where it runs.
+-- | Adjust the provided Property, adding to its
+-- propertyChidren the properties of the Hostlike.
+
+-- The Info of the propertyChildren is adjusted to only include
+-- info that should be propigated out to the Property.
+--
+-- DNS Info is propigated, so that eg, aliases of a Hostlike
+-- are reflected in the dns for the host where it runs.
--
--- This adjusts the Property that docks a container, to include such info
--- from the container.
-propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property
-propigateInfo hl p f = combineProperties (propertyDesc p) $
- p' : dnsprops ++ privprops
+-- PrivData Info is propigated, so that properties used inside a
+-- Hostlike will have the necessary PrivData available.
+propigateHostLike :: Hostlike hl => hl -> Property -> Property
+propigateHostLike hl prop = prop
+ { propertyChildren = propertyChildren prop ++ hostprops
+ }
where
- p' = p { propertyInfo = f (propertyInfo p) }
- i = hostInfo (getHost hl)
- dnsprops = map addDNS (S.toList $ _dns i)
- privprops = map addPrivData (S.toList $ _privData i)
+ hostprops = map go $ hostProperties $ getHost hl
+ go p =
+ let i = propertyInfo p
+ in p
+ { propertyInfo = mempty
+ { _dns = _dns i
+ , _privData = _privData i
+ }
+ , propertyChildren = map go (propertyChildren p)
+ }
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index ccb27cf3..15ea9466 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -12,7 +12,7 @@ import Data.Monoid
import Control.Applicative
pureInfoProperty :: Desc -> Info -> Property
-pureInfoProperty desc = Property ("has " ++ desc) (return NoChange)
+pureInfoProperty desc i = Property ("has " ++ desc) (return NoChange) i mempty
askInfo :: (Info -> Val a) -> Propellor (Maybe a)
askInfo f = asks (fromVal . f . hostInfo)
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index c0878fb6..43690735 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -16,19 +16,19 @@ import Utility.Monad
-- Constructs a Property.
property :: Desc -> Propellor Result -> Property
-property d s = Property d s mempty
+property d s = Property d s mempty mempty
-- | Combines a list of properties, resulting in a single property
-- that when run will run each property in the list in turn,
-- and print out the description of each as it's run. Does not stop
-- on failure; does propigate overall success/failure.
propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps)
+propertyList desc ps = Property desc (ensureProperties ps) mempty ps
-- | Combines a list of properties, resulting in one property that
-- ensures each in turn. Stops if a property fails.
combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps)
+combineProperties desc ps = Property desc (go ps NoChange) mempty ps
where
go [] rs = return rs
go (l:ls) rs = do
@@ -67,15 +67,16 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
--- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange :: Property -> Property -> Property
-p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook)
- where
- satisfy = do
+p `onChange` hook = p
+ { propertySatisfy = do
r <- ensureProperty p
case r of
MadeChange -> do
r' <- ensureProperty hook
return $ r <> r'
_ -> return r
+ , propertyChildren = propertyChildren p ++ [hook]
+ }
(==>) :: Desc -> Property -> Property
(==>) = flip describe
@@ -128,13 +129,6 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
--- | Combines the Info of two properties.
-combineInfo :: (IsProp p, IsProp q) => p -> q -> Info
-combineInfo p q = getInfo p <> getInfo q
-
-combineInfos :: IsProp p => [p] -> Info
-combineInfos = mconcat . map getInfo
-
makeChange :: IO () -> Propellor Result
makeChange a = liftIO a >> return MadeChange
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 3da8b0d6..de99e6c4 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -76,7 +76,9 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert
teardown = toProp (revert built)
propigateChrootInfo :: Chroot -> Property -> Property
-propigateChrootInfo c p = propigateInfo c p (<> chrootInfo c)
+propigateChrootInfo c p = propigateHostLike c p'
+ where
+ p' = p { propertyInfo = propertyInfo p <> chrootInfo c }
chrootInfo :: Chroot -> Info
chrootInfo (Chroot loc _ _ h) =
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index ceda2e07..6114834c 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -78,7 +78,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
baseprop = Property ("dns primary for " ++ domain) satisfy
- (addNamedConf conf)
+ (addNamedConf conf) []
satisfy = do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
let zone = partialzone
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index eb0d8ec5..3e2fbaf3 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -134,9 +134,9 @@ docked ctr@(Container _ h) = RevertableProperty
]
propigateContainerInfo :: Container -> Property -> Property
-propigateContainerInfo ctr@(Container _ h) p =
- propigateInfo ctr p (<> dockerinfo)
+propigateContainerInfo ctr@(Container _ h) p = propigateHostLike ctr p'
where
+ p' = p { propertyInfo = propertyInfo p <> dockerinfo }
dockerinfo = dockerInfo $
mempty { _dockerContainers = M.singleton (hostName h) h }
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index a2eb44b0..10312b4e 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -419,7 +419,6 @@ kiteMailServer = propertyList "kitenet.net mail server"
, "/etc/default/spamassassin" `File.containsLines`
[ "# Propellor deployed"
, "ENABLED=1"
- , "CRON=1"
, "OPTIONS=\"--create-prefs --max-children 5 --helper-home-dir\""
, "CRON=1"
, "NICE=\"--nicelevel 15\""
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index ab84a46b..9f1c8f1b 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -4,7 +4,7 @@
module Propellor.Types
( Host(..)
, Info(..)
- , getInfo
+ , getInfoRecursive
, Propellor(..)
, Property(..)
, RevertableProperty(..)
@@ -38,7 +38,6 @@ import "mtl" Control.Monad.RWS.Strict
import "MonadCatchIO-transformers" Control.Monad.CatchIO
import qualified Data.Set as S
import qualified Data.Map as M
-import qualified Propellor.Types.Dns as Dns
import Propellor.Types.OS
import Propellor.Types.Chroot
@@ -46,9 +45,10 @@ import Propellor.Types.Dns
import Propellor.Types.Docker
import Propellor.Types.PrivData
import Propellor.Types.Empty
+import qualified Propellor.Types.Dns as Dns
-- | Everything Propellor knows about a system: Its hostname,
--- properties and other info.
+-- properties and their collected info.
data Host = Host
{ hostName :: HostName
, hostProperties :: [Property]
@@ -77,7 +77,15 @@ data Property = Property
, propertySatisfy :: Propellor Result
-- ^ must be idempotent; may run repeatedly
, propertyInfo :: Info
- -- ^ a property can add info to the host.
+ -- ^ info associated with the property
+ , propertyChildren :: [Property]
+ -- ^ A property can include a list of child properties.
+ -- This allows them to be introspected to collect their info,
+ -- etc.
+ --
+ -- Note that listing Properties here does not ensure that
+ -- their propertySatisfy is run when satisfying the parent
+ -- property; it's up to the parent's propertySatisfy to do that.
}
instance Show Property where
@@ -93,21 +101,22 @@ class IsProp p where
-- | Indicates that the first property can only be satisfied
-- once the second one is.
requires :: p -> Property -> p
- getInfo :: p -> Info
+ -- | Gets the info of the property, combined with all info
+ -- of all children properties.
+ getInfoRecursive :: p -> Info
instance IsProp Property where
describe p d = p { propertyDesc = d }
toProp p = p
- getInfo = propertyInfo
- x `requires` y = Property (propertyDesc x) satisfy info
- where
- info = getInfo y <> getInfo x
- satisfy = do
+ getInfoRecursive p = propertyInfo p <> mconcat (map getInfoRecursive (propertyChildren p))
+ x `requires` y = x
+ { propertySatisfy = do
r <- propertySatisfy y
case r of
FailedChange -> return FailedChange
_ -> propertySatisfy x
-
+ , propertyChildren = y : propertyChildren x
+ }
instance IsProp RevertableProperty where
-- | Sets the description of both sides.
@@ -117,7 +126,7 @@ instance IsProp RevertableProperty where
(RevertableProperty p1 p2) `requires` y =
RevertableProperty (p1 `requires` y) p2
-- | Return the Info of the currently active side.
- getInfo (RevertableProperty p1 _p2) = getInfo p1
+ getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
type Desc = String