From 5a932c382d4cbe65957eb0d3ebe4a9319d8dfd14 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 7 Dec 2014 16:37:02 -0400 Subject: docuemnt info propigtion problem --- src/Propellor/Engine.hs | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 44b10cab..aa2ea4a3 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -52,6 +52,15 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc (ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host () return ret +-- | For when code running in the Propellor monad needs to ensure a +-- Property. +-- +-- Note that any info of the Property is not propigated out to +-- the enclosing Property, and so will not be available for propellor to +-- use. +ensureProperty :: Property -> Propellor Result +ensureProperty = catchPropellor . propertySatisfy + -- | Ensures a list of Properties, with a display of each as it runs. ensureProperties :: [Property] -> Propellor Result ensureProperties ps = ensure ps NoChange @@ -62,11 +71,6 @@ ensureProperties ps = ensure ps NoChange r <- actionMessageOn hn (propertyDesc l) (ensureProperty l) ensure ls (r <> rs) --- | For when code running in the Propellor monad needs to ensure a --- Property. -ensureProperty :: Property -> Propellor Result -ensureProperty = catchPropellor . propertySatisfy - -- | Lifts an action into a different host. -- -- For example, `fromHost hosts "otherhost" getSshPubKey` -- cgit v1.2.3 From 42a0c832483296fb111279fc3512a3dfd44f2089 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 7 Dec 2014 17:09:55 -0400 Subject: Display a warning when ensureProperty is used on a property which has Info and is so prevented from propigating it. Would much rather a type-based fixed, but this is all I have for now. --- debian/changelog | 7 +++++++ propellor.cabal | 1 + src/Propellor/Engine.hs | 32 +++++++++++++++++++++++++------- src/Propellor/Types.hs | 17 +++++++++++++++++ src/Propellor/Types/Chroot.hs | 12 +++++++++++- src/Propellor/Types/Dns.hs | 4 ++++ src/Propellor/Types/Docker.hs | 7 +++++++ src/Propellor/Types/Empty.hs | 16 ++++++++++++++++ 8 files changed, 88 insertions(+), 8 deletions(-) create mode 100644 src/Propellor/Types/Empty.hs diff --git a/debian/changelog b/debian/changelog index 0ea27675..827c7986 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,10 @@ +propellor (1.1.1) UNRELEASED; urgency=medium + + * Display a warning when ensureProperty is used on a property which has + Info and is so prevented from propigating it. + + -- Joey Hess Sun, 07 Dec 2014 17:08:55 -0400 + propellor (1.1.0) unstable; urgency=medium * --spin target --via relay causes propellor to bounce through an diff --git a/propellor.cabal b/propellor.cabal index 91d08bd5..fb109649 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -118,6 +118,7 @@ Library Propellor.Types.Chroot Propellor.Types.Docker Propellor.Types.Dns + Propellor.Types.Empty Propellor.Types.OS Propellor.Types.PrivData Other-Modules: diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index aa2ea4a3..dc8b2bc5 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -1,6 +1,14 @@ {-# LANGUAGE PackageImports #-} -module Propellor.Engine where +module Propellor.Engine ( + mainProperties, + runPropellor, + ensureProperty, + ensureProperties, + fromHost, + onlyProcess, + processChainOutput, +) where import System.Exit import System.IO @@ -15,6 +23,7 @@ import System.FilePath import System.Directory import Propellor.Types +import Propellor.Types.Empty import Propellor.Message import Propellor.Exception import Propellor.Info @@ -27,7 +36,7 @@ import Utility.Monad mainProperties :: Host -> IO () mainProperties host = do ret <- runPropellor host $ - ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty] + ensureProperties [Property "overall" (ensurePropertiesWith ensureProperty' $ hostProperties host) mempty] h <- mkMessageHandle whenConsole h $ setTitle "propellor: done" @@ -57,18 +66,27 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc -- -- Note that any info of the Property is not propigated out to -- the enclosing Property, and so will not be available for propellor to --- use. +-- use. A warning message will be printed if this is detected. ensureProperty :: Property -> Propellor Result -ensureProperty = catchPropellor . propertySatisfy +ensureProperty p = do + unless (isEmpty (getInfo p)) $ + warningMessage $ "ensureProperty called on " ++ show p ++ "; will not propigate its info: " ++ show (getInfo p) + ensureProperty' p + +ensureProperty' :: Property -> Propellor Result +ensureProperty' = catchPropellor . propertySatisfy -- | Ensures a list of Properties, with a display of each as it runs. ensureProperties :: [Property] -> Propellor Result -ensureProperties ps = ensure ps NoChange +ensureProperties = ensurePropertiesWith ensureProperty + +ensurePropertiesWith :: (Property -> Propellor Result) -> [Property] -> Propellor Result +ensurePropertiesWith a ps = ensure ps NoChange where ensure [] rs = return rs - ensure (l:ls) rs = do + ensure (p:ls) rs = do hn <- asks hostName - r <- actionMessageOn hn (propertyDesc l) (ensureProperty l) + r <- actionMessageOn hn (propertyDesc p) (a p) ensure ls (r <> rs) -- | Lifts an action into a different host. diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e00a457d..72e0e7ad 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -43,6 +43,7 @@ import Propellor.Types.Chroot import Propellor.Types.Dns import Propellor.Types.Docker import Propellor.Types.PrivData +import Propellor.Types.Empty -- | Everything Propellor knows about a system: Its hostname, -- properties and other info. @@ -188,6 +189,18 @@ instance Monoid Info where , _chrootinfo = _chrootinfo old <> _chrootinfo new } +instance Empty Info where + isEmpty i = and + [ isEmpty (_os i) + , isEmpty (_privDataFields i) + , isEmpty (_sshPubKey i) + , isEmpty (_aliases i) + , isEmpty (_dns i) + , isEmpty (_namedconf i) + , isEmpty (_dockerinfo i) + , isEmpty (_chrootinfo i) + ] + data Val a = Val a | NoVal deriving (Eq, Show) @@ -197,6 +210,10 @@ instance Monoid (Val a) where NoVal -> old _ -> new +instance Empty (Val a) where + isEmpty NoVal = True + isEmpty _ = False + fromVal :: Val a -> Maybe a fromVal (Val a) = Just a fromVal NoVal = Nothing diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs index b7ed7807..d37d34c7 100644 --- a/src/Propellor/Types/Chroot.hs +++ b/src/Propellor/Types/Chroot.hs @@ -2,6 +2,7 @@ module Propellor.Types.Chroot where import Data.Monoid import qualified Data.Map as M +import Propellor.Types.Empty data ChrootInfo host = ChrootInfo { _chroots :: M.Map FilePath host @@ -16,10 +17,16 @@ instance Monoid (ChrootInfo host) where , _chrootCfg = _chrootCfg old <> _chrootCfg new } +instance Empty (ChrootInfo host) where + isEmpty i = and + [ isEmpty (_chroots i) + , isEmpty (_chrootCfg i) + ] + data ChrootCfg = NoChrootCfg | SystemdNspawnCfg [(String, Bool)] - deriving (Show) + deriving (Show, Eq) instance Monoid ChrootCfg where mempty = NoChrootCfg @@ -27,3 +34,6 @@ instance Monoid ChrootCfg where mappend NoChrootCfg v = v mappend (SystemdNspawnCfg l1) (SystemdNspawnCfg l2) = SystemdNspawnCfg (l1 <> l2) + +instance Empty ChrootCfg where + isEmpty c= c == NoChrootCfg diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs index 66fbd1a4..5e9666d8 100644 --- a/src/Propellor/Types/Dns.hs +++ b/src/Propellor/Types/Dns.hs @@ -1,6 +1,7 @@ module Propellor.Types.Dns where import Propellor.Types.OS (HostName) +import Propellor.Types.Empty import Data.Word import Data.Monoid @@ -108,5 +109,8 @@ instance Monoid NamedConfMap where (Secondary, Master) -> o _ -> n +instance Empty NamedConfMap where + isEmpty (NamedConfMap m) = isEmpty m + fromNamedConfMap :: NamedConfMap -> M.Map Domain NamedConf fromNamedConfMap (NamedConfMap m) = m diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs index 42a65923..3eafa59d 100644 --- a/src/Propellor/Types/Docker.hs +++ b/src/Propellor/Types/Docker.hs @@ -1,6 +1,7 @@ module Propellor.Types.Docker where import Propellor.Types.OS +import Propellor.Types.Empty import Data.Monoid import qualified Data.Map as M @@ -18,6 +19,12 @@ instance Monoid (DockerInfo h) where , _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new) } +instance Empty (DockerInfo h) where + isEmpty i = and + [ isEmpty (_dockerRunParams i) + , isEmpty (_dockerContainers i) + ] + newtype DockerRunParam = DockerRunParam (HostName -> String) instance Show DockerRunParam where diff --git a/src/Propellor/Types/Empty.hs b/src/Propellor/Types/Empty.hs new file mode 100644 index 00000000..dcd2f4a0 --- /dev/null +++ b/src/Propellor/Types/Empty.hs @@ -0,0 +1,16 @@ +module Propellor.Types.Empty where + +import qualified Data.Map as M +import qualified Data.Set as S + +class Empty t where + isEmpty :: t -> Bool + +instance Empty [a] where + isEmpty = null + +instance Empty (M.Map k v) where + isEmpty = M.null + +instance Empty (S.Set v) where + isEmpty = S.null -- cgit v1.2.3