From 52ca81661f156122a3a5d4a438fea83e067215ac Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Wed, 15 Mar 2017 14:09:07 -0400 Subject: 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. --- src/Propellor/Container.hs | 2 +- src/Propellor/Engine.hs | 4 +++- src/Propellor/EnsureProperty.hs | 4 ++-- src/Propellor/Property.hs | 26 ++++++++++++++++++-------- src/Propellor/Property/Concurrent.hs | 11 +++++++---- src/Propellor/Property/List.hs | 2 +- src/Propellor/Types.hs | 17 ++++++++++++----- src/Propellor/Types/Core.hs | 4 ++-- 8 files changed, 46 insertions(+), 24 deletions(-) (limited to 'src/Propellor') 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 -- cgit v1.2.3