From 5fc4b006517051e937cbfa13b5f7ccbc25460c1b Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 31 May 2014 18:02:56 -0400 Subject: remove now redundant _hostname field of Attr Now that Host includes _hostName, it's redundant to also keep it in Attr. This requires changing the reader monad to operate on the whole Host. --- src/Propellor/Attr.hs | 26 +++++--------------------- src/Propellor/CmdLine.hs | 23 ++++++++++------------- src/Propellor/Engine.hs | 23 +++++++++++++++++------ src/Propellor/Property.hs | 2 +- src/Propellor/Property/Dns.hs | 27 +++++++++++++++------------ src/Propellor/Property/Docker.hs | 4 ++-- src/Propellor/Types.hs | 8 ++++---- src/Propellor/Types/Attr.hs | 15 ++++++--------- 8 files changed, 60 insertions(+), 68 deletions(-) (limited to 'src') diff --git a/src/Propellor/Attr.hs b/src/Propellor/Attr.hs index 6bc4fcf1..5749a4bf 100644 --- a/src/Propellor/Attr.hs +++ b/src/Propellor/Attr.hs @@ -14,19 +14,15 @@ import Control.Applicative pureAttrProperty :: Desc -> SetAttr -> Property pureAttrProperty desc = Property ("has " ++ desc) (return NoChange) -hostname :: HostName -> Property -hostname name = pureAttrProperty ("hostname " ++ name) $ - \d -> d { _hostname = name } - getHostName :: Propellor HostName -getHostName = asks _hostname +getHostName = asks _hostName os :: System -> Property os system = pureAttrProperty ("Operating " ++ show system) $ \d -> d { _os = Just system } getOS :: Propellor (Maybe System) -getOS = asks _os +getOS = asks (_os . hostAttr) -- | Indidate that a host has an A record in the DNS. -- @@ -74,17 +70,17 @@ addNamedConf conf d = d { _namedconf = new } _ -> M.insert domain conf m getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks _namedconf +getNamedConf = asks (_namedconf . hostAttr) sshPubKey :: String -> Property sshPubKey k = pureAttrProperty ("ssh pubkey known") $ \d -> d { _sshPubKey = Just k } getSshPubKey :: Propellor (Maybe String) -getSshPubKey = asks _sshPubKey +getSshPubKey = asks (_sshPubKey . hostAttr) hostAttr :: Host -> Attr -hostAttr (Host hn _ mkattrs) = mkattrs (newAttr hn) +hostAttr (Host _ _ mkattrs) = mkattrs newAttr hostProperties :: Host -> [Property] hostProperties (Host _ ps _) = ps @@ -92,9 +88,6 @@ hostProperties (Host _ ps _) = ps hostMap :: [Host] -> M.Map HostName Host hostMap l = M.fromList $ zip (map _hostName l) l -hostAttrMap :: [Host] -> M.Map HostName Attr -hostAttrMap l = M.fromList $ zip (map _hostName l) (map hostAttr l) - findHost :: [Host] -> HostName -> Maybe Host findHost l hn = M.lookup hn (hostMap l) @@ -105,12 +98,3 @@ hostAddresses :: HostName -> [Host] -> [IPAddr] hostAddresses hn hosts = case hostAttr <$> findHost hosts hn of Nothing -> [] Just attr -> mapMaybe getIPAddr $ S.toList $ _dns attr - --- | Lifts an action into a different host. --- --- For example, `fromHost hosts "otherhost" getSshPubKey` -fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) -fromHost l hn getter = case findHost l hn of - Nothing -> return Nothing - Just h -> liftIO $ Just <$> - runReaderT (runWithAttr getter) (hostAttr h) diff --git a/src/Propellor/CmdLine.hs b/src/Propellor/CmdLine.hs index ab1d7f9e..a7b7ef96 100644 --- a/src/Propellor/CmdLine.hs +++ b/src/Propellor/CmdLine.hs @@ -67,24 +67,21 @@ defaultMain hostlist = do go _ (Continue cmdline) = go False cmdline go _ (Set hn field) = setPrivData hn field go _ (AddKey keyid) = addKey keyid - go _ (Chain hn) = withprops hn $ \attr ps -> do - r <- runPropellor attr $ ensureProperties ps + go _ (Chain hn) = withhost hn $ \h -> do + r <- runPropellor h $ ensureProperties $ hostProperties h putStrLn $ "\n" ++ show r go _ (Docker hn) = Docker.chain hn go True cmdline@(Spin _) = buildFirst cmdline $ go False cmdline go True cmdline = updateFirst cmdline $ go False cmdline - go False (Spin hn) = withprops hn $ const . const $ spin hn + go False (Spin hn) = withhost hn $ const $ spin hn go False (Run hn) = ifM ((==) 0 <$> getRealUserID) - ( onlyProcess $ withprops hn mainProperties + ( onlyProcess $ withhost hn mainProperties , go True (Spin hn) ) - go False (Boot hn) = onlyProcess $ withprops hn boot + go False (Boot hn) = onlyProcess $ withhost hn boot - withprops :: HostName -> (Attr -> [Property] -> IO ()) -> IO () - withprops hn a = maybe - (unknownhost hn) - (\h -> a (hostAttr h) (hostProperties h)) - (findHost hostlist hn) + withhost :: HostName -> (Host -> IO ()) -> IO () + withhost hn a = maybe (unknownhost hn) a (findHost hostlist hn) onlyProcess :: IO a -> IO a onlyProcess a = bracket lock unlock (const a) @@ -279,15 +276,15 @@ fromMarked marker s len = length marker matches = filter (marker `isPrefixOf`) $ lines s -boot :: Attr -> [Property] -> IO () -boot attr ps = do +boot :: Host -> IO () +boot h = do sendMarked stdout statusMarker $ show Ready reply <- hGetContentsStrict stdin makePrivDataDir maybe noop (writeFileProtected privDataLocal) $ fromMarked privDataMarker reply - mainProperties attr ps + mainProperties h addKey :: String -> IO () addKey keyid = exitBool =<< allM id [ gpg, gitadd, gitconfig, gitcommit ] diff --git a/src/Propellor/Engine.hs b/src/Propellor/Engine.hs index 55ce7f77..9bb3531a 100644 --- a/src/Propellor/Engine.hs +++ b/src/Propellor/Engine.hs @@ -5,20 +5,22 @@ module Propellor.Engine where import System.Exit import System.IO import Data.Monoid +import Control.Applicative import System.Console.ANSI import "mtl" Control.Monad.Reader import Propellor.Types import Propellor.Message import Propellor.Exception +import Propellor.Attr -runPropellor :: Attr -> Propellor a -> IO a -runPropellor attr a = runReaderT (runWithAttr a) attr +runPropellor :: Host -> Propellor a -> IO a +runPropellor host a = runReaderT (runWithHost a) host -mainProperties :: Attr -> [Property] -> IO () -mainProperties attr ps = do - r <- runPropellor attr $ - ensureProperties [Property "overall" (ensureProperties ps) id] +mainProperties :: Host -> IO () +mainProperties host = do + r <- runPropellor host $ + ensureProperties [Property "overall" (ensureProperties $ hostProperties host) id] setTitle "propellor: done" hFlush stdout case r of @@ -35,3 +37,12 @@ ensureProperties ps = ensure ps NoChange ensureProperty :: Property -> Propellor Result ensureProperty = catchPropellor . propertySatisfy + +-- | Lifts an action into a different host. +-- +-- For example, `fromHost hosts "otherhost" getSshPubKey` +fromHost :: [Host] -> HostName -> Propellor a -> Propellor (Maybe a) +fromHost l hn getter = case findHost l hn of + Nothing -> return Nothing + Just h -> liftIO $ Just <$> + runReaderT (runWithHost getter) h diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 1f602624..f2a4b3dd 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -130,7 +130,7 @@ revert (RevertableProperty p1 p2) = RevertableProperty p2 p1 -- > ! oldproperty -- > & otherproperty host :: HostName -> Host -host hn = Host hn [] (\_ -> newAttr hn) +host hn = Host hn [] (\_ -> newAttr) -- | Adds a property to a Host -- diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index 5c3162cb..f82d5494 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -129,9 +129,9 @@ secondaryFor masters hosts domain = RevertableProperty setup cleanup otherServers :: DnsServerType -> [Host] -> Domain -> [HostName] otherServers wantedtype hosts domain = - M.keys $ M.filter wanted $ hostAttrMap hosts + M.keys $ M.filter wanted $ hostMap hosts where - wanted attr = case M.lookup domain (_namedconf attr) of + wanted h = case M.lookup domain (_namedconf $ hostAttr h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -341,7 +341,7 @@ genZone hosts zdomain soa = ] in (Zone zdomain soa (nub zhosts), warnings) where - m = hostAttrMap hosts + m = hostMap hosts -- Known hosts with hostname located in the zone's domain. inzdomain = M.elems $ M.filterWithKey (\hn _ -> inDomain zdomain $ AbsDomain $ hn) m @@ -350,12 +350,13 @@ genZone hosts zdomain soa = -- -- If a host lacks any IPAddr, it's probably a misconfiguration, -- so warn. - hostips :: Attr -> [Either WarningMessage (BindDomain, Record)] - hostips attr - | null l = [Left $ "no IP address defined for host " ++ _hostname attr] + hostips :: Host -> [Either WarningMessage (BindDomain, Record)] + hostips h + | null l = [Left $ "no IP address defined for host " ++ _hostName h] | otherwise = map Right l where - l = zip (repeat $ AbsDomain $ _hostname attr) + attr = hostAttr h + l = zip (repeat $ AbsDomain $ _hostName h) (map Address $ getAddresses attr) -- Any host, whether its hostname is in the zdomain or not, @@ -370,10 +371,11 @@ genZone hosts zdomain soa = -- -- We typically know the host's IPAddrs anyway. -- So we can just use the IPAddrs. - addcnames :: Attr -> [Either WarningMessage (BindDomain, Record)] - addcnames attr = concatMap gen $ filter (inDomain zdomain) $ + addcnames :: Host -> [Either WarningMessage (BindDomain, Record)] + addcnames h = concatMap gen $ filter (inDomain zdomain) $ mapMaybe getCNAME $ S.toList (_dns attr) where + attr = hostAttr h gen c = case getAddresses attr of [] -> [ret (CNAME c)] l -> map (ret . Address) l @@ -381,10 +383,11 @@ genZone hosts zdomain soa = ret record = Right (c, record) -- Adds any other DNS records for a host located in the zdomain. - hostrecords :: Attr -> [Either WarningMessage (BindDomain, Record)] - hostrecords attr = map Right l + hostrecords :: Host -> [Either WarningMessage (BindDomain, Record)] + hostrecords h = map Right l where - l = zip (repeat $ AbsDomain $ _hostname attr) + attr = hostAttr h + l = zip (repeat $ AbsDomain $ _hostName h) (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (_dns attr)) inDomain :: Domain -> BindDomain -> Bool diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index c1340ad9..34a9deb7 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -48,7 +48,7 @@ type ContainerName = String container :: ContainerName -> Image -> Host container cn image = Host hn [] (\_ -> attr) where - attr = (newAttr hn) { _dockerImage = Just image } + attr = newAttr { _dockerImage = Just image } hn = cn2hn cn cn2hn :: ContainerName -> HostName @@ -99,7 +99,7 @@ exposeDnsAttrs :: Host -> Property -> Property exposeDnsAttrs (Host _ _ containerattr) p = combineProperties (propertyDesc p) $ p : map addDNS (S.toList containerdns) where - containerdns = _dns $ containerattr $ newAttr undefined + containerdns = _dns $ containerattr newAttr findContainer :: Maybe Host diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index e5f5c1c7..a96e9520 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -42,14 +42,14 @@ data Host = Host , _hostAttrs :: SetAttr } --- | Propellor's monad provides read-only access to attributes of the --- system. -newtype Propellor p = Propellor { runWithAttr :: ReaderT Attr IO p } +-- | Propellor's monad provides read-only access to the host it's running +-- on, including its attributes. +newtype Propellor p = Propellor { runWithHost :: ReaderT Host IO p } deriving ( Monad , Functor , Applicative - , MonadReader Attr + , MonadReader Host , MonadIO , MonadCatchIO ) diff --git a/src/Propellor/Types/Attr.hs b/src/Propellor/Types/Attr.hs index 8b7d3b09..7f0add10 100644 --- a/src/Propellor/Types/Attr.hs +++ b/src/Propellor/Types/Attr.hs @@ -6,10 +6,9 @@ import qualified Propellor.Types.Dns as Dns import qualified Data.Set as S import qualified Data.Map as M --- | The attributes of a host. For example, its hostname. +-- | The attributes of a host. data Attr = Attr - { _hostname :: HostName - , _os :: Maybe System + { _os :: Maybe System , _sshPubKey :: Maybe String , _dns :: S.Set Dns.Record , _namedconf :: M.Map Dns.Domain Dns.NamedConf @@ -20,8 +19,7 @@ data Attr = Attr instance Eq Attr where x == y = and - [ _hostname x == _hostname y - , _os x == _os y + [ _os x == _os y , _dns x == _dns y , _namedconf x == _namedconf y , _sshPubKey x == _sshPubKey y @@ -33,8 +31,7 @@ instance Eq Attr where instance Show Attr where show a = unlines - [ "hostname " ++ _hostname a - , "OS " ++ show (_os a) + [ "OS " ++ show (_os a) , "sshPubKey " ++ show (_sshPubKey a) , "dns " ++ show (_dns a) , "namedconf " ++ show (_namedconf a) @@ -42,7 +39,7 @@ instance Show Attr where , "docker run params " ++ show (map (\mk -> mk "") (_dockerRunParams a)) ] -newAttr :: HostName -> Attr -newAttr hn = Attr hn Nothing Nothing S.empty M.empty Nothing [] +newAttr :: Attr +newAttr = Attr Nothing Nothing S.empty M.empty Nothing [] type SetAttr = Attr -> Attr -- cgit v1.2.3