From 36e97137e538de401bd0340b469e10dca5f4b475 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sat, 26 Mar 2016 19:31:23 -0400 Subject: ported propagateContainer Renamed several utility functions along the way. --- src/Propellor/Property/Chroot.hs | 43 ++++++++++++++++-------------------- src/Propellor/Property/Concurrent.hs | 2 +- src/Propellor/Property/Conductor.hs | 8 +++---- src/Propellor/Property/Dns.hs | 10 ++++----- src/Propellor/Property/Docker.hs | 10 ++++----- src/Propellor/Property/List.hs | 4 ++-- src/Propellor/Property/Partition.hs | 2 +- src/Propellor/Property/Postfix.hs | 2 +- src/Propellor/Property/Scheduled.hs | 6 ++--- src/Propellor/Property/Systemd.hs | 18 +++++++-------- 10 files changed, 50 insertions(+), 55 deletions(-) (limited to 'src/Propellor/Property') diff --git a/src/Propellor/Property/Chroot.hs b/src/Propellor/Property/Chroot.hs index 4480f98d..547e5c94 100644 --- a/src/Propellor/Property/Chroot.hs +++ b/src/Propellor/Property/Chroot.hs @@ -41,23 +41,18 @@ data Chroot where Chroot :: ChrootBootstrapper b => FilePath -> b -> Host -> Chroot chrootSystem :: Chroot -> Maybe System -chrootSystem (Chroot _ _ h) = fromInfoVal (getInfo (hostInfo h)) +chrootSystem (Chroot _ _ h) = fromInfoVal (fromInfo (hostInfo h)) instance Show Chroot where show c@(Chroot loc _ _) = "Chroot " ++ loc ++ " " ++ show (chrootSystem c) -instance PropAccum Chroot where - (Chroot l c h) `addProp` p = Chroot l c (h & p) - (Chroot l c h) `addPropFront` p = Chroot l c (h `addPropFront` p) - getProperties (Chroot _ _ h) = hostProperties h - -- | Class of things that can do initial bootstrapping of an operating -- System in a chroot. class ChrootBootstrapper b where -- | Do initial bootstrapping of an operating system in a chroot. -- If the operating System is not supported, return -- Left error message. - buildchroot :: b -> Maybe System -> FilePath -> Either String (Property HasInfo) + buildchroot :: b -> Maybe System -> FilePath -> Either String (Property (HasInfo + UnixLike)) -- | Use this to bootstrap a chroot by extracting a tarball. -- @@ -70,12 +65,11 @@ data ChrootTarball = ChrootTarball FilePath instance ChrootBootstrapper ChrootTarball where buildchroot (ChrootTarball tb) _ loc = Right $ extractTarball loc tb -extractTarball :: FilePath -> FilePath -> Property HasInfo -extractTarball target src = toProp . - check (unpopulated target) $ - cmdProperty "tar" params - `assume` MadeChange - `requires` File.dirExists target +extractTarball :: FilePath -> FilePath -> Property UnixLike +extractTarball target src = check (unpopulated target) $ + cmdProperty "tar" params + `assume` MadeChange + `requires` File.dirExists target where params = [ "-C" @@ -92,14 +86,15 @@ instance ChrootBootstrapper Debootstrapped where (Just s@(System (Debian _) _)) -> Right $ debootstrap s (Just s@(System (Buntish _) _)) -> Right $ debootstrap s (Just (System (FreeBSD _) _)) -> Left "FreeBSD not supported by debootstrap." - Nothing -> Left "Cannot debootstrap; `os` property not specified" + Nothing -> Left "Cannot debootstrap; OS not specified" where debootstrap s = Debootstrap.built loc s cf -- | Defines a Chroot at the given location, built with debootstrap. -- -- Properties can be added to configure the Chroot. At a minimum, --- add the `os` property to specify the operating system to bootstrap. +-- add a property such as `osDebian` to specify the operating system +-- to bootstrap. -- -- > debootstrapped Debootstrap.BuildD "/srv/chroot/ghc-dev" -- > & osDebian Unstable "amd64" @@ -131,25 +126,25 @@ provisioned' propigator c@(Chroot loc bootstrapper _) systemdonly = (propertyList (chrootDesc c "removed") [teardown]) where setup = propellChroot c (inChrootProcess (not systemdonly) c) systemdonly - `requires` toProp built + `requires` built built = case buildchroot bootstrapper (chrootSystem c) loc of Right p -> p Left e -> cantbuild e - cantbuild e = infoProperty (chrootDesc c "built") (error e) mempty [] + cantbuild e = property (chrootDesc c "built") (error e) teardown = check (not <$> unpopulated loc) $ property ("removed " ++ loc) $ makeChange (removeChroot loc) -propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property HasInfo +propagateChrootInfo :: (IsProp (Property i)) => Chroot -> Property i -> Property (HasInfo + UnixLike) propagateChrootInfo c@(Chroot location _ _) p = propagateContainer location c p' where p' = infoProperty - (propertyDesc p) + (getDesc p) (getSatisfy p) - (propertyInfo p <> chrootInfo c) + (getInfo p <> chrootInfo c) (propertyChildren p) chrootInfo :: Chroot -> Info @@ -157,7 +152,7 @@ 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 +propellChroot :: Chroot -> ([String] -> IO (CreateProcess, IO ())) -> Bool -> Property UnixLike propellChroot c@(Chroot loc _ _) mkproc systemdonly = property (chrootDesc c "provisioned") $ do let d = localdir shimdir c let me = localdir "propellor" @@ -205,7 +200,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 $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup loc (_chroots $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find chroot " ++ loc ++ " on host " ++ hn) Just h -> go h where @@ -215,7 +210,7 @@ chain hostlist (ChrootChain hn loc systemdonly onconsole) = onlyProcess (provisioningLock loc) $ do r <- runPropellor (setInChroot h) $ ensureChildProperties $ if systemdonly - then [toProp Systemd.installed] + then [toChildProperty Systemd.installed] else hostProperties h flushConcurrentOutput putStrLn $ "\n" ++ show r @@ -257,7 +252,7 @@ chrootDesc (Chroot loc _ _) desc = "chroot " ++ loc ++ " " ++ desc -- This is accomplished by installing a script -- that does not let any daemons be started by packages that use -- invoke-rc.d. Reverting the property removes the script. -noServices :: RevertableProperty NoInfo +noServices :: RevertableProperty DebianLike DebianLike noServices = setup teardown where f = "/usr/sbin/policy-rc.d" diff --git a/src/Propellor/Property/Concurrent.hs b/src/Propellor/Property/Concurrent.hs index a86c839f..ace85a3c 100644 --- a/src/Propellor/Property/Concurrent.hs +++ b/src/Propellor/Property/Concurrent.hs @@ -78,7 +78,7 @@ concurrently p1 p2 = (combineWith go go p1 p2) -- The above example will run foo and bar concurrently, and once either of -- those 2 properties finishes, will start running baz. concurrentList :: SingI metatypes => IO Int -> Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) -concurrentList getn d (Props ps) = property d go `modifyChildren` (++ ps) +concurrentList getn d (Props ps) = property d go `addChildren` ps where go = do n <- liftIO getn diff --git a/src/Propellor/Property/Conductor.hs b/src/Propellor/Property/Conductor.hs index ec15281b..8fe607bc 100644 --- a/src/Propellor/Property/Conductor.hs +++ b/src/Propellor/Property/Conductor.hs @@ -126,7 +126,7 @@ mkOrchestra = fromJust . go S.empty where go seen h | S.member (hostName h) seen = Nothing -- break loop - | otherwise = Just $ case getInfo (hostInfo h) of + | otherwise = Just $ case fromInfo (hostInfo h) of ConductorFor [] -> Conducted h ConductorFor l -> let seen' = S.insert (hostName h) seen @@ -214,7 +214,7 @@ orchestrate :: [Host] -> [Host] orchestrate hs = map go hs where go h - | isOrchestrated (getInfo (hostInfo h)) = h + | isOrchestrated (fromInfo (hostInfo h)) = h | otherwise = foldl orchestrate' (removeold h) (map (deloop h) os) os = extractOrchestras hs @@ -222,7 +222,7 @@ orchestrate hs = map go hs removeold' h oldconductor = addPropHost h $ undoRevertableProperty $ conductedBy oldconductor - oldconductors = zip hs (map (getInfo . hostInfo) hs) + oldconductors = zip hs (map (fromInfo . hostInfo) hs) oldconductorsof h = flip mapMaybe oldconductors $ \(oldconductor, NotConductorFor l) -> if any (sameHost h) l @@ -299,7 +299,7 @@ addConductorPrivData h hs = h { hostInfo = hostInfo h <> i } i = mempty `addInfo` mconcat (map privinfo hs) `addInfo` Orchestrated (Any True) - privinfo h' = forceHostContext (hostName h') $ getInfo (hostInfo h') + privinfo h' = forceHostContext (hostName h') $ fromInfo (hostInfo h') -- Use this property to let the specified conductor ssh in and run propellor. conductedBy :: Host -> RevertableProperty DebianLike UnixLike diff --git a/src/Propellor/Property/Dns.hs b/src/Propellor/Property/Dns.hs index a660a016..2b5596bd 100644 --- a/src/Propellor/Property/Dns.hs +++ b/src/Propellor/Property/Dns.hs @@ -213,7 +213,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 $ getInfo $ hostInfo h) of + wanted h = case M.lookup domain (fromNamedConfMap $ fromInfo $ hostInfo h) of Nothing -> False Just conf -> confDnsServerType conf == wantedtype && confDomain conf == domain @@ -468,7 +468,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 $ fromDnsInfo $ getInfo info + mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info where info = hostInfo h gen c = case getAddresses info of @@ -483,7 +483,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)) (fromDnsInfo $ getInfo info)) + (S.toList $ S.filter (\r -> isNothing (getIPAddr r) && isNothing (getCNAME r)) (fromDnsInfo $ fromInfo info)) -- Simplifies the list of hosts. Remove duplicate entries. -- Also, filter out any CHAMES where the same domain has an @@ -518,7 +518,7 @@ addNamedConf conf = NamedConfMap (M.singleton domain conf) domain = confDomain conf getNamedConf :: Propellor (M.Map Domain NamedConf) -getNamedConf = asks $ fromNamedConfMap . getInfo . hostInfo +getNamedConf = asks $ fromNamedConfMap . fromInfo . hostInfo -- | Generates SSHFP records for hosts in the domain (or with CNAMES -- in the domain) that have configured ssh public keys. @@ -531,7 +531,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 $ fromDnsInfo $ getInfo info + cnames = mapMaybe getCNAME $ S.toList $ fromDnsInfo $ fromInfo info hostname = hostName h info = hostInfo h diff --git a/src/Propellor/Property/Docker.hs b/src/Propellor/Property/Docker.hs index d19d15aa..fe1e3b18 100644 --- a/src/Propellor/Property/Docker.hs +++ b/src/Propellor/Property/Docker.hs @@ -172,9 +172,9 @@ propagateContainerInfo :: (IsProp (Property i)) => Container -> Property i -> Pr propagateContainerInfo ctr@(Container _ h) p = propagateContainer cn ctr p' where p' = infoProperty - (propertyDesc p) + (getDesc p) (getSatisfy p) - (propertyInfo p <> dockerinfo) + (getInfo p <> dockerinfo) (propertyChildren p) dockerinfo = dockerInfo $ mempty { _dockerContainers = M.singleton cn h } @@ -186,7 +186,7 @@ mkContainerInfo cid@(ContainerId hn _cn) (Container img h) = where runparams = map (\(DockerRunParam mkparam) -> mkparam hn) (_dockerRunParams info) - info = getInfo $ hostInfo h' + info = fromInfo $ hostInfo h' h' = h -- Restart by default so container comes up on -- boot or when docker is upgraded. @@ -435,7 +435,7 @@ myContainerSuffix = ".propellor" containerDesc :: (IsProp (Property i)) => ContainerId -> Property i -> Property i containerDesc cid p = p `describe` desc where - desc = "container " ++ fromContainerId cid ++ " " ++ propertyDesc p + desc = "container " ++ fromContainerId cid ++ " " ++ getDesc p runningContainer :: ContainerId -> Image -> [RunParam] -> Property Linux runningContainer cid@(ContainerId hn cn) image runps = containerDesc cid $ property "running" $ do @@ -574,7 +574,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 $ getInfo $ hostInfo parenthost) of + Just parenthost -> case M.lookup (containerName cid) (_dockerContainers $ fromInfo $ hostInfo parenthost) of Nothing -> errorMessage ("cannot find container " ++ containerName cid ++ " docked on host " ++ hn) Just h -> go cid h where diff --git a/src/Propellor/Property/List.hs b/src/Propellor/Property/List.hs index 304d0863..a8b8347a 100644 --- a/src/Propellor/Property/List.hs +++ b/src/Propellor/Property/List.hs @@ -35,7 +35,7 @@ toProps ps = Props (map toChildProperty ps) propertyList :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) propertyList desc (Props ps) = property desc (ensureChildProperties cs) - `modifyChildren` (++ cs) + `addChildren` cs where cs = map toChildProperty ps @@ -44,7 +44,7 @@ propertyList desc (Props ps) = combineProperties :: SingI metatypes => Desc -> Props (MetaTypes metatypes) -> Property (MetaTypes metatypes) combineProperties desc (Props ps) = property desc (combineSatisfy cs NoChange) - `modifyChildren` (++ cs) + `addChildren` cs where cs = map toChildProperty ps diff --git a/src/Propellor/Property/Partition.hs b/src/Propellor/Property/Partition.hs index 5aff4ba4..291d4168 100644 --- a/src/Propellor/Property/Partition.hs +++ b/src/Propellor/Property/Partition.hs @@ -68,7 +68,7 @@ kpartx :: FilePath -> ([LoopDev] -> Property DebianLike) -> Property DebianLike kpartx diskimage mkprop = go `requires` Apt.installed ["kpartx"] where go :: Property DebianLike - go = property' (propertyDesc (mkprop [])) $ \w -> do + go = property' (getDesc (mkprop [])) $ \w -> do cleanup -- idempotency loopdevs <- liftIO $ kpartxParse <$> readProcess "kpartx" ["-avs", diskimage] diff --git a/src/Propellor/Property/Postfix.hs b/src/Propellor/Property/Postfix.hs index 7d9e7068..45aa4e42 100644 --- a/src/Propellor/Property/Postfix.hs +++ b/src/Propellor/Property/Postfix.hs @@ -304,7 +304,7 @@ saslAuthdInstalled = setupdaemon -- | Uses `saslpasswd2` to set the password for a user in the sasldb2 file. -- -- The password is taken from the privdata. -saslPasswdSet :: Domain -> User -> Property HasInfo +saslPasswdSet :: Domain -> User -> Property (HasInfo + UnixLike) saslPasswdSet domain (User user) = go `changesFileContent` "/etc/sasldb2" where go = withPrivData src ctx $ \getpw -> diff --git a/src/Propellor/Property/Scheduled.hs b/src/Propellor/Property/Scheduled.hs index 534e1e88..95e4e362 100644 --- a/src/Propellor/Property/Scheduled.hs +++ b/src/Propellor/Property/Scheduled.hs @@ -22,18 +22,18 @@ import qualified Data.Map as M -- last run. period :: (IsProp (Property i)) => Property i -> Recurrance -> Property i period prop recurrance = flip describe desc $ adjustPropertySatisfy prop $ \satisfy -> do - lasttime <- liftIO $ getLastChecked (propertyDesc prop) + lasttime <- liftIO $ getLastChecked (getDesc prop) nexttime <- liftIO $ fmap startTime <$> nextTime schedule lasttime t <- liftIO localNow if Just t >= nexttime then do r <- satisfy - liftIO $ setLastChecked t (propertyDesc prop) + liftIO $ setLastChecked t (getDesc prop) return r else noChange where schedule = Schedule recurrance AnyTime - desc = propertyDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" + desc = getDesc prop ++ " (period " ++ fromRecurrance recurrance ++ ")" -- | Like period, but parse a human-friendly string. periodParse :: (IsProp (Property i)) => Property i -> String -> Property i diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index 2234ad5c..d909e4df 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -214,13 +214,13 @@ container name system mkchroot = Container name c h -- -- Reverting this property stops the container, removes the systemd unit, -- and deletes the chroot and all its contents. -nspawned :: Container -> RevertableProperty HasInfo +nspawned :: Container -> RevertableProperty (HasInfo + UnixLike) UnixLike nspawned c@(Container name (Chroot.Chroot loc builder _) h) = p `describe` ("nspawned " ++ name) where p = enterScript c `before` chrootprovisioned - `before` nspawnService c (_chrootCfg $ getInfo $ hostInfo h) + `before` nspawnService c (_chrootCfg $ fromInfo $ hostInfo h) `before` containerprovisioned -- Chroot provisioning is run in systemd-only mode, @@ -336,7 +336,7 @@ mungename = replace "/" "_" -- When there is no leading dash, "--" is prepended to the parameter. -- -- Reverting the property will remove a parameter, if it's present. -containerCfg :: String -> RevertableProperty HasInfo +containerCfg :: String -> RevertableProperty (HasInfo + UnixLike) UnixLike containerCfg p = RevertableProperty (mk True) (mk False) where mk b = pureInfoProperty ("container configuration " ++ (if b then "" else "without ") ++ p') $ @@ -348,18 +348,18 @@ containerCfg p = RevertableProperty (mk True) (mk False) -- | Bind mounts from the host into the container. -- -- This property is enabled by default. Revert it to disable it. -resolvConfed :: RevertableProperty HasInfo +resolvConfed :: RevertableProperty (HasInfo + UnixLike) UnixLike resolvConfed = containerCfg "bind=/etc/resolv.conf" -- | Link the container's journal to the host's if possible. -- (Only works if the host has persistent journal enabled.) -- -- This property is enabled by default. Revert it to disable it. -linkJournal :: RevertableProperty HasInfo +linkJournal :: RevertableProperty (HasInfo + UnixLike) UnixLike linkJournal = containerCfg "link-journal=try-guest" -- | Disconnect networking of the container from the host. -privateNetwork :: RevertableProperty HasInfo +privateNetwork :: RevertableProperty (HasInfo + UnixLike) UnixLike privateNetwork = containerCfg "private-network" class Publishable a where @@ -397,7 +397,7 @@ instance Publishable (Proto, Bound Port) where -- > & Systemd.running Systemd.networkd -- > & Systemd.publish (Port 80 ->- Port 8080) -- > & Apt.installedRunning "apache2" -publish :: Publishable p => p -> RevertableProperty HasInfo +publish :: Publishable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike publish p = containerCfg $ "--port=" ++ toPublish p class Bindable a where @@ -410,9 +410,9 @@ instance Bindable (Bound FilePath) where toBind v = hostSide v ++ ":" ++ containerSide v -- | Bind mount a file or directory from the host into the container. -bind :: Bindable p => p -> RevertableProperty HasInfo +bind :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike bind p = containerCfg $ "--bind=" ++ toBind p -- | Read-only mind mount. -bindRo :: Bindable p => p -> RevertableProperty HasInfo +bindRo :: Bindable p => p -> RevertableProperty (HasInfo + UnixLike) UnixLike bindRo p = containerCfg $ "--bind-ro=" ++ toBind p -- cgit v1.2.3