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).

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