From c7609c824ba1ce7cdcdf9c646b721db80333f04b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 15 Jan 2015 20:15:01 -0400 Subject: Add descriptions of how to set missing fields to --list-fields output. (Minor API changes) --- src/Propellor/Host.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'src/Propellor/Host.hs') diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs index 14d56e20..896db676 100644 --- a/src/Propellor/Host.hs +++ b/src/Propellor/Host.hs @@ -61,4 +61,4 @@ propigateInfo hl p f = combineProperties (propertyDesc p) $ p' = p { propertyInfo = f (propertyInfo p) } i = hostInfo (getHost hl) dnsprops = map addDNS (S.toList $ _dns i) - privprops = map addPrivDataField (S.toList $ _privDataFields i) + privprops = map addPrivData (S.toList $ _privData i) -- cgit v1.2.3 From afee550e708cb50a72f0505e3c4ca8f775f39ef0 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 18 Jan 2015 18:02:07 -0400 Subject: Property tree Properties now form a tree, instead of the flat list used before. This simplifies propigation of Info from the Properties used inside a container to the outer host; the Property that docks the container on the host can just have as child properties all the inner Properties, and their Info can then be gathered recursively. (Although in practice it still needs to be filtered, since not all Info should propigate out of a container.) Note that there is no change to how Properties are actually satisfied. Just because a Property lists some child properties, this does not mean they always have their propertySatisfy actions run. It's still up to the parent property to run those actions. That's necessary so that a container's properties can be satisfied inside it, not outside. It also allows property combinators to add the combined Properties to their childProperties list, even if, like onChange, they don't always run the child properties at all. Testing: I tested that the exact same Info is calculated before and after this change, for every Host in my config file. --- debian/changelog | 4 ++- src/Propellor/Engine.hs | 2 +- src/Propellor/Host.hs | 46 ++++++++++++++---------- src/Propellor/Info.hs | 2 +- src/Propellor/Property.hs | 20 ++++------- src/Propellor/Property/Chroot.hs | 4 ++- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 4 +-- src/Propellor/Property/SiteSpecific/JoeySites.hs | 1 - src/Propellor/Types.hs | 33 ++++++++++------- 10 files changed, 67 insertions(+), 51 deletions(-) (limited to 'src/Propellor/Host.hs') 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 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 -- cgit v1.2.3 From 1ae21965aaba0303088052e873fea39708e331ed Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Jan 2015 14:15:49 -0400 Subject: rename HostLike to PropAccum This is more general; it doesn't need to contain a Host. It would, for example, be possible to make Property itself be an instance of PropAccum. --- propellor.cabal | 2 +- src/Propellor.hs | 4 +-- src/Propellor/Host.hs | 74 --------------------------------------- src/Propellor/PropAccum.hs | 74 +++++++++++++++++++++++++++++++++++++++ src/Propellor/Property/Chroot.hs | 6 ++-- src/Propellor/Property/Docker.hs | 6 ++-- src/Propellor/Property/Systemd.hs | 8 ++--- 7 files changed, 87 insertions(+), 87 deletions(-) delete mode 100644 src/Propellor/Host.hs create mode 100644 src/Propellor/PropAccum.hs (limited to 'src/Propellor/Host.hs') diff --git a/propellor.cabal b/propellor.cabal index 982df527..00a5ac5b 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -108,7 +108,7 @@ Library Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.GitAnnexBuilder - Propellor.Host + Propellor.PropAccum Propellor.CmdLine Propellor.Info Propellor.Message diff --git a/src/Propellor.hs b/src/Propellor.hs index 0e34e988..d0e89ca5 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -33,7 +33,7 @@ module Propellor ( module Propellor.Types , module Propellor.Property , module Propellor.Property.Cmd - , module Propellor.Host + , module Propellor.PropAccum , module Propellor.Info , module Propellor.PrivData , module Propellor.Types.PrivData @@ -54,7 +54,7 @@ import Propellor.Types.PrivData import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Host +import Propellor.PropAccum import Utility.PartialPrelude as X import Utility.Process as X diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs deleted file mode 100644 index cfe90949..00000000 --- a/src/Propellor/Host.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Propellor.Host where - -import Data.Monoid - -import Propellor.Types -import Propellor.Property - --- | Starts accumulating the properties of a Host. --- --- > host "example.com" --- > & someproperty --- > ! oldproperty --- > & otherproperty -host :: HostName -> Host -host hn = Host hn [] mempty - --- | Something that can accumulate properties. -class Hostlike h where - -- | Adds a property. - -- - -- Can add Properties and RevertableProperties - (&) :: IsProp p => h -> p -> h - - -- | Like (&), but adds the property as the - -- first property of the host. Normally, property - -- order should not matter, but this is useful - -- when it does. - (&^) :: IsProp p => h -> p -> h - - getHost :: h -> Host - -instance Hostlike Host where - (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. -(!) :: Hostlike h => h -> RevertableProperty -> h -h ! p = h & revert p - -infixl 1 &^ -infixl 1 & -infixl 1 ! - --- | 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. --- --- 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 - 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/PropAccum.hs b/src/Propellor/PropAccum.hs new file mode 100644 index 00000000..4cbb057e --- /dev/null +++ b/src/Propellor/PropAccum.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.PropAccum where + +import Data.Monoid + +import Propellor.Types +import Propellor.Property + +-- | Starts accumulating the properties of a Host. +-- +-- > host "example.com" +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Host +host hn = Host hn [] mempty + +-- | Something that can accumulate properties. +class PropAccum h where + -- | Adds a property. + -- + -- Can add Properties and RevertableProperties + (&) :: IsProp p => h -> p -> h + + -- | Like (&), but adds the property as the + -- first property of the host. Normally, property + -- order should not matter, but this is useful + -- when it does. + (&^) :: IsProp p => h -> p -> h + + getProperties :: h -> [Property] + +instance PropAccum Host where + (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) + getProperties = hostProperties + +-- | Adds a property in reverted form. +(!) :: PropAccum h => h -> RevertableProperty -> h +h ! p = h & revert p + +infixl 1 &^ +infixl 1 & +infixl 1 ! + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. + +-- 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 PropAccum +-- are reflected in the dns for the host where it runs. +-- +-- PrivData Info is propigated, so that properties used inside a +-- PropAccum will have the necessary PrivData available. +propigateContainer :: PropAccum container => container -> Property -> Property +propigateContainer c prop = prop + { propertyChildren = propertyChildren prop ++ hostprops + } + where + hostprops = map go $ getProperties c + 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/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index de99e6c4..395ec74c 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -28,10 +28,10 @@ data BuilderConf = UsingDeboostrap Debootstrap.DebootstrapConfig deriving (Show) -instance Hostlike Chroot where +instance PropAccum Chroot where (Chroot l s c h) & p = Chroot l s c (h & p) (Chroot l s c h) &^ p = Chroot l s c (h &^ p) - getHost (Chroot _ _ _ h) = h + getProperties (Chroot _ _ _ h) = hostProperties h -- | Defines a Chroot at the given location, built with debootstrap. -- @@ -76,7 +76,7 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert teardown = toProp (revert built) propigateChrootInfo :: Chroot -> Property -> Property -propigateChrootInfo c p = propigateHostLike c p' +propigateChrootInfo c p = propigateContainer c p' where p' = p { propertyInfo = propertyInfo p <> chrootInfo c } diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 3e2fbaf3..e65d6bb7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -77,10 +77,10 @@ type ContainerName = String -- | A docker container. data Container = Container Image Host -instance Hostlike Container where +instance PropAccum Container where (Container i h) & p = Container i (h & p) (Container i h) &^ p = Container i (h &^ p) - getHost (Container _ h) = h + getProperties (Container _ h) = hostProperties h -- | Defines a Container with a given name, image, and properties. -- Properties can be added to configure the Container. @@ -134,7 +134,7 @@ docked ctr@(Container _ h) = RevertableProperty ] propigateContainerInfo :: Container -> Property -> Property -propigateContainerInfo ctr@(Container _ h) p = propigateHostLike ctr p' +propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p' where p' = p { propertyInfo = propertyInfo p <> dockerinfo } dockerinfo = dockerInfo $ diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index e80c32be..7fe600a0 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -33,10 +33,10 @@ type MachineName = String data Container = Container MachineName Chroot.Chroot Host deriving (Show) -instance Hostlike Container where - (Container n c h) & p = Container n c (h & p) - (Container n c h) &^ p = Container n c (h &^ p) - getHost (Container _ _ h) = h +instance PropAccum Container where + (Container n c h) & p = Container n c (h & p) + (Container n c h) &^ p = Container n c (h &^ p) + getProperties (Container _ _ h) = hostProperties h -- | Starts a systemd service. started :: ServiceName -> Property -- cgit v1.2.3