summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2016-03-25 14:04:40 -0400
committerJoey Hess2016-03-25 14:04:40 -0400
commit91d1833155a2e8be2c435d0a92a750cc9d2f30b5 (patch)
treebd9662a258b4b0544e19295a319b61086a201d6f
parent48a05503493caeb80794a872b0e3b4482d5859ce (diff)
ported Property.List
I wanted to keep propertyList [foo, bar] working, but had some difficulty making the type class approach work. Anyway, that's unlikely to be useful, since foo and bar probably have different types, or could easiy have their types updated breaking it.
-rw-r--r--debian/changelog34
-rw-r--r--src/Propellor/Base.hs4
-rw-r--r--src/Propellor/Engine.hs16
-rw-r--r--src/Propellor/EnsureProperty.hs2
-rw-r--r--src/Propellor/PrivData.hs2
-rw-r--r--src/Propellor/PropAccum.hs9
-rw-r--r--src/Propellor/Property.hs4
-rw-r--r--src/Propellor/Property/Chroot.hs2
-rw-r--r--src/Propellor/Property/Concurrent.hs4
-rw-r--r--src/Propellor/Property/Docker.hs2
-rw-r--r--src/Propellor/Property/List.hs104
-rw-r--r--src/Propellor/Types.hs20
12 files changed, 93 insertions, 110 deletions
diff --git a/debian/changelog b/debian/changelog
index ead6585e..b27559bd 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,37 +1,43 @@
propellor (3.0.0) UNRELEASED; urgency=medium
* Property types have been improved to indicate what systems they target.
- This allows, eg, Property Debian to not be used on a FreeBSD system.
+ This prevents using eg, Property FreeBSD on a Debian system.
Transition guide for this sweeping API change:
+ - Change "host name & foo & bar"
+ to "host name $ props & foo & bar"
+ - Similarly, Chroot and Docker need `props` to be used to combine
+ together the properies used inside them.
+ - And similarly, `propertyList` and `combineProperties` need `props`
+ to be used to combine together properties; lists of properties will
+ no longer work.
- Change "Property NoInfo" to "Property UnixLike"
- Change "Property HasInfo" to "Property (HasInfo + UnixLike)"
- Change "RevertableProperty NoInfo" to
"RevertableProperty UnixLike UnixLike"
- Change "RevertableProperty HasInfo" to
"RevertableProperty (HasInfo + UnixLike) UnixLike"
- - GHC needs {-# LANGUAGE TypeOperators #-} to use these new type signatures.
+ - GHC needs {-# LANGUAGE TypeOperators #-} to use these fancy types.
This is enabled by default for all modules in propellor.cabal. But
if you are using propellor as a library, you may need to enable it
manually.
- If you know a property only works on a particular OS, like Debian
or FreeBSD, use that instead of "UnixLike". For example:
- "Property (HasInfo + Debian)"
+ "Property Debian"
- It's also possible make a property support a set of OS's, for example:
- "Property (HasInfo + Debian + FreeBSD)"
- - `ensureProperty` now needs information about the metatypes of the
- property it's used in to be passed to it. See the documentation
- of `ensureProperty` for an example, but basically, change
- this: foo = property desc $ ... ensureProperty bar
- to this: foo = property' desc $ \o -> ... ensureProperty o bar
+ "Property (Debian + FreeBSD)"
+ - `ensureProperty` now needs to be passed information about the
+ property it's used in.
+ change this: foo = property desc $ ... ensureProperty bar
+ to this: foo = property' desc $ \o -> ... ensureProperty o bar
- General purpose properties like cmdProperty have type "Property UnixLike".
When using that to run a command only available on Debian, you can
- tighten the targets to only the OS that your more specific
- property works on. For example:
+ tighten the type to only the OS that your more specific property works on.
+ For example:
upgraded :: Property Debian
upgraded = tightenTargets (cmdProperty "apt-get" ["upgrade"])
- - The new `pickOS` property combinator can be used to combine different
- properties, supporting different OS's, into one Property that chooses
- what to do based on the Host's OS.
+ * The new `pickOS` property combinator can be used to combine different
+ properties, supporting different OS's, into one Property that chooses
+ what to do based on the Host's OS.
-- Joey Hess <id@joeyh.name> Thu, 24 Mar 2016 15:02:33 -0400
diff --git a/src/Propellor/Base.hs b/src/Propellor/Base.hs
index e50adf10..4afad2ab 100644
--- a/src/Propellor/Base.hs
+++ b/src/Propellor/Base.hs
@@ -9,7 +9,7 @@ module Propellor.Base (
, module Propellor.Property.Cmd
--, module Propellor.Property.List
, module Propellor.Types.PrivData
- --, module Propellor.PropAccum
+ , module Propellor.PropAccum
, module Propellor.Info
, module Propellor.PrivData
--, module Propellor.Engine
@@ -43,7 +43,7 @@ import Propellor.Message
import Propellor.Debug
import Propellor.Exception
import Propellor.Info
---import Propellor.PropAccum
+import Propellor.PropAccum
import Propellor.Location
import Propellor.Utilities
diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs
index 2e914d67..62fad5af 100644
--- a/src/Propellor/Engine.hs
+++ b/src/Propellor/Engine.hs
@@ -2,10 +2,10 @@
{-# LANGUAGE GADTs #-}
module Propellor.Engine (
- mainProperties,
+ -- mainProperties,
runPropellor,
ensureProperty,
- ensureProperties,
+ ensureChildProperties,
fromHost,
fromHost',
onlyProcess,
@@ -29,6 +29,8 @@ import Propellor.Info
import Propellor.Property
import Utility.Exception
+{-
+
-- | Gets the Properties of a Host, and ensures them all,
-- with nice display of what's being done.
mainProperties :: Host -> IO ()
@@ -42,6 +44,8 @@ mainProperties host = do
where
ps = map ignoreInfo $ hostProperties host
+-}
+
-- | Runs a Propellor action with the specified host.
--
-- If the Result is not FailedChange, any EndActions
@@ -58,14 +62,14 @@ runEndAction host res (EndAction desc a) = actionMessageOn (hostName host) desc
(ret, _s, _) <- runRWST (runWithHost (catchPropellor (a res))) host ()
return ret
--- | Ensures a list of Properties, with a display of each as it runs.
-ensureProperties :: [Property NoInfo] -> Propellor Result
-ensureProperties ps = ensure ps NoChange
+-- | Ensures the child properties, with a display of each as it runs.
+ensureChildProperties :: [ChildProperty] -> Propellor Result
+ensureChildProperties ps = ensure ps NoChange
where
ensure [] rs = return rs
ensure (p:ls) rs = do
hn <- asks hostName
- r <- actionMessageOn hn (propertyDesc p) (ensureProperty p)
+ r <- actionMessageOn hn (getDesc p) (catchPropellor $ getSatisfy p)
ensure ls (r <> rs)
-- | Lifts an action into the context of a different host.
diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs
index f42003c0..21f8acce 100644
--- a/src/Propellor/EnsureProperty.hs
+++ b/src/Propellor/EnsureProperty.hs
@@ -39,7 +39,7 @@ ensureProperty
=> OuterMetaTypes outer
-> Property (MetaTypes inner)
-> Propellor Result
-ensureProperty _ = catchPropellor . propertySatisfy
+ensureProperty _ = catchPropellor . getSatisfy
-- The name of this was chosen to make type errors a more understandable.
type family CannotUse_ensureProperty_WithInfo (l :: [a]) :: Bool
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index bc61c538..5e6e0869 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -129,7 +129,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
return FailedChange
addinfo p = Property undefined -- FIXME: should use sing here
(propertyDesc p)
- (propertySatisfy p)
+ (getSatisfy p)
(propertyInfo p `addInfo` privset)
(propertyChildren p)
privset = PrivInfo $ S.fromList $
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index fb38e260..8177b97b 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -36,8 +36,9 @@ host hn (Props i c) = Host hn c i
-- metatypes and info.
data Props metatypes = Props Info [ChildProperty]
--- | Start constructing a Props. Properties can then be added to it using
--- `(&)` etc.
+-- | Start accumulating a list of properties.
+--
+-- Properties can be added to it using `(&)` etc.
props :: Props UnixLike
props = Props mempty []
@@ -102,7 +103,7 @@ propagateContainer
propagateContainer containername c prop = Property
undefined
(propertyDesc prop)
- (propertySatisfy prop)
+ (getSatisfy prop)
(propertyInfo prop)
(propertyChildren prop ++ hostprops)
where
@@ -111,6 +112,6 @@ propagateContainer containername c prop = Property
let i = mapInfo (forceHostContext containername)
(propagatableInfo (propertyInfo p))
cs = map go (propertyChildren p)
- in infoProperty (propertyDesc p) (propertySatisfy p) i cs
+ in infoProperty (propertyDesc p) (getSatisfy p) i cs
-}
diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs
index 582b7cfb..8999d8d8 100644
--- a/src/Propellor/Property.hs
+++ b/src/Propellor/Property.hs
@@ -255,8 +255,8 @@ isNewerThan x y = do
tightenTargets
::
-- Note that this uses PolyKinds
- ( (Targets old `NotSuperset` Targets new) ~ 'CanCombineTargets
- , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombineTargets
+ ( (Targets old `NotSuperset` Targets new) ~ 'CanCombine
+ , (NonTargets new `NotSuperset` NonTargets old) ~ 'CanCombine
, SingI new
)
=> Property (MetaTypes old)
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index 378836e8..fb05d659 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -148,7 +148,7 @@ propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p'
where
p' = infoProperty
(propertyDesc p)
- (propertySatisfy p)
+ (getSatisfy p)
(propertyInfo p <> chrootInfo c)
(propertyChildren p)
diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs
index 74afecc4..8d608a54 100644
--- a/src/Propellor/Property/Concurrent.hs
+++ b/src/Propellor/Property/Concurrent.hs
@@ -97,7 +97,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps
(p:rest) -> return (rest, Just p)
case v of
Nothing -> return r
- -- This use of propertySatisfy does not lose any
+ -- This use of getSatisfy does not lose any
-- Info asociated with the property, because
-- concurrentList sets all the properties as
-- children, and so propigates their info.
@@ -105,7 +105,7 @@ concurrentList getn d (PropList ps) = infoProperty d go mempty ps
hn <- asks hostName
r' <- actionMessageOn hn
(propertyDesc p)
- (propertySatisfy p)
+ (getSatisfy p)
worker q (r <> r')
-- | Run an action with the number of capabiities increased as necessary to
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index ebc0b301..c2c131c7 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -178,7 +178,7 @@ propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p'
where
p' = infoProperty
(propertyDesc p)
- (propertySatisfy p)
+ (getSatisfy p)
(propertyInfo p <> dockerinfo)
(propertyChildren p)
dockerinfo = dockerInfo $
diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs
index 74aa6ca6..b4a72fa8 100644
--- a/src/Propellor/Property/List.hs
+++ b/src/Propellor/Property/List.hs
@@ -1,86 +1,54 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
module Propellor.Property.List (
props,
- PropertyList(..),
- PropertyListType,
- PropList(..),
+ Props,
+ propertyList,
+ combineProperties,
) where
import Propellor.Types
+import Propellor.Types.MetaTypes
import Propellor.Engine
import Propellor.PropAccum
+import Propellor.Exception
import Data.Monoid
--- | Starts accumulating a list of properties.
+-- | 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 propagate overall success/failure.
+--
+-- For example:
--
-- > propertyList "foo" $ props
--- > & someproperty
--- > ! oldproperty
--- > & otherproperty
-props :: PropList
-props = PropList []
-
-data PropList = PropList [Property HasInfo]
-
-instance PropAccum PropList where
- PropList l `addProp` p = PropList (toProp p : l)
- PropList l `addPropFront` p = PropList (l ++ [toProp p])
- getProperties (PropList l) = reverse l
-
-class PropertyList l where
- -- | 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 propagate overall success/failure.
- --
- -- Note that Property HasInfo and Property NoInfo are not the same
- -- type, and so cannot be mixed in a list. To make a list of
- -- mixed types, which can also include RevertableProperty,
- -- use `props`
- propertyList :: Desc -> l -> Property (PropertyListType l)
-
- -- | Combines a list of properties, resulting in one property that
- -- ensures each in turn. Stops if a property fails.
- combineProperties :: Desc -> l -> Property (PropertyListType l)
-
--- | Type level function to calculate whether a PropertyList has Info.
-type family PropertyListType t
-type instance PropertyListType [Property HasInfo] = HasInfo
-type instance PropertyListType [Property NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty NoInfo] = NoInfo
-type instance PropertyListType [RevertableProperty HasInfo] = HasInfo
-type instance PropertyListType PropList = HasInfo
-
-instance PropertyList [Property NoInfo] where
- propertyList desc ps = simpleProperty desc (ensureProperties ps) ps
- combineProperties desc ps = simpleProperty desc (combineSatisfy ps NoChange) ps
-
-instance PropertyList [Property HasInfo] where
- -- It's ok to use ignoreInfo here, because the ps are made the
- -- child properties of the property, and so their info is visible
- -- that way.
- propertyList desc ps = infoProperty desc (ensureProperties $ map ignoreInfo ps) mempty ps
- combineProperties desc ps = infoProperty desc (combineSatisfy ps NoChange) mempty ps
-
-instance PropertyList [RevertableProperty HasInfo] where
- propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
- combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList [RevertableProperty NoInfo] where
- propertyList desc ps = propertyList desc (map setupRevertableProperty ps)
- combineProperties desc ps = combineProperties desc (map setupRevertableProperty ps)
-
-instance PropertyList PropList where
- propertyList desc = propertyList desc . getProperties
- combineProperties desc = combineProperties desc . getProperties
-
-combineSatisfy :: [Property i] -> Result -> Propellor Result
+-- > & bar
+-- > & baz
+propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+propertyList desc (Props _i ps) =
+ property desc (ensureChildProperties cs)
+ `modifyChildren` (++ cs)
+ where
+ cs = map toProp ps
+
+-- | Combines a list of properties, resulting in one property that
+-- ensures each in turn. Stops if a property fails.
+combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes)
+combineProperties desc (Props _i ps) =
+ property desc (combineSatisfy cs NoChange)
+ `modifyChildren` (++ cs)
+ where
+ cs = map toProp ps
+
+combineSatisfy :: [ChildProperty] -> Result -> Propellor Result
combineSatisfy [] rs = return rs
-combineSatisfy (l:ls) rs = do
- r <- ensureProperty $ ignoreInfo l
+combineSatisfy (p:ps) rs = do
+ r <- catchPropellor $ getSatisfy p
case r of
FailedChange -> return FailedChange
- _ -> combineSatisfy ls (r <> rs)
+ _ -> combineSatisfy ps (r <> rs)
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 42c12492..db05e100 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -14,6 +14,7 @@ module Propellor.Types
, Info
, Desc
, MetaType(..)
+ , MetaTypes
, OS(..)
, UnixLike
, Debian
@@ -41,8 +42,6 @@ module Propellor.Types
, module Propellor.Types.Dns
, module Propellor.Types.Result
, module Propellor.Types.ZFS
- , propertySatisfy
- , MetaTypes
) where
import Data.Monoid
@@ -169,12 +168,6 @@ ignoreInfo =
-}
--- | Gets the action that can be run to satisfy a Property.
--- You should never run this action directly. Use
--- 'Propellor.EnsureProperty.ensureProperty` instead.
-propertySatisfy :: Property metatypes -> Propellor Result
-propertySatisfy (Property _ _ a _ _) = a
-
-- | Changes the action that is performed to satisfy a property.
adjustPropertySatisfy :: Property metatypes -> (Propellor Result -> Propellor Result) -> Property metatypes
adjustPropertySatisfy (Property t d s i c) f = Property t d (f s) i c
@@ -214,34 +207,45 @@ setup <!> undo = RevertableProperty setup undo
class IsProp p where
setDesc :: p -> Desc -> p
getDesc :: p -> Desc
+ modifyChildren :: p -> ([ChildProperty] -> [ChildProperty]) -> p
-- | Gets the info of the property, combined with all info
-- of all children properties.
getInfoRecursive :: p -> Info
toProp :: p -> ChildProperty
+ -- | Gets the action that can be run to satisfy a Property.
+ -- You should never run this action directly. Use
+ -- 'Propellor.EnsureProperty.ensureProperty` instead.
+ getSatisfy :: p -> Propellor Result
instance IsProp (Property metatypes) where
setDesc (Property t _ a i c) d = Property t d a i c
getDesc = propertyDesc
+ modifyChildren (Property t d a i c) f = Property t d a i (f c)
getInfoRecursive (Property _ _ _ i c) =
i <> mconcat (map getInfoRecursive c)
toProp (Property _ d a i c) = ChildProperty d a i c
+ getSatisfy (Property _ _ a _ _) = a
instance IsProp ChildProperty where
setDesc (ChildProperty _ a i c) d = ChildProperty d a i c
getDesc (ChildProperty d _ _ _) = d
+ modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c)
getInfoRecursive (ChildProperty _ _ i c) =
i <> mconcat (map getInfoRecursive c)
toProp = id
+ getSatisfy (ChildProperty _ a _ _) = a
instance IsProp (RevertableProperty setupmetatypes undometatypes) where
-- | Sets the description of both sides.
setDesc (RevertableProperty p1 p2) d =
RevertableProperty (setDesc p1 d) (setDesc p2 ("not " ++ d))
getDesc (RevertableProperty p1 _) = getDesc p1
+ modifyChildren (RevertableProperty p1 p2) f = RevertableProperty (modifyChildren p1 f) (modifyChildren p2 f)
-- toProp (RevertableProperty p1 _) = p1
-- | Return the Info of the currently active side.
getInfoRecursive (RevertableProperty p1 _p2) = getInfoRecursive p1
toProp (RevertableProperty p1 _p2) = toProp p1
+ getSatisfy (RevertableProperty p1 _) = getSatisfy p1
-- | Type level calculation of the type that results from combining two
-- types of properties.