From def53b64cc17b95eb5729dd97a800dfe1257b352 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 6 Sep 2015 08:19:02 -0700 Subject: 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. --- debian/changelog | 6 +++- propellor.cabal | 2 +- src/Propellor/Info.hs | 38 +++++++++++----------- src/Propellor/PrivData.hs | 26 +++++++++++---- src/Propellor/PropAccum.hs | 15 ++------- src/Propellor/Property/Chroot.hs | 7 ++-- src/Propellor/Property/Dns.hs | 17 +++++----- src/Propellor/Property/Docker.hs | 13 ++++---- src/Propellor/Property/Ssh.hs | 25 ++++++++++++--- src/Propellor/Property/Systemd.hs | 5 +-- src/Propellor/Spin.hs | 3 +- src/Propellor/Types.hs | 53 +++---------------------------- src/Propellor/Types/Chroot.hs | 20 ++++++++---- src/Propellor/Types/Dns.hs | 34 ++++++++++++++++++-- src/Propellor/Types/Docker.hs | 18 +++++++---- src/Propellor/Types/Info.hs | 67 +++++++++++++++++++++++++++++++++++++++ src/Propellor/Types/OS.hs | 5 ++- src/Propellor/Types/Val.hs | 22 ------------- 18 files changed, 228 insertions(+), 148 deletions(-) create mode 100644 src/Propellor/Types/Info.hs delete mode 100644 src/Propellor/Types/Val.hs 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 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 -- 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 -- cgit v1.2.3