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. --- debian/changelog | 13 ++++++++++++- 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 ++++++++++++------- 6 files changed, 36 insertions(+), 23 deletions(-) diff --git a/debian/changelog b/debian/changelog index c870e48a..7c4d2ef2 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,5 +1,16 @@ -propellor (5.5.1) UNRELEASED; urgency=medium +propellor (5.6.0) UNRELEASED; urgency=medium + * 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. + (API change) + The fix may cause some of your valid uses of withOS to no longer type + check; the best way to work around that is to use pickOS to pick between + several properties that are further specialized using withOS. + For an example of how to do that, see the source code to + Propellor.Property.Borg.installed + * 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. * Some openbsd portability fixes. Thanks, rsiddharth. * Added Libvirt module. Thanks, Sean Whitton. * When bootstrapping on Debian, libghc-stm-dev may not be available, 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