summaryrefslogtreecommitdiff
path: root/src/Propellor
diff options
context:
space:
mode:
authorJoey Hess2015-10-24 16:43:26 -0400
committerJoey Hess2015-10-24 17:53:26 -0400
commit2410a8f1d6c850142181d724f4abd706a82b9593 (patch)
tree9c824830406ed9531826100d0f2aee255abe8f4c /src/Propellor
parente9cac11ad3df54208b4a41d945ac9a333d21bb07 (diff)
improve RevertableProperty combining
* Various property combinators that combined a RevertableProperty with a non-revertable property used to yield a RevertableProperty. This was a bug, because the combined property could not be fully reverted in many cases. Fixed by making the combined property instead be a Property HasInfo. * combineWith now takes an addional parameter to control how revert actions are combined (API change).
Diffstat (limited to 'src/Propellor')
-rw-r--r--src/Propellor/Property.hs69
-rw-r--r--src/Propellor/Property/Concurrent.hs10
-rw-r--r--src/Propellor/Property/Dns.hs2
-rw-r--r--src/Propellor/Property/DnsSec.hs4
-rw-r--r--src/Propellor/Property/SiteSpecific/JoeySites.hs2
-rw-r--r--src/Propellor/Types.hs81
6 files changed, 94 insertions, 74 deletions
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 95805054..d80d9c1f 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -66,30 +66,43 @@ flagFile' p getflagfile = adjustPropertySatisfy p $ \satisfy -> do
-- | Indicates that the first property depends on the second,
-- so before the first is ensured, the second must be ensured.
+--
+-- The combined property uses the description of the first property.
requires :: Combines x y => x -> y -> CombinedType x y
-requires = (<<>>)
+requires = combineWith
+ -- Run action of y, then x
+ (flip (<>))
+ -- When reverting, run in reverse order.
+ (<>)
-- | Combines together two properties, resulting in one property
-- that ensures the first, and if the first succeeds, ensures the second.
--
-- The combined property uses the description of the first property.
-before :: (IsProp x, Combines y x, IsProp (CombinedType y x)) => x -> y -> CombinedType y x
-before x y = (y `requires` x) `describe` getDesc x
+before :: Combines x y => x -> y -> CombinedType x y
+before = combineWith
+ -- Run action of x, then y
+ (<>)
+ -- When reverting, run in reverse order.
+ (flip (<>))
-- | Whenever a change has to be made for a Property, causes a hook
-- Property to also be run, but not otherwise.
onChange
- :: (Combines (Property x) (Property y))
- => Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-onChange = combineWith $ \p hook -> do
- r <- p
- case r of
- MadeChange -> do
- r' <- hook
- return $ r <> r'
- _ -> return r
+ :: (Combines x y)
+ => x
+ -> y
+ -> CombinedType x y
+onChange = combineWith combiner revertcombiner
+ where
+ combiner p hook = do
+ r <- p
+ case r of
+ MadeChange -> do
+ r' <- hook
+ return $ r <> r'
+ _ -> return r
+ revertcombiner = (<>)
-- | Same as `onChange` except that if property y fails, a flag file
-- is generated. On next run, if the flag file is present, property y
@@ -99,14 +112,14 @@ onChange = combineWith $ \p hook -> do
-- `FailedChange`. But if this property is applied again, it returns
-- `NoChange`. This behavior can cause trouble...
onChangeFlagOnFail
- :: (Combines (Property x) (Property y))
+ :: (Combines x y)
=> FilePath
- -> Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-onChangeFlagOnFail flagfile = combineWith go
+ -> x
+ -> y
+ -> CombinedType x y
+onChangeFlagOnFail flagfile = combineWith combiner revertcombiner
where
- go s1 s2 = do
+ combiner s1 s2 = do
r1 <- s1
case r1 of
MadeChange -> flagFailed s2
@@ -114,6 +127,7 @@ onChangeFlagOnFail flagfile = combineWith go
(flagFailed s2
, return r1
)
+ revertcombiner = (<>)
flagFailed s = do
r <- s
liftIO $ case r of
@@ -151,12 +165,15 @@ check c p = adjustPropertySatisfy p $ \satisfy ->
-- | Tries the first property, but if it fails to work, instead uses
-- the second.
-fallback :: (Combines (Property p1) (Property p2)) => Property p1 -> Property p2 -> Property (CInfo p1 p2)
-fallback = combineWith $ \a1 a2 -> do
- r <- a1
- if r == FailedChange
- then a2
- else return r
+fallback :: (Combines p1 p2) => p1 -> p2 -> CombinedType p1 p2
+fallback = combineWith combiner revertcombiner
+ where
+ combiner a1 a2 = do
+ r <- a1
+ if r == FailedChange
+ then a2
+ else return r
+ revertcombiner = (<>)
-- | Marks a Property as trivial. It can only return FailedChange or
-- NoChange.
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index 95fd9fc5..c57f5228 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -21,11 +21,11 @@ import Control.Monad.RWS.Strict
-- | Ensures two properties concurrently.
concurrently
- :: (IsProp (Property x), IsProp (Property y), Combines (Property x) (Property y), IsProp (Property (CInfo x y)))
- => Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-concurrently p1 p2 = (combineWith go p1 p2)
+ :: (IsProp p1, IsProp p2, Combines p1 p2, IsProp (CombinedType p1 p2))
+ => p1
+ -> p2
+ -> CombinedType p1 p2
+concurrently p1 p2 = (combineWith go go p1 p2)
`describe` d
where
d = getDesc p1 ++ " `concurrently` " ++ getDesc p2
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index 6646582b..4c2f787f 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -164,7 +164,7 @@ signedPrimary recurrance hosts domain soa rs = setup <!> cleanup
`onChange` Service.reloaded "bind9"
cleanup = cleanupPrimary zonefile domain
- `onChange` toProp (revert (zoneSigned domain zonefile))
+ `onChange` revert (zoneSigned domain zonefile)
`onChange` Service.reloaded "bind9"
-- Include the public keys into the zone file.
diff --git a/src/Propellor/Property/DnsSec.hs b/src/Propellor/Property/DnsSec.hs
index 7d1414d4..c0aa1302 100644
--- a/src/Propellor/Property/DnsSec.hs
+++ b/src/Propellor/Property/DnsSec.hs
@@ -41,11 +41,11 @@ zoneSigned :: Domain -> FilePath -> RevertableProperty
zoneSigned domain zonefile = setup <!> cleanup
where
setup = check needupdate (forceZoneSigned domain zonefile)
- `requires` toProp (keysInstalled domain)
+ `requires` keysInstalled domain
cleanup = File.notPresent (signedZoneFile zonefile)
`before` File.notPresent dssetfile
- `before` toProp (revert (keysInstalled domain))
+ `before` revert (keysInstalled domain)
dssetfile = dir </> "-" ++ domain ++ "."
dir = takeDirectory zonefile
diff --git a/src/Propellor/Property/SiteSpecific/JoeySites.hs b/src/Propellor/Property/SiteSpecific/JoeySites.hs
index 70d5884f..92903e9a 100644
--- a/src/Propellor/Property/SiteSpecific/JoeySites.hs
+++ b/src/Propellor/Property/SiteSpecific/JoeySites.hs
@@ -924,7 +924,7 @@ legacyWebSites = propertyList "legacy web sites" $ props
userDirHtml :: Property HasInfo
userDirHtml = File.fileProperty "apache userdir is html" (map munge) conf
`onChange` Apache.reloaded
- `requires` (toProp $ Apache.modEnabled "userdir")
+ `requires` Apache.modEnabled "userdir"
where
munge = replace "public_html" "html"
conf = "/etc/apache2/mods-available/userdir.conf"
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 5904374e..5f0e0561 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -27,7 +27,6 @@ module Propellor.Types
, IsProp(..)
, Combines(..)
, CombinedType
- , combineWith
, Propellor(..)
, LiftPropellor(..)
, EndAction(..)
@@ -160,6 +159,9 @@ propertySatisfy (SProperty _ a _) = a
instance Show (Property i) where
show p = "property " ++ show (propertyDesc p)
+instance Show RevertableProperty where
+ show (RevertableProperty p _) = "property " ++ show (propertyDesc p)
+
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property i -> (Propellor Result -> Propellor Result) -> Property i
adjustPropertySatisfy (IProperty d s i cs) f = IProperty d (f s) i cs
@@ -221,57 +223,58 @@ instance IsProp RevertableProperty where
-- types of properties.
type family CombinedType x y
type instance CombinedType (Property x) (Property y) = Property (CInfo x y)
-type instance CombinedType RevertableProperty (Property NoInfo) = RevertableProperty
-type instance CombinedType RevertableProperty (Property HasInfo) = RevertableProperty
type instance CombinedType RevertableProperty RevertableProperty = RevertableProperty
+-- When only one of the properties is revertable, the combined property is
+-- not fully revertable, so is not a RevertableProperty.
+type instance CombinedType RevertableProperty (Property NoInfo) = Property HasInfo
+type instance CombinedType RevertableProperty (Property HasInfo) = Property HasInfo
+type instance CombinedType (Property NoInfo) RevertableProperty = Property HasInfo
+type instance CombinedType (Property HasInfo) RevertableProperty = Property HasInfo
class Combines x y where
- -- | Combines two properties. The second property is ensured
- -- first, and only once it is successfully ensures will the first
- -- be ensured. The combined property will have the description of
- -- the first property.
- (<<>>) :: x -> y -> CombinedType x y
-
--- | Combines together two properties, yielding a property that
--- has the description and info of the first, and that has the second
--- property as a child. The two actions to satisfy the properties
--- are passed to a function that can combine them in arbitrary ways.
-combineWith
- :: (Combines (Property x) (Property y))
- => (Propellor Result -> Propellor Result -> Propellor Result)
- -> Property x
- -> Property y
- -> CombinedType (Property x) (Property y)
-combineWith f x y = adjustPropertySatisfy (x <<>> y) $ \_ ->
- f (propertySatisfy $ toSProperty x) (propertySatisfy $ toSProperty y)
+ -- | Combines together two properties, yielding a property that
+ -- has the description and info of the first, and that has the second
+ -- property as a child.
+ combineWith
+ :: (Propellor Result -> Propellor Result -> Propellor Result)
+ -- ^ How to combine the actions to satisfy the properties.
+ -> (Propellor Result -> Propellor Result -> Propellor Result)
+ -- ^ Used when combining revertable properties, to combine
+ -- their reversion actions.
+ -> x
+ -> y
+ -> CombinedType x y
instance Combines (Property HasInfo) (Property HasInfo) where
- (IProperty d1 a1 i1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) =
- IProperty d1 (a2 <> a1) i1 (y : cs1)
+ combineWith f _ (IProperty d1 a1 i1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (f a1 a2) i1 (y : cs1)
instance Combines (Property HasInfo) (Property NoInfo) where
- (IProperty d1 a1 i1 cs1) <<>> y@(SProperty _d2 a2 _cs2) =
- IProperty d1 (a2 <> a1) i1 (toIProperty y : cs1)
+ combineWith f _ (IProperty d1 a1 i1 cs1) y@(SProperty _d2 a2 _cs2) =
+ IProperty d1 (f a1 a2) i1 (toIProperty y : cs1)
instance Combines (Property NoInfo) (Property HasInfo) where
- (SProperty d1 a1 cs1) <<>> y@(IProperty _d2 a2 _i2 _cs2) =
- IProperty d1 (a2 <> a1) mempty (y : map toIProperty cs1)
+ combineWith f _ (SProperty d1 a1 cs1) y@(IProperty _d2 a2 _i2 _cs2) =
+ IProperty d1 (f a1 a2) mempty (y : map toIProperty cs1)
instance Combines (Property NoInfo) (Property NoInfo) where
- (SProperty d1 a1 cs1) <<>> y@(SProperty _d2 a2 _cs2) =
- SProperty d1 (a2 <> a1) (y : cs1)
+ combineWith f _ (SProperty d1 a1 cs1) y@(SProperty _d2 a2 _cs2) =
+ SProperty d1 (f a1 a2) (y : cs1)
+
+instance Combines RevertableProperty RevertableProperty where
+ combineWith sf tf (RevertableProperty setup1 teardown1) (RevertableProperty setup2 teardown2) =
+ RevertableProperty
+ (combineWith sf tf setup1 setup2)
+ (combineWith tf sf teardown1 teardown2)
instance Combines RevertableProperty (Property HasInfo) where
- (RevertableProperty p1 p2) <<>> y =
- RevertableProperty (p1 <<>> y) p2
+ combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
instance Combines RevertableProperty (Property NoInfo) where
- (RevertableProperty p1 p2) <<>> y =
- RevertableProperty (p1 <<>> toIProperty y) p2
+ combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y
-instance Combines RevertableProperty RevertableProperty where
- (RevertableProperty x1 x2) <<>> (RevertableProperty y1 y2) =
- RevertableProperty
- (x1 <<>> y1)
- -- when reverting, run actions in reverse order
- (y2 <<>> x2)
+instance Combines (Property HasInfo) RevertableProperty where
+ combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y
+
+instance Combines (Property NoInfo) RevertableProperty where
+ combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y