summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2017-03-15 14:09:07 -0400
committerJoey Hess2017-03-15 14:09:07 -0400
commit52ca81661f156122a3a5d4a438fea83e067215ac (patch)
tree2156d53d78dceb7e342b3dd365d7ab33e1ebd5d0
parent51e281911d683f833d4d71ad62f2b64a5f4a0cea (diff)
Property types changed to use a Maybe (Propellor Result). (API change)
* Property types changed to use a Maybe (Propellor Result). (API change) * When Nothing needs to be done to ensure a property, propellor will avoid displaying its description at all. The doNothing property is an example of such a property. This is mostly in preparation for Monoid instances for Property types, but is's also nice that anything that uses doNothing will avoid printing out any message at all. At least, I think it probably is. It might potentially be confusing for something that sometimes takes an action and sometimes resolves to doNothing and in either case has a description set to not always show the description. If this did turn out to be confusing, the change to doNothing could be reverted. This commit was sponsored by Boyd Stephen Smith Jr. on Patreon.
-rw-r--r--debian/changelog4
-rw-r--r--src/Propellor/Container.hs2
-rw-r--r--src/Propellor/Engine.hs4
-rw-r--r--src/Propellor/EnsureProperty.hs4
-rw-r--r--src/Propellor/Property.hs26
-rw-r--r--src/Propellor/Property/Concurrent.hs11
-rw-r--r--src/Propellor/Property/List.hs2
-rw-r--r--src/Propellor/Types.hs17
-rw-r--r--src/Propellor/Types/Core.hs4
9 files changed, 50 insertions, 24 deletions
diff --git a/debian/changelog b/debian/changelog
index e698c9c0..460d468d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -20,6 +20,10 @@ propellor (3.5.0) UNRELEASED; urgency=medium
creation and servers will not be running in it.
* The IsInfo types class's propagateInfo function changed to use a
PropagateInfo data type. (API change)
+ * Property types changed to use a Maybe (Propellor Result). (API change)
+ * When Nothing needs to be done to ensure a property, propellor
+ will avoid displaying its description at all. The doNothing property
+ is an example of such a property.
-- Joey Hess <id@joeyh.name> Wed, 08 Mar 2017 14:02:10 -0400
diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs
index b64f5949..a805add8 100644
--- a/src/Propellor/Container.hs
+++ b/src/Propellor/Container.hs
@@ -58,7 +58,7 @@ propagateContainer containername c wanted prop = prop
`addChildren` map convert (containerProperties c)
where
convert p =
- let n = property (getDesc p) (getSatisfy p) :: Property UnixLike
+ let n = property'' (getDesc p) (getSatisfy p) :: Property UnixLike
n' = n
`setInfoProperty` mapInfo (forceHostContext containername)
(propagatableInfo wanted (getInfo p))
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 8958da6b..08f535e0 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -66,7 +66,9 @@ ensureChildProperties ps = ensure ps NoChange
ensure [] rs = return rs
ensure (p:ls) rs = do
hn <- asks hostName
- r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p)
+ r <- maybe (pure NoChange)
+ (actionMessageOn hn (getDesc p) . catchPropellor)
+ (getSatisfy p)
ensure ls (r <> rs)
-- | Lifts an action into the context of a different host.
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index 30dfd5ad..badc7293 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -46,7 +46,7 @@ ensureProperty
=> OuterMetaTypesWitness outer
-> Property (MetaTypes inner)
-> Propellor Result
-ensureProperty _ = catchPropellor . getSatisfy
+ensureProperty _ = maybe (pure NoChange) catchPropellor . getSatisfy
-- The name of this was chosen to make type errors a bit more understandable.
type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool
@@ -62,7 +62,7 @@ property'
-> (OuterMetaTypesWitness metatypes -> Propellor Result)
-> Property (MetaTypes metatypes)
property' d a =
- let p = Property sing d (a (outerMetaTypesWitness p)) mempty mempty
+ let p = Property sing d (Just (a (outerMetaTypesWitness p))) mempty mempty
in p
-- | Used to provide the metatypes of a Property to calls to
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 7860a3df..1a40bb75 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -120,13 +120,15 @@ onChange
-> CombinedType x y
onChange = combineWith combiner revertcombiner
where
- combiner p hook = do
+ combiner (Just p) (Just hook) = Just $ do
r <- p
case r of
MadeChange -> do
r' <- hook
return $ r <> r'
_ -> return r
+ combiner (Just p) Nothing = Just p
+ combiner Nothing _ = Nothing
revertcombiner = (<>)
-- | Same as `onChange` except that if property y fails, a flag file
@@ -144,24 +146,30 @@ onChangeFlagOnFail
-> CombinedType x y
onChangeFlagOnFail flagfile = combineWith combiner revertcombiner
where
- combiner s1 s2 = do
+ combiner (Just s1) s2 = Just $ do
r1 <- s1
case r1 of
MadeChange -> flagFailed s2
_ -> ifM (liftIO $ doesFileExist flagfile)
- (flagFailed s2
+ ( flagFailed s2
, return r1
)
+ combiner Nothing _ = Nothing
+
revertcombiner = (<>)
- flagFailed s = do
+
+ flagFailed (Just s) = do
r <- s
liftIO $ case r of
FailedChange -> createFlagFile
_ -> removeFlagFile
return r
+ flagFailed Nothing = return NoChange
+
createFlagFile = unlessM (doesFileExist flagfile) $ do
createDirectoryIfMissing True (takeDirectory flagfile)
writeFile flagfile ""
+
removeFlagFile = whenM (doesFileExist flagfile) $ removeFile flagfile
-- | Changes the description of a property.
@@ -178,11 +186,13 @@ infixl 1 ==>
fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
fallback = combineWith combiner revertcombiner
where
- combiner a1 a2 = do
+ combiner (Just a1) (Just a2) = Just $ do
r <- a1
if r == FailedChange
then a2
else return r
+ combiner (Just a1) Nothing = Just a1
+ combiner Nothing _ = Nothing
revertcombiner = (<>)
-- | Indicates that a Property may change a particular file. When the file
@@ -292,9 +302,9 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b]
-- are added as children, so their info will propigate.
c = withOS (getDesc a) $ \_ o ->
if matching o a
- then getSatisfy a
+ then maybe (pure NoChange) id (getSatisfy a)
else if matching o b
- then getSatisfy b
+ then maybe (pure NoChange) id (getSatisfy b)
else unsupportedOS'
matching Nothing _ = False
matching (Just o) p =
@@ -358,7 +368,7 @@ noChange :: Propellor Result
noChange = return NoChange
doNothing :: SingI t => Property (MetaTypes t)
-doNothing = property "noop property" noChange
+doNothing = property'' "noop property" Nothing
-- | Registers an action that should be run at the very end, after
-- propellor has checks all the properties of a host.
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index e69dc17d..e729d0cb 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -64,10 +64,13 @@ concurrently p1 p2 = (combineWith go go p1 p2)
-- Increase the number of capabilities right up to the number of
-- processors, so that A `concurrently` B `concurrently` C
-- runs all 3 properties on different processors when possible.
- go a1 a2 = do
+ go (Just a1) (Just a2) = Just $ do
n <- liftIO getNumProcessors
withCapabilities n $
concurrentSatisfy a1 a2
+ go (Just a1) Nothing = Just a1
+ go Nothing (Just a2) = Just a2
+ go Nothing Nothing = Nothing
-- | Ensures all the properties in the list, with a specified amount of
-- concurrency.
@@ -101,9 +104,9 @@ concurrentList getn d (Props ps) = property d go `addChildren` ps
Nothing -> return r
Just p -> do
hn <- asks hostName
- r' <- actionMessageOn hn
- (getDesc p)
- (getSatisfy p)
+ r' <- case getSatisfy p of
+ Nothing -> return NoChange
+ Just a -> actionMessageOn hn (getDesc p) a
worker q (r <> r')
-- | Run an action with the number of capabiities increased as necessary to
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 0eec04c7..11d201b1 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -53,7 +53,7 @@ combineProperties desc (Props ps) =
combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
combineSatisfy [] rs = return rs
combineSatisfy (p:ps) rs = do
- r <- catchPropellor $ getSatisfy p
+ r <- maybe (pure NoChange) catchPropellor (getSatisfy p)
case r of
FailedChange -> return FailedChange
_ -> combineSatisfy ps (r <> rs)
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 097c332d..6554abd2 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -12,6 +12,7 @@ module Propellor.Types (
Host(..)
, Property(..)
, property
+ , property''
, Desc
, RevertableProperty(..)
, (<!>)
@@ -56,7 +57,6 @@ import Propellor.Types.ZFS
-- | The core data type of Propellor, this represents a property
-- that the system should have, with a descrition, and an action to ensure
-- it has the property.
--- that have the property.
--
-- There are different types of properties that target different OS's,
-- and so have different metatypes.
@@ -67,7 +67,7 @@ import Propellor.Types.ZFS
--
-- There are many associated type families, which are mostly used
-- internally, so you needn't worry about them.
-data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty]
+data Property metatypes = Property metatypes Desc (Maybe (Propellor Result)) Info [ChildProperty]
instance Show (Property metatypes) where
show p = "property " ++ show (getDesc p)
@@ -90,11 +90,18 @@ property
=> Desc
-> Propellor Result
-> Property (MetaTypes metatypes)
-property d a = Property sing d a mempty mempty
+property d a = Property sing d (Just a) mempty mempty
+
+property''
+ :: SingI metatypes
+ => Desc
+ -> Maybe (Propellor Result)
+ -> Property (MetaTypes metatypes)
+property'' d a = Property sing d a mempty mempty
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
-adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c
+adjustPropertySatisfy (Property t d s i c) f = Property t d (f <$> s) i c
-- | A property that can be reverted. The first Property is run
-- normally and the second is run when it's reverted.
@@ -148,7 +155,7 @@ type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Re
type instance CombinedType (RevertableProperty (MetaTypes x) (MetaTypes x')) (Property (MetaTypes y)) = Property (MetaTypes (Combine x y))
type instance CombinedType (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) = Property (MetaTypes (Combine x y))
-type ResultCombiner = Propellor Result -> Propellor Result -> Propellor Result
+type ResultCombiner = Maybe (Propellor Result) -> Maybe (Propellor Result) -> Maybe (Propellor Result)
class Combines x y where
-- | Combines together two properties, yielding a property that
diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs
index 6fedc47e..dcd206eb 100644
--- a/src/Propellor/Types/Core.hs
+++ b/src/Propellor/Types/Core.hs
@@ -71,7 +71,7 @@ data Props metatypes = Props [ChildProperty]
-- | Since there are many different types of Properties, they cannot be put
-- into a list. The simplified ChildProperty can be put into a list.
-data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty]
+data ChildProperty = ChildProperty Desc (Maybe (Propellor Result)) Info [ChildProperty]
instance Show ChildProperty where
show p = "property " ++ show (getDesc p)
@@ -92,7 +92,7 @@ class IsProp p where
-- | Gets the action that can be run to satisfy a Property.
-- You should never run this action directly. Use
-- 'Propellor.EnsureProperty.ensureProperty` instead.
- getSatisfy :: p -> Propellor Result
+ getSatisfy :: p -> Maybe (Propellor Result)
instance IsProp ChildProperty where
setDesc (ChildProperty _ a i c) d = ChildProperty d a i c