summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorJoey Hess2015-01-24 13:59:29 -0400
committerJoey Hess2015-01-24 16:53:59 -0400
commit414ee7eee60300eb7f7c49e4890b056d19b3c59b (patch)
tree93f7ca55067b2c2e00c04110e8605c4d67088fea /src
parent38eec6fc37054df1838be905670e1ed1ff308a65 (diff)
added GADT to determine between a property with info and without
Not yet used
Diffstat (limited to 'src')
-rw-r--r--src/Propellor/Engine.hs5
-rw-r--r--src/Propellor/Info.hs2
-rw-r--r--src/Propellor/PrivData.hs6
-rw-r--r--src/Propellor/PropAccum.hs19
-rw-r--r--src/Propellor/Property.hs27
-rw-r--r--src/Propellor/Property/Chroot.hs6
-rw-r--r--src/Propellor/Property/Dns.hs2
-rw-r--r--src/Propellor/Property/Docker.hs6
-rw-r--r--src/Propellor/Types.hs81
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.