From 9d6dc29555b8499d8ae6c73c891b0b5dc19f83e5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 27 Mar 2016 19:59:20 -0400 Subject: improve haddocks and move code around to make them more clear --- src/Propellor/Container.hs | 4 +- src/Propellor/Engine.hs | 4 +- src/Propellor/EnsureProperty.hs | 1 + src/Propellor/Info.hs | 28 +++++- src/Propellor/PrivData.hs | 2 +- src/Propellor/PropAccum.hs | 5 +- src/Propellor/Property.hs | 1 + src/Propellor/Property/Chroot.hs | 3 +- src/Propellor/Property/Concurrent.hs | 2 + src/Propellor/Property/Conductor.hs | 13 +-- src/Propellor/Property/Dns.hs | 2 +- src/Propellor/Property/Docker.hs | 3 +- src/Propellor/Property/FreeBSD/Pkg.hs | 4 +- src/Propellor/Property/List.hs | 2 + src/Propellor/Property/Partition.hs | 1 + src/Propellor/Property/Scheduled.hs | 1 + src/Propellor/Types.hs | 168 ++++++---------------------------- src/Propellor/Types/Core.hs | 106 +++++++++++++++++++++ src/Propellor/Types/Info.hs | 5 + 19 files changed, 195 insertions(+), 160 deletions(-) create mode 100644 src/Propellor/Types/Core.hs (limited to 'src/Propellor') diff --git a/src/Propellor/Container.hs b/src/Propellor/Container.hs index 4cd46ae5..c4d6f864 100644 --- a/src/Propellor/Container.hs +++ b/src/Propellor/Container.hs @@ -3,8 +3,10 @@ module Propellor.Container where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Types.Info +import Propellor.Info import Propellor.PrivData import Propellor.PropAccum @@ -54,7 +56,7 @@ propagateContainer containername c prop = prop convert p = let n = property (getDesc p) (getSatisfy p) :: Property UnixLike n' = n - `addInfoProperty` mapInfo (forceHostContext containername) + `setInfoProperty` mapInfo (forceHostContext containername) (propagatableInfo (getInfo p)) `addChildren` map convert (getChildren p) in toChildProperty n' diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 4c37e704..f0035c40 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -4,7 +4,6 @@ module Propellor.Engine ( mainProperties, runPropellor, - ensureProperty, ensureChildProperties, fromHost, fromHost', @@ -23,10 +22,11 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Property import Utility.Exception -- | Gets the Properties of a Host, and ensures them all, diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index f9094c5b..ce01d436 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -11,6 +11,7 @@ module Propellor.EnsureProperty ) where import Propellor.Types +import Propellor.Types.Core import Propellor.Types.MetaTypes import Propellor.Exception diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs index ff0b3b5e..b87369c3 100644 --- a/src/Propellor/Info.hs +++ b/src/Propellor/Info.hs @@ -1,9 +1,11 @@ -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PackageImports, TypeFamilies, DataKinds, PolyKinds #-} module Propellor.Info ( osDebian, osBuntish, osFreeBSD, + setInfoProperty, + addInfoProperty, pureInfoProperty, pureInfoProperty', askInfo, @@ -22,6 +24,7 @@ module Propellor.Info ( import Propellor.Types import Propellor.Types.Info +import Propellor.Types.MetaTypes import "mtl" Control.Monad.Reader import qualified Data.Set as S @@ -31,11 +34,32 @@ import Data.Monoid import Control.Applicative import Prelude +-- | Adds info to a Property. +-- +-- The new Property will include HasInfo in its metatypes. +setInfoProperty + :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') + => Property metatypes + -> Info + -> Property (MetaTypes metatypes') +setInfoProperty (Property _ d a oldi c) newi = + Property sing d a (oldi <> newi) c + +-- | Adds more info to a Property that already HasInfo. +addInfoProperty + :: (IncludesInfo metatypes ~ 'True) + => Property metatypes + -> Info + -> Property metatypes +addInfoProperty (Property t d a oldi c) newi = + Property t d a (oldi <> newi) c + +-- | Makes a property that does nothing but set some `Info`. pureInfoProperty :: (IsInfo v) => Desc -> v -> Property (HasInfo + UnixLike) pureInfoProperty desc v = pureInfoProperty' desc (toInfo v) pureInfoProperty' :: Desc -> Info -> Property (HasInfo + UnixLike) -pureInfoProperty' desc i = addInfoProperty p i +pureInfoProperty' desc i = setInfoProperty p i where p :: Property UnixLike p = property ("has " ++ desc) (return NoChange) diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs index 0bc0c100..d3bb3a6d 100644 --- a/src/Propellor/PrivData.hs +++ b/src/Propellor/PrivData.hs @@ -127,7 +127,7 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a -> "Fix this by running:" : showSet (map (\s -> (privDataField s, Context cname, describePrivDataSource s)) srclist) return FailedChange - addinfo p = p `addInfoProperty'` (toInfo privset) + addinfo p = p `addInfoProperty` (toInfo privset) privset = PrivInfo $ S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist fieldnames = map show fieldlist diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 856f2e8e..d9fa8ec7 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -16,6 +16,7 @@ module Propellor.PropAccum import Propellor.Types import Propellor.Types.MetaTypes +import Propellor.Types.Core import Propellor.Property import Data.Monoid @@ -30,10 +31,6 @@ import Prelude host :: HostName -> Props metatypes -> Host host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) --- | Props is a combination of a list of properties, with their combined --- metatypes. -data Props metatypes = Props [ChildProperty] - -- | Start accumulating a list of properties. -- -- Properties can be added to it using `(&)` etc. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 70583edc..29a8ec0f 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -53,6 +53,7 @@ import Control.Applicative import Prelude import Propellor.Types +import Propellor.Types.Core import Propellor.Types.ResultCheck import Propellor.Types.MetaTypes import Propellor.Info diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 811b5baa..09047ce5 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -23,6 +23,7 @@ import Propellor.Container import Propellor.Types.CmdLine import Propellor.Types.Chroot import Propellor.Types.Info +import Propellor.Types.Core import Propellor.Property.Chroot.Util import qualified Propellor.Property.Debootstrap as Debootstrap import qualified Propellor.Property.Systemd.Core as Systemd @@ -151,7 +152,7 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = propagateChrootInfo :: Chroot -> Property Linux -> Property (HasInfo + Linux) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c $ - p `addInfoProperty` chrootInfo c + p `setInfoProperty` chrootInfo c chrootInfo :: Chroot -> Info chrootInfo (Chroot loc _ h) = mempty `addInfo` diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index ace85a3c..e69dc17d 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -37,6 +37,8 @@ module Propellor.Property.Concurrent ( ) where import Propellor.Base +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Control.Concurrent import qualified Control.Concurrent.Async as A diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ab747acc..8aa18d20 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -83,16 +83,17 @@ import qualified Propellor.Property.Ssh as Ssh import qualified Data.Set as S -- | Class of things that can be conducted. +-- +-- There are instances for single hosts, and for lists of hosts. +-- With a list, each listed host will be conducted in turn. Failure to conduct +-- one host does not prevent conducting subsequent hosts in the list, but +-- will be propagated as an overall failure of the property. class Conductable c where conducts :: c -> RevertableProperty (HasInfo + UnixLike) (HasInfo + UnixLike) instance Conductable Host where - -- | Conduct the specified host. conducts h = conductorFor h notConductorFor h --- | Each host in the list will be conducted in turn. Failure to conduct --- one host does not prevent conducting subsequent hosts in the list, but --- will be propagated as an overall failure of the property. instance Conductable [Host] where conducts hs = propertyList desc (toProps $ map (setupRevertableProperty . conducts) hs) @@ -246,7 +247,7 @@ orchestrate' h (Conductor c l) -- to have any effect. conductorFor :: Host -> Property (HasInfo + UnixLike) conductorFor h = go - `addInfoProperty` (toInfo (ConductorFor [h])) + `setInfoProperty` (toInfo (ConductorFor [h])) `requires` setupRevertableProperty (conductorKnownHost h) `requires` Ssh.installed where @@ -270,7 +271,7 @@ conductorFor h = go -- Reverts conductorFor. notConductorFor :: Host -> Property (HasInfo + UnixLike) notConductorFor h = (doNothing :: Property UnixLike) - `addInfoProperty` (toInfo (NotConductorFor [h])) + `setInfoProperty` (toInfo (NotConductorFor [h])) `describe` desc `requires` undoRevertableProperty (conductorKnownHost h) where diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 2b5596bd..2e2710a6 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -81,7 +81,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs = (partialzone, zonewarnings) = genZone indomain hostmap domain soa baseprop = primaryprop - `addInfoProperty` (toInfo (addNamedConf conf)) + `setInfoProperty` (toInfo (addNamedConf conf)) primaryprop :: Property DebianLike primaryprop = property ("dns primary for " ++ domain) $ do sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap) diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index ddefef15..2ef97438 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,6 +48,7 @@ module Propellor.Property.Docker ( import Propellor.Base hiding (init) import Propellor.Types.Docker import Propellor.Types.Container +import Propellor.Types.Core import Propellor.Types.CmdLine import Propellor.Types.Info import Propellor.Container @@ -183,7 +184,7 @@ imagePulled ctr = pulled `describe` msg propagateContainerInfo :: Container -> Property (HasInfo + Linux) -> Property (HasInfo + Linux) propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr $ - p `addInfoProperty'` dockerinfo + p `addInfoProperty` dockerinfo where dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } diff --git a/src/Propellor/Property/FreeBSD/Pkg.hs b/src/Propellor/Property/FreeBSD/Pkg.hs index 6c775b94..704c1db9 100644 --- a/src/Propellor/Property/FreeBSD/Pkg.hs +++ b/src/Propellor/Property/FreeBSD/Pkg.hs @@ -51,7 +51,7 @@ update = go = ifM (pkgUpdated <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg update has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) newtype PkgUpgrade = PkgUpgrade String deriving (Typeable, Monoid, Show) @@ -68,7 +68,7 @@ upgrade = go = ifM (pkgUpgraded <$> askInfo) ((noChange), (liftIO upd >> return MadeChange)) in (property "pkg upgrade has run" go :: Property FreeBSD) - `addInfoProperty` (toInfo (PkgUpdate "")) + `setInfoProperty` (toInfo (PkgUpdate "")) `requires` update type Package = String diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index a8b8347a..0eec04c7 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -13,6 +13,8 @@ module Propellor.Property.List ( ) where import Propellor.Types +import Propellor.Types.Core +import Propellor.Types.MetaTypes import Propellor.PropAccum import Propellor.Engine import Propellor.Exception diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 291d4168..2bf5b927 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -3,6 +3,7 @@ module Propellor.Property.Partition where import Propellor.Base +import Propellor.Types.Core import qualified Propellor.Property.Apt as Apt import Utility.Applicative diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 95e4e362..729a3749 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -10,6 +10,7 @@ module Propellor.Property.Scheduled ) where import Propellor.Base +import Propellor.Types.Core import Utility.Scheduled import Data.Time.Clock diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index d5959cbb..6d6b14ea 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE PackageImports #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} @@ -8,15 +7,18 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} -module Propellor.Types - ( Host(..) +module Propellor.Types ( + -- * Core data types + Host(..) , Property(..) , property - , Info , Desc - , MetaType(..) - , MetaTypes - , TargetOS(..) + , RevertableProperty(..) + , () + , Propellor(..) + , LiftPropellor(..) + , Info + -- * Types of properties , UnixLike , Linux , DebianLike @@ -25,34 +27,22 @@ module Propellor.Types , FreeBSD , HasInfo , type (+) - , addInfoProperty - , addInfoProperty' - , adjustPropertySatisfy - , RevertableProperty(..) - , () - , ChildProperty - , IsProp(..) + , TightenTargets(..) + -- * Combining and modifying properties , Combines(..) , CombinedType , ResultCombiner - , Propellor(..) - , LiftPropellor(..) - , EndAction(..) + , adjustPropertySatisfy + -- * Other included types , module Propellor.Types.OS , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS - , TightenTargets(..) - , SingI ) where import Data.Monoid -import "mtl" Control.Monad.RWS.Strict -import Control.Monad.Catch -import Data.Typeable -import Control.Applicative -import Prelude +import Propellor.Types.Core import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns @@ -60,89 +50,38 @@ import Propellor.Types.Result import Propellor.Types.MetaTypes import Propellor.Types.ZFS --- | Everything Propellor knows about a system: Its hostname, --- properties and their collected info. -data Host = Host - { hostName :: HostName - , hostProperties :: [ChildProperty] - , hostInfo :: Info - } - deriving (Show, Typeable) - --- | Propellor's monad provides read-only access to info about the host --- it's running on, and a writer to accumulate EndActions. -newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } - deriving - ( Monad - , Functor - , Applicative - , MonadReader Host - , MonadWriter [EndAction] - , MonadIO - , MonadCatch - , MonadThrow - , MonadMask - ) - -class LiftPropellor m where - liftPropellor :: m a -> Propellor a - -instance LiftPropellor Propellor where - liftPropellor = id - -instance LiftPropellor IO where - liftPropellor = liftIO - -instance Monoid (Propellor Result) where - mempty = return NoChange - -- | The second action is only run if the first action does not fail. - mappend x y = do - rx <- x - case rx of - FailedChange -> return FailedChange - _ -> do - ry <- y - return (rx <> ry) - --- | An action that Propellor runs at the end, after trying to satisfy all --- properties. It's passed the combined Result of the entire Propellor run. -data EndAction = EndAction Desc (Result -> Propellor Result) - -type Desc = String - -- | The core data type of Propellor, this represents a property --- that the system should have, with a descrition, an action to ensure --- it has the property, and perhaps some Info that can be added to Hosts +-- that the system should have, with a descrition, and an action to ensure +-- it has the property. -- that have the property. -- --- A property has a list of `[MetaType]`, which is part of its type. +-- There are different types of properties that target different OS's, +-- and so have different metatypes. +-- For example: "Property DebianLike" and "Property FreeBSD". -- --- There are many instances and type families, which are mostly used +-- Also, some properties have associated `Info`, which is indicated in +-- their type: "Property (HasInfo + DebianLike)" +-- +-- There are many associated type families, which are mostly used -- internally, so you needn't worry about them. data Property metatypes = Property metatypes Desc (Propellor Result) Info [ChildProperty] instance Show (Property metatypes) where show p = "property " ++ show (getDesc p) --- | Since there are many different types of Properties, they cannot be put --- into a list. The simplified ChildProperty can be put into a list. -data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] - -instance Show ChildProperty where - show = getDesc - -- | Constructs a Property, from a description and an action to run to -- ensure the Property is met. -- --- You can specify any metatypes that make sense to indicate what OS --- the property targets, etc. +-- Due to the polymorphic return type of this function, most uses will need +-- to specify a type signature. This lets you specify what OS the property +-- targets, etc. -- -- For example: -- -- > foo :: Property Debian --- > foo = mkProperty "foo" (...) --- --- Note that using this needs LANGUAGE PolyKinds. +-- > foo = property "foo" $ do +-- > ... +-- > return MadeChange property :: SingI metatypes => Desc @@ -150,26 +89,6 @@ property -> Property (MetaTypes metatypes) property d a = Property sing d a mempty mempty --- | Adds info to a Property. --- --- The new Property will include HasInfo in its metatypes. -addInfoProperty - :: (MetaTypes metatypes' ~ (+) HasInfo metatypes, SingI metatypes') - => Property metatypes - -> Info - -> Property (MetaTypes metatypes') -addInfoProperty (Property _ d a oldi c) newi = - Property sing d a (oldi <> newi) c - --- | Adds more info to a Property that already HasInfo. -addInfoProperty' - :: (IncludesInfo metatypes ~ 'True) - => Property metatypes - -> Info - -> Property metatypes -addInfoProperty' (Property t d a oldi c) newi = - Property t d a (oldi <> newi) c - -- | 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 @@ -191,24 +110,6 @@ instance Show (RevertableProperty setupmetatypes undometatypes) where -> RevertableProperty setupmetatypes undometatypes setup undo = RevertableProperty setup undo -class IsProp p where - setDesc :: p -> Desc -> p - getDesc :: p -> Desc - getChildren :: p -> [ChildProperty] - addChildren :: p -> [ChildProperty] -> p - -- | Gets the info of the property, combined with all info - -- of all children properties. - getInfoRecursive :: p -> Info - -- | Info, not including info from children. - getInfo :: p -> Info - -- | Gets a ChildProperty representing the Property. - -- You should not normally need to use this. - toChildProperty :: 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 (Property _ d _ _ _) = d @@ -220,17 +121,6 @@ instance IsProp (Property metatypes) where toChildProperty (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 - getChildren (ChildProperty _ _ _ c) = c - addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') - getInfoRecursive (ChildProperty _ _ i c) = - i <> mconcat (map getInfoRecursive c) - getInfo (ChildProperty _ _ i _) = i - toChildProperty = id - getSatisfy (ChildProperty _ a _ _) = a - instance IsProp (RevertableProperty setupmetatypes undometatypes) where -- | Sets the description of both sides. setDesc (RevertableProperty p1 p2) d = diff --git a/src/Propellor/Types/Core.hs b/src/Propellor/Types/Core.hs new file mode 100644 index 00000000..fa939d2b --- /dev/null +++ b/src/Propellor/Types/Core.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleInstances #-} + +module Propellor.Types.Core where + +import Propellor.Types.Info +import Propellor.Types.OS +import Propellor.Types.Result + +import Data.Monoid +import "mtl" Control.Monad.RWS.Strict +import Control.Monad.Catch +import Control.Applicative +import Prelude + +-- | Everything Propellor knows about a system: Its hostname, +-- properties and their collected info. +data Host = Host + { hostName :: HostName + , hostProperties :: [ChildProperty] + , hostInfo :: Info + } + deriving (Show, Typeable) + +-- | Propellor's monad provides read-only access to info about the host +-- it's running on, and a writer to accumulate EndActions. +newtype Propellor p = Propellor { runWithHost :: RWST Host [EndAction] () IO p } + deriving + ( Monad + , Functor + , Applicative + , MonadReader Host + , MonadWriter [EndAction] + , MonadIO + , MonadCatch + , MonadThrow + , MonadMask + ) + +class LiftPropellor m where + liftPropellor :: m a -> Propellor a + +instance LiftPropellor Propellor where + liftPropellor = id + +instance LiftPropellor IO where + liftPropellor = liftIO + +instance Monoid (Propellor Result) where + mempty = return NoChange + -- | The second action is only run if the first action does not fail. + mappend x y = do + rx <- x + case rx of + FailedChange -> return FailedChange + _ -> do + ry <- y + return (rx <> ry) + +-- | An action that Propellor runs at the end, after trying to satisfy all +-- properties. It's passed the combined Result of the entire Propellor run. +data EndAction = EndAction Desc (Result -> Propellor Result) + +type Desc = String + +-- | Props is a combination of a list of properties, with their combined +-- metatypes. +data Props metatypes = Props [ChildProperty] + +-- | Since there are many different types of Properties, they cannot be put +-- into a list. The simplified ChildProperty can be put into a list. +data ChildProperty = ChildProperty Desc (Propellor Result) Info [ChildProperty] + +instance Show ChildProperty where + show = getDesc + +class IsProp p where + setDesc :: p -> Desc -> p + getDesc :: p -> Desc + getChildren :: p -> [ChildProperty] + addChildren :: p -> [ChildProperty] -> p + -- | Gets the info of the property, combined with all info + -- of all children properties. + getInfoRecursive :: p -> Info + -- | Info, not including info from children. + getInfo :: p -> Info + -- | Gets a ChildProperty representing the Property. + -- You should not normally need to use this. + toChildProperty :: 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 ChildProperty where + setDesc (ChildProperty _ a i c) d = ChildProperty d a i c + getDesc (ChildProperty d _ _ _) = d + getChildren (ChildProperty _ _ _ c) = c + addChildren (ChildProperty d a i c) c' = ChildProperty d a i (c ++ c') + getInfoRecursive (ChildProperty _ _ i c) = + i <> mconcat (map getInfoRecursive c) + getInfo (ChildProperty _ _ i _) = i + toChildProperty = id + getSatisfy (ChildProperty _ a _ _) = a diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs index c7f6b82f..2e188ae5 100644 --- a/src/Propellor/Types/Info.hs +++ b/src/Propellor/Types/Info.hs @@ -19,6 +19,9 @@ import Data.Monoid import Prelude -- | Information about a Host, which can be provided by its properties. +-- +-- Many different types of data can be contained in the same Info value +-- at the same time. See `toInfo` and `fromInfo`. newtype Info = Info [InfoEntry] deriving (Monoid, Show) @@ -47,6 +50,8 @@ class (Typeable v, Monoid v, Show v) => IsInfo v where addInfo :: IsInfo v => Info -> v -> Info addInfo (Info l) v = Info (InfoEntry v:l) +-- | Converts any value in the `IsInfo` type class into an Info, +-- which is otherwise empty. toInfo :: IsInfo v => v -> Info toInfo = addInfo mempty -- cgit v1.2.3