From fc49d75e4fb9e8d2c7ce9d60647a26ecc030d253 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 9 Jun 2014 01:45:58 -0400 Subject: Attr is renamed to Info. --- src/Propellor.hs | 4 +- src/Propellor/Attr.hs | 83 -------------------------------------- src/Propellor/Engine.hs | 2 +- src/Propellor/Info.hs | 83 ++++++++++++++++++++++++++++++++++++++ src/Propellor/Property.hs | 20 ++++----- src/Propellor/Property/Dns.hs | 26 ++++++------ src/Propellor/Property/Docker.hs | 32 +++++++-------- src/Propellor/Property/Hostname.hs | 2 +- src/Propellor/Types.hs | 30 +++++++------- src/Propellor/Types/Attr.hs | 65 ----------------------------- src/Propellor/Types/Info.hs | 65 +++++++++++++++++++++++++++++ 11 files changed, 206 insertions(+), 206 deletions(-) delete mode 100644 src/Propellor/Attr.hs create mode 100644 src/Propellor/Info.hs delete mode 100644 src/Propellor/Types/Attr.hs create mode 100644 src/Propellor/Types/Info.hs (limited to 'src') diff --git a/src/Propellor.hs b/src/Propellor.hs index e6312248..c0ef14f4 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.Attr + , module Propellor.Info , module Propellor.PrivData , module Propellor.Engine , module Propellor.Exception @@ -50,7 +50,7 @@ import Propellor.Property.Cmd import Propellor.PrivData import Propellor.Message import Propellor.Exception -import Propellor.Attr +import Propellor.Info import Utility.PartialPrelude as X import Utility.Process as X diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs deleted file mode 100644 index 7d371d40..00000000 --- a/src/Propellor/Attr.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE PackageImports #-} - -module Propellor.Attr where - -import Propellor.Types -import Propellor.Types.Attr - -import "mtl" Control.Monad.Reader -import qualified Data.Set as S -import qualified Data.Map as M -import Data.Maybe -import Data.Monoid -import Control.Applicative - -pureAttrProperty :: Desc -> Attr -> Property -pureAttrProperty desc = Property ("has " ++ desc) (return NoChange) - -askAttr :: (Attr -> Val a) -> Propellor (Maybe a) -askAttr f = asks (fromVal . f . hostAttr) - -os :: System -> Property -os system = pureAttrProperty ("Operating " ++ show system) $ - mempty { _os = Val system } - -getOS :: Propellor (Maybe System) -getOS = askAttr _os - --- | Indidate that a host has an A record in the DNS. --- --- TODO check at run time if the host really has this address. --- (Can't change the host's address, but as a sanity check.) -ipv4 :: String -> Property -ipv4 = addDNS . Address . IPv4 - --- | Indidate that a host has an AAAA record in the DNS. -ipv6 :: String -> Property -ipv6 = addDNS . Address . IPv6 - --- | Indicates another name for the host in the DNS. --- --- When the host's ipv4/ipv6 addresses are known, the alias is set up --- to use their address, rather than using a CNAME. This avoids various --- 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 -alias = addDNS . CNAME . AbsDomain - -addDNS :: Record -> Property -addDNS r = pureAttrProperty (rdesc r) $ - mempty { _dns = S.singleton r } - where - rdesc (CNAME d) = unwords ["alias", ddesc d] - rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] - rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr] - rdesc (MX n d) = unwords ["MX", show n, ddesc d] - rdesc (NS d) = unwords ["NS", ddesc d] - rdesc (TXT s) = unwords ["TXT", s] - rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] - - ddesc (AbsDomain domain) = domain - ddesc (RelDomain domain) = domain - ddesc RootDomain = "@" - -sshPubKey :: String -> Property -sshPubKey k = pureAttrProperty ("ssh pubkey known") $ - mempty { _sshPubKey = Val k } - -getSshPubKey :: Propellor (Maybe String) -getSshPubKey = askAttr _sshPubKey - -hostMap :: [Host] -> M.Map HostName Host -hostMap l = M.fromList $ zip (map hostName l) l - -findHost :: [Host] -> HostName -> Maybe Host -findHost l hn = M.lookup hn (hostMap l) - -getAddresses :: Attr -> [IPAddr] -getAddresses = mapMaybe getIPAddr . S.toList . _dns - -hostAddresses :: HostName -> [Host] -> [IPAddr] -hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of - Nothing -> [] - Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index ca0f7265..a3fc0f30 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -12,7 +12,7 @@ import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Message import Propellor.Exception -import Propellor.Attr +import Propellor.Info runPropellor :: Host -> Propellor a -> IO a runPropellor host a = runReaderT (runWithHost a) host diff --git a/src/Propellor/Info.hs b/src/Propellor/Info.hs new file mode 100644 index 00000000..00f1b0e9 --- /dev/null +++ b/src/Propellor/Info.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE PackageImports #-} + +module Propellor.Info where + +import Propellor.Types +import Propellor.Types.Info + +import "mtl" Control.Monad.Reader +import qualified Data.Set as S +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Control.Applicative + +pureInfoProperty :: Desc -> Info -> Property +pureInfoProperty desc = Property ("has " ++ desc) (return NoChange) + +askInfo :: (Info -> Val a) -> Propellor (Maybe a) +askInfo f = asks (fromVal . f . hostInfo) + +os :: System -> Property +os system = pureInfoProperty ("Operating " ++ show system) $ + mempty { _os = Val system } + +getOS :: Propellor (Maybe System) +getOS = askInfo _os + +-- | Indidate that a host has an A record in the DNS. +-- +-- TODO check at run time if the host really has this address. +-- (Can't change the host's address, but as a sanity check.) +ipv4 :: String -> Property +ipv4 = addDNS . Address . IPv4 + +-- | Indidate that a host has an AAAA record in the DNS. +ipv6 :: String -> Property +ipv6 = addDNS . Address . IPv6 + +-- | Indicates another name for the host in the DNS. +-- +-- When the host's ipv4/ipv6 addresses are known, the alias is set up +-- to use their address, rather than using a CNAME. This avoids various +-- 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 +alias = addDNS . CNAME . AbsDomain + +addDNS :: Record -> Property +addDNS r = pureInfoProperty (rdesc r) $ + mempty { _dns = S.singleton r } + where + rdesc (CNAME d) = unwords ["alias", ddesc d] + rdesc (Address (IPv4 addr)) = unwords ["ipv4", addr] + rdesc (Address (IPv6 addr)) = unwords ["ipv6", addr] + rdesc (MX n d) = unwords ["MX", show n, ddesc d] + rdesc (NS d) = unwords ["NS", ddesc d] + rdesc (TXT s) = unwords ["TXT", s] + rdesc (SRV x y z d) = unwords ["SRV", show x, show y, show z, ddesc d] + + ddesc (AbsDomain domain) = domain + ddesc (RelDomain domain) = domain + ddesc RootDomain = "@" + +sshPubKey :: String -> Property +sshPubKey k = pureInfoProperty ("ssh pubkey known") $ + mempty { _sshPubKey = Val k } + +getSshPubKey :: Propellor (Maybe String) +getSshPubKey = askInfo _sshPubKey + +hostMap :: [Host] -> M.Map HostName Host +hostMap l = M.fromList $ zip (map hostName l) l + +findHost :: [Host] -> HostName -> Maybe Host +findHost l hn = M.lookup hn (hostMap l) + +getAddresses :: Info -> [IPAddr] +getAddresses = mapMaybe getIPAddr . S.toList . _dns + +hostAddresses :: HostName -> [Host] -> [IPAddr] +hostAddresses hn hosts = case hostInfo <$> findHost hosts hn of + Nothing -> [] + Just info -> mapMaybe getIPAddr $ S.toList $ _dns info diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 8e419a6b..68b6f6a9 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -9,7 +9,7 @@ import Control.Monad.IfElse import "mtl" Control.Monad.Reader import Propellor.Types -import Propellor.Attr +import Propellor.Info import Propellor.Engine import Utility.Monad import System.FilePath @@ -23,13 +23,13 @@ property d s = Property d s mempty -- and print out the description of each as it's run. Does not stop -- on failure; does propigate overall success/failure. propertyList :: Desc -> [Property] -> Property -propertyList desc ps = Property desc (ensureProperties ps) (combineAttrs ps) +propertyList desc ps = Property desc (ensureProperties ps) (combineInfos ps) -- | Combines a list of properties, resulting in one property that -- ensures each in turn. Does not stop on failure; does propigate -- overall success/failure. combineProperties :: Desc -> [Property] -> Property -combineProperties desc ps = Property desc (go ps NoChange) (combineAttrs ps) +combineProperties desc ps = Property desc (go ps NoChange) (combineInfos ps) where go [] rs = return rs go (l:ls) rs = do @@ -68,7 +68,7 @@ flagFile' p getflagfile = adjustProperty p $ \satisfy -> do --- | Whenever a change has to be made for a Property, causes a hook -- Property to also be run, but not otherwise. onChange :: Property -> Property -> Property -p `onChange` hook = Property (propertyDesc p) satisfy (combineAttr p hook) +p `onChange` hook = Property (propertyDesc p) satisfy (combineInfo p hook) where satisfy = do r <- ensureProperty p @@ -135,7 +135,7 @@ host hn = Host hn [] mempty -- -- Can add Properties and RevertableProperties (&) :: IsProp p => Host -> p -> Host -(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (as <> getAttr p) +(Host hn ps as) & p = Host hn (ps ++ [toProp p]) (as <> getInfo p) infixl 1 & @@ -149,12 +149,12 @@ infixl 1 ! adjustProperty :: Property -> (Propellor Result -> Propellor Result) -> Property adjustProperty p f = p { propertySatisfy = f (propertySatisfy p) } --- Combines the Attr of two properties. -combineAttr :: (IsProp p, IsProp q) => p -> q -> Attr -combineAttr p q = getAttr p <> getAttr q +-- Combines the Info of two properties. +combineInfo :: (IsProp p, IsProp q) => p -> q -> Info +combineInfo p q = getInfo p <> getInfo q -combineAttrs :: IsProp p => [p] -> Attr -combineAttrs = mconcat . map getAttr +combineInfos :: IsProp p => [p] -> Info +combineInfos = mconcat . map getInfo makeChange :: IO () -> Propellor Result makeChange a = liftIO a >> return MadeChange diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 50ce649e..ddfcf8e6 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -15,7 +15,7 @@ module Propellor.Property.Dns ( import Propellor import Propellor.Types.Dns import Propellor.Property.File -import Propellor.Types.Attr +import Propellor.Types.Info import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Service as Service import Utility.Applicative @@ -113,7 +113,7 @@ secondary hosts domain = secondaryFor (otherServers Master hosts domain) hosts d secondaryFor :: [HostName] -> [Host] -> Domain -> RevertableProperty secondaryFor masters hosts domain = RevertableProperty setup cleanup where - setup = pureAttrProperty desc (addNamedConf conf) + setup = pureInfoProperty desc (addNamedConf conf) `requires` servingZones cleanup = namedConfWritten @@ -131,7 +131,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 $ hostAttr h) of + wanted h = case M.lookup domain (fromNamedConfMap $ _namedconf $ hostInfo h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -346,7 +346,7 @@ genZone hosts zdomain soa = inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m -- Each host with a hostname located in the zdomain - -- should have 1 or more IPAddrs in its Attr. + -- should have 1 or more IPAddrs in its Info. -- -- If a host lacks any IPAddr, it's probably a misconfiguration, -- so warn. @@ -355,9 +355,9 @@ genZone hosts zdomain soa = | null l = [Left $ "no IP address defined for host " ++ hostName h] | otherwise = map Right l where - attr = hostAttr h + info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (map Address $ getAddresses attr) + (map Address $ getAddresses info) -- Any host, whether its hostname is in the zdomain or not, -- may have cnames which are in the zdomain. The cname may even be @@ -373,10 +373,10 @@ genZone hosts 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 attr) + mapMaybe getCNAME $ S.toList (_dns info) where - attr = hostAttr h - gen c = case getAddresses attr of + info = hostInfo h + gen c = case getAddresses info of [] -> [ret (CNAME c)] l -> map (ret . Address) l where @@ -386,9 +386,9 @@ genZone hosts zdomain soa = hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] hostrecords h = map Right l where - attr = hostAttr h + info = hostInfo h l = zip (repeat $ AbsDomain $ hostName h) - (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -417,10 +417,10 @@ domainHost base (AbsDomain d) where dotbase = '.':base -addNamedConf :: NamedConf -> Attr +addNamedConf :: NamedConf -> Info addNamedConf conf = mempty { _namedconf = NamedConfMap (M.singleton domain conf) } where domain = confDomain conf getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks $ fromNamedConfMap . _namedconf . hostAttr +getNamedConf = asks $ fromNamedConfMap . _namedconf . hostInfo diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index fa3e2344..1521eb65 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -35,7 +35,7 @@ module Propellor.Property.Docker ( import Propellor import Propellor.SimpleSh -import Propellor.Types.Attr +import Propellor.Types.Info import qualified Propellor.Property.File as File import qualified Propellor.Property.Apt as Apt import qualified Propellor.Property.Docker.Shim as Shim @@ -72,9 +72,9 @@ type ContainerName = String -- > & Apt.installed {"apache2"] -- > & ... container :: ContainerName -> Image -> Host -container cn image = Host hn [] attr +container cn image = Host hn [] info where - attr = dockerAttr $ mempty { _dockerImage = Val image } + info = dockerInfo $ mempty { _dockerImage = Val image } hn = cn2hn cn cn2hn :: ContainerName -> HostName @@ -86,8 +86,8 @@ cn2hn cn = cn ++ ".docker" -- The container has its own Properties which are handled by running -- propellor inside the container. -- --- Additionally, the container can have DNS attributes, such as a CNAME. --- These become attributes of the host(s) it's docked in. +-- Additionally, the container can have DNS info, such as a CNAME. +-- These become info of the host(s) it's docked in. -- -- Reverting this property ensures that the container is stopped and -- removed. @@ -96,7 +96,7 @@ docked -> ContainerName -> RevertableProperty docked hosts cn = RevertableProperty - ((maybe id exposeDnsAttrs mhost) (go "docked" setup)) + ((maybe id exposeDnsInfos mhost) (go "docked" setup)) (go "undocked" teardown) where go desc a = property (desc ++ " " ++ cn) $ do @@ -123,9 +123,9 @@ docked hosts cn = RevertableProperty ] ] -exposeDnsAttrs :: Host -> Property -> Property -exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $ - p : map addDNS (S.toList $ _dns containerattr) +exposeDnsInfos :: Host -> Property -> Property +exposeDnsInfos (Host _ _ containerinfo) p = combineProperties (propertyDesc p) $ + p : map addDNS (S.toList $ _dns containerinfo) findContainer :: Maybe Host @@ -144,10 +144,10 @@ findContainer mhost cid cn mk = case mhost of mkContainer :: ContainerId -> Host -> Maybe Container mkContainer cid@(ContainerId hn _cn) h = Container - <$> fromVal (_dockerImage attr) - <*> pure (map (\a -> a hn) (_dockerRunParams attr)) + <$> fromVal (_dockerImage info) + <*> pure (map (\a -> a hn) (_dockerRunParams info)) where - attr = _dockerattr $ hostAttr h' + info = _dockerinfo $ hostInfo h' h' = h -- expose propellor directory inside the container & volume (localdir++":"++localdir) @@ -469,17 +469,17 @@ listImages :: IO [Image] listImages = lines <$> readProcess dockercmd ["images", "--all", "--quiet"] runProp :: String -> RunParam -> Property -runProp field val = pureAttrProperty (param) $ dockerAttr $ +runProp field val = pureInfoProperty (param) $ dockerInfo $ mempty { _dockerRunParams = [\_ -> "--"++param] } where param = field++"="++val genProp :: String -> (HostName -> RunParam) -> Property -genProp field mkval = pureAttrProperty field $ dockerAttr $ +genProp field mkval = pureInfoProperty field $ dockerInfo $ mempty { _dockerRunParams = [\hn -> "--"++field++"=" ++ mkval hn] } -dockerAttr :: DockerAttr -> Attr -dockerAttr a = mempty { _dockerattr = a } +dockerInfo :: DockerInfo -> Info +dockerInfo i = mempty { _dockerinfo = 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/Hostname.hs b/src/Propellor/Property/Hostname.hs index 3a6283cf..10fda040 100644 --- a/src/Propellor/Property/Hostname.hs +++ b/src/Propellor/Property/Hostname.hs @@ -3,7 +3,7 @@ module Propellor.Property.Hostname where import Propellor import qualified Propellor.Property.File as File --- | Ensures that the hostname is set to the HostAttr value. +-- | Ensures that the hostname is set to the HostInfo value. -- Configures /etc/hostname and the current hostname. -- -- A FQDN also configures /etc/hosts, with an entry for 127.0.1.1, which is diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index d91ce71b..383797a9 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -3,8 +3,8 @@ module Propellor.Types ( Host(..) - , Attr - , getAttr + , Info + , getInfo , Propellor(..) , Property(..) , RevertableProperty(..) @@ -29,21 +29,21 @@ import System.Console.ANSI import "mtl" Control.Monad.Reader import "MonadCatchIO-transformers" Control.Monad.CatchIO -import Propellor.Types.Attr +import Propellor.Types.Info import Propellor.Types.OS import Propellor.Types.Dns -- | Everything Propellor knows about a system: Its hostname, --- properties and attributes. +-- properties and other info. data Host = Host { hostName :: HostName , hostProperties :: [Property] - , hostAttr :: Attr + , hostInfo :: Info } deriving (Show) --- | Propellor's monad provides read-only access to the host it's running --- on, including its attributes. +-- | Propellor's monad provides read-only access to info about the host +-- it's running on. newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p } deriving ( Monad @@ -61,8 +61,8 @@ data Property = Property { propertyDesc :: Desc , propertySatisfy :: Propellor Result -- ^ must be idempotent; may run repeatedly - , propertyAttr :: Attr - -- ^ a property can set an attribute of the host that has the property. + , propertyInfo :: Info + -- ^ a property can add info to the host. } instance Show Property where @@ -78,15 +78,15 @@ class IsProp p where -- | Indicates that the first property can only be satisfied -- once the second one is. requires :: p -> Property -> p - getAttr :: p -> Attr + getInfo :: p -> Info instance IsProp Property where describe p d = p { propertyDesc = d } toProp p = p - getAttr = propertyAttr - x `requires` y = Property (propertyDesc x) satisfy attr + getInfo = propertyInfo + x `requires` y = Property (propertyDesc x) satisfy info where - attr = getAttr y <> getAttr x + info = getInfo y <> getInfo x satisfy = do r <- propertySatisfy y case r of @@ -101,8 +101,8 @@ instance IsProp RevertableProperty where toProp (RevertableProperty p1 _) = p1 (RevertableProperty p1 p2) `requires` y = RevertableProperty (p1 `requires` y) p2 - -- | Return the Attr of the currently active side. - getAttr (RevertableProperty p1 _p2) = getAttr p1 + -- | Return the Info of the currently active side. + getInfo (RevertableProperty p1 _p2) = getInfo p1 type Desc = String diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs deleted file mode 100644 index 4389a4e5..00000000 --- a/src/Propellor/Types/Attr.hs +++ /dev/null @@ -1,65 +0,0 @@ -module Propellor.Types.Attr where - -import Propellor.Types.OS -import qualified Propellor.Types.Dns as Dns - -import qualified Data.Set as S -import Data.Monoid - --- | The attributes of a host. -data Attr = Attr - { _os :: Val System - , _sshPubKey :: Val String - , _dns :: S.Set Dns.Record - , _namedconf :: Dns.NamedConfMap - , _dockerattr :: DockerAttr - } - deriving (Eq, Show) - -instance Monoid Attr where - mempty = Attr mempty mempty mempty mempty mempty - mappend old new = Attr - { _os = _os old <> _os new - , _sshPubKey = _sshPubKey old <> _sshPubKey new - , _dns = _dns old <> _dns new - , _namedconf = _namedconf old <> _namedconf new - , _dockerattr = _dockerattr old <> _dockerattr new - } - -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 - -fromVal :: Val a -> Maybe a -fromVal (Val a) = Just a -fromVal NoVal = Nothing - -data DockerAttr = DockerAttr - { _dockerImage :: Val String - , _dockerRunParams :: [HostName -> String] - } - -instance Eq DockerAttr where - x == y = and - [ _dockerImage x == _dockerImage y - , let simpl v = map (\a -> a "") (_dockerRunParams v) - in simpl x == simpl y - ] - -instance Monoid DockerAttr where - mempty = DockerAttr mempty mempty - mappend old new = DockerAttr - { _dockerImage = _dockerImage old <> _dockerImage new - , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new - } - -instance Show DockerAttr where - show a = unlines - [ "docker image " ++ show (_dockerImage a) - , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) - ] diff --git a/src/Propellor/Types/Info.hs b/src/Propellor/Types/Info.hs new file mode 100644 index 00000000..5f034492 --- /dev/null +++ b/src/Propellor/Types/Info.hs @@ -0,0 +1,65 @@ +module Propellor.Types.Info where + +import Propellor.Types.OS +import qualified Propellor.Types.Dns as Dns + +import qualified Data.Set as S +import Data.Monoid + +-- | Information about a host. +data Info = Info + { _os :: Val System + , _sshPubKey :: Val String + , _dns :: S.Set Dns.Record + , _namedconf :: Dns.NamedConfMap + , _dockerinfo :: DockerInfo + } + deriving (Eq, Show) + +instance Monoid Info where + mempty = Info mempty mempty mempty mempty mempty + mappend old new = Info + { _os = _os old <> _os new + , _sshPubKey = _sshPubKey old <> _sshPubKey new + , _dns = _dns old <> _dns new + , _namedconf = _namedconf old <> _namedconf new + , _dockerinfo = _dockerinfo old <> _dockerinfo new + } + +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 + +fromVal :: Val a -> Maybe a +fromVal (Val a) = Just a +fromVal NoVal = Nothing + +data DockerInfo = DockerInfo + { _dockerImage :: Val String + , _dockerRunParams :: [HostName -> String] + } + +instance Eq DockerInfo where + x == y = and + [ _dockerImage x == _dockerImage y + , let simpl v = map (\a -> a "") (_dockerRunParams v) + in simpl x == simpl y + ] + +instance Monoid DockerInfo where + mempty = DockerInfo mempty mempty + mappend old new = DockerInfo + { _dockerImage = _dockerImage old <> _dockerImage new + , _dockerRunParams = _dockerRunParams old <> _dockerRunParams new + } + +instance Show DockerInfo where + show a = unlines + [ "docker image " ++ show (_dockerImage a) + , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) + ] -- cgit v1.2.3