summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess2015-09-06 08:19:02 -0700
committerJoey Hess2015-09-06 16:13:54 -0400
commitdef53b64cc17b95eb5729dd97a800dfe1257b352 (patch)
tree03f63e5bcb6486b00639e1ea78c21d8928c3b8ca
parent6f4024f5307a81f26f5e6bf86b84c7363219cb3d (diff)
Added Propellor.Property.Rsync. WIP; untested
Convert Info to use Data.Dynamic, so properties can export and consume info of any type that is Typeable and a Monoid, including data types private to a module. (API change) Thanks to Joachim Breitner for the idea.
-rw-r--r--debian/changelog6
-rw-r--r--propellor.cabal2
-rw-r--r--src/Propellor/Info.hs38
-rw-r--r--src/Propellor/PrivData.hs26
-rw-r--r--src/Propellor/PropAccum.hs15
-rw-r--r--src/Propellor/Property/Chroot.hs7
-rw-r--r--src/Propellor/Property/Dns.hs17
-rw-r--r--src/Propellor/Property/Docker.hs13
-rw-r--r--src/Propellor/Property/Ssh.hs25
-rw-r--r--src/Propellor/Property/Systemd.hs5
-rw-r--r--src/Propellor/Spin.hs3
-rw-r--r--src/Propellor/Types.hs53
-rw-r--r--src/Propellor/Types/Chroot.hs20
-rw-r--r--src/Propellor/Types/Dns.hs34
-rw-r--r--src/Propellor/Types/Docker.hs18
-rw-r--r--src/Propellor/Types/Info.hs67
-rw-r--r--src/Propellor/Types/OS.hs5
-rw-r--r--src/Propellor/Types/Val.hs22
18 files changed, 228 insertions, 148 deletions
diff --git a/debian/changelog b/debian/changelog
index 7d57759a..a217329d 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,6 +1,10 @@
-propellor (2.7.4) UNRELEASED; urgency=medium
+propellor (2.8.0) UNRELEASED; urgency=medium
* Added Propellor.Property.Rsync.
+ * Convert Info to use Data.Dynamic, so properties can export and consume
+ info of any type that is Typeable and a Monoid, including data types
+ private to a module. (API change)
+ Thanks to Joachim Breitner for the idea.
-- Joey Hess <id@joeyh.name> Fri, 04 Sep 2015 10:36:40 -0700
diff --git a/propellor.cabal b/propellor.cabal
index 17f3c0fe..b8e19828 100644
--- a/propellor.cabal
+++ b/propellor.cabal
@@ -132,9 +132,9 @@ Library
Propellor.Types.Docker
Propellor.Types.Dns
Propellor.Types.Empty
+ Propellor.Types.Info
Propellor.Types.OS
Propellor.Types.PrivData
- Propellor.Types.Val
Propellor.Types.Result
Propellor.Types.CmdLine
Other-Modules:
diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs
index 0eea0816..b9436e58 100644
--- a/src/Propellor/Info.hs
+++ b/src/Propellor/Info.hs
@@ -3,7 +3,7 @@
module Propellor.Info where
import Propellor.Types
-import Propellor.Types.Val
+import Propellor.Types.Info
import "mtl" Control.Monad.Reader
import qualified Data.Set as S
@@ -12,23 +12,26 @@ import Data.Maybe
import Data.Monoid
import Control.Applicative
-pureInfoProperty :: Desc -> Info -> Property HasInfo
-pureInfoProperty desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
+pureInfoProperty :: (IsInfo v) => Desc -> v -> Property HasInfo
+pureInfoProperty desc v = pureInfoProperty' desc (addInfo mempty v)
-askInfo :: (Info -> Val a) -> Propellor (Maybe a)
-askInfo f = asks (fromVal . f . hostInfo)
+pureInfoProperty' :: Desc -> Info -> Property HasInfo
+pureInfoProperty' desc i = infoProperty ("has " ++ desc) (return NoChange) i mempty
+
+-- | Gets a value from the host's Info.
+askInfo :: (IsInfo v) => Propellor v
+askInfo = asks (getInfo . hostInfo)
-- | Specifies the operating system of a host.
--
-- This only provides info for other Properties, so they can act
--- conditional on the os.
+-- conditionally on the os.
os :: System -> Property HasInfo
-os system = pureInfoProperty ("Operating " ++ show system) $
- mempty { _os = Val system }
+os system = pureInfoProperty ("Operating " ++ show system) (InfoVal system)
-- Gets the operating system of a host, if it has been specified.
getOS :: Propellor (Maybe System)
-getOS = askInfo _os
+getOS = fromInfoVal <$> askInfo
-- | Indidate that a host has an A record in the DNS.
--
@@ -53,15 +56,14 @@ ipv6 = addDNS . Address . IPv6
-- problems with CNAMEs, and also means that when multiple hosts have the
-- same alias, a DNS round-robin is automatically set up.
alias :: Domain -> Property HasInfo
-alias d = pureInfoProperty ("alias " ++ d) $ mempty
- { _aliases = S.singleton d
+alias d = pureInfoProperty' ("alias " ++ d) $ mempty
+ `addInfo` toAliasesInfo [d]
-- A CNAME is added here, but the DNS setup code converts it to an
-- IP address when that makes sense.
- , _dns = S.singleton $ CNAME $ AbsDomain d
- }
+ `addInfo` (toDnsInfo $ S.singleton $ CNAME $ AbsDomain d)
addDNS :: Record -> Property HasInfo
-addDNS r = pureInfoProperty (rdesc r) $ mempty { _dns = S.singleton r }
+addDNS r = pureInfoProperty (rdesc r) (toDnsInfo (S.singleton r))
where
rdesc (CNAME d) = unwords ["alias", ddesc d]
rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr]
@@ -82,7 +84,7 @@ hostMap l = M.fromList $ zip (map hostName l) l
aliasMap :: [Host] -> M.Map HostName Host
aliasMap = M.fromList . concat .
- map (\h -> map (\aka -> (aka, h)) $ S.toList $ _aliases $ hostInfo h)
+ map (\h -> map (\aka -> (aka, h)) $ fromAliasesInfo $ getInfo $ hostInfo h)
findHost :: [Host] -> HostName -> Maybe Host
findHost l hn = maybe (findAlias l hn) Just (findHostNoAlias l hn)
@@ -94,9 +96,7 @@ findAlias :: [Host] -> HostName -> Maybe Host
findAlias l hn = M.lookup hn (aliasMap l)
getAddresses :: Info -> [IPAddr]
-getAddresses = mapMaybe getIPAddr . S.toList . _dns
+getAddresses = mapMaybe getIPAddr . S.toList . fromDnsInfo . getInfo
hostAddresses :: HostName -> [Host] -> [IPAddr]
-hostAddresses hn hosts = case hostInfo <$> findHost hosts hn of
- Nothing -> []
- Just info -> mapMaybe getIPAddr $ S.toList $ _dns info
+hostAddresses hn hosts = maybe [] (getAddresses . hostInfo) (findHost hosts hn)
diff --git a/src/Propellor/PrivData.hs b/src/Propellor/PrivData.hs
index d0426e75..9aa6f380 100644
--- a/src/Propellor/PrivData.hs
+++ b/src/Propellor/PrivData.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Propellor.PrivData (
withPrivData,
@@ -14,6 +16,7 @@ module Propellor.PrivData (
makePrivDataDir,
decryptPrivData,
PrivMap,
+ PrivInfo,
) where
import Control.Applicative
@@ -22,6 +25,7 @@ import System.Directory
import Data.Maybe
import Data.Monoid
import Data.List
+import Data.Typeable
import Control.Monad
import Control.Monad.IfElse
import "mtl" Control.Monad.Reader
@@ -30,6 +34,7 @@ import qualified Data.Set as S
import Propellor.Types
import Propellor.Types.PrivData
+import Propellor.Types.Info
import Propellor.Message
import Propellor.Info
import Propellor.Gpg
@@ -102,9 +107,10 @@ withPrivData' feed srclist c mkprop = addinfo $ mkprop $ \a ->
addinfo p = infoProperty
(propertyDesc p)
(propertySatisfy p)
- (propertyInfo p <> mempty { _privData = privset })
+ (propertyInfo p `addInfo` privset)
(propertyChildren p)
- privset = S.fromList $ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
+ privset = PrivInfo $ S.fromList $
+ map (\s -> (privDataField s, describePrivDataSource s, hc)) srclist
fieldnames = map show fieldlist
fieldlist = map privDataField srclist
hc = asHostContext c
@@ -116,8 +122,7 @@ showSet l = forM_ l $ \(f, Context c, md) -> do
putStrLn ""
addPrivData :: (PrivDataField, Maybe PrivDataSourceDesc, HostContext) -> Property HasInfo
-addPrivData v = pureInfoProperty (show v) $
- mempty { _privData = S.singleton v }
+addPrivData v = pureInfoProperty (show v) (PrivInfo (S.singleton v))
{- Gets the requested field's value, in the specified context if it's
- available, from the host's local privdata cache. -}
@@ -134,7 +139,7 @@ filterPrivData :: Host -> PrivMap -> PrivMap
filterPrivData host = M.filterWithKey (\k _v -> S.member k used)
where
used = S.map (\(f, _, c) -> (f, mkHostContext c (hostName host))) $
- _privData $ hostInfo host
+ fromPrivInfo $ getInfo $ hostInfo host
getPrivData :: PrivDataField -> Context -> PrivMap -> Maybe PrivData
getPrivData field context = M.lookup (field, context)
@@ -188,7 +193,7 @@ listPrivDataFields hosts = do
, intercalate ", " $ sort $ fromMaybe [] $ M.lookup k usedby
]
mkhostmap host mkv = M.fromList $ map (\(f, d, c) -> ((f, mkHostContext c (hostName host)), mkv d)) $
- S.toList $ _privData $ hostInfo host
+ S.toList $ fromPrivInfo $ getInfo $ hostInfo host
usedby = M.unionsWith (++) $ map (\h -> mkhostmap h $ const $ [hostName h]) hosts
wantedmap = M.fromList $ zip (M.keys usedby) (repeat "")
descmap = M.unions $ map (\h -> mkhostmap h id) hosts
@@ -219,3 +224,12 @@ decryptPrivData = fromMaybe M.empty . readish <$> gpgDecrypt privDataFile
makePrivDataDir :: IO ()
makePrivDataDir = createDirectoryIfMissing False privDataDir
+
+newtype PrivInfo = PrivInfo
+ { fromPrivInfo :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext) }
+ deriving (Eq, Ord, Show, Typeable, Monoid)
+
+-- PrivInfo is propigated out of containers, so that propellor can see which
+-- hosts need it.
+instance IsInfo PrivInfo where
+ propigateInfo _ = True
diff --git a/src/Propellor/PropAccum.hs b/src/Propellor/PropAccum.hs
index 20d083cb..d2736b50 100644
--- a/src/Propellor/PropAccum.hs
+++ b/src/Propellor/PropAccum.hs
@@ -13,6 +13,7 @@ import Data.Monoid
import Propellor.Types
import Propellor.Property
+import Propellor.Types.Info
-- | Starts accumulating the properties of a Host.
--
@@ -71,12 +72,6 @@ infixl 1 !
--
-- 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
@@ -90,10 +85,6 @@ propigateContainer c prop = infoProperty
where
hostprops = map go $ getProperties c
go p =
- let i = propertyInfo p
- i' = mempty
- { _dns = _dns i
- , _privData = _privData i
- }
+ let i = propigatableInfo (propertyInfo p)
cs = map go (propertyChildren p)
- in infoProperty (propertyDesc p) (propertySatisfy p) i' cs
+ in infoProperty (propertyDesc p) (propertySatisfy p) i cs
diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs
index ded108bc..0cbc8642 100644
--- a/src/Propellor/Property/Chroot.hs
+++ b/src/Propellor/Property/Chroot.hs
@@ -15,6 +15,7 @@ module Propellor.Property.Chroot (
import Propellor
import Propellor.Types.CmdLine
import Propellor.Types.Chroot
+import Propellor.Types.Info
import Propellor.Property.Chroot.Util
import qualified Propellor.Property.Debootstrap as Debootstrap
import qualified Propellor.Property.Systemd.Core as Systemd
@@ -91,8 +92,8 @@ propigateChrootInfo c p = propigateContainer c p'
(propertyChildren p)
chrootInfo :: Chroot -> Info
-chrootInfo (Chroot loc _ _ h) =
- mempty { _chrootinfo = mempty { _chroots = M.singleton loc h } }
+chrootInfo (Chroot loc _ _ h) = mempty `addInfo`
+ mempty { _chroots = M.singleton loc h }
-- | Propellor is run inside the chroot to provision it.
propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property NoInfo
@@ -143,7 +144,7 @@ chain :: [Host] -> CmdLine -> IO ()
chain hostlist (ChrootChain hn loc systemdonly onconsole) =
case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup loc (_chroots $ _chrootinfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup loc (_chroots $ getInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn)
Just h -> go h
where
diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs
index a7dbf86a..6051ba63 100644
--- a/src/Propellor/Property/Dns.hs
+++ b/src/Propellor/Property/Dns.hs
@@ -15,6 +15,7 @@ module Propellor.Property.Dns (
import Propellor
import Propellor.Types.Dns
+import Propellor.Types.Info
import Propellor.Property.File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Ssh as Ssh
@@ -78,7 +79,7 @@ setupPrimary zonefile mknamedconffile hosts domain soa rs =
(partialzone, zonewarnings) = genZone indomain hostmap domain soa
baseprop = infoProperty ("dns primary for " ++ domain) satisfy
- (addNamedConf conf) []
+ (mempty `addInfo` addNamedConf conf) []
satisfy = do
sshfps <- concat <$> mapM (genSSHFP domain) (M.elems hostmap)
let zone = partialzone
@@ -207,7 +208,7 @@ otherServers :: DnsServerType -> [Host] -> Domain -> [HostName]
otherServers wantedtype hosts domain =
M.keys $ M.filter wanted $ hostMap hosts
where
- wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostInfo h) of
+ wanted h = case M.lookup domain (fromNamedConfMap $ getInfo $ hostInfo h) of
Nothing -> False
Just conf -> confDnsServerType conf == wantedtype
&& confDomain conf == domain
@@ -459,7 +460,7 @@ genZone inzdomain hostmap zdomain soa =
-- So we can just use the IPAddrs.
addcnames :: Host -> [Either WarningMessage (BindDomain, Record)]
addcnames h = concatMap gen $ filter (inDomain zdomain) $
- mapMaybe getCNAME $ S.toList (_dns info)
+ mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
where
info = hostInfo h
gen c = case getAddresses info of
@@ -474,7 +475,7 @@ genZone inzdomain hostmap zdomain soa =
where
info = hostInfo h
l = zip (repeat $ AbsDomain $ hostName h)
- (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns info))
+ (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ getInfo info))
-- Simplifies the list of hosts. Remove duplicate entries.
-- Also, filter out any CHAMES where the same domain has an
@@ -503,13 +504,13 @@ domainHost base (AbsDomain d)
where
dotbase = '.':base
-addNamedConf :: NamedConf -> Info
-addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) }
+addNamedConf :: NamedConf -> NamedConfMap
+addNamedConf conf = NamedConfMap (M.singleton domain conf)
where
domain = confDomain conf
getNamedConf :: Propellor (M.Map Domain NamedConf)
-getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo
+getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo
-- | Generates SSHFP records for hosts in the domain (or with CNAMES
-- in the domain) that have configured ssh public keys.
@@ -522,7 +523,7 @@ genSSHFP domain h = concatMap mk . concat <$> (gen =<< get)
gen = liftIO . mapM genSSHFP' . M.elems . fromMaybe M.empty
mk r = mapMaybe (\d -> if inDomain domain d then Just (d, r) else Nothing)
(AbsDomain hostname : cnames)
- cnames = mapMaybe getCNAME $ S.toList $ _dns info
+ cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ getInfo info
hostname = hostName h
info = hostInfo h
diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs
index 05f25c31..e24d58d4 100644
--- a/src/Propellor/Property/Docker.hs
+++ b/src/Propellor/Property/Docker.hs
@@ -49,6 +49,7 @@ import Propellor hiding (init)
import Propellor.Types.Docker
import Propellor.Types.Container
import Propellor.Types.CmdLine
+import Propellor.Types.Info
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.Cmd as Cmd
@@ -186,7 +187,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) =
where
runparams = map (\(DockerRunParam mkparam) -> mkparam hn)
(_dockerRunParams info)
- info = _dockerinfo $ hostInfo h'
+ info = getInfo $ hostInfo h'
h' = h
-- Restart by default so container comes up on
-- boot or when docker is upgraded.
@@ -572,7 +573,7 @@ chain hostlist hn s = case toContainerId s of
Nothing -> errorMessage "bad container id"
Just cid -> case findHostNoAlias hostlist hn of
Nothing -> errorMessage ("cannot find host " ++ hn)
- Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ _dockerinfo $ hostInfo parenthost) of
+ Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ getInfo $ hostInfo parenthost) of
Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn)
Just h -> go cid h
where
@@ -643,17 +644,17 @@ listImages :: IO [ImageUID]
listImages = map ImageUID . lines <$> readProcess dockercmd ["images", "--all", "--quiet"]
runProp :: String -> RunParam -> Property HasInfo
-runProp field val = pureInfoProperty (param) $ dockerInfo $
+runProp field val = pureInfoProperty (param) $
mempty { _dockerRunParams = [DockerRunParam (\_ -> "--"++param)] }
where
param = field++"="++val
genProp :: String -> (HostName -> RunParam) -> Property HasInfo
-genProp field mkval = pureInfoProperty field $ dockerInfo $
+genProp field mkval = pureInfoProperty field $
mempty { _dockerRunParams = [DockerRunParam (\hn -> "--"++field++"=" ++ mkval hn)] }
-dockerInfo :: DockerInfo Host -> Info
-dockerInfo i = mempty { _dockerinfo = i }
+dockerInfo :: DockerInfo -> Info
+dockerInfo i = mempty `addInfo` i
-- | The ContainerIdent of a container is written to
-- </.propellor-ident> inside it. This can be checked to see if
diff --git a/src/Propellor/Property/Ssh.hs b/src/Propellor/Property/Ssh.hs
index fca7d037..c85694db 100644
--- a/src/Propellor/Property/Ssh.hs
+++ b/src/Propellor/Property/Ssh.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Propellor.Property.Ssh (
PubKeyText,
sshdConfig,
@@ -27,6 +29,7 @@ import Propellor
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.User
+import Propellor.Types.Info
import Utility.FileMode
import System.PosixCompat
@@ -169,11 +172,25 @@ keyFile keytype ispub = "/etc/ssh/ssh_host_" ++ fromKeyType keytype ++ "_key" ++
-- configure the host to use it. Normally this does not need to be used;
-- use 'hostKey' instead.
pubKey :: SshKeyType -> PubKeyText -> Property HasInfo
-pubKey t k = pureInfoProperty ("ssh pubkey known") $
- mempty { _sshPubKey = M.singleton t k }
+pubKey t k = pureInfoProperty ("ssh pubkey known")
+ (SshPubKeyInfo (M.singleton t k))
+
+getPubKey :: Propellor (M.Map SshKeyType PubKeyText)
+getPubKey = fromSshPubKeyInfo <$> askInfo
+
+newtype SshPubKeyInfo = SshPubKeyInfo
+ { fromSshPubKeyInfo :: M.Map SshKeyType PubKeyText }
+ deriving (Eq, Ord, Typeable)
+
+instance IsInfo SshPubKeyInfo where
+ propigateInfo _ = False
-getPubKey :: Propellor (M.Map SshKeyType String)
-getPubKey = asks (_sshPubKey . hostInfo)
+instance Monoid SshPubKeyInfo where
+ mempty = SshPubKeyInfo M.empty
+ mappend (SshPubKeyInfo old) (SshPubKeyInfo new) =
+ -- new first because union prefers values from the first
+ -- parameter when there is a duplicate key
+ SshPubKeyInfo (new `M.union` old)
-- | Sets up a user with a ssh private key and public key pair from the
-- PrivData.
diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs
index 4da5b3f2..e44ef717 100644
--- a/src/Propellor/Property/Systemd.hs
+++ b/src/Propellor/Property/Systemd.hs
@@ -43,6 +43,7 @@ module Propellor.Property.Systemd (
import Propellor
import Propellor.Types.Chroot
import Propellor.Types.Container
+import Propellor.Types.Info
import qualified Propellor.Property.Chroot as Chroot
import qualified Propellor.Property.Apt as Apt
import qualified Propellor.Property.File as File
@@ -209,7 +210,7 @@ nspawned c@(Container name (Chroot.Chroot loc system builderconf _) h) =
where
p = enterScript c
`before` chrootprovisioned
- `before` nspawnService c (_chrootCfg $ _chrootinfo $ hostInfo h)
+ `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h)
`before` containerprovisioned
-- Chroot provisioning is run in systemd-only mode,
@@ -328,7 +329,7 @@ containerCfg :: String -> RevertableProperty
containerCfg p = RevertableProperty (mk True) (mk False)
where
mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $
- mempty { _chrootinfo = mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] } }
+ mempty { _chrootCfg = SystemdNspawnCfg [(p', b)] }
p' = case p of
('-':_) -> p
_ -> "--" ++ p
diff --git a/src/Propellor/Spin.hs b/src/Propellor/Spin.hs
index 61d519c3..cce754ca 100644
--- a/src/Propellor/Spin.hs
+++ b/src/Propellor/Spin.hs
@@ -24,6 +24,7 @@ import Propellor.Ssh
import Propellor.Gpg
import Propellor.Bootstrap
import Propellor.Types.CmdLine
+import Propellor.Types.Info
import qualified Propellor.Shim as Shim
import Utility.FileMode
import Utility.SafeCommand
@@ -126,7 +127,7 @@ getSshTarget target hst
return ip
configips = map fromIPAddr $ mapMaybe getIPAddr $
- S.toList $ _dns $ hostInfo hst
+ S.toList $ fromDnsInfo $ getInfo $ hostInfo hst
-- Update the privdata, repo url, and git repo over the ssh
-- connection, talking to the user's local propellor instance which is
diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs
index 474385b7..1fc26892 100644
--- a/src/Propellor/Types.hs
+++ b/src/Propellor/Types.hs
@@ -6,11 +6,13 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable #-}
module Propellor.Types
( Host(..)
, Desc
, Property
+ , Info
, HasInfo
, NoInfo
, CInfo
@@ -27,7 +29,6 @@ module Propellor.Types
, CombinedType
, before
, combineWith
- , Info(..)
, Propellor(..)
, EndAction(..)
, module Propellor.Types.OS
@@ -41,18 +42,12 @@ import Data.Monoid
import Control.Applicative
import "mtl" Control.Monad.RWS.Strict
import Control.Monad.Catch
-import qualified Data.Set as S
-import qualified Data.Map as M
+import Data.Typeable
+import Propellor.Types.Info
import Propellor.Types.OS
-import Propellor.Types.Chroot
import Propellor.Types.Dns
-import Propellor.Types.Docker
-import Propellor.Types.PrivData
-import Propellor.Types.Empty
-import Propellor.Types.Val
import Propellor.Types.Result
-import qualified Propellor.Types.Dns as Dns
-- | Everything Propellor knows about a system: Its hostname,
-- properties and their collected info.
@@ -61,7 +56,7 @@ data Host = Host
, hostProperties :: [Property HasInfo]
, hostInfo :: Info
}
- deriving (Show)
+ 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.
@@ -269,41 +264,3 @@ instance Combines RevertableProperty RevertableProperty where
(x1 `requires` y1)
-- when reverting, run actions in reverse order
(y2 `requires` x2)
-
--- | Information about a host.
-data Info = Info
- { _os :: Val System
- , _privData :: S.Set (PrivDataField, Maybe PrivDataSourceDesc, HostContext)
- , _sshPubKey :: M.Map SshKeyType String
- , _aliases :: S.Set HostName
- , _dns :: S.Set Dns.Record
- , _namedconf :: Dns.NamedConfMap
- , _dockerinfo :: DockerInfo Host
- , _chrootinfo :: ChrootInfo Host
- }
- deriving (Show)
-
-instance Monoid Info where
- mempty = Info mempty mempty mempty mempty mempty mempty mempty mempty
- mappend old new = Info
- { _os = _os old <> _os new
- , _privData = _privData old <> _privData new
- , _sshPubKey = _sshPubKey new `M.union` _sshPubKey old
- , _aliases = _aliases old <> _aliases new
- , _dns = _dns old <> _dns new
- , _namedconf = _namedconf old <> _namedconf new
- , _dockerinfo = _dockerinfo old <> _dockerinfo new
- , _chrootinfo = _chrootinfo old <> _chrootinfo new
- }
-
-instance Empty Info where
- isEmpty i = and
- [ isEmpty (_os i)
- , isEmpty (_privData i)
- , isEmpty (_sshPubKey i)
- , isEmpty (_aliases i)
- , isEmpty (_dns i)
- , isEmpty (_namedconf i)
- , isEmpty (_dockerinfo i)
- , isEmpty (_chrootinfo i)
- ]
diff --git a/src/Propellor/Types/Chroot.hs b/src/Propellor/Types/Chroot.hs
index d37d34c7..d92c7070 100644
--- a/src/Propellor/Types/Chroot.hs
+++ b/src/Propellor/Types/Chroot.hs
@@ -1,23 +1,31 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Propellor.Types.Chroot where
+import Propellor.Types
+import Propellor.Types.Empty
+import Propellor.Types.Info
+
import Data.Monoid
import qualified Data.Map as M
-import Propellor.Types.Empty
-data ChrootInfo host = ChrootInfo
- { _chroots :: M.Map FilePath host
+data ChrootInfo = ChrootInfo
+ { _chroots :: M.Map FilePath Host
, _chrootCfg :: ChrootCfg
}
- deriving (Show)
+ deriving (Show, Typeable)
+
+instance IsInfo ChrootInfo where
+ propigateInfo _ = False
-instance Monoid (ChrootInfo host) where
+instance Monoid ChrootInfo where
mempty = ChrootInfo mempty mempty
mappend old new = ChrootInfo
{ _chroots = M.union (_chroots old) (_chroots new)
, _chrootCfg = _chrootCfg old <> _chrootCfg new
}
-instance Empty (ChrootInfo host) where
+instance Empty ChrootInfo where
isEmpty i = and
[ isEmpty (_chroots i)
, isEmpty (_chrootCfg i)
diff --git a/src/Propellor/Types/Dns.hs b/src/Propellor/Types/Dns.hs
index 50297f57..d78c78fd 100644
--- a/src/Propellor/Types/Dns.hs
+++ b/src/Propellor/Types/Dns.hs
@@ -1,11 +1,15 @@
+{-# LANGUAGE DeriveDataTypeable, GeneralizedNewtypeDeriving #-}
+
module Propellor.Types.Dns where
import Propellor.Types.OS (HostName)
import Propellor.Types.Empty
+import Propellor.Types.Info
import Data.Word
import Data.Monoid
import qualified Data.Map as M
+import qualified Data.Set as S
type Domain = String
@@ -16,6 +20,29 @@ fromIPAddr :: IPAddr -> String
fromIPAddr (IPv4 addr) = addr
fromIPAddr (IPv6 addr) = addr
+newtype AliasesInfo = AliasesInfo (S.Set HostName)
+ deriving (Show, Eq, Ord, Monoid, Typeable)
+
+instance IsInfo AliasesInfo where
+ propigateInfo _ = False
+
+toAliasesInfo :: [HostName] -> AliasesInfo
+toAliasesInfo l = AliasesInfo (S.fromList l)
+
+fromAliasesInfo :: AliasesInfo -> [HostName]
+fromAliasesInfo (AliasesInfo s) = S.toList s
+
+newtype DnsInfo = DnsInfo { fromDnsInfo :: S.Set Record }
+ deriving (Show, Eq, Ord, Monoid, Typeable)
+
+toDnsInfo :: S.Set Record -> DnsInfo
+toDnsInfo = DnsInfo
+
+-- | DNS Info is propigated, so that eg, aliases of a container
+-- are reflected in the dns for the host where it runs.
+instance IsInfo DnsInfo where
+ propigateInfo _ = True
+
-- | Represents a bind 9 named.conf file.
data NamedConf = NamedConf
{ confDomain :: Domain
@@ -64,7 +91,7 @@ data Record
| SRV Word16 Word16 Word16 BindDomain
| SSHFP Int Int String
| INCLUDE FilePath
- deriving (Read, Show, Eq, Ord)
+ deriving (Read, Show, Eq, Ord, Typeable)
getIPAddr :: Record -> Maybe IPAddr
getIPAddr (Address addr) = Just addr
@@ -97,7 +124,10 @@ domainHostName (AbsDomain d) = Just d
domainHostName RootDomain = Nothing
newtype NamedConfMap = NamedConfMap (M.Map Domain NamedConf)
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Typeable)
+
+instance IsInfo NamedConfMap where
+ propigateInfo _ = False
-- | Adding a Master NamedConf stanza for a particulr domain always
-- overrides an existing Secondary stanza for that domain, while a
diff --git a/src/Propellor/Types/Docker.hs b/src/Propellor/Types/Docker.hs
index 3eafa59d..a1ed4cd9 100644
--- a/src/Propellor/Types/Docker.hs
+++ b/src/Propellor/Types/Docker.hs
@@ -1,25 +1,31 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Propellor.Types.Docker where
-import Propellor.Types.OS
+import Propellor.Types
import Propellor.Types.Empty
+import Propellor.Types.Info
import Data.Monoid
import qualified Data.Map as M
-data DockerInfo h = DockerInfo
+data DockerInfo = DockerInfo
{ _dockerRunParams :: [DockerRunParam]
- , _dockerContainers :: M.Map String h
+ , _dockerContainers :: M.Map String Host
}
- deriving (Show)
+ deriving (Show, Typeable)
+
+instance IsInfo DockerInfo where
+ propigateInfo _ = False
-instance Monoid (DockerInfo h) where
+instance Monoid DockerInfo where
mempty = DockerInfo mempty mempty
mappend old new = DockerInfo
{ _dockerRunParams = _dockerRunParams old <> _dockerRunParams new
, _dockerContainers = M.union (_dockerContainers old) (_dockerContainers new)
}
-instance Empty (DockerInfo h) where
+instance Empty DockerInfo where
isEmpty i = and
[ isEmpty (_dockerRunParams i)
, isEmpty (_dockerContainers i)
diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs
new file mode 100644
index 00000000..d5c463c3
--- /dev/null
+++ b/src/Propellor/Types/Info.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
+module Propellor.Types.Info (
+ Info,
+ IsInfo(..),
+ addInfo,
+ getInfo,
+ propigatableInfo,
+ InfoVal(..),
+ fromInfoVal,
+ Typeable,
+) where
+
+import Data.Dynamic
+import Data.Monoid
+import Data.Maybe
+
+-- | Information about a Host, which can be provided by its properties.
+--
+-- Any value in the `IsInfo` type class can be added to an Info.
+data Info = Info [(Dynamic, Bool)]
+
+instance Show Info where
+ show (Info l) = "Info " ++ show (length l)
+
+instance Monoid Info where
+ mempty = Info []
+ mappend (Info a) (Info b) = Info (a <> b)
+
+-- | Values stored in Info must be members of this class.
+--
+-- This is used to avoid accidentially using other data types
+-- as info, especially type aliases which coud easily lead to bugs.
+-- We want a little bit of dynamic types here, but not too far..
+class (Typeable v, Monoid v) => IsInfo v where
+ -- | Should info of this type be propigated out of a
+ -- container to its Host?
+ propigateInfo :: v -> Bool
+
+addInfo :: IsInfo v => Info -> v -> Info
+addInfo (Info l) v = Info ((toDyn v, propigateInfo v):l)
+
+getInfo :: IsInfo v => Info -> v
+getInfo (Info l) = mconcat (mapMaybe (fromDynamic . fst) (reverse l))
+
+-- | Filters out parts of the Info that should not propigate out of a
+-- container.
+propigatableInfo :: Info -> Info
+propigatableInfo (Info l) = Info (filter snd l)
+
+-- | Use this to put a value in Info that is not a monoid.
+-- The last value set will be used. This info does not propigate
+-- out of a container.
+data InfoVal v = NoInfoVal | InfoVal v
+ deriving (Typeable)
+
+instance Monoid (InfoVal v) where
+ mempty = NoInfoVal
+ mappend _ v@(InfoVal _) = v
+ mappend v NoInfoVal = v
+
+instance Typeable v => IsInfo (InfoVal v) where
+ propigateInfo _ = False
+
+fromInfoVal :: InfoVal v -> Maybe v
+fromInfoVal NoInfoVal = Nothing
+fromInfoVal (InfoVal v) = Just v
diff --git a/src/Propellor/Types/OS.hs b/src/Propellor/Types/OS.hs
index c46d9a28..eb6b5171 100644
--- a/src/Propellor/Types/OS.hs
+++ b/src/Propellor/Types/OS.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+
module Propellor.Types.OS (
System(..),
Distribution(..),
@@ -14,10 +16,11 @@ module Propellor.Types.OS (
) where
import Network.BSD (HostName)
+import Data.Typeable
-- | High level description of a operating system.
data System = System Distribution Architecture
- deriving (Show, Eq)
+ deriving (Show, Eq, Typeable)
data Distribution
= Debian DebianSuite
diff --git a/src/Propellor/Types/Val.hs b/src/Propellor/Types/Val.hs
deleted file mode 100644
index 8890bee8..00000000
--- a/src/Propellor/Types/Val.hs
+++ /dev/null
@@ -1,22 +0,0 @@
-module Propellor.Types.Val where
-
-import Data.Monoid
-
-import Propellor.Types.Empty
-
-data Val a = Val a | NoVal
- deriving (Eq, Show)
-
-instance Monoid (Val a) where
- mempty = NoVal
- mappend old new = case new of
- NoVal -> old
- _ -> new
-
-instance Empty (Val a) where
- isEmpty NoVal = True
- isEmpty _ = False
-
-fromVal :: Val a -> Maybe a
-fromVal (Val a) = Just a
-fromVal NoVal = Nothing