added GADT to determine between a property with info and without

Not yet used

src/Propellor/Engine.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PackageImports #-}
+{-# LANGUAGE GADTs #-}
 
 module Propellor.Engine (
 	mainProperties,
@@ -35,7 +36,7 @@ import Utility.Monad
 mainProperties :: Host -> IO ()
 mainProperties host = do
 	ret <- runPropellor host $
-		ensureProperties [Property "overall" (ensureProperties $ hostProperties host) mempty mempty]
+		ensureProperties [mkProperty "overall" (ensureProperties ps) mempty mempty]
 	h <- mkMessageHandle
         whenConsole h $
 		setTitle "propellor: done"
@@ -43,6 +44,8 @@ mainProperties host = do
 	case ret of
 		FailedChange -> exitWith (ExitFailure 1)
 		_ -> exitWith ExitSuccess
+  where
+	ps = hostProperties host
 
 -- | Runs a Propellor action with the specified host.
 --

src/Propellor/Info.hs

@@ -13,7 +13,7 @@ import Data.Monoid
 import Control.Applicative
 
 pureInfoProperty :: Desc -> Info -> Property 
-pureInfoProperty desc i = Property ("has " ++ desc) (return NoChange) i mempty
+pureInfoProperty desc i = mkProperty ("has " ++ desc) (return NoChange) i mempty
 
 askInfo :: (Info -> Val a) -> Propellor (Maybe a)
 askInfo f = asks (fromVal . f . hostInfo)

src/Propellor/PrivData.hs

@@ -97,7 +97,11 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
 		liftIO $ showSet $
 			map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist
 		return FailedChange
-	addinfo p = p { propertyInfo = propertyInfo p <> mempty { _privData = privset } }
+	addinfo p = mkProperty
+		(propertyDesc p)
+		(propertySatisfy p)
+		(propertyInfo p <> mempty { _privData = privset })
+		(propertyChildren p)
 	privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
 	fieldnames = map show fieldlist
 	fieldlist = map privDataField srclist

src/Propellor/PropAccum.hs

@@ -58,17 +58,18 @@ infixl 1 !
 -- PrivData Info is propigated, so that properties used inside a
 -- PropAccum will have the necessary PrivData available.
 propigateContainer :: PropAccum container => container -> Property -> Property
-propigateContainer c prop = prop
+propigateContainer c prop = mkProperty
-	{ propertyChildren = propertyChildren prop ++ hostprops
+	(propertyDesc prop)
-	}
+	(propertySatisfy prop)
+	(propertyInfo prop)
+	(propertyChildren prop ++ hostprops)
   where
 	hostprops = map go $ getProperties c
 	go p = 
 		let i = propertyInfo p
-		in p
+		    i' = mempty
-			{ propertyInfo = mempty
+			{ _dns = _dns i
-				{ _dns = _dns i
+			, _privData = _privData i
-				, _privData = _privData i
-				}
-			, propertyChildren = map go (propertyChildren p)
 			}
+		    cs = map go (propertyChildren p)
+		in mkProperty (propertyDesc p) (propertySatisfy p) i' cs

src/Propellor/Property.hs

@@ -16,19 +16,19 @@ import Utility.Monad
 
 -- Constructs a Property.
 property :: Desc -> Propellor Result -> Property
-property d s = Property d s mempty mempty
+property d s = mkProperty d s mempty mempty
 
 -- | Combines a list of properties, resulting in a single property
 -- that when run will run each property in the list in turn,
 -- and print out the description of each as it's run. Does not stop
 -- on failure; does propigate overall success/failure.
 propertyList :: Desc -> [Property] -> Property
-propertyList desc ps = Property desc (ensureProperties ps) mempty ps
+propertyList desc ps = mkProperty desc (ensureProperties ps) mempty ps
 
 -- | Combines a list of properties, resulting in one property that
 -- ensures each in turn. Stops if a property fails.
 combineProperties :: Desc -> [Property] -> Property
-combineProperties desc ps = Property desc (go ps NoChange) mempty ps
+combineProperties desc ps = mkProperty desc (go ps NoChange) mempty ps
   where
 	go [] rs = return rs
 	go (l:ls) rs = do
@@ -67,16 +67,16 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do
 --- | Whenever a change has to be made for a Property, causes a hook
 -- Property to also be run, but not otherwise.
 onChange :: Property -> Property -> Property
-p `onChange` hook = p
+p `onChange` hook = mkProperty (propertyDesc p) satisfy (propertyInfo p) cs
-	{ propertySatisfy = do
+  where
+	satisfy = do
 		r <- ensureProperty p
 		case r of
 			MadeChange -> do
 				r' <- ensureProperty hook
 				return $ r <> r'
 			_ -> return r
-	, propertyChildren = propertyChildren p ++ [hook]
+	cs = propertyChildren p ++ [hook]
-	}
 
 (==>) :: Desc -> Property -> Property
 (==>) = flip describe
@@ -92,10 +92,11 @@ check c p = adjustProperty p $ \satisfy -> ifM (liftIO c)
 -- | Tries the first property, but if it fails to work, instead uses
 -- the second.
 fallback :: Property -> Property -> Property
-fallback p1 p2 = p1' { propertyChildren = p2 : propertyChildren p1' }
+fallback p1 p2 = mkProperty (propertyDesc p1) satisfy (propertyInfo p1) cs
   where
-	p1' = adjustProperty p1 $ \satisfy -> do
+	cs = p2 : propertyChildren p1
-		r <- satisfy
+	satisfy = do
+		r <- propertySatisfy p1
 		if r == FailedChange
 			then propertySatisfy p2
 			else return r
@@ -129,7 +130,11 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1
 
 -- | Changes the action that is performed to satisfy a property. 
 adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property
-adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) }
+adjustProperty p f = mkProperty
+	(propertyDesc p)
+	(f (propertySatisfy p))
+	(propertyInfo p)
+	(propertyChildren p)
 
 makeChange :: IO () -> Propellor Result
 makeChange a = liftIO a >> return MadeChange

src/Propellor/Property/Chroot.hs

@@ -80,7 +80,11 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert
 propigateChrootInfo :: Chroot -> Property -> Property
 propigateChrootInfo c p = propigateContainer c p'
   where
-	p' = p { propertyInfo = propertyInfo p <> chrootInfo c }
+	p' = mkProperty
+		(propertyDesc p)
+		(propertySatisfy p)
+		(propertyInfo p <> chrootInfo c)
+		(propertyChildren p)
 
 chrootInfo :: Chroot -> Info
 chrootInfo (Chroot loc _ _ h) =

src/Propellor/Property/Dns.hs

@@ -77,7 +77,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
 	indomain = M.elems $ M.filterWithKey (\hn _ -> inDomain domain $ AbsDomain $ hn) hostmap
 	
 	(partialzone, zonewarnings) = genZone indomain hostmap domain soa
-	baseprop = Property ("dns primary for " ++ domain) satisfy
+	baseprop = mkProperty ("dns primary for " ++ domain) satisfy
 		(addNamedConf conf) []
 	satisfy = do
 		sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)

src/Propellor/Property/Docker.hs

@@ -137,7 +137,11 @@ docked ctr@(Container _ h) = RevertableProperty
 propigateContainerInfo :: Container -> Property -> Property
 propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p'
   where
-	p' = p { propertyInfo = propertyInfo p <> dockerinfo }
+	p' = mkProperty
+		(propertyDesc p)
+		(propertySatisfy p)
+		(propertyInfo p <> dockerinfo)
+		(propertyChildren p)
 	dockerinfo = dockerInfo $
 		mempty { _dockerContainers = M.singleton (hostName h) h }
 

src/Propellor/Types.hs

@@ -1,9 +1,16 @@
 {-# LANGUAGE PackageImports #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE EmptyDataDecls #-}
 
 module Propellor.Types
 	( Host(..)
 	, Property(..)
+	, mkProperty
+	, propertyDesc
+	, propertySatisfy
+	, propertyInfo
+	, propertyChildren
 	, RevertableProperty(..)
 	, IsProp(..)
 	, Desc
@@ -61,24 +68,49 @@ data EndAction = EndAction Desc (Result -> Propellor Result)
 -- | The core data type of Propellor, this represents a property
 -- that the system should have, and an action to ensure it has the
 -- property.
-data Property = Property
+data Property = IProperty (GProperty HasInfo) | SProperty (GProperty NoInfo)
-	{ propertyDesc :: Desc
+
-	, propertySatisfy :: Propellor Result
+-- | Constructs a Property
-	-- ^ must be idempotent; may run repeatedly
+mkProperty 
-	, propertyInfo :: Info
+	:: Desc -- ^ description of the property
-	-- ^ info associated with the property
+	-> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly)
-	, propertyChildren :: [Property]
+	-> Info -- ^ info associated with the property
-	-- ^ A property can include a list of child properties.
+	-> [Property] -- ^ child properties
-	-- This allows them to be introspected to collect their info,
+	-> Property
-	-- etc.
+mkProperty d a i cs
-	--
+	| isEmpty i && all isEmpty (map propertyInfo cs) = 
-	-- Note that listing Properties here does not ensure that
+		SProperty (GSProperty d a cs)
-	-- their propertySatisfy is run when satisfying the parent
+	| otherwise = IProperty (GIProperty d a i cs)
-	-- property; it's up to the parent's propertySatisfy to do that.
-	}
 
 instance Show Property where
-	show p = "property " ++ show (propertyDesc p)
+        show p = "property " ++ show (propertyDesc p)
+
+-- | This GADT allows creating operations that only act on Properties
+-- that do not add Info to their Host.
+data GProperty i where
+	GIProperty :: Desc -> Propellor Result -> Info -> [Property] -> GProperty HasInfo
+	GSProperty :: Desc -> Propellor Result -> [Property] -> GProperty NoInfo
+
+data HasInfo
+data NoInfo
+
+propertyDesc :: Property -> Desc
+propertyDesc (IProperty (GIProperty d _ _ _)) = d
+propertyDesc (SProperty (GSProperty d _ _)) = d
+
+propertySatisfy :: Property -> Propellor Result
+propertySatisfy (IProperty (GIProperty _ a _ _)) = a
+propertySatisfy (SProperty (GSProperty _ a _)) = a
+
+propertyInfo :: Property -> Info
+propertyInfo (IProperty (GIProperty _ _ i _)) = i
+propertyInfo (SProperty _) = mempty
+
+-- | A Property can include a list of child properties that it also
+-- satisfies. This allows them to be introspected to collect their info, etc.
+propertyChildren :: Property -> [Property]
+propertyChildren (IProperty (GIProperty _ _ _ cs)) = cs
+propertyChildren (SProperty (GSProperty _ _ cs)) = cs
 
 -- | A property that can be reverted.
 data RevertableProperty = RevertableProperty Property Property
@@ -95,17 +127,22 @@ class IsProp p where
 	getInfoRecursive :: p -> Info
 
 instance IsProp Property where
-	describe p d = p { propertyDesc = d }
+	describe (IProperty (GIProperty _ a i cs)) d = 
+		IProperty (GIProperty d a i cs)
+	describe (SProperty (GSProperty _ a cs)) d =
+		SProperty (GSProperty d a cs)
 	toProp p = p
-	getInfoRecursive p = propertyInfo p <> mconcat (map getInfoRecursive (propertyChildren p))
+	getInfoRecursive (IProperty (GIProperty _ _ i cs)) = 
-	x `requires` y = x 
+		i <> mconcat (map getInfoRecursive cs)
-		{ propertySatisfy = do
+	getInfoRecursive (SProperty _) = mempty
+	x `requires` y = mkProperty (propertyDesc x) satisfy (propertyInfo x) cs
+	  where
+		satisfy = do
 			r <- propertySatisfy y
 			case r of
 				FailedChange -> return FailedChange
 				_ -> propertySatisfy x
-		, propertyChildren = y : propertyChildren x
+		cs = y : propertyChildren x
-		}
 
 instance IsProp RevertableProperty where
 	-- | Sets the description of both sides.