summaryrefslogtreecommitdiff
path: root/src/Propellor/Property/Apt.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Propellor/Property/Apt.hs')
-rw-r--r--src/Propellor/Property/Apt.hs273
1 files changed, 175 insertions, 98 deletions
diff --git a/src/Propellor/Property/Apt.hs b/src/Propellor/Property/Apt.hs
index 7cf6c2b0..5e185a0e 100644
--- a/src/Propellor/Property/Apt.hs
+++ b/src/Propellor/Property/Apt.hs
@@ -1,12 +1,15 @@
+{-# LANGUAGE FlexibleContexts #-}
+
module Propellor.Property.Apt where
import Data.Maybe
-import Control.Applicative
import Data.List
import System.IO
import Control.Monad
+import Control.Applicative
+import Prelude
-import Propellor
+import Propellor.Base
import qualified Propellor.Property.File as File
import qualified Propellor.Property.Service as Service
import Propellor.Property.File (Line)
@@ -29,6 +32,10 @@ backportSuite :: DebianSuite -> Maybe String
backportSuite (Stable s) = Just (s ++ "-backports")
backportSuite _ = Nothing
+stableUpdatesSuite :: DebianSuite -> Maybe String
+stableUpdatesSuite (Stable s) = Just (s ++ "-updates")
+stableUpdatesSuite _ = Nothing
+
debLine :: String -> Url -> [Section] -> Line
debLine suite mirror sections = unwords $
["deb", mirror, suite] ++ sections
@@ -55,7 +62,7 @@ binandsrc url suite = catMaybes
return $ debLine bs url stdSections
debCdn :: SourcesGenerator
-debCdn = binandsrc "http://http.debian.net/debian"
+debCdn = binandsrc "http://httpredir.debian.org/debian"
kernelOrg :: SourcesGenerator
kernelOrg = binandsrc "http://mirrors.kernel.org/debian"
@@ -68,42 +75,41 @@ securityUpdates suite
in [l, srcLine l]
| otherwise = []
--- | Makes sources.list have a standard content using the mirror CDN,
+-- | Makes sources.list have a standard content using the Debian mirror CDN,
-- with the Debian suite configured by the os.
--
-- Since the CDN is sometimes unreliable, also adds backup lines using
-- kernel.org.
-stdSourcesList :: Property
-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
+stdSourcesList :: Property Debian
+stdSourcesList = withOS "standard sources.list" $ \w o -> case o of
+ (Just (System (Debian suite) _)) ->
+ ensureProperty w $ 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 /etc/apt/sources.list.d/
-stdSourcesList' :: DebianSuite -> [SourcesGenerator] -> Property
-stdSourcesList' suite more = setSourcesList
+-- to do so via a separate file in </etc/apt/sources.list.d/>
+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
+setSourcesList :: [Line] -> Property DebianLike
setSourcesList ls = sourcesList `File.hasContent` ls `onChange` update
-setSourcesListD :: [Line] -> FilePath -> Property
+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] -> Property
-runApt ps = cmdProperty' "apt-get" ps noninteractiveEnv
+runApt :: [String] -> UncheckedProperty DebianLike
+runApt ps = tightenTargets $ cmdPropertyEnv "apt-get" ps noninteractiveEnv
noninteractiveEnv :: [(String, String)]
noninteractiveEnv =
@@ -111,75 +117,93 @@ noninteractiveEnv =
, ("APT_LISTCHANGES_FRONTEND", "none")
]
-update :: Property
-update = runApt ["update"]
- `describe` "apt update"
-
-upgrade :: Property
-upgrade = runApt ["-y", "dist-upgrade"]
- `describe` "apt dist-upgrade"
+-- | Have apt update its lists of packages, but without upgrading anything.
+update :: Property DebianLike
+update = combineProperties ("apt update") $ props
+ & pendingConfigured
+ & runApt ["update"]
+ `assume` MadeChange
+
+-- | Have apt upgrade packages, adding new packages and removing old as
+-- necessary. Often used in combination with the `update` property.
+upgrade :: Property DebianLike
+upgrade = upgrade' "dist-upgrade"
+
+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 DebianLike
+safeUpgrade = upgrade' "upgrade"
+
+-- | Have dpkg try to configure any packages that are not fully configured.
+pendingConfigured :: Property DebianLike
+pendingConfigured = tightenTargets $
+ cmdPropertyEnv "dpkg" ["--configure", "--pending"] noninteractiveEnv
+ `assume` MadeChange
+ `describe` "dpkg configured pending"
type Package = String
-installed :: [Package] -> Property
+installed :: [Package] -> Property DebianLike
installed = installed' ["-y"]
-installed' :: [String] -> [Package] -> Property
+installed' :: [String] -> [Package] -> Property DebianLike
installed' params ps = robustly $ check (isInstallable ps) go
- `describe` (unwords $ "apt installed":ps)
+ `describe` unwords ("apt installed":ps)
where
- go = runApt $ params ++ ["install"] ++ ps
+ go = runApt (params ++ ["install"] ++ ps)
-installedBackport :: [Package] -> Property
-installedBackport ps = trivial $ withOS desc $ \o -> case o of
- Nothing -> error "cannot install backports; os not declared"
+installedBackport :: [Package] -> Property Debian
+installedBackport ps = withOS desc $ \w o -> case o of
(Just (System (Debian suite) _)) -> case backportSuite suite of
- Nothing -> notsupported o
- Just bs -> ensureProperty $ runApt $
- ["install", "-t", bs, "-y"] ++ ps
- _ -> notsupported o
+ Nothing -> unsupportedOS'
+ Just bs -> ensureProperty w $
+ runApt (["install", "-t", bs, "-y"] ++ ps)
+ `changesFile` dpkgStatus
+ _ -> unsupportedOS'
where
- desc = (unwords $ "apt installed backport":ps)
- notsupported o = error $ "backports not supported on " ++ show o
+ desc = unwords ("apt installed backport":ps)
-- | Minimal install of package, without recommends.
-installedMin :: [Package] -> Property
+installedMin :: [Package] -> Property DebianLike
installedMin = installed' ["--no-install-recommends", "-y"]
-removed :: [Package] -> Property
-removed ps = check (or <$> isInstalled' ps) go
- `describe` (unwords $ "apt removed":ps)
- where
- go = runApt $ ["-y", "remove"] ++ ps
+removed :: [Package] -> Property DebianLike
+removed ps = check (or <$> isInstalled' ps) (runApt (["-y", "remove"] ++ ps))
+ `describe` unwords ("apt removed":ps)
-buildDep :: [Package] -> Property
-buildDep ps = robustly go
- `describe` (unwords $ "apt build-dep":ps)
+buildDep :: [Package] -> Property DebianLike
+buildDep ps = robustly $ go
+ `changesFile` dpkgStatus
+ `describe` unwords ("apt build-dep":ps)
where
go = runApt $ ["-y", "build-dep"] ++ ps
-- | 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
-buildDepIn dir = go `requires` installedMin ["devscripts", "equivs"]
+buildDepIn :: FilePath -> Property DebianLike
+buildDepIn dir = cmdPropertyEnv "sh" ["-c", cmd] noninteractiveEnv
+ `changesFile` dpkgStatus
+ `requires` installedMin ["devscripts", "equivs"]
where
- go = cmdProperty' "sh" ["-c", "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"]
- noninteractiveEnv
+ cmd = "cd '" ++ dir ++ "' && mk-build-deps debian/control --install --tool 'apt-get -y --no-install-recommends' --remove"
-- | Package installation may fail becuse the archive has changed.
-- Run an update in that case and retry.
-robustly :: Property -> Property
-robustly p = adjustProperty p $ \satisfy -> do
- r <- satisfy
- if r == FailedChange
- then ensureProperty $ p `requires` update
- else return r
+robustly :: Property DebianLike -> Property DebianLike
+robustly p = p `fallback` (update `before` p)
isInstallable :: [Package] -> IO Bool
isInstallable ps = do
l <- isInstalled' ps
- return $ any (== False) l && not (null l)
+ return $ elem False l && not (null l)
isInstalled :: Package -> IO Bool
isInstalled p = (== [True]) <$> isInstalled' [p]
@@ -189,25 +213,30 @@ isInstalled p = (== [True]) <$> isInstalled' [p]
-- even vary. If apt does not know about a package at all, it will not
-- be included in the result list.
isInstalled' :: [Package] -> IO [Bool]
-isInstalled' ps = catMaybes . map parse . lines
- <$> readProcess "apt-cache" ("policy":ps)
+isInstalled' ps = (mapMaybe parse . lines) <$> policy
where
parse l
| "Installed: (none)" `isInfixOf` l = Just False
| "Installed: " `isInfixOf` l = Just True
| otherwise = Nothing
+ policy = do
+ environ <- addEntry "LANG" "C" <$> getEnvironment
+ readProcessEnv "apt-cache" ("policy":ps) (Just environ)
-autoRemove :: Property
+autoRemove :: Property DebianLike
autoRemove = runApt ["-y", "autoremove"]
+ `changesFile` dpkgStatus
`describe` "apt autoremove"
-- | Enables unattended upgrades. Revert to disable.
-unattendedUpgrades :: RevertableProperty
-unattendedUpgrades = RevertableProperty enable disable
+unattendedUpgrades :: RevertableProperty DebianLike DebianLike
+unattendedUpgrades = enable <!> disable
where
enable = setup True
`before` Service.running "cron"
`before` configure
+ -- work around http://bugs.debian.org/812380
+ `before` File.notPresent "/etc/apt/apt.conf.d/50unattended-upgrades.ucf-dist"
disable = setup False
setup enabled = (if enabled then installed else removed) ["unattended-upgrades"]
@@ -218,36 +247,64 @@ unattendedUpgrades = RevertableProperty enable disable
v
| enabled = "true"
| otherwise = "false"
-
- configure = withOS "unattended upgrades configured" $ \o ->
- case o of
- -- the package defaults to only upgrading stable
- (Just (System (Debian suite) _))
- | not (isStable suite) -> ensureProperty $
- "/etc/apt/apt.conf.d/50unattended-upgrades"
- `File.containsLine`
- ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
- _ -> noChange
+
+ configure :: Property DebianLike
+ configure = propertyList "unattended upgrades configured" $ props
+ & enableupgrading
+ & unattendedconfig `File.containsLine` "Unattended-Upgrade::Mail \"root\";"
+ where
+ enableupgrading :: Property DebianLike
+ enableupgrading = withOS "unattended upgrades configured" $ \w o ->
+ case o of
+ -- the package defaults to only upgrading stable
+ (Just (System (Debian suite) _))
+ | not (isStable suite) -> ensureProperty w $
+ unattendedconfig
+ `File.containsLine`
+ ("Unattended-Upgrade::Origins-Pattern { \"o=Debian,a="++showSuite suite++"\"; };")
+ _ -> noChange
+ unattendedconfig = "/etc/apt/apt.conf.d/50unattended-upgrades"
+
+-- | Enable periodic updates (but not upgrades), including download
+-- of packages.
+periodicUpdates :: Property DebianLike
+periodicUpdates = tightenTargets $ "/etc/apt/apt.conf.d/02periodic" `File.hasContent`
+ [ "APT::Periodic::Enable \"1\";"
+ , "APT::Periodic::Update-Package-Lists \"1\";"
+ , "APT::Periodic::Download-Upgradeable-Packages \"1\";"
+ , "APT::Periodic::Verbose \"1\";"
+ ]
+
+type DebconfTemplate = String
+type DebconfTemplateType = String
+type DebconfTemplateValue = String
-- | Preseeds debconf values and reconfigures the package so it takes
-- effect.
-reConfigure :: Package -> [(String, String, String)] -> Property
-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 "preseed" $ makeChange $
- withHandle StdinHandle createProcessSuccess
- (proc "debconf-set-selections" []) $ \h -> do
- forM_ vals $ \(tmpl, tmpltype, value) ->
- hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
- hClose h
- reconfigure = cmdProperty' "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv
+ setselections :: Property DebianLike
+ setselections = property "preseed" $
+ if null vals
+ then noChange
+ else makeChange $
+ withHandle StdinHandle createProcessSuccess
+ (proc "debconf-set-selections" []) $ \h -> do
+ forM_ vals $ \(tmpl, tmpltype, value) ->
+ hPutStrLn h $ unwords [package, tmpl, tmpltype, value]
+ hClose h
+ reconfigure = cmdPropertyEnv "dpkg-reconfigure" ["-fnone", package] noninteractiveEnv
+ `assume` MadeChange
-- | Ensures that a service is installed and running.
--
-- Assumes that there is a 1:1 mapping between service names and apt
-- package names.
-serviceInstalledRunning :: Package -> Property
+serviceInstalledRunning :: Package -> Property DebianLike
serviceInstalledRunning svc = Service.running svc `requires` installed [svc]
data AptKey = AptKey
@@ -255,21 +312,41 @@ data AptKey = AptKey
, pubkey :: String
}
-trustsKey :: AptKey -> RevertableProperty
-trustsKey k = RevertableProperty trust untrust
+trustsKey :: AptKey -> RevertableProperty DebianLike DebianLike
+trustsKey k = trustsKey' k <!> untrustKey k
+
+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
+ hPutStr h (pubkey k)
+ hClose h
+ nukeFile $ f ++ "~" -- gpg dropping
where
desc = "apt trusts key " ++ keyname k
- f = "/etc/apt/trusted.gpg.d" </> keyname k ++ ".gpg"
- untrust = File.notPresent f
- trust = check (not <$> doesFileExist f) $ property desc $ makeChange $ do
- withHandle StdinHandle createProcessSuccess
- (proc "gpg" ["--no-default-keyring", "--keyring", f, "--import", "-"]) $ \h -> do
- hPutStr h (pubkey k)
- hClose h
- nukeFile $ f ++ "~" -- gpg dropping
+ f = aptKeyFile k
+
+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
-cacheCleaned = trivial $ cmdProperty "apt-get" ["clean"]
- `describe` "apt cache cleaned"
+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 DebianLike
+hasForeignArch arch = check notAdded (add `before` update)
+ `describe` ("dpkg has foreign architecture " ++ arch)
+ where
+ notAdded = (notElem arch . lines) <$> readProcess "dpkg" ["--print-foreign-architectures"]
+ add = cmdProperty "dpkg" ["--add-architecture", arch]
+ `assume` MadeChange
+
+dpkgStatus :: FilePath
+dpkgStatus = "/var/lib/dpkg/status"
generated by cgit v1.2.3 (git 2.25.1) at 2024-07-01 11:14:53 +0000