summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2014-12-07 17:09:55 -0400
committerJoey Hess2014-12-07 17:09:55 -0400
commit42a0c832483296fb111279fc3512a3dfd44f2089 (patch)
tree328c20c8a34e908806d240ec2dd5a02437c8df6b
parent5a932c382d4cbe65957eb0d3ebe4a9319d8dfd14 (diff)
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.
-rw-r--r--debian/changelog7
-rw-r--r--propellor.cabal1
-rw-r--r--src/Propellor/Engine.hs32
-rw-r--r--src/Propellor/Types.hs17
-rw-r--r--src/Propellor/Types/Chroot.hs12
-rw-r--r--src/Propellor/Types/Dns.hs4
-rw-r--r--src/Propellor/Types/Docker.hs7
-rw-r--r--src/Propellor/Types/Empty.hs16
8 files changed, 88 insertions, 8 deletions
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 <id@joeyh.name> 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