summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-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
8 files changed, 46 insertions, 24 deletions
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
generated by cgit v1.3-2-g0d8e (git 2.53.0) at 2026-06-16 15:17:53 +0000