From 1edce2b72614e2e8eceefde97436db024799ff20 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Fri, 25 Mar 2016 15:28:31 -0400 Subject: ported Property.Apt --- src/Propellor/EnsureProperty.hs | 14 ++--- src/Propellor/Property.hs | 54 ++++++++---------- src/Propellor/Property/Apt.hs | 113 +++++++++++++++++++------------------ src/Propellor/Property/Service.hs | 10 ++-- src/Propellor/Types.hs | 23 ++++++++ src/Propellor/Types/ResultCheck.hs | 3 + 6 files changed, 119 insertions(+), 98 deletions(-) (limited to 'src') diff --git a/src/Propellor/EnsureProperty.hs b/src/Propellor/EnsureProperty.hs index 21f8acce..c4b5fde1 100644 --- a/src/Propellor/EnsureProperty.hs +++ b/src/Propellor/EnsureProperty.hs @@ -7,7 +7,7 @@ module Propellor.EnsureProperty ( ensureProperty , property' - , OuterMetaTypes + , OuterMetaTypes(..) ) where import Propellor.Types @@ -33,8 +33,8 @@ import Propellor.Exception -- with the property to be lost. ensureProperty :: - ( (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine - , CannotUse_ensureProperty_WithInfo inner ~ 'True + ( Cannot_ensureProperty_WithInfo inner ~ 'True + , (Targets inner `NotSuperset` Targets outer) ~ 'CanCombine ) => OuterMetaTypes outer -> Property (MetaTypes inner) @@ -42,10 +42,10 @@ ensureProperty ensureProperty _ = catchPropellor . getSatisfy -- The name of this was chosen to make type errors a more understandable. -type family CannotUse_ensureProperty_WithInfo (l :: [a]) :: Bool -type instance CannotUse_ensureProperty_WithInfo '[] = 'True -type instance CannotUse_ensureProperty_WithInfo (t ': ts) = - Not (t `EqT` 'WithInfo) && CannotUse_ensureProperty_WithInfo ts +type family Cannot_ensureProperty_WithInfo (l :: [a]) :: Bool +type instance Cannot_ensureProperty_WithInfo '[] = 'True +type instance Cannot_ensureProperty_WithInfo (t ': ts) = + Not (t `EqT` 'WithInfo) && Cannot_ensureProperty_WithInfo ts -- | Constructs a property, like `property`, but provides its -- `OuterMetaTypes`. diff --git a/src/Propellor/Property.hs b/src/Propellor/Property.hs index ba30209e..2ddec439 100644 --- a/src/Propellor/Property.hs +++ b/src/Propellor/Property.hs @@ -22,9 +22,9 @@ module Propellor.Property ( , Propellor , property , property' + , OuterMetaTypes , ensureProperty - , tightenTargets - --, withOS + , withOS , unsupportedOS , makeChange , noChange @@ -243,26 +243,6 @@ isNewerThan x y = do where mtime f = catchMaybeIO $ modificationTimeHiRes <$> getFileStatus f --- | Tightens the MetaType list of a Property, to contain fewer targets. --- --- Anything else in the MetaType list is passed through unchanged. --- --- For example, to make a property that uses apt-get, which is only --- available on DebianLike systems: --- --- > upgraded :: Property DebianLike --- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] -tightenTargets - :: - -- Note that this uses PolyKinds - ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine - , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine - , SingI tightened - ) - => Property (MetaTypes untightened) - -> Property (MetaTypes tightened) -tightenTargets (Property _old d a i c) = Property sing d a i c - {- -- | Picks one of the two input properties to use, @@ -286,17 +266,29 @@ pickOS a@(Property ta ioa) b@(Property tb iob) = Property sing io -} --- | Makes a property that is satisfied differently depending on the host's --- operating system. +-- | Makes a property that is satisfied differently depending on specifics +-- of the host's operating system. -- --- Note that the operating system may not be declared for all hosts. +-- > myproperty :: Property Debian +-- > myproperty = withOS "foo installed" $ \o os -> case os of +-- > (Just (System (Debian (Stable release)) arch)) -> ensureProperty o ... +-- > (Just (System (Debian suite) arch)) -> ensureProperty o ... +-- > _ -> unsupportedOS -- --- > myproperty = withOS "foo installed" $ \o -> case o of --- > (Just (System (Debian suite) arch)) -> ... --- > (Just (System (Buntish release) arch)) -> ... --- > Nothing -> unsupportedOS ---withOS :: Desc -> (Maybe System -> Propellor Result) -> Property NoInfo ---withOS desc a = property desc $ a =<< getOS +-- Note that the operating system specifics may not be declared for all hosts, +-- which is where Nothing comes in. +withOS + :: (SingI metatypes) + => Desc + -> (OuterMetaTypes '[] -> 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 :: OuterMetaTypes ('[]) + dummyoutermetatypes = OuterMetaTypes sing -- | Throws an error, for use in `withOS` when a property is lacking -- support for an OS. diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs index 7301a6ae..3dd7277e 100644 --- a/src/Propellor/Property/Apt.hs +++ b/src/Propellor/Property/Apt.hs @@ -80,37 +80,36 @@ securityUpdates suite -- -- Since the CDN is sometimes unreliable, also adds backup lines using -- kernel.org. -stdSourcesList :: Property NoInfo -stdSourcesList = withOS "standard sources.list" $ \o -> - case o of - (Just (System (Debian suite) _)) -> - ensureProperty $ stdSourcesListFor suite - _ -> error "os is not declared to be Debian" - -stdSourcesListFor :: DebianSuite -> Property NoInfo +stdSourcesList :: Property Debian +stdSourcesList = withOS "standard sources.list" $ \o os -> case os of + (Just (System (Debian suite) _)) -> + ensureProperty o $ stdSourcesListFor suite + _ -> unsupportedOS + +stdSourcesListFor :: DebianSuite -> Property Debian stdSourcesListFor suite = stdSourcesList' suite [] -- | Adds additional sources.list generators. -- -- Note that if a Property needs to enable an apt source, it's better -- to do so via a separate file in -stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property NoInfo -stdSourcesList' suite more = setSourcesList +stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property Debian +stdSourcesList' suite more = tightenTargets $ setSourcesList (concatMap (\gen -> gen suite) generators) `describe` ("standard sources.list for " ++ show suite) where generators = [debCdn, kernelOrg, securityUpdates] ++ more -setSourcesList :: [Line] -> Property NoInfo +setSourcesList :: [Line] -> Property DebianLike setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update -setSourcesListD :: [Line] -> FilePath -> Property NoInfo +setSourcesListD :: [Line] -> FilePath -> Property DebianLike setSourcesListD ls basename = f `File.hasContent` ls `onChange` update where f = "/etc/apt/sources.list.d/" ++ basename ++ ".list" -runApt :: [String] -> UncheckedProperty NoInfo -runApt ps = cmdPropertyEnv "apt-get" ps noninteractiveEnv +runApt :: [String] -> UncheckedProperty DebianLike +runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv noninteractiveEnv :: [(String, String)] noninteractiveEnv = @@ -118,51 +117,51 @@ noninteractiveEnv = , ("APT_LISTCHANGES_FRONTEND", "none") ] -update :: Property NoInfo +update :: Property DebianLike update = runApt ["update"] `assume` MadeChange `describe` "apt update" -- | Have apt upgrade packages, adding new packages and removing old as -- necessary. -upgrade :: Property NoInfo +upgrade :: Property DebianLike upgrade = upgrade' "dist-upgrade" -upgrade' :: String -> Property NoInfo -upgrade' p = combineProperties ("apt " ++ p) - [ pendingConfigured - , runApt ["-y", p] +upgrade' :: String -> Property DebianLike +upgrade' p = combineProperties ("apt " ++ p) $ props + & pendingConfigured + & runApt ["-y", p] `assume` MadeChange - ] -- | Have apt upgrade packages, but never add new packages or remove -- old packages. Not suitable for upgrading acrocess major versions -- of the distribution. -safeUpgrade :: Property NoInfo +safeUpgrade :: Property DebianLike safeUpgrade = upgrade' "upgrade" -- | Have dpkg try to configure any packages that are not fully configured. -pendingConfigured :: Property NoInfo -pendingConfigured = cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv - `assume` MadeChange - `describe` "dpkg configured pending" +pendingConfigured :: Property DebianLike +pendingConfigured = tightenTargets $ + cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv + `assume` MadeChange + `describe` "dpkg configured pending" type Package = String -installed :: [Package] -> Property NoInfo +installed :: [Package] -> Property DebianLike installed = installed' ["-y"] -installed' :: [String] -> [Package] -> Property NoInfo +installed' :: [String] -> [Package] -> Property DebianLike installed' params ps = robustly $ check (isInstallable ps) go `describe` unwords ("apt installed":ps) where go = runApt (params ++ ["install"] ++ ps) -installedBackport :: [Package] -> Property NoInfo -installedBackport ps = withOS desc $ \o -> case o of +installedBackport :: [Package] -> Property DebianLike +installedBackport ps = withOS desc $ \o os -> case os of (Just (System (Debian suite) _)) -> case backportSuite suite of Nothing -> unsupportedOS - Just bs -> ensureProperty $ + Just bs -> ensureProperty o $ runApt (["install", "-t", bs, "-y"] ++ ps) `changesFile` dpkgStatus _ -> unsupportedOS @@ -170,14 +169,14 @@ installedBackport ps = withOS desc $ \o -> case o of desc = unwords ("apt installed backport":ps) -- | Minimal install of package, without recommends. -installedMin :: [Package] -> Property NoInfo +installedMin :: [Package] -> Property DebianLike installedMin = installed' ["--no-install-recommends", "-y"] -removed :: [Package] -> Property NoInfo +removed :: [Package] -> Property DebianLike removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps)) `describe` unwords ("apt removed":ps) -buildDep :: [Package] -> Property NoInfo +buildDep :: [Package] -> Property DebianLike buildDep ps = robustly $ go `changesFile` dpkgStatus `describe` unwords ("apt build-dep":ps) @@ -187,7 +186,7 @@ buildDep ps = robustly $ go -- | Installs the build deps for the source package unpacked -- in the specifed directory, with a dummy package also -- installed so that autoRemove won't remove them. -buildDepIn :: FilePath -> Property NoInfo +buildDepIn :: FilePath -> Property DebianLike buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv `changesFile` dpkgStatus `requires` installedMin ["devscripts", "equivs"] @@ -196,13 +195,13 @@ buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv -- | Package installation may fail becuse the archive has changed. -- Run an update in that case and retry. -robustly :: (Combines (Property i) (Property NoInfo)) => Property i -> Property i +robustly :: Property DebianLike -> Property DebianLike robustly p = adjustPropertySatisfy p $ \satisfy -> do r <- satisfy if r == FailedChange - -- Safe to use ignoreInfo because we're re-running - -- the same property. - then ensureProperty $ ignoreInfo $ p `requires` update + -- Safe to use getSatisfy because we're re-running + -- the same property as before. + then getSatisfy $ p `requires` update else return r isInstallable :: [Package] -> IO Bool @@ -228,13 +227,13 @@ isInstalled' ps = (mapMaybe parse . lines) <$> policy environ <- addEntry "LANG" "C" <$> getEnvironment readProcessEnv "apt-cache" ("policy":ps) (Just environ) -autoRemove :: Property NoInfo +autoRemove :: Property DebianLike autoRemove = runApt ["-y", "autoremove"] `changesFile` dpkgStatus `describe` "apt autoremove" -- | Enables unattended upgrades. Revert to disable. -unattendedUpgrades :: RevertableProperty NoInfo +unattendedUpgrades :: RevertableProperty DebianLike DebianLike unattendedUpgrades = enable disable where enable = setup True @@ -253,11 +252,12 @@ unattendedUpgrades = enable disable | enabled = "true" | otherwise = "false" - configure = withOS "unattended upgrades configured" $ \o -> - case o of + configure :: Property DebianLike + configure = withOS "unattended upgrades configured" $ \o os -> + case os of -- the package defaults to only upgrading stable (Just (System (Debian suite) _)) - | not (isStable suite) -> ensureProperty $ + | not (isStable suite) -> ensureProperty o $ "/etc/apt/apt.conf.d/50unattended-upgrades" `File.containsLine` ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };") @@ -269,10 +269,13 @@ type DebconfTemplateValue = String -- | Preseeds debconf values and reconfigures the package so it takes -- effect. -reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property NoInfo -reConfigure package vals = reconfigure `requires` setselections - `describe` ("reconfigure " ++ package) +reConfigure :: Package -> [(DebconfTemplate, DebconfTemplateType, DebconfTemplateValue)] -> Property DebianLike +reConfigure package vals = tightenTargets $ + reconfigure + `requires` setselections + `describe` ("reconfigure " ++ package) where + setselections :: Property DebianLike setselections = property "preseed" $ if null vals then noChange @@ -289,7 +292,7 @@ reConfigure package vals = reconfigure `requires` setselections -- -- Assumes that there is a 1:1 mapping between service names and apt -- package names. -serviceInstalledRunning :: Package -> Property NoInfo +serviceInstalledRunning :: Package -> Property DebianLike serviceInstalledRunning svc = Service.running svc `requires` installed [svc] data AptKey = AptKey @@ -297,10 +300,10 @@ data AptKey = AptKey , pubkey :: String } -trustsKey :: AptKey -> RevertableProperty NoInfo +trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike trustsKey k = trustsKey' k untrustKey k -trustsKey' :: AptKey -> Property NoInfo +trustsKey' :: AptKey -> Property DebianLike trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do withHandle StdinHandle createProcessSuccess (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do @@ -311,21 +314,21 @@ trustsKey' k = check (not <$> doesFileExist f) $ property desc $ makeChange $ do desc = "apt trusts key " ++ keyname k f = aptKeyFile k -untrustKey :: AptKey -> Property NoInfo -untrustKey = File.notPresent . aptKeyFile +untrustKey :: AptKey -> Property DebianLike +untrustKey = tightenTargets . File.notPresent . aptKeyFile aptKeyFile :: AptKey -> FilePath aptKeyFile k = "/etc/apt/trusted.gpg.d" keyname k ++ ".gpg" -- | Cleans apt's cache of downloaded packages to avoid using up disk -- space. -cacheCleaned :: Property NoInfo -cacheCleaned = cmdProperty "apt-get" ["clean"] +cacheCleaned :: Property DebianLike +cacheCleaned = tightenTargets $ cmdProperty "apt-get" ["clean"] `assume` NoChange `describe` "apt cache cleaned" -- | Add a foreign architecture to dpkg and apt. -hasForeignArch :: String -> Property NoInfo +hasForeignArch :: String -> Property DebianLike hasForeignArch arch = check notAdded (add `before` update) `describe` ("dpkg has foreign architecture " ++ arch) where diff --git a/src/Propellor/Property/Service.hs b/src/Propellor/Property/Service.hs index 0e96ed4c..46f9e8ef 100644 --- a/src/Propellor/Property/Service.hs +++ b/src/Propellor/Property/Service.hs @@ -11,17 +11,17 @@ type ServiceName = String -- Note that due to the general poor state of init scripts, the best -- we can do is try to start the service, and if it fails, assume -- this means it's already running. -running :: ServiceName -> Property NoInfo +running :: ServiceName -> Property DebianLike running = signaled "start" "running" -restarted :: ServiceName -> Property NoInfo +restarted :: ServiceName -> Property DebianLike restarted = signaled "restart" "restarted" -reloaded :: ServiceName -> Property NoInfo +reloaded :: ServiceName -> Property DebianLike reloaded = signaled "reload" "reloaded" -signaled :: String -> Desc -> ServiceName -> Property NoInfo -signaled cmd desc svc = p `describe` (desc ++ " " ++ svc) +signaled :: String -> Desc -> ServiceName -> Property DebianLike +signaled cmd desc svc = tightenTargets $ p `describe` (desc ++ " " ++ svc) where p = scriptProperty ["service " ++ shellEscape svc ++ " " ++ cmd ++ " >/dev/null 2>&1 || true"] `assume` NoChange diff --git a/src/Propellor/Types.hs b/src/Propellor/Types.hs index db05e100..7098c83f 100644 --- a/src/Propellor/Types.hs +++ b/src/Propellor/Types.hs @@ -42,6 +42,7 @@ module Propellor.Types , module Propellor.Types.Dns , module Propellor.Types.Result , module Propellor.Types.ZFS + , TightenTargets(..) ) where import Data.Monoid @@ -285,3 +286,25 @@ instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (R combineWith sf tf (RevertableProperty x _) y = combineWith sf tf x y instance (CheckCombinable x y ~ 'CanCombine, SingI (Combine x y)) => Combines (Property (MetaTypes x)) (RevertableProperty (MetaTypes y) (MetaTypes y')) where combineWith sf tf x (RevertableProperty y _) = combineWith sf tf x y + +class TightenTargets p where + -- | Tightens the MetaType list of a Property (or similar), + -- to contain fewer targets. + -- + -- For example, to make a property that uses apt-get, which is only + -- available on DebianLike systems: + -- + -- > upgraded :: Property DebianLike + -- > upgraded = tightenTargets $ cmdProperty "apt-get" ["upgrade"] + tightenTargets + :: + -- Note that this uses PolyKinds + ( (Targets untightened `NotSuperset` Targets tightened) ~ 'CanCombine + , (NonTargets tightened `NotSuperset` NonTargets untightened) ~ 'CanCombine + , SingI tightened + ) + => p (MetaTypes untightened) + -> p (MetaTypes tightened) + +instance TightenTargets Property where + tightenTargets (Property _ d a i c) = Property sing d a i c diff --git a/src/Propellor/Types/ResultCheck.hs b/src/Propellor/Types/ResultCheck.hs index 4c6524ee..f03c174f 100644 --- a/src/Propellor/Types/ResultCheck.hs +++ b/src/Propellor/Types/ResultCheck.hs @@ -22,6 +22,9 @@ import Data.Monoid -- and `FailedChange` is still an error. data UncheckedProperty i = UncheckedProperty (Property i) +instance TightenTargets UncheckedProperty where + tightenTargets (UncheckedProperty p) = UncheckedProperty (tightenTargets p) + -- | Use to indicate that a Property is unchecked. unchecked :: Property i -> UncheckedProperty i unchecked = UncheckedProperty -- cgit v1.2.3