summaryrefslogtreecommitdiff
path: root/src/Propellor/Host.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Host.hs')
-rw-r--r--src/Propellor/Host.hs64
1 files changed, 64 insertions, 0 deletions
diff --git a/src/Propellor/Host.hs b/src/Propellor/Host.hs
new file mode 100644
index 00000000..14d56e20
--- /dev/null
+++ b/src/Propellor/Host.hs
@@ -0,0 +1,64 @@
+{-# LANGUAGE PackageImports #-}
+
+module Propellor.Host where
+
+import Data.Monoid
+import qualified Data.Set as S
+
+import Propellor.Types
+import Propellor.Info
+import Propellor.Property
+import Propellor.PrivData
+
+-- | 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 <> getInfo p)
+ (Host hn ps is) &^ p = Host hn ([toProp p] ++ ps) (getInfo 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 !
+
+-- | When eg, docking a container, some of the Info about the container
+-- should propigate out to the Host it's on. This includes DNS info,
+-- so that eg, aliases of the container are reflected in the dns for the
+-- host where it runs.
+--
+-- This adjusts the Property that docks a container, to include such info
+-- from the container.
+propigateInfo :: Hostlike hl => hl -> Property -> (Info -> Info) -> Property
+propigateInfo hl p f = combineProperties (propertyDesc p) $
+ p' : dnsprops ++ privprops
+ where
+ p' = p { propertyInfo = f (propertyInfo p) }
+ i = hostInfo (getHost hl)
+ dnsprops = map addDNS (S.toList $ _dns i)
+ privprops = map addPrivDataField (S.toList $ _privDataFields i)