From 91d1833155a2e8be2c435d0a92a750cc9d2f30b5 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 14:04:40 -0400 Subject: 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. --- src/Propellor/Engine.hs | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) (limited to 'src/Propellor/Engine.hs') 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. -- cgit v1.2.3 From 6b9f3158df63e18b32b7175205ef686badc3bc1b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 16:12:27 -0400 Subject: ported mainProperties --- src/Propellor/Engine.hs | 15 ++++++--------- src/Propellor/PropAccum.hs | 2 +- 2 files changed, 7 insertions(+), 10 deletions(-) (limited to 'src/Propellor/Engine.hs') diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 62fad5af..bf49b95f 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -1,8 +1,8 @@ {-# LANGUAGE PackageImports #-} -{-# LANGUAGE GADTs #-} +{-# LANGUAGE DataKinds #-} module Propellor.Engine ( - -- mainProperties, + mainProperties, runPropellor, ensureProperty, ensureChildProperties, @@ -29,22 +29,19 @@ 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 () mainProperties host = do - ret <- runPropellor host $ - ensureProperties [ignoreInfo $ infoProperty "overall" (ensureProperties ps) mempty mempty] + ret <- runPropellor host $ ensureChildProperties [toProp overall] messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) _ -> exitWith ExitSuccess where - ps = map ignoreInfo $ hostProperties host - --} + overall :: Property (MetaTypes '[]) + overall = property "overall" $ + ensureChildProperties (hostProperties host) -- | Runs a Propellor action with the specified host. -- diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 91d7b80d..06b8ad3f 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -30,7 +30,7 @@ import Propellor.PrivData -- > ! oldproperty -- > & otherproperty host :: HostName -> Props metatypes -> Host -host hn (Props c) = Host hn c (mconcat (map getInfoRecursive c)) +host hn (Props ps) = Host hn ps (mconcat (map getInfoRecursive ps)) -- | Props is a combination of a list of properties, with their combined -- metatypes. -- cgit v1.2.3 From f01776d64b1b8fcf89903d0de1ffe27f10d620ee Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 16:20:32 -0400 Subject: rename toProp to toChildProperties and note that it's not meant to be used by regular users --- config-simple.hs | 12 ------------ src/Propellor/Engine.hs | 2 +- src/Propellor/PropAccum.hs | 6 +++--- src/Propellor/Property/Chroot.hs | 7 +++---- src/Propellor/Property/Docker.hs | 4 +--- src/Propellor/Property/List.hs | 6 +++--- src/Propellor/Types.hs | 23 ++++++----------------- 7 files changed, 17 insertions(+), 43 deletions(-) (limited to 'src/Propellor/Engine.hs') diff --git a/config-simple.hs b/config-simple.hs index 28b38409..da1580c6 100644 --- a/config-simple.hs +++ b/config-simple.hs @@ -12,7 +12,6 @@ import Propellor.Property.Scheduled import qualified Propellor.Property.User as User --import qualified Propellor.Property.Hostname as Hostname --import qualified Propellor.Property.Tor as Tor -import qualified Propellor.Property.Docker as Docker main :: IO () main = defaultMain hosts @@ -34,15 +33,4 @@ mybox = host "mybox.example.com" $ props & User.hasSomePassword (User "root") & Network.ipv6to4 & File.dirExists "/var/www" - & Docker.docked webserverContainer - & Docker.garbageCollected `period` Daily & Cron.runPropellor (Cron.Times "30 * * * *") - --- A generic webserver in a Docker container. -webserverContainer :: Docker.Container -webserverContainer = Docker.container "webserver" (Docker.latestImage "debian") $ props - & os (System (Debian (Stable "jessie")) "amd64") - & Apt.stdSourcesList - & Docker.publish "80:80" - & Docker.volume "/var/www:/var/www" - & Apt.serviceInstalledRunning "apache2" diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index bf49b95f..4c37e704 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -33,7 +33,7 @@ import Utility.Exception -- with nice display of what's being done. mainProperties :: Host -> IO () mainProperties host = do - ret <- runPropellor host $ ensureChildProperties [toProp overall] + ret <- runPropellor host $ ensureChildProperties [toChildProperty overall] messagesDone case ret of FailedChange -> exitWith (ExitFailure 1) diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs index 06b8ad3f..7547a81d 100644 --- a/src/Propellor/PropAccum.hs +++ b/src/Propellor/PropAccum.hs @@ -62,7 +62,7 @@ type instance GetMetaTypes (RevertableProperty (MetaTypes t) undo) = MetaTypes t => Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y)) -Props c & p = Props (c ++ [toProp p]) +Props c & p = Props (c ++ [toChildProperty p]) -- | Adds a property before any other properties. (&^) @@ -74,7 +74,7 @@ Props c & p = Props (c ++ [toProp p]) => Props (MetaTypes x) -> p -> Props (MetaTypes (Combine x y)) -Props c &^ p = Props (toProp p : c) +Props c &^ p = Props (toChildProperty p : c) -- | Adds a property in reverted form. (!) @@ -82,7 +82,7 @@ Props c &^ p = Props (toProp p : c) => Props (MetaTypes x) -> RevertableProperty (MetaTypes y) (MetaTypes z) -> Props (MetaTypes (Combine x z)) -Props c ! p = Props (c ++ [toProp (revert p)]) +Props c ! p = Props (c ++ [toChildProperty (revert p)]) {- diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index fb05d659..bf6f2083 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -213,11 +213,10 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = changeWorkingDirectory localdir when onconsole forceConsole onlyProcess (provisioningLock loc) $ do - r <- runPropellor (setInChroot h) $ ensureProperties $ + r <- runPropellor (setInChroot h) $ ensureChildProperties $ if systemdonly - then [Systemd.installed] - else map ignoreInfo $ - hostProperties h + then [toProp Systemd.installed] + else hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r chain _ _ = errorMessage "bad chain command" diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 4bbfeef3..d19d15aa 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -581,9 +581,7 @@ chain hostlist hn s = case toContainerId s of go cid h = do changeWorkingDirectory localdir onlyProcess (provisioningLock cid) $ do - r <- runPropellor h $ ensureChildProperties $ - map ignoreInfo $ - hostProperties h + r <- runPropellor h $ ensureChildProperties $ hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 44916f23..d8c5cff4 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -21,7 +21,7 @@ import Propellor.Exception import Data.Monoid toProps :: [Property (MetaTypes metatypes)] -> Props (MetaTypes metatypes) -toProps ps = Props (map toProp ps) +toProps ps = Props (map toChildProperty ps) -- | Combines a list of properties, resulting in a single property -- that when run will run each property in the list in turn, @@ -38,7 +38,7 @@ propertyList desc (Props ps) = property desc (ensureChildProperties cs) `modifyChildren` (++ cs) where - cs = map toProp ps + cs = map toChildProperty ps -- | Combines a list of properties, resulting in one property that -- ensures each in turn. Stops if a property fails. @@ -47,7 +47,7 @@ combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) `modifyChildren` (++ cs) where - cs = map toProp ps + cs = map toChildProperty ps combineSatisfy :: [ChildProperty] -> Result -> Propellor Result combineSatisfy [] rs = return rs diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index dd8721ac..f42f55d7 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -158,18 +158,6 @@ addInfoProperty addInfoProperty (Property _ d a oldi c) newi = Property sing d a (oldi <> newi) c -{- - --- | Makes a version of a Proprty without its Info. --- Use with caution! -ignoreInfo - :: (metatypes' ~ - => Property metatypes - -> Property (MetaTypes metatypes') -ignoreInfo = - --} - -- | 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 @@ -213,7 +201,9 @@ class IsProp p where -- | Gets the info of the property, combined with all info -- of all children properties. getInfoRecursive :: p -> Info - toProp :: p -> ChildProperty + -- | 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. @@ -225,7 +215,7 @@ instance IsProp (Property metatypes) where 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 + toChildProperty (Property _ d a i c) = ChildProperty d a i c getSatisfy (Property _ _ a _ _) = a instance IsProp ChildProperty where @@ -234,7 +224,7 @@ instance IsProp ChildProperty where modifyChildren (ChildProperty d a i c) f = ChildProperty d a i (f c) getInfoRecursive (ChildProperty _ _ i c) = i <> mconcat (map getInfoRecursive c) - toProp = id + toChildProperty = id getSatisfy (ChildProperty _ a _ _) = a instance IsProp (RevertableProperty setupmetatypes undometatypes) where @@ -243,10 +233,9 @@ instance IsProp (RevertableProperty setupmetatypes undometatypes) where 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 + toChildProperty (RevertableProperty p1 _p2) = toChildProperty p1 getSatisfy (RevertableProperty p1 _) = getSatisfy p1 -- | Type level calculation of the type that results from combining two -- cgit v1.2.3 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 --- propellor.cabal | 1 + 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 + 20 files changed, 196 insertions(+), 160 deletions(-) create mode 100644 src/Propellor/Types/Core.hs (limited to 'src/Propellor/Engine.hs') diff --git a/propellor.cabal b/propellor.cabal index f11d2afe..e946f697 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -150,6 +150,7 @@ Library Propellor.EnsureProperty Propellor.Exception Propellor.Types + Propellor.Types.Core Propellor.Types.Chroot Propellor.Types.CmdLine Propellor.Types.Container 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