From 414ee7eee60300eb7f7c49e4890b056d19b3c59b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 24 Jan 2015 13:59:29 -0400 Subject: added GADT to determine between a property with info and without Not yet used --- src/Propellor/Engine.hs | 5 ++- src/Propellor/Info.hs | 2 +- src/Propellor/PrivData.hs | 6 ++- src/Propellor/PropAccum.hs | 19 +++++----- src/Propellor/Property.hs | 27 ++++++++------ src/Propellor/Property/Chroot.hs | 6 ++- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 6 ++- src/Propellor/Types.hs | 81 +++++++++++++++++++++++++++++----------- 9 files changed, 106 insertions(+), 48 deletions(-) diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 0835660f..ddc22305 100644 --- a/src/Propellor/Engine.hs +++ b/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. -- diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index 6cb3342c..6d85cb74 100644 --- a/src/Propellor/Info.hs +++ b/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) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 9e35274a..1e7a9d28 100644 --- a/src/Propellor/PrivData.hs +++ b/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 diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index beca8ccc..ddbc1e66 100644 --- a/src/Propellor/PropAccum.hs +++ b/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 - { propertyChildren = propertyChildren prop ++ hostprops - } +propigateContainer c prop = mkProperty + (propertyDesc prop) + (propertySatisfy prop) + (propertyInfo prop) + (propertyChildren prop ++ hostprops) where hostprops = map go $ getProperties c go p = let i = propertyInfo p - in p - { propertyInfo = mempty - { _dns = _dns i - , _privData = _privData i - } - , propertyChildren = map go (propertyChildren p) + i' = mempty + { _dns = _dns i + , _privData = _privData i } + cs = map go (propertyChildren p) + in mkProperty (propertyDesc p) (propertySatisfy p) i' cs diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 9db08b2d..faf66074 100644 --- a/src/Propellor/Property.hs +++ b/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 - { propertySatisfy = do +p `onChange` hook = mkProperty (propertyDesc p) satisfy (propertyInfo p) cs + 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 - r <- satisfy + cs = p2 : propertyChildren p1 + 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 diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index e8afb656..0ef6e7dd 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/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) = diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 6114834c..d6666618 100644 --- a/src/Propellor/Property/Dns.hs +++ b/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) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index b641c89c..9645bfe7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/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 } diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index 12fa676b..ba8b7b95 100644 --- a/src/Propellor/Types.hs +++ b/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 - { propertyDesc :: Desc - , propertySatisfy :: Propellor Result - -- ^ must be idempotent; may run repeatedly - , propertyInfo :: Info - -- ^ info associated with the property - , propertyChildren :: [Property] - -- ^ A property can include a list of child properties. - -- This allows them to be introspected to collect their info, - -- etc. - -- - -- Note that listing Properties here does not ensure that - -- their propertySatisfy is run when satisfying the parent - -- property; it's up to the parent's propertySatisfy to do that. - } +data Property = IProperty (GProperty HasInfo) | SProperty (GProperty NoInfo) + +-- | Constructs a Property +mkProperty + :: Desc -- ^ description of the property + -> Propellor Result -- ^ action to run to satisfy the property (must be idempotent; may run repeatedly) + -> Info -- ^ info associated with the property + -> [Property] -- ^ child properties + -> Property +mkProperty d a i cs + | isEmpty i && all isEmpty (map propertyInfo cs) = + SProperty (GSProperty d a cs) + | otherwise = IProperty (GIProperty d a i cs) 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)) - x `requires` y = x - { propertySatisfy = do + getInfoRecursive (IProperty (GIProperty _ _ i cs)) = + i <> mconcat (map getInfoRecursive cs) + 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. -- cgit v1.2.3