summaryrefslogtreecommitdiff
path: root/src/Propellor/Property
diff options
context:
space:
mode:
authorJoey Hess2015-09-06 08:19:02 -0700
committerJoey Hess2015-09-06 16:13:54 -0400
commitdef53b64cc17b95eb5729dd97a800dfe1257b352 (patch)
tree03f63e5bcb6486b00639e1ea78c21d8928c3b8ca /src/Propellor/Property
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.
Diffstat (limited to 'src/Propellor/Property')
-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
5 files changed, 44 insertions, 23 deletions
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