From 1ae21965aaba0303088052e873fea39708e331ed Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 19 Jan 2015 14:15:49 -0400 Subject: rename HostLike to PropAccum This is more general; it doesn't need to contain a Host. It would, for example, be possible to make Property itself be an instance of PropAccum. --- propellor.cabal | 2 +- src/Propellor.hs | 4 +-- src/Propellor/Host.hs | 74 --------------------------------------- src/Propellor/PropAccum.hs | 74 +++++++++++++++++++++++++++++++++++++++ src/Propellor/Property/Chroot.hs | 6 ++-- src/Propellor/Property/Docker.hs | 6 ++-- src/Propellor/Property/Systemd.hs | 8 ++--- 7 files changed, 87 insertions(+), 87 deletions(-) delete mode 100644 src/Propellor/Host.hs create mode 100644 src/Propellor/PropAccum.hs diff --git a/propellor.cabal b/propellor.cabal index 982df527..00a5ac5b 100644 --- a/propellor.cabal +++ b/propellor.cabal @@ -108,7 +108,7 @@ Library Propellor.Property.SiteSpecific.GitHome Propellor.Property.SiteSpecific.JoeySites Propellor.Property.SiteSpecific.GitAnnexBuilder - Propellor.Host + Propellor.PropAccum Propellor.CmdLine Propellor.Info Propellor.Message diff --git a/src/Propellor.hs b/src/Propellor.hs index 0e34e988..d0e89ca5 100644 --- a/src/Propellor.hs +++ b/src/Propellor.hs @@ -33,7 +33,7 @@ module Propellor ( module Propellor.Types , module Propellor.Property , module Propellor.Property.Cmd - , module Propellor.Host + , module Propellor.PropAccum , module Propellor.Info , module Propellor.PrivData , module Propellor.Types.PrivData @@ -54,7 +54,7 @@ import Propellor.Types.PrivData import Propellor.Message import Propellor.Exception import Propellor.Info -import Propellor.Host +import Propellor.PropAccum import Utility.PartialPrelude as X import Utility.Process as X diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs deleted file mode 100644 index cfe90949..00000000 --- a/src/Propellor/Host.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Propellor.Host where - -import Data.Monoid - -import Propellor.Types -import Propellor.Property - --- | Starts accumulating the properties of a Host. --- --- > host "example.com" --- > & someproperty --- > ! oldproperty --- > & otherproperty -host :: HostName -> Host -host hn = Host hn [] mempty - --- | Something that can accumulate properties. -class Hostlike h where - -- | Adds a property. - -- - -- Can add Properties and RevertableProperties - (&) :: IsProp p => h -> p -> h - - -- | Like (&), but adds the property as the - -- first property of the host. Normally, property - -- order should not matter, but this is useful - -- when it does. - (&^) :: IsProp p => h -> p -> h - - getHost :: h -> Host - -instance Hostlike Host where - (Host hn ps is) & p = Host hn (ps ++ [toProp p]) - (is <> getInfoRecursive p) - (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) - (getInfoRecursive p <> is) - getHost h = h - --- | Adds a property in reverted form. -(!) :: Hostlike h => h -> RevertableProperty -> h -h ! p = h & revert p - -infixl 1 &^ -infixl 1 & -infixl 1 ! - --- | Adjust the provided Property, adding to its --- propertyChidren the properties of the Hostlike. - --- The Info of the propertyChildren is adjusted to only include --- info that should be propigated out to the Property. --- --- DNS Info is propigated, so that eg, aliases of a Hostlike --- are reflected in the dns for the host where it runs. --- --- PrivData Info is propigated, so that properties used inside a --- Hostlike will have the necessary PrivData available. -propigateHostLike :: Hostlike hl => hl -> Property -> Property -propigateHostLike hl prop = prop - { propertyChildren = propertyChildren prop ++ hostprops - } - where - hostprops = map go $ hostProperties $ getHost hl - go p = - let i = propertyInfo p - in p - { propertyInfo = mempty - { _dns = _dns i - , _privData = _privData i - } - , propertyChildren = map go (propertyChildren p) - } diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs new file mode 100644 index 00000000..4cbb057e --- /dev/null +++ b/src/Propellor/PropAccum.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.PropAccum where + +import Data.Monoid + +import Propellor.Types +import Propellor.Property + +-- | Starts accumulating the properties of a Host. +-- +-- > host "example.com" +-- > & someproperty +-- > ! oldproperty +-- > & otherproperty +host :: HostName -> Host +host hn = Host hn [] mempty + +-- | Something that can accumulate properties. +class PropAccum h where + -- | Adds a property. + -- + -- Can add Properties and RevertableProperties + (&) :: IsProp p => h -> p -> h + + -- | Like (&), but adds the property as the + -- first property of the host. Normally, property + -- order should not matter, but this is useful + -- when it does. + (&^) :: IsProp p => h -> p -> h + + getProperties :: h -> [Property] + +instance PropAccum Host where + (Host hn ps is) & p = Host hn (ps ++ [toProp p]) + (is <> getInfoRecursive p) + (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) + (getInfoRecursive p <> is) + getProperties = hostProperties + +-- | Adds a property in reverted form. +(!) :: PropAccum h => h -> RevertableProperty -> h +h ! p = h & revert p + +infixl 1 &^ +infixl 1 & +infixl 1 ! + +-- | Adjust the provided Property, adding to its +-- propertyChidren the properties of the provided container. + +-- The Info of the propertyChildren is adjusted to only include +-- info that should be propigated out to the Property. +-- +-- DNS Info is propigated, so that eg, aliases of a PropAccum +-- are reflected in the dns for the host where it runs. +-- +-- 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 + } + 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) + } diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index de99e6c4..395ec74c 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -28,10 +28,10 @@ data BuilderConf = UsingDeboostrap Debootstrap.DebootstrapConfig deriving (Show) -instance Hostlike Chroot where +instance PropAccum Chroot where (Chroot l s c h) & p = Chroot l s c (h & p) (Chroot l s c h) &^ p = Chroot l s c (h &^ p) - getHost (Chroot _ _ _ h) = h + getProperties (Chroot _ _ _ h) = hostProperties h -- | Defines a Chroot at the given location, built with debootstrap. -- @@ -76,7 +76,7 @@ provisioned' propigator c@(Chroot loc system builderconf _) systemdonly = Revert teardown = toProp (revert built) propigateChrootInfo :: Chroot -> Property -> Property -propigateChrootInfo c p = propigateHostLike c p' +propigateChrootInfo c p = propigateContainer c p' where p' = p { propertyInfo = propertyInfo p <> chrootInfo c } diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index 3e2fbaf3..e65d6bb7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -77,10 +77,10 @@ type ContainerName = String -- | A docker container. data Container = Container Image Host -instance Hostlike Container where +instance PropAccum Container where (Container i h) & p = Container i (h & p) (Container i h) &^ p = Container i (h &^ p) - getHost (Container _ h) = h + getProperties (Container _ h) = hostProperties h -- | Defines a Container with a given name, image, and properties. -- Properties can be added to configure the Container. @@ -134,7 +134,7 @@ docked ctr@(Container _ h) = RevertableProperty ] propigateContainerInfo :: Container -> Property -> Property -propigateContainerInfo ctr@(Container _ h) p = propigateHostLike ctr p' +propigateContainerInfo ctr@(Container _ h) p = propigateContainer ctr p' where p' = p { propertyInfo = propertyInfo p <> dockerinfo } dockerinfo = dockerInfo $ diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index e80c32be..7fe600a0 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -33,10 +33,10 @@ type MachineName = String data Container = Container MachineName Chroot.Chroot Host deriving (Show) -instance Hostlike Container where - (Container n c h) & p = Container n c (h & p) - (Container n c h) &^ p = Container n c (h &^ p) - getHost (Container _ _ h) = h +instance PropAccum Container where + (Container n c h) & p = Container n c (h & p) + (Container n c h) &^ p = Container n c (h &^ p) + getProperties (Container _ _ h) = hostProperties h -- | Starts a systemd service. started :: ServiceName -> Property -- cgit v1.2.3