From b9d9333e030ac59ea11d435b7e2e4758daff4b4a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 18 Jan 2019 02:19:06 -0400 Subject: fix withOS type level bug withOS had a type level bug that allowed ensureProperty to be used inside it with a Property that does not match the type of the withOS itself. Propellor.Property.Cron.runPropellor is a Property DebianLike; it was incorrectly a Property UnixLike before and that wrong type was hidden by the withOS bug. This commit was sponsored by Jack Hill on Patreon. --- src/Propellor/Property.hs | 10 ++-------- src/Propellor/Property/Borg.hs | 13 ++++++++----- src/Propellor/Property/Cron.hs | 2 +- .../Property/SiteSpecific/GitAnnexBuilder.hs | 2 +- src/Propellor/Property/Systemd.hs | 19 ++++++++++++------- 5 files changed, 24 insertions(+), 22 deletions(-) (limited to 'src/Propellor') diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index 8c0a5859..cb2f01a8 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -330,15 +330,9 @@ pickOS a b = c `addChildren` [toChildProperty a, toChildProperty b] withOS :: (SingI metatypes) => Desc - -> (OuterMetaTypesWitness '[] -> Maybe System -> Propellor Result) + -> (OuterMetaTypesWitness metatypes -> Maybe System -> Propellor Result) -> Property (MetaTypes metatypes) -withOS desc a = property desc $ a dummyoutermetatypes =<< getOS - where - -- Using this dummy value allows ensureProperty to be used - -- even though the inner property probably doesn't target everything - -- that the outer withOS property targets. - dummyoutermetatypes :: OuterMetaTypesWitness ('[]) - dummyoutermetatypes = OuterMetaTypesWitness sing +withOS desc a = property' desc $ \w -> a w =<< getOS -- | A property that always fails with an unsupported OS error. unsupportedOS :: Property UnixLike diff --git a/src/Propellor/Property/Borg.hs b/src/Propellor/Property/Borg.hs index 9d49fdf4..f662c8ee 100644 --- a/src/Propellor/Property/Borg.hs +++ b/src/Propellor/Property/Borg.hs @@ -59,12 +59,15 @@ runBorgEnv (BorgRepoUsing os _) = map go os go (UsesEnvVar (k, v)) = (k, v) installed :: Property DebianLike -installed = withOS desc $ \w o -> case o of - (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $ - Apt.backportInstalled ["borgbackup", "python3-msgpack"] - _ -> ensureProperty w $ - Apt.installed ["borgbackup"] +installed = pickOS installdebian aptinstall where + installdebian :: Property Debian + installdebian = withOS desc $ \w o -> case o of + (Just (System (Debian _ (Stable "jessie")) _)) -> ensureProperty w $ + Apt.backportInstalled ["borgbackup", "python3-msgpack"] + _ -> ensureProperty w $ + Apt.installed ["borgbackup"] + aptinstall = Apt.installed ["borgbackup"] `describe` desc desc = "installed borgbackup" repoExists :: BorgRepo -> IO Bool diff --git a/src/Propellor/Property/Cron.hs b/src/Propellor/Property/Cron.hs index ab700a9d..b9fb10e0 100644 --- a/src/Propellor/Property/Cron.hs +++ b/src/Propellor/Property/Cron.hs @@ -79,7 +79,7 @@ niceJob desc times user cddir command = job desc times user cddir ("nice ionice -c 3 sh -c " ++ shellEscape command) -- | Installs a cron job to run propellor. -runPropellor :: Times -> Property UnixLike +runPropellor :: Times -> Property DebianLike runPropellor times = withOS "propellor cron job" $ \w o -> do bootstrapper <- getBootstrapper ensureProperty w $ diff --git a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs index 8a9f913b..2805cc97 100644 --- a/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs +++ b/src/Propellor/Property/SiteSpecific/GitAnnexBuilder.hs @@ -140,7 +140,7 @@ stackAutoBuilder suite arch flavor = -- Workaround https://github.com/commercialhaskell/stack/issues/2093 & Apt.installed ["libtinfo-dev"] -stackInstalled :: Property Linux +stackInstalled :: Property DebianLike stackInstalled = withOS "stack installed" $ \w o -> case o of (Just (System (Debian Linux (Stable "jessie")) arch)) -> diff --git a/src/Propellor/Property/Systemd.hs b/src/Propellor/Property/Systemd.hs index cb63ff5a..9c9f5914 100644 --- a/src/Propellor/Property/Systemd.hs +++ b/src/Propellor/Property/Systemd.hs @@ -204,13 +204,18 @@ killUserProcesses = set "yes" set "no" -- | Ensures machined and machinectl are installed machined :: Property Linux -machined = withOS "machined installed" $ \w o -> - case o of - -- Split into separate debian package since systemd 225. - (Just (System (Debian _ suite) _)) - | not (isStable suite) || suite == (Stable "stretch") -> - ensureProperty w $ Apt.installed ["systemd-container"] - _ -> noChange +machined = installeddebian `pickOS` assumeinstalled + where + installeddebian :: Property DebianLike + installeddebian = withOS "machined installed" $ \w o -> + case o of + -- Split into separate debian package since systemd 225. + (Just (System (Debian _ suite) _)) + | not (isStable suite) || suite == (Stable "stretch") -> + ensureProperty w $ Apt.installed ["systemd-container"] + _ -> noChange + assumeinstalled :: Property Linux + assumeinstalled = doNothing -- | Defines a container with a given machine name, -- and how to create its chroot if not already present. -- cgit v1.2.3